tcalfun2.pp 31 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401
  1. {****************************************************************}
  2. { CODE GENERATOR TEST PROGRAM }
  3. { By Carl Eric Codere }
  4. {****************************************************************}
  5. { NODE TESTED : secondcallparan() }
  6. {****************************************************************}
  7. { PRE-REQUISITES: secondload() }
  8. { secondassign() }
  9. { secondtypeconv() }
  10. { secondtryexcept() }
  11. { secondcalln() }
  12. { secondadd() }
  13. {****************************************************************}
  14. { DEFINES: }
  15. { FPC = Target is FreePascal compiler }
  16. {****************************************************************}
  17. { REMARKS: This tests a subset of the secondcalln() node }
  18. { (function return values with pascal calling cnvs) }
  19. { (also tests nested routines up to 2 level deep) }
  20. {****************************************************************}
  21. program tcalfun2;
  22. {$ifdef fpc}
  23. {$mode objfpc}
  24. {$INLINE ON}
  25. {$endif}
  26. {$R+}
  27. {$P-}
  28. {$ifdef VER70}
  29. {$define tp}
  30. {$endif}
  31. { REAL should map to single or double }
  32. { so it is not checked, since single }
  33. { double nodes are checked. }
  34. { assumes that enumdef is the same as orddef (same storage format) }
  35. const
  36. { should be defined depending on CPU target }
  37. {$ifdef fpc}
  38. {$ifdef cpu68k}
  39. BIG_INDEX = 8000;
  40. SMALL_INDEX = 13;
  41. {$else}
  42. BIG_INDEX = 33000;
  43. SMALL_INDEX = 13; { value should not be aligned! }
  44. {$endif}
  45. {$else}
  46. BIG_INDEX = 33000;
  47. SMALL_INDEX = 13; { value should not be aligned! }
  48. {$endif}
  49. RESULT_U8BIT = $55;
  50. RESULT_U16BIT = $500F;
  51. RESULT_S32BIT = $500F0000;
  52. RESULT_S64BIT = $500F0000;
  53. RESULT_S32REAL = 1777.12;
  54. RESULT_S64REAL = 3444.24;
  55. RESULT_BOOL8BIT = 1;
  56. RESULT_BOOL16BIT = 1;
  57. RESULT_BOOL32BIT = 1;
  58. RESULT_PCHAR = 'Hello world';
  59. RESULT_BIGSTRING = 'Hello world';
  60. RESULT_SMALLSTRING = 'H';
  61. RESULT_CHAR = 'I';
  62. RESULT_BOOLEAN = TRUE;
  63. type
  64. {$ifndef tp}
  65. tclass1 = class
  66. end;
  67. {$else}
  68. shortstring = string;
  69. {$endif}
  70. tprocedure = procedure;
  71. tsmallrecord = packed record
  72. b: byte;
  73. w: word;
  74. end;
  75. tlargerecord = packed record
  76. b: array[1..BIG_INDEX] of byte;
  77. end;
  78. tsmallarray = packed array[1..SMALL_INDEX] of byte;
  79. tsmallsetenum =
  80. (A_A,A_B,A_C,A_D);
  81. tsmallset = set of tsmallsetenum;
  82. tlargeset = set of char;
  83. tsmallstring = string[2];
  84. var
  85. global_u8bit : byte;
  86. global_u16bit : word;
  87. global_s32bit : longint;
  88. global_s32real : single;
  89. global_s64real : double;
  90. global_ptr : pchar;
  91. global_proc : tprocedure;
  92. global_bigstring : shortstring;
  93. global_boolean : boolean;
  94. global_char : char;
  95. {$ifndef tp}
  96. global_class : tclass1;
  97. global_s64bit : int64;
  98. value_s64bit : int64;
  99. value_class : tclass1;
  100. {$endif}
  101. value_ansistring : ansistring;
  102. value_u8bit : byte;
  103. value_u16bit : word;
  104. value_s32bit : longint;
  105. value_s32real : single;
  106. value_s64real : double;
  107. value_proc : tprocedure;
  108. value_ptr : pchar;
  109. value_smallrec : tsmallrecord;
  110. value_largerec : tlargerecord;
  111. value_smallset : tsmallset;
  112. value_smallstring : tsmallstring;
  113. value_bigstring : shortstring;
  114. value_largeset : tlargeset;
  115. value_smallarray : tsmallarray;
  116. value_boolean : boolean;
  117. value_char : char;
  118. procedure fail;
  119. begin
  120. WriteLn('Failure.');
  121. halt(1);
  122. end;
  123. procedure clear_globals;
  124. begin
  125. global_u8bit := 0;
  126. global_u16bit := 0;
  127. global_s32bit := 0;
  128. global_s32real := 0.0;
  129. global_s64real := 0.0;
  130. global_ptr := nil;
  131. global_proc := nil;
  132. global_bigstring := '';
  133. global_boolean := false;
  134. global_char := #0;
  135. global_s64bit := 0;
  136. global_class := nil;
  137. end;
  138. procedure clear_values;
  139. begin
  140. value_u8bit := 0;
  141. value_u16bit := 0;
  142. value_s32bit := 0;
  143. value_s32real := 0.0;
  144. value_s64real := 0.0;
  145. value_proc := nil;
  146. value_ptr := nil;
  147. fillchar(value_smallrec, sizeof(value_smallrec), #0);
  148. fillchar(value_largerec, sizeof(value_largerec), #0);
  149. value_smallset := [];
  150. value_smallstring := '';
  151. value_bigstring := '';
  152. value_largeset := [];
  153. fillchar(value_smallarray, sizeof(value_smallarray), #0);
  154. value_boolean := false;
  155. value_char:=#0;
  156. value_ansistring := '';
  157. {$ifndef tp}
  158. value_s64bit := 0;
  159. value_class := nil;
  160. {$endif}
  161. end;
  162. {********************************* FUNCTION RESULTS *************************}
  163. { LOC_MEM return values }
  164. function func_array: tsmallarray;pascal;
  165. var
  166. smallarray: tsmallarray;
  167. begin
  168. fillchar(smallarray, sizeof(smallarray), #0);
  169. smallarray[1] := RESULT_U8BIT;
  170. smallarray[SMALL_INDEX] := RESULT_U8BIT;
  171. func_array := smallarray;
  172. end;
  173. function func_largerecord: tlargerecord;pascal;
  174. var
  175. largerecord : tlargerecord;
  176. begin
  177. fillchar(largerecord, sizeof(largerecord), #0);
  178. largerecord.b[1] := RESULT_U8BIT;
  179. largerecord.b[BIG_INDEX] := RESULT_U8BIT;
  180. func_largerecord := largerecord;
  181. end;
  182. function func_shortstring: shortstring;pascal;
  183. begin
  184. func_shortstring := RESULT_BIGSTRING;
  185. end;
  186. function func_largeset : tlargeset;pascal;
  187. var
  188. largeset : tlargeset;
  189. begin
  190. largeset := ['I'];
  191. func_largeset := largeset;
  192. end;
  193. function func_u8bit : byte;pascal;
  194. begin
  195. func_u8bit := RESULT_U8BIT;
  196. end;
  197. function func_u16bit : word;pascal;
  198. begin
  199. func_u16bit := RESULT_U16BIT;
  200. end;
  201. function func_s32bit : longint;pascal;
  202. begin
  203. func_s32bit := RESULT_S32BIT;
  204. end;
  205. function func_s64bit : int64;pascal;
  206. begin
  207. func_s64bit := RESULT_S64BIT;
  208. end;
  209. function func_s32real : single;pascal;
  210. begin
  211. func_s32real := RESULT_S32REAL;
  212. end;
  213. function func_s64real : double;pascal;
  214. begin
  215. func_s64real := RESULT_S64REAl;
  216. end;
  217. function func_ansistring : ansistring;pascal;
  218. begin
  219. func_ansistring := RESULT_BIGSTRING;
  220. end;
  221. function func_pchar : pchar;pascal;
  222. begin
  223. func_pchar := RESULT_PCHAR;
  224. end;
  225. {************************** FUNCTION RESULT WITH PARAMS ******************}
  226. { LOC_MEM return values }
  227. function func_array_mixed(b: byte): tsmallarray;pascal;
  228. var
  229. local_b: byte;
  230. smallarray: tsmallarray;
  231. begin
  232. fillchar(smallarray, sizeof(smallarray), #0);
  233. smallarray[1] := RESULT_U8BIT;
  234. smallarray[SMALL_INDEX] := RESULT_U8BIT;
  235. func_array_mixed := smallarray;
  236. local_b:=b;
  237. global_u8bit := b;
  238. end;
  239. function func_largerecord_mixed(b: byte): tlargerecord;pascal;
  240. var
  241. local_b: byte;
  242. largerecord : tlargerecord;
  243. begin
  244. fillchar(largerecord, sizeof(largerecord), #0);
  245. largerecord.b[1] := RESULT_U8BIT;
  246. largerecord.b[BIG_INDEX] := RESULT_U8BIT;
  247. func_largerecord_mixed := largerecord;
  248. local_b:=b;
  249. global_u8bit := b;
  250. end;
  251. function func_shortstring_mixed(b: byte): shortstring;pascal;
  252. var
  253. local_b: byte;
  254. begin
  255. func_shortstring_mixed := RESULT_BIGSTRING;
  256. local_b:=b;
  257. global_u8bit := b;
  258. end;
  259. function func_largeset_mixed(b: byte) : tlargeset;pascal;
  260. var
  261. local_b: byte;
  262. largeset : tlargeset;
  263. begin
  264. largeset := ['I'];
  265. func_largeset_mixed := largeset;
  266. local_b:=b;
  267. global_u8bit := b;
  268. end;
  269. function func_u8bit_mixed(b: byte) : byte;pascal;
  270. var
  271. local_b: byte;
  272. begin
  273. func_u8bit_mixed := RESULT_U8BIT;
  274. local_b:=b;
  275. global_u8bit := b;
  276. end;
  277. function func_u16bit_mixed(b: byte) : word;pascal;
  278. var
  279. local_b: byte;
  280. begin
  281. func_u16bit_mixed := RESULT_U16BIT;
  282. local_b:=b;
  283. global_u8bit := b;
  284. end;
  285. function func_s32bit_mixed(b: byte) : longint;pascal;
  286. var
  287. local_b: byte;
  288. begin
  289. func_s32bit_mixed := RESULT_S32BIT;
  290. local_b:=b;
  291. global_u8bit := b;
  292. end;
  293. function func_s64bit_mixed(b: byte) : int64;pascal;
  294. var
  295. local_b: byte;
  296. begin
  297. func_s64bit_mixed := RESULT_S64BIT;
  298. local_b:=b;
  299. global_u8bit := b;
  300. end;
  301. function func_s32real_mixed(b: byte) : single;pascal;
  302. var
  303. local_b: byte;
  304. begin
  305. func_s32real_mixed := RESULT_S32REAL;
  306. local_b:=b;
  307. global_u8bit := b;
  308. end;
  309. function func_s64real_mixed(b: byte) : double;pascal;
  310. var
  311. local_b: byte;
  312. begin
  313. func_s64real_mixed := RESULT_S64REAl;
  314. local_b:=b;
  315. global_u8bit := b;
  316. end;
  317. function func_ansistring_mixed(b: byte) : ansistring;pascal;
  318. var
  319. local_b: byte;
  320. begin
  321. func_ansistring_mixed := RESULT_BIGSTRING;
  322. local_b:=b;
  323. global_u8bit := b;
  324. end;
  325. function func_pchar_mixed(b: byte) : pchar;pascal;
  326. var
  327. local_b: byte;
  328. begin
  329. func_pchar_mixed := RESULT_PCHAR;
  330. local_b:=b;
  331. global_u8bit := b;
  332. end;
  333. {********************* FUNCTION RESULT WITH PARAMS (NESTED) ******************}
  334. { LOC_MEM return values }
  335. function func_array_mixed_nested(b: byte): tsmallarray;pascal;
  336. procedure nested_one_proc(l: longint);
  337. begin
  338. global_u16bit := b;
  339. global_s32bit := l;
  340. end;
  341. procedure nested_two_proc(l : longint);
  342. begin
  343. global_s64bit := l;
  344. end;
  345. function nested_one_func(level1_b : byte; s: shortstring): byte;
  346. var
  347. s1 : shortstring;
  348. function nested_two_func(level2_b : byte; s :shortstring): byte;
  349. begin
  350. nested_two_func:=level2_b;
  351. global_bigstring := s;
  352. nested_one_proc(RESULT_S32BIT);
  353. end;
  354. begin
  355. s1:=s;
  356. nested_one_func := nested_two_func(level1_b,s1);
  357. nested_two_proc(level1_b);
  358. end;
  359. var
  360. local_b: byte;
  361. smallarray: tsmallarray;
  362. begin
  363. fillchar(smallarray, sizeof(smallarray), #0);
  364. smallarray[1] := RESULT_U8BIT;
  365. smallarray[SMALL_INDEX] := RESULT_U8BIT;
  366. func_array_mixed_nested := smallarray;
  367. local_b:=b;
  368. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  369. { nested_one_proc(RESULT_S32BIT);}
  370. end;
  371. function func_largerecord_mixed_nested(b: byte): tlargerecord;pascal;
  372. procedure nested_one_proc(l: longint);
  373. begin
  374. global_u16bit := b;
  375. global_s32bit := l;
  376. end;
  377. procedure nested_two_proc(l : longint);
  378. begin
  379. global_s64bit := l;
  380. end;
  381. function nested_one_func(level1_b : byte; s: shortstring): byte;
  382. var
  383. s1 : shortstring;
  384. function nested_two_func(level2_b : byte; s :shortstring): byte;
  385. begin
  386. nested_two_func:=level2_b;
  387. global_bigstring := s;
  388. nested_one_proc(RESULT_S32BIT);
  389. end;
  390. begin
  391. s1:=s;
  392. nested_one_func := nested_two_func(level1_b,s1);
  393. nested_two_proc(level1_b);
  394. end;
  395. var
  396. local_b: byte;
  397. largerecord : tlargerecord;
  398. begin
  399. fillchar(largerecord, sizeof(largerecord), #0);
  400. largerecord.b[1] := RESULT_U8BIT;
  401. largerecord.b[BIG_INDEX] := RESULT_U8BIT;
  402. func_largerecord_mixed_nested := largerecord;
  403. local_b:=b;
  404. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  405. end;
  406. function func_shortstring_mixed_nested(b: byte): shortstring;pascal;
  407. procedure nested_one_proc(l: longint);
  408. begin
  409. global_u16bit := b;
  410. global_s32bit := l;
  411. end;
  412. procedure nested_two_proc(l : longint);
  413. begin
  414. global_s64bit := l;
  415. end;
  416. function nested_one_func(level1_b : byte; s: shortstring): byte;
  417. var
  418. s1 : shortstring;
  419. function nested_two_func(level2_b : byte; s :shortstring): byte;
  420. begin
  421. nested_two_func:=level2_b;
  422. global_bigstring := s;
  423. nested_one_proc(RESULT_S32BIT);
  424. end;
  425. begin
  426. s1:=s;
  427. nested_one_func := nested_two_func(level1_b,s1);
  428. nested_two_proc(level1_b);
  429. end;
  430. var
  431. local_b: byte;
  432. begin
  433. func_shortstring_mixed_nested := RESULT_BIGSTRING;
  434. local_b:=b;
  435. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  436. end;
  437. function func_largeset_mixed_nested(b: byte) : tlargeset;pascal;
  438. procedure nested_one_proc(l: longint);
  439. begin
  440. global_u16bit := b;
  441. global_s32bit := l;
  442. end;
  443. procedure nested_two_proc(l : longint);
  444. begin
  445. global_s64bit := l;
  446. end;
  447. function nested_one_func(level1_b : byte; s: shortstring): byte;
  448. var
  449. s1 : shortstring;
  450. function nested_two_func(level2_b : byte; s :shortstring): byte;
  451. begin
  452. nested_two_func:=level2_b;
  453. global_bigstring := s;
  454. nested_one_proc(RESULT_S32BIT);
  455. end;
  456. begin
  457. s1:=s;
  458. nested_one_func := nested_two_func(level1_b,s1);
  459. nested_two_proc(level1_b);
  460. end;
  461. var
  462. local_b: byte;
  463. largeset : tlargeset;
  464. begin
  465. largeset := ['I'];
  466. func_largeset_mixed_nested := largeset;
  467. local_b:=b;
  468. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  469. end;
  470. function func_u8bit_mixed_nested(b: byte) : byte;pascal;
  471. procedure nested_one_proc(l: longint);
  472. begin
  473. global_u16bit := b;
  474. global_s32bit := l;
  475. end;
  476. procedure nested_two_proc(l : longint);
  477. begin
  478. global_s64bit := l;
  479. end;
  480. function nested_one_func(level1_b : byte; s: shortstring): byte;
  481. var
  482. s1 : shortstring;
  483. function nested_two_func(level2_b : byte; s :shortstring): byte;
  484. begin
  485. nested_two_func:=level2_b;
  486. global_bigstring := s;
  487. nested_one_proc(RESULT_S32BIT);
  488. end;
  489. begin
  490. s1:=s;
  491. nested_one_func := nested_two_func(level1_b,s1);
  492. nested_two_proc(level1_b);
  493. end;
  494. var
  495. local_b: byte;
  496. begin
  497. func_u8bit_mixed_nested := RESULT_U8BIT;
  498. local_b:=b;
  499. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  500. end;
  501. function func_u16bit_mixed_nested(b: byte) : word;pascal;
  502. procedure nested_one_proc(l: longint);
  503. begin
  504. global_u16bit := b;
  505. global_s32bit := l;
  506. end;
  507. procedure nested_two_proc(l : longint);
  508. begin
  509. global_s64bit := l;
  510. end;
  511. function nested_one_func(level1_b : byte; s: shortstring): byte;
  512. var
  513. s1 : shortstring;
  514. function nested_two_func(level2_b : byte; s :shortstring): byte;
  515. begin
  516. nested_two_func:=level2_b;
  517. global_bigstring := s;
  518. nested_one_proc(RESULT_S32BIT);
  519. end;
  520. begin
  521. s1:=s;
  522. nested_one_func := nested_two_func(level1_b,s1);
  523. nested_two_proc(level1_b);
  524. end;
  525. var
  526. local_b: byte;
  527. begin
  528. func_u16bit_mixed_nested := RESULT_U16BIT;
  529. local_b:=b;
  530. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  531. end;
  532. function func_s32bit_mixed_nested(b: byte) : longint;pascal;
  533. procedure nested_one_proc(l: longint);
  534. begin
  535. global_u16bit := b;
  536. global_s32bit := l;
  537. end;
  538. procedure nested_two_proc(l : longint);
  539. begin
  540. global_s64bit := l;
  541. end;
  542. function nested_one_func(level1_b : byte; s: shortstring): byte;
  543. var
  544. s1 : shortstring;
  545. function nested_two_func(level2_b : byte; s :shortstring): byte;
  546. begin
  547. nested_two_func:=level2_b;
  548. global_bigstring := s;
  549. nested_one_proc(RESULT_S32BIT);
  550. end;
  551. begin
  552. s1:=s;
  553. nested_one_func := nested_two_func(level1_b,s1);
  554. nested_two_proc(level1_b);
  555. end;
  556. var
  557. local_b: byte;
  558. begin
  559. func_s32bit_mixed_nested := RESULT_S32BIT;
  560. local_b:=b;
  561. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  562. end;
  563. function func_s64bit_mixed_nested(b: byte) : int64;pascal;
  564. procedure nested_one_proc(l: longint);
  565. begin
  566. global_u16bit := b;
  567. global_s32bit := l;
  568. end;
  569. procedure nested_two_proc(l : longint);
  570. begin
  571. global_s64bit := l;
  572. end;
  573. function nested_one_func(level1_b : byte; s: shortstring): byte;
  574. var
  575. s1 : shortstring;
  576. function nested_two_func(level2_b : byte; s :shortstring): byte;
  577. begin
  578. nested_two_func:=level2_b;
  579. global_bigstring := s;
  580. nested_one_proc(RESULT_S32BIT);
  581. end;
  582. begin
  583. s1:=s;
  584. nested_one_func := nested_two_func(level1_b,s1);
  585. nested_two_proc(level1_b);
  586. end;
  587. var
  588. local_b: byte;
  589. begin
  590. func_s64bit_mixed_nested := RESULT_S64BIT;
  591. local_b:=b;
  592. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  593. end;
  594. function func_s32real_mixed_nested(b: byte) : single;pascal;
  595. procedure nested_one_proc(l: longint);
  596. begin
  597. global_u16bit := b;
  598. global_s32bit := l;
  599. end;
  600. procedure nested_two_proc(l : longint);
  601. begin
  602. global_s64bit := l;
  603. end;
  604. function nested_one_func(level1_b : byte; s: shortstring): byte;
  605. var
  606. s1 : shortstring;
  607. function nested_two_func(level2_b : byte; s :shortstring): byte;
  608. begin
  609. nested_two_func:=level2_b;
  610. global_bigstring := s;
  611. nested_one_proc(RESULT_S32BIT);
  612. end;
  613. begin
  614. s1:=s;
  615. nested_one_func := nested_two_func(level1_b,s1);
  616. nested_two_proc(level1_b);
  617. end;
  618. var
  619. local_b: byte;
  620. begin
  621. func_s32real_mixed_nested := RESULT_S32REAL;
  622. local_b:=b;
  623. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  624. end;
  625. function func_s64real_mixed_nested(b: byte) : double;pascal;
  626. procedure nested_one_proc(l: longint);
  627. begin
  628. global_u16bit := b;
  629. global_s32bit := l;
  630. end;
  631. procedure nested_two_proc(l : longint);
  632. begin
  633. global_s64bit := l;
  634. end;
  635. function nested_one_func(level1_b : byte; s: shortstring): byte;
  636. var
  637. s1 : shortstring;
  638. function nested_two_func(level2_b : byte; s :shortstring): byte;
  639. begin
  640. nested_two_func:=level2_b;
  641. global_bigstring := s;
  642. nested_one_proc(RESULT_S32BIT);
  643. end;
  644. begin
  645. s1:=s;
  646. nested_one_func := nested_two_func(level1_b,s1);
  647. nested_two_proc(level1_b);
  648. end;
  649. var
  650. local_b: byte;
  651. begin
  652. func_s64real_mixed_nested := RESULT_S64REAl;
  653. local_b:=b;
  654. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  655. end;
  656. function func_ansistring_mixed_nested(b: byte) : ansistring;pascal;
  657. procedure nested_one_proc(l: longint);
  658. begin
  659. global_u16bit := b;
  660. global_s32bit := l;
  661. end;
  662. procedure nested_two_proc(l : longint);
  663. begin
  664. global_s64bit := l;
  665. end;
  666. function nested_one_func(level1_b : byte; s: shortstring): byte;
  667. var
  668. s1 : shortstring;
  669. function nested_two_func(level2_b : byte; s :shortstring): byte;
  670. begin
  671. nested_two_func:=level2_b;
  672. global_bigstring := s;
  673. nested_one_proc(RESULT_S32BIT);
  674. end;
  675. begin
  676. s1:=s;
  677. nested_one_func := nested_two_func(level1_b,s1);
  678. nested_two_proc(level1_b);
  679. end;
  680. var
  681. local_b: byte;
  682. begin
  683. func_ansistring_mixed_nested := RESULT_BIGSTRING;
  684. local_b:=b;
  685. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  686. end;
  687. function func_pchar_mixed_nested(b: byte) : pchar;pascal;
  688. procedure nested_one_proc(l: longint);
  689. begin
  690. global_u16bit := b;
  691. global_s32bit := l;
  692. end;
  693. procedure nested_two_proc(l : longint);
  694. begin
  695. global_s64bit := l;
  696. end;
  697. function nested_one_func(level1_b : byte; s: shortstring): byte;
  698. var
  699. s1 : shortstring;
  700. function nested_two_func(level2_b : byte; s :shortstring): byte;
  701. begin
  702. nested_two_func:=level2_b;
  703. global_bigstring := s;
  704. nested_one_proc(RESULT_S32BIT);
  705. end;
  706. begin
  707. s1:=s;
  708. nested_one_func := nested_two_func(level1_b,s1);
  709. nested_two_proc(level1_b);
  710. end;
  711. var
  712. local_b: byte;
  713. begin
  714. func_pchar_mixed_nested := RESULT_PCHAR;
  715. local_b:=b;
  716. global_u8bit := nested_one_func(local_b, RESULT_BIGSTRING);
  717. end;
  718. var
  719. failed: boolean;
  720. Begin
  721. {************************************* SIMPLE TESTS ***********************************}
  722. write('Testing function results (LOC_REFERENCE)...');
  723. clear_globals;
  724. clear_values;
  725. failed := false;
  726. value_smallarray := func_array;
  727. if (value_smallarray[1] <> RESULT_U8BIT) or (value_smallarray[SMALL_INDEX] <> RESULT_U8BIT) then
  728. failed := true;
  729. clear_globals;
  730. clear_values;
  731. value_largerec := func_largerecord;
  732. if (value_largerec.b[1] <> RESULT_U8BIT) or (value_largerec.b[BIG_INDEX] <> RESULT_U8BIT) then
  733. failed:=true;
  734. clear_globals;
  735. clear_values;
  736. value_bigstring := func_shortstring;
  737. if value_bigstring <> RESULT_BIGSTRING then
  738. failed := true;
  739. clear_globals;
  740. clear_values;
  741. value_largeset := func_largeset;
  742. if not ('I' in value_largeset) then
  743. failed := true;
  744. if failed then
  745. fail
  746. else
  747. WriteLn('Passed!');
  748. write('Testing orddef/enumdef function results (LOC_REGISTER)...');
  749. clear_globals;
  750. clear_values;
  751. failed := false;
  752. value_u8bit := func_u8bit;
  753. if value_u8bit <> RESULT_U8BIT then
  754. failed := true;
  755. clear_globals;
  756. clear_values;
  757. value_u16bit := func_u16bit;
  758. if value_u16bit <> RESULT_U16BIT then
  759. failed := true;
  760. clear_globals;
  761. clear_values;
  762. value_s32bit := func_s32bit;
  763. if value_s32bit <> RESULT_S32BIT then
  764. failed := true;
  765. clear_globals;
  766. clear_values;
  767. value_s64bit := func_s64bit;
  768. if value_s64bit <> RESULT_S64BIT then
  769. failed := true;
  770. if failed then
  771. fail
  772. else
  773. WriteLn('Passed!');
  774. write('Testing floatdef function results...');
  775. clear_globals;
  776. clear_values;
  777. failed := false;
  778. clear_globals;
  779. clear_values;
  780. value_s32real := func_s32real;
  781. if trunc(value_s32real) <> trunc(RESULT_S32REAL) then
  782. failed:=true;
  783. clear_globals;
  784. clear_values;
  785. value_s64real := func_s64real;
  786. if trunc(value_s64real) <> trunc(RESULT_S64REAL) then
  787. failed:=true;
  788. if failed then
  789. fail
  790. else
  791. WriteLn('Passed!');
  792. write('Testing ansistring function result...');
  793. clear_globals;
  794. clear_values;
  795. failed := false;
  796. value_ansistring := func_ansistring;
  797. if value_ansistring <> RESULT_BIGSTRING then
  798. failed:=true;
  799. if failed then
  800. fail
  801. else
  802. WriteLn('Passed!');
  803. write('Testing pointer function result (LOC_REGISTER)...');
  804. clear_globals;
  805. clear_values;
  806. failed := false;
  807. value_ptr := func_pchar;
  808. if value_ptr <> RESULT_PCHAR then
  809. failed := true;
  810. if failed then
  811. fail
  812. else
  813. WriteLn('Passed!');
  814. {*********************************** TESTS W/PARAMS ***********************************}
  815. write('Testing function results with parameter (LOC_REFERENCE)...');
  816. clear_globals;
  817. clear_values;
  818. failed := false;
  819. value_smallarray := func_array_mixed(RESULT_U8BIT);
  820. if (value_smallarray[1] <> RESULT_U8BIT) or (value_smallarray[SMALL_INDEX] <> RESULT_U8BIT) then
  821. failed := true;
  822. if global_u8bit <> RESULT_U8BIT then
  823. failed := true;
  824. clear_globals;
  825. clear_values;
  826. value_largerec := func_largerecord_mixed(RESULT_U8BIT);
  827. if (value_largerec.b[1] <> RESULT_U8BIT) or (value_largerec.b[BIG_INDEX] <> RESULT_U8BIT) then
  828. failed:=true;
  829. if global_u8bit <> RESULT_U8BIT then
  830. failed := true;
  831. clear_globals;
  832. clear_values;
  833. value_bigstring := func_shortstring_mixed(RESULT_U8BIT);
  834. if value_bigstring <> RESULT_BIGSTRING then
  835. failed := true;
  836. if global_u8bit <> RESULT_U8BIT then
  837. failed := true;
  838. clear_globals;
  839. clear_values;
  840. value_largeset := func_largeset_mixed(RESULT_U8BIT);
  841. if not ('I' in value_largeset) then
  842. failed := true;
  843. if global_u8bit <> RESULT_U8BIT then
  844. failed := true;
  845. if failed then
  846. fail
  847. else
  848. WriteLn('Passed!');
  849. write('Testing orddef/enumdef function results with parameter (LOC_REGISTER)...');
  850. clear_globals;
  851. clear_values;
  852. failed := false;
  853. value_u8bit := func_u8bit_mixed(RESULT_U8BIT);
  854. if value_u8bit <> RESULT_U8BIT then
  855. failed := true;
  856. if global_u8bit <> RESULT_U8BIT then
  857. failed := true;
  858. clear_globals;
  859. clear_values;
  860. value_u16bit := func_u16bit_mixed(RESULT_U8BIT);
  861. if value_u16bit <> RESULT_U16BIT then
  862. failed := true;
  863. if global_u8bit <> RESULT_U8BIT then
  864. failed := true;
  865. clear_globals;
  866. clear_values;
  867. value_s32bit := func_s32bit_mixed(RESULT_U8BIT);
  868. if value_s32bit <> RESULT_S32BIT then
  869. failed := true;
  870. if global_u8bit <> RESULT_U8BIT then
  871. failed := true;
  872. clear_globals;
  873. clear_values;
  874. value_s64bit := func_s64bit_mixed(RESULT_U8BIT);
  875. if value_s64bit <> RESULT_S64BIT then
  876. failed := true;
  877. if global_u8bit <> RESULT_U8BIT then
  878. failed := true;
  879. if failed then
  880. fail
  881. else
  882. WriteLn('Passed!');
  883. write('Testing floatdef function results with parameter...');
  884. clear_globals;
  885. clear_values;
  886. failed := false;
  887. value_s32real := func_s32real_mixed(RESULT_U8BIT);
  888. if trunc(value_s32real) <> trunc(RESULT_S32REAL) then
  889. failed:=true;
  890. if global_u8bit <> RESULT_U8BIT then
  891. failed := true;
  892. clear_globals;
  893. clear_values;
  894. value_s64real := func_s64real_mixed(RESULT_U8BIT);
  895. if trunc(value_s64real) <> trunc(RESULT_S64REAL) then
  896. failed:=true;
  897. if global_u8bit <> RESULT_U8BIT then
  898. failed := true;
  899. if failed then
  900. fail
  901. else
  902. WriteLn('Passed!');
  903. write('Testing ansistring function result with parameter...');
  904. clear_globals;
  905. clear_values;
  906. failed := false;
  907. value_ansistring := func_ansistring_mixed(RESULT_U8BIT);
  908. if value_ansistring <> RESULT_BIGSTRING then
  909. failed:=true;
  910. if global_u8bit <> RESULT_U8BIT then
  911. failed := true;
  912. if failed then
  913. fail
  914. else
  915. WriteLn('Passed!');
  916. write('Testing pointer function result with parameter (LOC_REGISTER)...');
  917. clear_globals;
  918. clear_values;
  919. failed := false;
  920. value_ptr := func_pchar_mixed(RESULT_U8BIT);
  921. if value_ptr <> RESULT_PCHAR then
  922. failed := true;
  923. if global_u8bit <> RESULT_U8BIT then
  924. failed := true;
  925. if failed then
  926. fail
  927. else
  928. WriteLn('Passed!');
  929. {******************************NESTED TESTS W/PARAMS **********************************}
  930. write('Testing function (w/nesting) results with parameter (LOC_REFERENCE)...');
  931. clear_globals;
  932. clear_values;
  933. failed := false;
  934. value_smallarray := func_array_mixed_nested(RESULT_U8BIT);
  935. if (value_smallarray[1] <> RESULT_U8BIT) or (value_smallarray[SMALL_INDEX] <> RESULT_U8BIT) then
  936. failed := true;
  937. if global_u8bit <> RESULT_U8BIT then
  938. failed := true;
  939. if global_bigstring <> RESULT_BIGSTRING then
  940. failed := true;
  941. if global_u16bit <> RESULT_U8BIT then
  942. failed := true;
  943. if global_s32bit <> RESULT_S32BIT then
  944. failed := true;
  945. if global_s64bit <> RESULT_U8BIT then
  946. failed := true;
  947. clear_globals;
  948. clear_values;
  949. value_largerec := func_largerecord_mixed_nested(RESULT_U8BIT);
  950. if (value_largerec.b[1] <> RESULT_U8BIT) or (value_largerec.b[BIG_INDEX] <> RESULT_U8BIT) then
  951. failed:=true;
  952. if global_u8bit <> RESULT_U8BIT then
  953. failed := true;
  954. if global_bigstring <> RESULT_BIGSTRING then
  955. failed := true;
  956. if global_u16bit <> RESULT_U8BIT then
  957. failed := true;
  958. if global_s64bit <> RESULT_U8BIT then
  959. failed := true;
  960. if global_s32bit <> RESULT_S32BIT then
  961. failed := true;
  962. clear_globals;
  963. clear_values;
  964. value_bigstring := func_shortstring_mixed_nested(RESULT_U8BIT);
  965. if value_bigstring <> RESULT_BIGSTRING then
  966. failed := true;
  967. if global_u8bit <> RESULT_U8BIT then
  968. failed := true;
  969. if global_bigstring <> RESULT_BIGSTRING then
  970. failed := true;
  971. if global_u16bit <> RESULT_U8BIT then
  972. failed := true;
  973. if global_s32bit <> RESULT_S32BIT then
  974. failed := true;
  975. if global_s64bit <> RESULT_U8BIT then
  976. failed := true;
  977. clear_globals;
  978. clear_values;
  979. value_largeset := func_largeset_mixed_nested(RESULT_U8BIT);
  980. if not ('I' in value_largeset) then
  981. failed := true;
  982. if global_u8bit <> RESULT_U8BIT then
  983. failed := true;
  984. if global_bigstring <> RESULT_BIGSTRING then
  985. failed := true;
  986. if global_u16bit <> RESULT_U8BIT then
  987. failed := true;
  988. if global_s32bit <> RESULT_S32BIT then
  989. failed := true;
  990. if global_s64bit <> RESULT_U8BIT then
  991. failed := true;
  992. if failed then
  993. fail
  994. else
  995. WriteLn('Passed!');
  996. write('Testing orddef/enumdef function (w/nesting) results with parameter (LOC_REGISTER)...');
  997. clear_globals;
  998. clear_values;
  999. failed := false;
  1000. value_u8bit := func_u8bit_mixed_nested(RESULT_U8BIT);
  1001. if value_u8bit <> RESULT_U8BIT then
  1002. failed := true;
  1003. if global_u8bit <> RESULT_U8BIT then
  1004. failed := true;
  1005. if global_bigstring <> RESULT_BIGSTRING then
  1006. failed := true;
  1007. if global_u16bit <> RESULT_U8BIT then
  1008. failed := true;
  1009. if global_s32bit <> RESULT_S32BIT then
  1010. failed := true;
  1011. if global_s64bit <> RESULT_U8BIT then
  1012. failed := true;
  1013. clear_globals;
  1014. clear_values;
  1015. value_u16bit := func_u16bit_mixed_nested(RESULT_U8BIT);
  1016. if value_u16bit <> RESULT_U16BIT then
  1017. failed := true;
  1018. if global_u8bit <> RESULT_U8BIT then
  1019. failed := true;
  1020. if global_bigstring <> RESULT_BIGSTRING then
  1021. failed := true;
  1022. if global_u16bit <> RESULT_U8BIT then
  1023. failed := true;
  1024. if global_s64bit <> RESULT_U8BIT then
  1025. failed := true;
  1026. if global_s32bit <> RESULT_S32BIT then
  1027. failed := true;
  1028. clear_globals;
  1029. clear_values;
  1030. value_s32bit := func_s32bit_mixed_nested(RESULT_U8BIT);
  1031. if value_s32bit <> RESULT_S32BIT then
  1032. failed := true;
  1033. if global_u8bit <> RESULT_U8BIT then
  1034. failed := true;
  1035. if global_bigstring <> RESULT_BIGSTRING then
  1036. failed := true;
  1037. if global_u16bit <> RESULT_U8BIT then
  1038. failed := true;
  1039. if global_s64bit <> RESULT_U8BIT then
  1040. failed := true;
  1041. if global_s32bit <> RESULT_S32BIT then
  1042. failed := true;
  1043. clear_globals;
  1044. clear_values;
  1045. value_s64bit := func_s64bit_mixed_nested(RESULT_U8BIT);
  1046. if value_s64bit <> RESULT_S64BIT then
  1047. failed := true;
  1048. if global_u8bit <> RESULT_U8BIT then
  1049. failed := true;
  1050. if global_bigstring <> RESULT_BIGSTRING then
  1051. failed := true;
  1052. if global_u16bit <> RESULT_U8BIT then
  1053. failed := true;
  1054. if global_s64bit <> RESULT_U8BIT then
  1055. failed := true;
  1056. if global_s32bit <> RESULT_S32BIT then
  1057. failed := true;
  1058. if failed then
  1059. fail
  1060. else
  1061. WriteLn('Passed!');
  1062. write('Testing floatdef function (w/nesting) results with parameter...');
  1063. clear_globals;
  1064. clear_values;
  1065. failed := false;
  1066. value_s32real := func_s32real_mixed_nested(RESULT_U8BIT);
  1067. if trunc(value_s32real) <> trunc(RESULT_S32REAL) then
  1068. failed:=true;
  1069. if global_u8bit <> RESULT_U8BIT then
  1070. failed := true;
  1071. if global_bigstring <> RESULT_BIGSTRING then
  1072. failed := true;
  1073. if global_u16bit <> RESULT_U8BIT then
  1074. failed := true;
  1075. if global_s64bit <> RESULT_U8BIT then
  1076. failed := true;
  1077. if global_s32bit <> RESULT_S32BIT then
  1078. failed := true;
  1079. clear_globals;
  1080. clear_values;
  1081. value_s64real := func_s64real_mixed_nested(RESULT_U8BIT);
  1082. if trunc(value_s64real) <> trunc(RESULT_S64REAL) then
  1083. failed:=true;
  1084. if global_u8bit <> RESULT_U8BIT then
  1085. failed := true;
  1086. if global_bigstring <> RESULT_BIGSTRING then
  1087. failed := true;
  1088. if global_u16bit <> RESULT_U8BIT then
  1089. failed := true;
  1090. if global_s64bit <> RESULT_U8BIT then
  1091. failed := true;
  1092. if global_s32bit <> RESULT_S32BIT then
  1093. failed := true;
  1094. if failed then
  1095. fail
  1096. else
  1097. WriteLn('Passed!');
  1098. write('Testing ansistring function (w/nesting) result with parameter...');
  1099. clear_globals;
  1100. clear_values;
  1101. failed := false;
  1102. value_ansistring := func_ansistring_mixed_nested(RESULT_U8BIT);
  1103. if value_ansistring <> RESULT_BIGSTRING then
  1104. failed:=true;
  1105. if global_u8bit <> RESULT_U8BIT then
  1106. failed := true;
  1107. if global_bigstring <> RESULT_BIGSTRING then
  1108. failed := true;
  1109. if global_u16bit <> RESULT_U8BIT then
  1110. failed := true;
  1111. if global_s64bit <> RESULT_U8BIT then
  1112. failed := true;
  1113. if global_s32bit <> RESULT_S32BIT then
  1114. failed := true;
  1115. if failed then
  1116. fail
  1117. else
  1118. WriteLn('Passed!');
  1119. write('Testing pointer function (w/nesting) result with parameter (LOC_REGISTER)...');
  1120. clear_globals;
  1121. clear_values;
  1122. failed := false;
  1123. value_ptr := func_pchar_mixed_nested(RESULT_U8BIT);
  1124. if value_ptr <> RESULT_PCHAR then
  1125. failed := true;
  1126. if global_u8bit <> RESULT_U8BIT then
  1127. failed := true;
  1128. if global_bigstring <> RESULT_BIGSTRING then
  1129. failed := true;
  1130. if global_u16bit <> RESULT_U8BIT then
  1131. failed := true;
  1132. if global_s64bit <> RESULT_U8BIT then
  1133. failed := true;
  1134. if global_s32bit <> RESULT_S32BIT then
  1135. failed := true;
  1136. if failed then
  1137. fail
  1138. else
  1139. WriteLn('Passed!');
  1140. end.