├── xdp.exe ├── compsamp.bat ├── memory.png ├── readme.txt ├── samples ├── eqerr.dat ├── eq.dat ├── cannabis.pas ├── palette.pas ├── gauss.inc ├── factor.pas ├── list.pas ├── lineq.pas ├── fractal.pas ├── clock.pas ├── life.pas ├── sort.pas ├── fft.pas ├── inserr.pas └── kalman.inc ├── README.md ├── system.pas └── xdp.dpr /xdp.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vtereshkov/xdp/HEAD/xdp.exe -------------------------------------------------------------------------------- /compsamp.bat: -------------------------------------------------------------------------------- 1 | for %%f in (samples\*.pas) do xdp %%f %1 2 | pause 3 | -------------------------------------------------------------------------------- /memory.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vtereshkov/xdp/HEAD/memory.png -------------------------------------------------------------------------------- /readme.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vtereshkov/xdp/HEAD/readme.txt -------------------------------------------------------------------------------- /samples/eqerr.dat: -------------------------------------------------------------------------------- 1 | Example. Zero on the diagonal 2 | 7 3 | 0 -63.142 -38.836 -18.205 -74.554 -98.818 -64.683 -11794.102 4 | -9.677 11.028 -78.284 -6.888 56.992 -79.873 -73.671 -7350.587 5 | -51.427 24.076 70.244 -69.468 21.93 72.647 90.342 11518.809 6 | 20.945 60.902 -69.023 47.597 -85.542 49.466 -94.432 -62.607 7 | 16.921 82.31 -84.13 65.338 30.77 -23.976 -88.814 -4355.97 8 | -1.11 45.532 28.197 74.669 -79.037 10.561 -73.67 -1908.373 9 | 48.148 -36.996 9.018 -39.984 -54.582 91.142 72.861 6856.28 10 | -------------------------------------------------------------------------------- /samples/eq.dat: -------------------------------------------------------------------------------- 1 | Example. Reference solution: x = (-32, 17, 5, -14, 9, 77, 26) 2 | 7 3 | 25.614 -63.142 -38.836 -18.205 -74.554 -98.818 -64.683 -11794.102 4 | -9.677 11.028 -78.284 -6.888 56.992 -79.873 -73.671 -7350.587 5 | -51.427 24.076 70.244 -69.468 21.93 72.647 90.342 11518.809 6 | 20.945 60.902 -69.023 47.597 -85.542 49.466 -94.432 -62.607 7 | 16.921 82.31 -84.13 65.338 30.77 -23.976 -88.814 -4355.97 8 | -1.11 45.532 28.197 74.669 -79.037 10.561 -73.67 -1908.373 9 | 48.148 -36.996 9.018 -39.984 -54.582 91.142 72.861 6856.28 10 | -------------------------------------------------------------------------------- /samples/cannabis.pas: -------------------------------------------------------------------------------- 1 | // Cannabola plot program 2 | 3 | 4 | program Cannabis; 5 | 6 | 7 | 8 | const 9 | dt0 = 0.003; 10 | scale = 120; 11 | 12 | 13 | var 14 | r, rold, rdot, t, dt, x, y: Real; 15 | 16 | 17 | begin 18 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 19 | 20 | t := 0; 21 | dt := dt0; 22 | rold := 0; 23 | 24 | while t <= 2 * pi do 25 | begin 26 | r := (1 + sin(t)) * (1 + 0.9 * cos(8 * t)) * (1 + 0.1 * cos(24 * t)) * (0.5 + 0.05 * cos(200 * t)); 27 | 28 | x := r * cos(t); 29 | y := r * sin(t); 30 | 31 | rdot := abs(r - rold) / dt; 32 | 33 | dt := dt0 / (1 + rdot); 34 | 35 | PutPixel(320 + Round(scale * x), 290 - Round(scale * y), 10); 36 | 37 | t := t + dt; 38 | rold := r; 39 | end; 40 | 41 | repeat until KeyPressed; 42 | SetScreenMode($03); 43 | end. -------------------------------------------------------------------------------- /samples/palette.pas: -------------------------------------------------------------------------------- 1 | // Graphics palette usage demo 2 | 3 | 4 | program Palette; 5 | 6 | 7 | 8 | const 9 | VideoBufOrigin = $A0000000; 10 | Width = 320; 11 | Height = 200; 12 | 13 | 14 | type 15 | TVideoBuf = array [0..Height - 1, 0..Width - 1] of ShortInt; 16 | PVideoBuf = ^TVideoBuf; 17 | 18 | 19 | procedure SetPalette; 20 | var 21 | i: Integer; 22 | begin 23 | for i := 0 to 255 do 24 | begin 25 | OutP($3C8, i); 26 | OutP($3C9, i div 8); // Red 27 | OutP($3C9, i div 8); // Green 28 | OutP($3C9, i div 4); // Blue 29 | end; 30 | end; 31 | 32 | 33 | var 34 | x, y, i: Integer; 35 | Color: ShortInt; 36 | VideoBuf: PVideoBuf; 37 | 38 | 39 | begin 40 | SetScreenMode($13); // 320 x 200, 256 colors 41 | SetPalette; 42 | 43 | VideoBuf := PVideoBuf(VideoBufOrigin); 44 | 45 | i := 0; 46 | repeat 47 | for x := 0 to Width - 1 do 48 | for y := 0 to Height - 1 do 49 | begin 50 | Color := Round(127.5 * (1 + sin(0.01 * (x + y + i)))) mod 256; 51 | VideoBuf^[y, x] := Color; 52 | end; 53 | Inc(i); 54 | until KeyPressed; 55 | 56 | SetScreenMode($03); 57 | end. -------------------------------------------------------------------------------- /samples/gauss.inc: -------------------------------------------------------------------------------- 1 | // Implementation of Gauss' method for linear systems 2 | 3 | 4 | 5 | const 6 | MAXSIZE = 10; 7 | 8 | 9 | type 10 | TVector = array [1..MAXSIZE] of Real; 11 | TMatrix = array [1..MAXSIZE] of TVector; 12 | 13 | 14 | 15 | procedure Error(const E: string); forward; // To be defined in the main module 16 | 17 | 18 | 19 | procedure SolveLinearSystem(var T: TMatrix; var x: TVector; m: Integer); 20 | var 21 | i, j, k: Integer; 22 | s: Real; 23 | 24 | procedure TriangularizeMatrix(var T: TMatrix; m: Integer); 25 | var 26 | i, j, k: Integer; 27 | r: Real; 28 | begin 29 | for k := 1 to m - 1 do 30 | for i := k + 1 to m do 31 | begin 32 | if T[k, k] = 0 then Error('Diagonal element is zero'); 33 | 34 | r := -T[i, k] / T[k, k]; 35 | 36 | for j := k to m + 1 do 37 | T[i, j] := T[i, j] + r * T[k, j]; 38 | end; 39 | end; 40 | 41 | begin 42 | TriangularizeMatrix(T, m); 43 | 44 | for i := m downto 1 do 45 | begin 46 | s := T[i, m + 1]; 47 | for j := m downto i + 1 do 48 | s := s - T[i, j] * x[j]; 49 | 50 | if T[i, i] = 0 then Error('Singular matrix'); 51 | 52 | x[i] := s / T[i, i]; 53 | end; // for 54 | 55 | end; 56 | 57 | -------------------------------------------------------------------------------- /samples/factor.pas: -------------------------------------------------------------------------------- 1 | // Factorization demo 2 | 3 | 4 | program Factor; 5 | 6 | 7 | 8 | var 9 | LowBound, HighBound, Number, Dividend, Divisor, MaxDivisor: Integer; 10 | DivisorFound: Boolean; 11 | 12 | 13 | begin 14 | WriteLn; 15 | WriteLn('Integer factorization demo'); 16 | WriteLn; 17 | Write('From number: '); ReadLn(LowBound); 18 | Write('To number : '); ReadLn(HighBound); 19 | WriteLn; 20 | 21 | if LowBound < 2 then 22 | begin 23 | WriteLn('Numbers should be greater than 2'); 24 | ReadLn; 25 | Halt(1); 26 | end; 27 | 28 | for Number := LowBound to HighBound do 29 | begin 30 | Write(Number, ' = '); 31 | 32 | Dividend := Number; 33 | while Dividend > 1 do 34 | begin 35 | MaxDivisor := IMin(Round(Sqrt(Dividend)), Dividend - 1); 36 | Divisor := 1; 37 | DivisorFound := FALSE; 38 | 39 | while (Divisor <= MaxDivisor) and not DivisorFound do 40 | begin 41 | Inc(Divisor); 42 | if Dividend mod Divisor = 0 then DivisorFound := TRUE; 43 | end; 44 | 45 | if not DivisorFound then Divisor := Dividend; // Prime number 46 | 47 | Write(Divisor, ' '); 48 | Dividend := Dividend div Divisor; 49 | end; // while 50 | 51 | WriteLn; 52 | end; // for 53 | 54 | WriteLn; 55 | WriteLn('Done.'); 56 | 57 | ReadLn; 58 | end. 59 | -------------------------------------------------------------------------------- /samples/list.pas: -------------------------------------------------------------------------------- 1 | // Linked list operations demo 2 | 3 | 4 | program List; 5 | 6 | 7 | 8 | type 9 | PPerson = ^TPerson; 10 | 11 | TPerson = record 12 | Next: PPerson; 13 | Name, Surname: string; 14 | Born: SmallInt; 15 | end; 16 | 17 | 18 | var 19 | Head, Node, NewNode: PPerson; 20 | ch: Char; 21 | 22 | 23 | 24 | begin 25 | WriteLn; 26 | WriteLn('Linked list operations demo'); 27 | WriteLn; 28 | 29 | New(Node); 30 | Head := Node; 31 | 32 | 33 | // Fill the list 34 | repeat 35 | Write('Add new record? (Y/N): '); ReadLn(ch); 36 | WriteLn; 37 | 38 | if (ch = 'y') or (ch = 'Y') then 39 | begin 40 | New(NewNode); 41 | Node^.Next := NewNode; 42 | Node := NewNode; 43 | Node^.Next := nil; 44 | Write('Name : '); ReadLn(Node^.Name); 45 | Write('Surname : '); ReadLn(Node^.Surname); 46 | Write('Born in : '); ReadLn(Node^.Born); 47 | WriteLn; 48 | end; 49 | until (ch = 'n') or (ch = 'N'); 50 | 51 | 52 | WriteLn; 53 | WriteLn('Record list: '); 54 | WriteLn; 55 | 56 | 57 | // Traverse the list 58 | Node := Head^.Next; 59 | 60 | while Node <> nil do 61 | begin 62 | WriteLn(Node^.Name, ' ', Node^.Surname, ', b. ', Node^.Born); 63 | Node := Node^.Next; 64 | end; 65 | 66 | 67 | // Clear the list 68 | Node := Head; 69 | 70 | while Node <> nil do 71 | begin 72 | NewNode := Node^.Next; 73 | Dispose(Node); 74 | Node := NewNode; 75 | end; 76 | 77 | WriteLn; 78 | WriteLn('Done.'); 79 | 80 | ReadLn; 81 | end. 82 | 83 | 84 | 85 | 86 | -------------------------------------------------------------------------------- /samples/lineq.pas: -------------------------------------------------------------------------------- 1 | // Linear equations solver 2 | 3 | 4 | program LinEq; 5 | 6 | 7 | 8 | {$I samples\gauss.inc} 9 | 10 | 11 | 12 | procedure Error; 13 | begin 14 | WriteLn; 15 | WriteLn('Error: ', E, '.'); 16 | ReadLn; 17 | Halt(1); 18 | end; 19 | 20 | 21 | 22 | var 23 | A: TMatrix; 24 | x: TVector; 25 | m, i, j: Integer; 26 | 27 | DatName, Comment: string; 28 | DatFile: Text; 29 | Err: Integer; 30 | 31 | 32 | 33 | begin 34 | WriteLn; 35 | WriteLn('Linear equations solver'); 36 | WriteLn; 37 | Write('File name : '); ReadLn(DatName); 38 | WriteLn; 39 | 40 | Reset(DatFile, DatName); 41 | Err := IOResult; 42 | if Err <> 0 then 43 | begin 44 | WriteLn('Unable to open file: ', DatName, ' (error code ', Err, ')'); 45 | ReadLn; 46 | Halt(1); 47 | end; 48 | 49 | ReadLn(DatFile, Comment); 50 | WriteLn('Comment : ', Comment); 51 | WriteLn; 52 | 53 | ReadLn(DatFile, m); 54 | WriteLn('System order: ', m); 55 | WriteLn; 56 | 57 | WriteLn('Augmented ', m, ' x ', m + 1, ' matrix: '); 58 | WriteLn; 59 | 60 | for i := 1 to m do 61 | begin 62 | for j := 1 to m + 1 do 63 | begin 64 | Read(DatFile, A[i, j]); 65 | Write(A[i, j], ' '); 66 | end; 67 | ReadLn(DatFile); 68 | WriteLn; 69 | end; 70 | 71 | Close(DatFile); 72 | 73 | SolveLinearSystem(A, x, m); 74 | 75 | WriteLn; 76 | WriteLn('Triangularized matrix:'); 77 | WriteLn; 78 | 79 | for i := 1 to m do 80 | begin 81 | for j := 1 to m + 1 do 82 | Write(A[i, j], ' '); 83 | WriteLn; 84 | end; 85 | 86 | WriteLn; 87 | WriteLn('Solution: '); 88 | WriteLn; 89 | 90 | for i := 1 to m do 91 | WriteLn('x', i, ' = ', x[i]); 92 | 93 | WriteLn; 94 | WriteLn('Done.'); 95 | ReadLn; 96 | end. 97 | -------------------------------------------------------------------------------- /samples/fractal.pas: -------------------------------------------------------------------------------- 1 | // Mandelbrot set fragment plot program 2 | 3 | 4 | program Fractal; 5 | 6 | 7 | 8 | const 9 | ReCmax = 0.08; ReCmin = -0.66; 10 | ImCmax = -0.3; ImCmin = -1.25; 11 | 12 | Inf = 200; 13 | MaxPoints = 45; 14 | 15 | Scale = 320; 16 | 17 | 18 | 19 | function ScreenX(x: Real): Integer; 20 | begin 21 | Result := 410 + Round(Scale * x); 22 | end; 23 | 24 | 25 | 26 | function ScreenY(y: Real): Integer; 27 | begin 28 | Result := 420 + Round(Scale * y); 29 | end; 30 | 31 | 32 | 33 | var 34 | ReC, ImC, ReZ, ImZ, ReZnew, ImZnew: Real; 35 | i, x, y, xmin, ymin, xmax, ymax: SmallInt; 36 | color: ShortInt; 37 | IsInf: Boolean; 38 | Palette: array [0..8] of ShortInt; 39 | 40 | 41 | 42 | begin 43 | // Custom palette 44 | Palette[0] := 4 ; Palette[1] := 12; Palette[2] := 13; 45 | Palette[3] := 14; Palette[4] := 10; Palette[5] := 2 ; 46 | Palette[6] := 3 ; Palette[7] := 1 ; Palette[8] := 0 ; 47 | 48 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 49 | 50 | // Border lines 51 | xmin := ScreenX(ReCmin) - 1; ymin := ScreenY(ImCmin) - 1; 52 | xmax := ScreenX(ReCmax) + 1; ymax := ScreenY(ImCmax) + 1; 53 | 54 | Line(xmin, ymin, xmax, ymin, 15); 55 | Line(xmin, ymax, xmax, ymax, 15); 56 | Line(xmin, ymin, xmin, ymax, 15); 57 | Line(xmax, ymin, xmax, ymax, 15); 58 | 59 | // Mandelbrot set construction 60 | ReC := ReCmin; 61 | 62 | while ReC <= ReCmax do 63 | begin 64 | ImC := ImCmin; 65 | 66 | while ImC <= ImCmax do 67 | begin 68 | ReZ := 0; ImZ := 0; 69 | IsInf := FALSE; 70 | color := 0; 71 | i := 1; 72 | 73 | while (i <= MaxPoints) and not IsInf do 74 | begin 75 | ReZnew := ReZ * ReZ - ImZ * ImZ + ReC; 76 | ImZnew := 2 * ReZ * ImZ + ImC; 77 | 78 | if (abs(ReZnew) > Inf) or (abs(ImZnew) > Inf) then 79 | begin 80 | IsInf := TRUE; 81 | color := Palette[8 - (i - 1) div 5]; 82 | end; 83 | 84 | ReZ := ReZnew; ImZ := ImZnew; 85 | Inc(i); 86 | end; // while i... 87 | 88 | PutPixel(ScreenX(ReC), ScreenY(ImC), color); 89 | 90 | ImC := ImC + 0.001; 91 | end; // while ImC... 92 | 93 | ReC := ReC + 0.001; 94 | end; // while ReC... 95 | 96 | repeat until KeyPressed; 97 | SetScreenMode($03); 98 | end. 99 | -------------------------------------------------------------------------------- /samples/clock.pas: -------------------------------------------------------------------------------- 1 | // Clock demo program 2 | 3 | 4 | program Clock; 5 | 6 | 7 | 8 | const 9 | LHr = 60; 10 | LMn = 100; 11 | LSec = 120; 12 | RTickStart = 130; 13 | RTickEnd = 160; 14 | LTail = -10; 15 | RClock = 170; 16 | 17 | 18 | 19 | var 20 | Time: Integer; 21 | Hr, Mn, Sec, HrOld, MnOld, SecOld: Real; 22 | 23 | 24 | 25 | 26 | 27 | procedure DrawArrow(Value, Rmin, Rmax: Real; Positions: Integer; Color: Integer); 28 | var 29 | Angle: Real; 30 | begin 31 | Angle := Pi / 2 - 2 * Pi * Value / Positions; 32 | Line(320 + Round(Rmin * cos(Angle)), 175 - Round(Rmin * sin(Angle)), 33 | 320 + Round(Rmax * cos(Angle)), 175 - Round(Rmax * sin(Angle)), Color); 34 | end; 35 | 36 | 37 | 38 | procedure DrawDigits(Value: Integer; R: Real; Positions: Integer; Color: Integer); 39 | var 40 | Angle: Real; 41 | Digits: string; 42 | begin 43 | Angle := Pi / 2 - 2 * Pi * Value / Positions; 44 | IStr(Value, Digits); 45 | OutTextXY(320 + Round(R * cos(Angle)), 175 - Round(R * sin(Angle)), Color, Digits); 46 | end; 47 | 48 | 49 | 50 | 51 | var 52 | TickIndex: Integer; 53 | 54 | 55 | 56 | begin 57 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 58 | 59 | Circle(320, 175, Round(RClock), 15); 60 | 61 | for TickIndex := 0 to 11 do 62 | DrawArrow(TickIndex, RTickStart, RTickEnd, 12, 15); // Draw long ticks 63 | 64 | for TickIndex := 0 to 59 do 65 | DrawArrow(TickIndex, RTickStart + 20, RTickEnd, 60, 15); // Draw short ticks 66 | 67 | repeat 68 | Time := Round(Timer / 1573032 * 86400); 69 | 70 | Hr := Time / 3600; 71 | Mn := (Time mod 3600) / 60; 72 | Sec := (Time mod 3600) mod 60; 73 | 74 | if Sec <> SecOld then 75 | begin 76 | DrawArrow(SecOld, LTail, LSec, 60, 0 ); // Erase old arrow 77 | DrawArrow(Sec, LTail, LSec, 60, 14); // Draw new arrow 78 | 79 | DrawArrow(MnOld, LTail, LMn, 60, 0 ); // Erase old arrow 80 | DrawArrow(Mn, LTail, LMn, 60, 13); // Draw new arrow 81 | 82 | DrawArrow(HrOld, LTail, LHr, 12, 0 ); // Erase old arrow 83 | DrawArrow(Hr, LTail, LHr, 12, 10); // Draw new arrow 84 | 85 | // Refresh hour digits 86 | for TickIndex := 1 to 12 do 87 | DrawDigits(TickIndex, RTickStart - 20, 12, 15); 88 | end; 89 | 90 | HrOld := Hr; MnOld := Mn; SecOld := Sec; 91 | until KeyPressed; 92 | 93 | 94 | SetScreenMode($03); 95 | end. 96 | 97 | -------------------------------------------------------------------------------- /samples/life.pas: -------------------------------------------------------------------------------- 1 | // The Game of Life 2 | 3 | 4 | program Life; 5 | 6 | 7 | 8 | const 9 | VideoBufOrigin = $A0000000; 10 | Width = 320; 11 | Height = 200; 12 | FieldSize = 100; 13 | 14 | 15 | type 16 | TVideoBuf = array [0..Height - 1, 0..Width - 1] of ShortInt; 17 | PVideoBuf = ^TVideoBuf; 18 | TField = array [1..FieldSize * FieldSize] of Boolean; 19 | 20 | 21 | var 22 | VideoBuf: PVideoBuf; 23 | Fld: TField; 24 | 25 | 26 | 27 | function ind(i, j: Integer): Integer; // Linear index of a cell modulo field size 28 | begin 29 | while i > FIELDSIZE do i := i - FIELDSIZE; 30 | while i < 1 do i := i + FIELDSIZE; 31 | while j > FIELDSIZE do j := j - FIELDSIZE; 32 | while j < 1 do j := j + FIELDSIZE; 33 | 34 | Result := FIELDSIZE * (i - 1) + j; 35 | end; 36 | 37 | 38 | 39 | 40 | procedure Redraw; 41 | const 42 | OriginX = Width div 2 - FieldSize div 2; 43 | OriginY = Height div 2 - FieldSize div 2; 44 | 45 | var 46 | i, j: Integer; 47 | clr: ShortInt; 48 | 49 | begin 50 | for i := 1 to FieldSize do 51 | for j := 1 to FieldSize do 52 | begin 53 | if Fld[ind(i, j)] then clr := 14 else clr := 1; 54 | VideoBuf^[OriginY + j, OriginX + i] := clr; 55 | end; 56 | 57 | end; // Redraw 58 | 59 | 60 | 61 | 62 | procedure Init; 63 | var 64 | i, j: Integer; 65 | begin 66 | Randomize; 67 | 68 | for i := 1 to FieldSize do 69 | for j := 1 to FieldSize do 70 | Fld[ind(i, j)] := Random > 0.5; 71 | end; // Init 72 | 73 | 74 | 75 | 76 | procedure Regenerate; 77 | var 78 | NextFld: TField; 79 | i, j, ni, nj, n: Integer; 80 | begin 81 | 82 | for i := 1 to FieldSize do 83 | for j := 1 to FieldSize do 84 | begin 85 | // Count cell neighbors 86 | n := 0; 87 | for ni := i - 1 to i + 1 do 88 | for nj := j - 1 to j + 1 do 89 | if Fld[ind(ni, nj)] and not ((ni = i) and (nj = j)) then Inc(n); 90 | 91 | // Bear or kill the current cell in the next generation 92 | if Fld[ind(i, j)] then 93 | NextFld[ind(i, j)] := (n > 1) and (n < 4) // Kill the cell or keep it alive 94 | else 95 | NextFld[ind(i, j)] := n = 3; // Bear the cell or keep it dead 96 | end; // for j... 97 | 98 | // Make new generation 99 | for i := 1 to FieldSize do 100 | for j := 1 to FieldSize do 101 | Fld[ind(i, j)] := NextFld[ind(i, j)]; 102 | 103 | end; // Regenerate 104 | 105 | 106 | 107 | 108 | var 109 | Ch: Char; 110 | 111 | begin 112 | // Create initial population 113 | Init; 114 | 115 | // Set graphics mode 116 | SetScreenMode($13); // 320 x 200, 256 colors 117 | VideoBuf := PVideoBuf(VideoBufOrigin); 118 | 119 | // Run simulation 120 | repeat 121 | Redraw; 122 | Regenerate; 123 | until KeyPressed; 124 | 125 | SetScreenMode($03); 126 | end. 127 | 128 | 129 | 130 | -------------------------------------------------------------------------------- /samples/sort.pas: -------------------------------------------------------------------------------- 1 | // Sorting demo 2 | 3 | 4 | program Sort; 5 | 6 | 7 | 8 | const 9 | DataLength = 60; 10 | 11 | 12 | 13 | type 14 | TNumber = Integer; 15 | 16 | TData = array [1..DataLength] of TNumber; 17 | PData = ^TData; 18 | 19 | 20 | 21 | procedure Swap(var x, y: TNumber); 22 | var 23 | buf: TNumber; 24 | begin 25 | buf := x; 26 | x := y; 27 | y := buf; 28 | end; 29 | 30 | 31 | 32 | 33 | function Partition(var data: TData; len: Integer): Integer; 34 | var 35 | pivot: TNumber; 36 | pivotIndex, i: Integer; 37 | begin 38 | pivot := data[len]; 39 | pivotIndex := 1; 40 | 41 | for i := 1 to len do 42 | if data[i] < pivot then 43 | begin 44 | Swap(data[pivotIndex], data[i]); 45 | Inc(pivotIndex); 46 | end; {if} 47 | 48 | Swap(data[len], data[pivotIndex]); 49 | 50 | Result := pivotIndex; 51 | end; 52 | 53 | 54 | 55 | 56 | procedure QuickSort(var data: TData; len: Integer); 57 | var 58 | pivotIndex: Integer; 59 | dataShiftedPtr: PData; 60 | begin 61 | if len > 1 then 62 | begin 63 | pivotIndex := Partition(data, len); 64 | dataShiftedPtr := PData(@data[pivotIndex + 1]); 65 | 66 | QuickSort(data, pivotIndex - 1 ); 67 | QuickSort(dataShiftedPtr^, len - pivotIndex); 68 | end; // if 69 | end; 70 | 71 | 72 | 73 | 74 | procedure BubbleSort(var data: TData; len: Integer); 75 | var 76 | changed: Boolean; 77 | i: Integer; 78 | begin 79 | repeat 80 | changed := FALSE; 81 | 82 | for i := 1 to len - 1 do 83 | if data[i + 1] < data[i] then 84 | begin 85 | Swap(data[i + 1], data[i]); 86 | changed := TRUE; 87 | end; 88 | 89 | until not changed; 90 | end; 91 | 92 | 93 | 94 | procedure SelectionSort(var data: TData; len: Integer); 95 | var 96 | i, j, extrIndex: Integer; 97 | extr: TNumber; 98 | begin 99 | for i := 1 to len do 100 | begin 101 | extr := data[i]; 102 | extrIndex := i; 103 | 104 | for j := i + 1 to len do 105 | if data[j] < extr then 106 | begin 107 | extr := data[j]; 108 | extrIndex := j; 109 | end; 110 | 111 | Swap(data[i], data[extrIndex]); 112 | end; // for 113 | end; 114 | 115 | 116 | 117 | var 118 | RandomData: TData; 119 | i: Integer; 120 | Method: Char; 121 | 122 | 123 | 124 | begin 125 | WriteLn; 126 | WriteLn('Sorting demo'); 127 | WriteLn; 128 | WriteLn('Initial array: '); 129 | WriteLn; 130 | 131 | Randomize; 132 | 133 | for i := 1 to DataLength do 134 | begin 135 | RandomData[i] := Round((Random - 0.5) * 1000000); 136 | Write(RandomData[i]); 137 | if i mod 4 <> 0 then Write(#9) else WriteLn; 138 | end; 139 | 140 | WriteLn; 141 | WriteLn; 142 | Write('Select method (Q - quick, B - bubble, S - selection): '); Read(Method); 143 | WriteLn; 144 | WriteLn; 145 | 146 | case Method of 147 | 'Q', 'q': 148 | begin 149 | WriteLn('Quick sorting'); 150 | QuickSort(RandomData, DataLength); 151 | end; 152 | 'B', 'b': 153 | begin 154 | WriteLn('Bubble sorting'); 155 | BubbleSort(RandomData, DataLength); 156 | end; 157 | 'S', 's': 158 | begin 159 | WriteLn('Selection sorting'); 160 | SelectionSort(RandomData, DataLength); 161 | end 162 | else 163 | WriteLn('Sorting method is not selected.'); 164 | ReadLn; 165 | Halt; 166 | end; 167 | 168 | WriteLn; 169 | WriteLn('Sorted array: '); 170 | WriteLn; 171 | 172 | for i := 1 to DataLength do 173 | begin 174 | Write(RandomData[i]); 175 | if i mod 4 <> 0 then Write(#9) else WriteLn; 176 | end; 177 | WriteLn; 178 | 179 | WriteLn; 180 | WriteLn('Done.'); 181 | 182 | ReadLn; 183 | end. 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | -------------------------------------------------------------------------------- /samples/fft.pas: -------------------------------------------------------------------------------- 1 | // Fast Fourier Transform demo program 2 | 3 | 4 | program FFT; 5 | 6 | 7 | 8 | const 9 | DataLength = 512; 10 | 11 | 12 | 13 | type 14 | Complex = record 15 | Re, Im: Real; 16 | end; 17 | 18 | TData = array [0..DataLength - 1] of Real; 19 | TComplexData = array [0..DataLength - 1] of Complex; 20 | 21 | PData = ^TData; 22 | 23 | 24 | 25 | var 26 | x, S: TData; 27 | Twiddle: TComplexData; 28 | 29 | 30 | 31 | 32 | procedure CAdd(var a, b, c: Complex); 33 | begin 34 | c.Re := a.Re + b.Re; 35 | c.Im := a.Im + b.Im; 36 | end; 37 | 38 | 39 | 40 | 41 | procedure CSub(var a, b, c: Complex); 42 | begin 43 | c.Re := a.Re - b.Re; 44 | c.Im := a.Im - b.Im; 45 | end; 46 | 47 | 48 | 49 | 50 | procedure CMul(var a, b, c: Complex); 51 | begin 52 | c.Re := a.Re * b.Re - a.Im * b.Im; 53 | c.Im := a.Re * b.Im + a.Im * b.Re; 54 | end; 55 | 56 | 57 | 58 | 59 | function CAbs(var a: Complex): Real; 60 | begin 61 | CAbs := sqrt(a.Re * a.Re + a.Im * a.Im); 62 | end; 63 | 64 | 65 | 66 | 67 | procedure GetFFT(var x: TData; var FFT: TComplexData; Depth: Integer); 68 | var 69 | k, HalfLen, Step: Integer; 70 | FFTEven, FFTOdd: TComplexData; 71 | FFTOddTwiddled: Complex; 72 | xShiftedPtr: PData; 73 | 74 | begin 75 | HalfLen := DataLength shr (Depth + 1); 76 | Step := 1 shl Depth; 77 | 78 | if HalfLen = 0 then 79 | begin 80 | FFT[0].Re := x[0]; 81 | FFT[0].Im := 0; 82 | end 83 | else 84 | begin 85 | xShiftedPtr := @x[Step]; 86 | 87 | GetFFT(x, FFTEven, Depth + 1); 88 | GetFFT(xShiftedPtr^, FFTOdd, Depth + 1); 89 | 90 | for k := 0 to HalfLen - 1 do 91 | begin 92 | CMul(FFTOdd[k], Twiddle[k * Step], FFTOddTwiddled); 93 | 94 | CAdd(FFTEven[k], FFTOddTwiddled, FFT[k]); 95 | CSub(FFTEven[k], FFTOddTwiddled, FFT[k + HalfLen]); 96 | end; // for 97 | end; // else 98 | 99 | end; 100 | 101 | 102 | 103 | 104 | procedure Spectrum(var x, S: TData); 105 | var 106 | FFT: TComplexData; 107 | i: Integer; 108 | begin 109 | for i := 0 to DataLength - 1 do 110 | begin 111 | Twiddle[i].Re := cos(2 * Pi * i / DataLength); 112 | Twiddle[i].Im := -sin(2 * Pi * i / DataLength); 113 | end; 114 | 115 | GetFFT(x, FFT, 0); 116 | 117 | for i := 0 to DataLength - 1 do 118 | S[i] := CAbs(FFT[i]); 119 | 120 | end; 121 | 122 | 123 | 124 | 125 | const 126 | x01 = 50; y01 = 100; scale = 4.0; 127 | x02 = 50; y02 = 300; 128 | 129 | 130 | 131 | var 132 | Amp, Period: array [0..4] of Real; 133 | Phase: Real; 134 | i, j: Integer; 135 | Ch: Char; 136 | 137 | 138 | 139 | begin 140 | Randomize; 141 | 142 | repeat 143 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 144 | 145 | Line(x01, y01, x01 + 540, y01, 12); // Time axis 146 | OutTextXY(x01 + 550, y01, 15, 'Time'); 147 | 148 | Line(x01, y01 - 50, x01, y01 + 50, 12); // Signal axis 149 | OutTextXY(x01, y01 - 60, 15, 'Signal'); 150 | 151 | Line(x02, y02, x02 + 270, y02, 12); // Frequency axis 152 | OutTextXY(x02 + 280, y02, 15, 'Frequency'); 153 | 154 | Line(x02, y02 - 100, x02, y02, 12); // Amplitude axis 155 | OutTextXY(x02, y02 - 110, 15, 'Magnitude'); 156 | 157 | for j := 0 to 4 do 158 | begin 159 | Amp[j] := (Random - 0.5) * 40; 160 | Period[j] := 2 + abs(Random - 0.5) * 40; 161 | end; 162 | 163 | for i := 0 to DataLength - 1 do 164 | begin 165 | Phase := 2 * Pi * i; 166 | 167 | x[i] := Amp[0] / 2; 168 | 169 | for j := 1 to 4 do 170 | x[i] := x[i] + Amp[j] * sin(Phase / Period[j]); 171 | 172 | if i > 0 then Line(x01 + i - 1, y01 - Round(x[i - 1]), x01 + i, y01 - Round(x[i]), 10); 173 | end; // for 174 | 175 | Spectrum(x, S); 176 | 177 | for i := 0 to DataLength shr 1 - 1 do 178 | Line(x02 + i, y02, x02 + i, y02 - Round(scale * S[i] * 2 / DataLength), 9); 179 | 180 | Line(x02 - 2, y02 - Round(scale * abs(Amp[0])), 181 | x02 + 2, y02 - Round(scale * abs(Amp[0])), 14); 182 | 183 | for j := 1 to 4 do 184 | Line(x02 + Round(DataLength / Period[j]) - 2, y02 - Round(scale * abs(Amp[j])), 185 | x02 + Round(DataLength / Period[j]) + 2, y02 - Round(scale * abs(Amp[j])), 14); 186 | 187 | Read(Ch); 188 | until Ch = #27; 189 | 190 | SetScreenMode($03); 191 | end. 192 | 193 | 194 | -------------------------------------------------------------------------------- /samples/inserr.pas: -------------------------------------------------------------------------------- 1 | // Inertial navigation system error estimator demo 2 | 3 | 4 | program INSErr; 5 | 6 | 7 | {$I samples\kalman.inc} 8 | 9 | 10 | 11 | const 12 | g = 9.81; 13 | Re = 6378e3; 14 | dt = 0.1; 15 | A = 100.0; 16 | beta = 1e-4; 17 | deg = pi / 180; 18 | hr = 3600; 19 | tstop = 2 * hr; 20 | 21 | 22 | 23 | type 24 | TModel = record 25 | dV, Phi, omegaDr, z: Real; 26 | end; 27 | 28 | 29 | 30 | 31 | function GaussRnd(m, sigma: Real): Real; 32 | var 33 | s: Real; 34 | i: SmallInt; 35 | begin 36 | s := 0; 37 | 38 | for i := 1 to 12 do 39 | s := s + Random; 40 | 41 | Result := m + sigma * (s - 6); 42 | end; 43 | 44 | 45 | 46 | 47 | procedure InitModel(var M: TModel); 48 | begin 49 | M.dV := 0; 50 | M.Phi := GaussRnd(0, 0.1 * deg); 51 | M.omegaDr := GaussRnd(0, 0.5 * deg / hr); 52 | end; 53 | 54 | 55 | 56 | procedure ExecuteModel(var M: TModel); 57 | var 58 | dVdot, Phidot, omegaDrdot: Real; 59 | begin 60 | dVdot := -g * M.Phi; 61 | Phidot := M.dV / Re + M.omegaDr; 62 | omegaDrdot := -beta * M.omegaDr + A * sqrt(2 * beta) * GaussRnd(0, 0.0000001); 63 | 64 | M.dV := M.dV + dVdot * dt; 65 | M.Phi := M.Phi + Phidot * dt; 66 | M.omegaDr := M.omegaDr + omegaDrdot * dt; 67 | 68 | M.z := M.dV + GaussRnd(0, 3.0); 69 | end; 70 | 71 | 72 | 73 | procedure InitSchulerKF(var KF: TKalmanFilter; Q, R: Real); 74 | begin 75 | {The following error model is used: 76 | 77 | dV' := -g F; 78 | F' := dV / R + wdr; 79 | wdr' := -b wdr + A sqrt(2b) w; 80 | 81 | z := dV + v.} 82 | 83 | KF.n := 3; KF.m := 1; KF.s := 1; 84 | 85 | KF.Phi[1, 1] := 1; KF.Phi[1, 2] := -g * dt; KF.Phi[1, 3] := 0; 86 | KF.Phi[2, 1] := dt / Re; KF.Phi[2, 2] := 1; KF.Phi[2, 3] := dt; 87 | KF.Phi[3, 1] := 0; KF.Phi[3, 2] := 0; KF.Phi[3, 3] := 1 - beta * dt; 88 | 89 | KF.H[1, 1] := 1; KF.H[1, 2] := 0; KF.H[1, 3] := 0; 90 | 91 | KF.G[1, 1] := 0; 92 | KF.G[2, 1] := 0; 93 | KF.G[3, 1] := A * sqrt(2 * beta) * dt; 94 | 95 | KF.Q[1, 1] := Q; 96 | 97 | KF.R[1, 1] := R; 98 | 99 | KF.x[1, 1] := 0; KF.x[2, 1] := 0; KF.x[3, 1] := 0; 100 | 101 | KF.P[1, 1] := 1; KF.P[1, 2] := 0; KF.P[1, 3] := 0; 102 | KF.P[2, 1] := 0; KF.P[2, 2] := 1; KF.P[2, 3] := 0; 103 | KF.P[3, 1] := 0; KF.P[3, 2] := 0; KF.P[3, 3] := 1; 104 | end; 105 | 106 | 107 | 108 | 109 | const 110 | x0 = 50; scalex = 540 / (tstop / dt); 111 | y01 = 60; scaley1 = 1; 112 | y02 = 170; scaley2 = 100; 113 | y03 = 280; scaley3 = 10; 114 | 115 | 116 | 117 | var 118 | Model: TModel; 119 | Filter: TKalmanFilter; 120 | 121 | i, screenx: Integer; 122 | Ch: Char; 123 | rand: Real; 124 | 125 | 126 | 127 | begin 128 | Randomize; 129 | 130 | repeat 131 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 132 | 133 | Line(x0, y01, x0 + 540, y01, 12); // t axis 134 | OutTextXY(x0 + 550, y01, 15, 'Time'); 135 | 136 | Line(x0, y01 - 40, x0, y01 + 40, 12); // dV axis 137 | OutTextXY(x0, y01 - 50, 15, 'Velocity Error'); 138 | 139 | Line(x0, y02, x0 + 540, y02, 12); // t axis 140 | OutTextXY(x0 + 550, y02, 15, 'Time'); 141 | 142 | Line(x0, y02 - 40, x0, y02 + 40, 12); // Phi axis 143 | OutTextXY(x0, y02 - 50, 15, 'Angle Error'); 144 | 145 | Line(x0, y03, x0 + 540, y03, 12); // t axis 146 | OutTextXY(x0 + 550, y03, 15, 'Time'); 147 | 148 | Line(x0, y03 - 40, x0, y03 + 40, 12); // omegaDr axis 149 | OutTextXY(x0, y03 - 50, 15, 'Gyro Drift'); 150 | 151 | InitModel(Model); 152 | InitSchulerKF(Filter, 1e-10, 1e6); 153 | 154 | for i := 0 to Round(tstop / dt) do 155 | begin 156 | ExecuteModel(Model); 157 | Filter.z[1, 1] := Model.z; 158 | ExecuteFilter(Filter); 159 | 160 | screenx := x0 + Round(scalex * i); 161 | 162 | PutPixel(screenx, y01 - Round(scaley1 * Model.z ), 5); 163 | 164 | PutPixel(screenx, y01 - Round(scaley1 * Model.dV ), 9); 165 | PutPixel(screenx, y02 - Round(scaley2 * Model.Phi / deg ), 9); 166 | PutPixel(screenx, y03 - Round(scaley3 * Model.omegaDr / (deg / hr)), 9); 167 | 168 | if i * dt > 0.01 * tstop then 169 | begin 170 | PutPixel(screenx, y01 - Round(scaley1 * Filter.x[1, 1] ), 14); 171 | PutPixel(screenx, y02 - Round(scaley2 * Filter.x[2, 1] / deg ), 14); 172 | PutPixel(screenx, y03 - Round(scaley3 * Filter.x[3, 1] / (deg / hr)), 14); 173 | end; 174 | 175 | end; // for 176 | 177 | Read(Ch); 178 | until Ch = #27; 179 | 180 | SetScreenMode($03); 181 | end. 182 | -------------------------------------------------------------------------------- /samples/kalman.inc: -------------------------------------------------------------------------------- 1 | // Kalman filter implementation 2 | 3 | 4 | 5 | const 6 | MAXORDER = 3; 7 | 8 | 9 | 10 | type 11 | TMatrix = array [1..MAXORDER, 1..MAXORDER] of Real; 12 | 13 | TKalmanFilter = record 14 | n, m, s: SmallInt; 15 | x, xapri, z: TMatrix; 16 | Phi, G, H, Q, R, P, Papri, K: TMatrix; 17 | end; 18 | 19 | 20 | 21 | 22 | 23 | procedure Transpose(m, n: SmallInt; var C, CT: TMatrix); 24 | var 25 | i, j: SmallInt; 26 | begin 27 | for i := 1 to m do 28 | for j := 1 to n do 29 | CT[j, i] := C[i, j]; 30 | end; 31 | 32 | 33 | 34 | 35 | // C = C1 + C2 36 | procedure Add(m, n: SmallInt; var C1, C2, C: TMatrix); 37 | var 38 | i, j: SmallInt; 39 | begin 40 | for i := 1 to m do 41 | for j := 1 to n do 42 | C[i, j] := C1[i, j] + C2[i, j]; 43 | end; 44 | 45 | 46 | 47 | 48 | // C = C1 - C2 49 | procedure Sub(m, n: SmallInt; var C1, C2, C: TMatrix); 50 | var 51 | i, j: SmallInt; 52 | begin 53 | for i := 1 to m do 54 | for j := 1 to n do 55 | C[i, j] := C1[i, j] - C2[i, j]; 56 | end; 57 | 58 | 59 | 60 | 61 | // C = C1 * C2 62 | procedure Mult(m1, n1, n2: SmallInt; var C1, C2, C: TMatrix); 63 | var 64 | i, j, k: SmallInt; 65 | begin 66 | for i := 1 to m1 do 67 | for j := 1 to n2 do 68 | begin 69 | C[i, j] := 0; 70 | for k := 1 to n1 do 71 | C[i, j] := C[i, j] + C1[i, k] * C2[k, j]; 72 | end; 73 | end; 74 | 75 | 76 | 77 | 78 | // Cs = B * C * BT 79 | // mm mn nn nm 80 | procedure Similarity(m, n: SmallInt; var B, C, Cs: TMatrix); 81 | var 82 | BT, BC: TMatrix; 83 | begin 84 | Mult(m, n, n, B, C, BC); 85 | Transpose(m, n, B, BT); 86 | Mult(m, n, m, BC, BT, Cs); 87 | end; 88 | 89 | 90 | 91 | 92 | procedure Identity(n: SmallInt; var E: TMatrix); 93 | var 94 | i, j: SmallInt; 95 | begin 96 | for i := 1 to n do 97 | for j := 1 to n do 98 | if i = j then E[i, j] := 1 else E[i, j] := 0; 99 | end; 100 | 101 | 102 | 103 | 104 | procedure Inverse(m: SmallInt; var C, Cinv: TMatrix); 105 | var 106 | big, fabval, pivinv, temp: Real; 107 | i, j, k, l, ll, irow, icol: SmallInt; 108 | indxc, indxr, ipiv: array [1..MAXORDER] of SmallInt; 109 | 110 | begin 111 | for i := 1 to m do 112 | for j := 1 to m do 113 | Cinv[i, j] := C[i, j]; 114 | 115 | for j := 1 to m do 116 | ipiv[j] := 0; 117 | 118 | icol := 1; irow := 1; 119 | 120 | for i := 1 to m do 121 | begin 122 | big := 0; 123 | 124 | for j := 1 to m do 125 | if ipiv[j] <> 1 then 126 | for k := 1 to m do 127 | begin 128 | if ipiv[k] = 0 then 129 | begin 130 | if Cinv[j, k] < 0 then fabval := -Cinv[j, k] else fabval := Cinv[j, k]; 131 | 132 | if fabval >= big then 133 | begin 134 | big := fabval; 135 | irow := j; 136 | icol := k; 137 | end; 138 | end // if 139 | else 140 | begin 141 | // Singular matrix 142 | end; // else 143 | end; // for 144 | 145 | Inc(ipiv[icol]); 146 | 147 | if irow <> icol then 148 | for l := 1 to m do 149 | begin 150 | temp := Cinv[irow, l]; 151 | Cinv[irow, l] := Cinv[icol, l]; 152 | Cinv[icol, l] := temp; 153 | end; 154 | 155 | indxr[i] := irow; 156 | indxc[i] := icol; 157 | 158 | pivinv := 1 / Cinv[icol, icol]; 159 | Cinv[icol, icol] := 1; 160 | 161 | for l := 1 to m do 162 | Cinv[icol, l] := Cinv[icol, l] * pivinv; 163 | 164 | for ll := 1 to m do 165 | if ll <> icol then 166 | begin 167 | temp := Cinv[ll, icol]; 168 | Cinv[ll, icol] := 0; 169 | for l := 1 to m do Cinv[ll, l] := Cinv[ll, l] - Cinv[icol, l] * temp; 170 | end; // for 171 | end; // for 172 | 173 | for l := m downto 1 do 174 | begin 175 | if indxr[l] <> indxc[l] then 176 | for k := 1 to m do 177 | begin 178 | temp := Cinv[k, indxr[l]]; 179 | Cinv[k, indxr[l]] := Cinv[k, indxc[l]]; 180 | Cinv[k, indxc[l]] := temp; 181 | end; // for 182 | end; //for 183 | end; 184 | 185 | 186 | 187 | 188 | procedure ExecuteFilter(var KF: TKalmanFilter); 189 | var 190 | PhiPPhiT, GQGT, HT, HPapriHT, HPapriHTplusR, HPapriHTplusRinv, PapriHT, Hxapri, nu, Knu, KH, EminusKH, E: TMatrix; 191 | begin 192 | {All variable names correspond to the notation in the book: 193 | Salychev O. S. Applied Inertial Navigation 194 | 'apri' means 'a priori' and stands for 'k/k-1'} 195 | 196 | // A priori state vector estimate 197 | Mult(KF.n, KF.n, 1, KF.Phi, KF.x, KF.xapri); 198 | 199 | // A priori variance matrix 200 | Similarity(KF.n, KF.n, KF.Phi, KF.P, PhiPPhiT); 201 | Similarity(KF.n, KF.s, KF.G, KF.Q, GQGT); 202 | 203 | Add(KF.n, KF.n, PhiPPhiT, GQGT, KF.Papri); 204 | 205 | // Gain matrix 206 | Similarity(KF.m, KF.n, KF.H, KF.Papri, HPapriHT); 207 | Add(KF.m, KF.m, HPapriHT, KF.R, HPapriHTplusR); 208 | Inverse(KF.m, HPapriHTplusR, HPapriHTplusRinv); 209 | 210 | Transpose(KF.m, KF.n, KF.H, HT); 211 | Mult(KF.n, KF.n, KF.m, KF.Papri, HT, PapriHT); 212 | 213 | Mult(KF.n, KF.m, KF.m, PapriHT, HPapriHTplusRinv, KF.K); 214 | 215 | // A posteriori state vector estimate 216 | Mult(KF.m, KF.n, 1, KF.H, KF.xapri, Hxapri); 217 | Sub(KF.m, 1, KF.z, Hxapri, nu); 218 | Mult(KF.n, KF.m, 1, KF.K, nu, Knu); 219 | 220 | Add(KF.n, 1, KF.xapri, Knu, KF.x); 221 | 222 | // A posteriori variance matrix 223 | Mult(KF.n, KF.m, KF.n, KF.K, KF.H, KH); 224 | Identity(KF.n, E); 225 | Sub(KF.n, KF.n, E, KH, EminusKH); 226 | 227 | Mult(KF.n, KF.n, KF.n, EminusKH, KF.Papri, KF.P); 228 | end; 229 | 230 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # XD Pascal Compiler 2 | 3 | ## Summary 4 | XD Pascal is a small educational compiler for a subset of the Pascal language. A native x86 machine code generator directly emits COM executables for MS-DOS. The compiler supports VGA graphics, floating-point arithmetic, etc. 32-bit Pascal source is provided. 5 | 6 | ### Features 7 | * Fast recursive descent parsing 8 | * Native x86 code generation (COM executables) 9 | * No external assembler or linker 10 | * Source file inclusion facility 11 | * Single-precision floating-point arithmetic (using the x87 FPU) 12 | * VGA graphics support 13 | * Compiler source for both Windows (Delphi) and DOS (TMT Pascal) 14 | 15 | ## Detailed description 16 | ### Preamble 17 | The software is in the public domain. It comes with absolutely no warranty. 18 | Any comments, suggestions, or bug reports are VERY MUCH appreciated. 19 | Feel free to contact me via e-mail. 20 | Enjoy. 21 | 22 | ### Usage 23 | Type in the command prompt: 24 | ``` 25 | xdp [/n] 26 | ``` 27 | Option: `/n` - disable code optimization. 28 | The source file should be specified with its extension (.pas). 29 | 30 | ### Language 31 | 32 | #### Overview 33 | XD Pascal is a dialect of Pascal programming language that resembles 34 | Turbo Pascal v. 3.0 with the following differences and limitations: 35 | * There are no labels, "goto" and "with" statements. 36 | * Unsigned integers, sets, enumerations, and variant records are not supported. 37 | * Strings are null-terminated arrays of characters (C style). String 38 | manipulation routines should be used instead of direct concatenation 39 | or comparison. 40 | * The only file type is Text. It can be used for both text and untyped files. 41 | * Structured parameters cannot be passed to subroutines by value. 42 | * The predefined Result variable can be used instead of function 43 | name in assignments (Delphi style). 44 | * Single-line comments ("//") are supported (Delphi style). 45 | 46 | #### Formal grammar 47 | ``` 48 | Program = "program" Ident ";" Block "." . 49 | 50 | Block = { [ "const" Ident "=" ConstExpression ";" 51 | {Ident "=" ConstExpression ";"} ] 52 | [ "type" Ident "=" Type ";" {Ident "=" Type ";"} ] 53 | [ "var" IdentList ":" Type ";" {IdentList ":" Type ";"} ] 54 | [ "procedure" Ident [FormalParam] ";" 55 | (Block | "forward") ";" ] 56 | [ "function" Ident [FormalParam] [":" TypeIdent] ";" 57 | (Block | "forward") ";" ] } 58 | CompoundStatement . 59 | 60 | ActualParam = "(" (Expression | Designator) | 61 | {"," (Expression | Designator)} ")" . 62 | 63 | FormalParam = "(" ["const" | "var"] IdentList ":" TypeIdent 64 | {";" ["const" | "var"] IdentList ":" TypeIdent} ")" . 65 | 66 | IdentList = Ident {"," Ident} . 67 | 68 | Type = "^" TypeIdent | 69 | "array" "[" Type {"," Type} "]" "of" Type | 70 | "record" IdentList ":" Type {";" IdentList ":" Type} [";"] "end" | 71 | ConstExpression ".." ConstExpression | 72 | TypeIdent . 73 | 74 | Designator = Ident {"^" | ("[" Expression {"," Expression} "]") | ("." Ident)} . 75 | 76 | Statement = [ (Designator | Ident) ":=" Expression | 77 | Ident [ActualParam] | 78 | CompoundStatement | 79 | "if" Expression "then" Statement ["else" Statement] | 80 | "case" Expression "of" CaseElement {";" CaseElement} 81 | ["else" StatementList] [";"] "end" | 82 | "while" Expression "do" Statement | 83 | "repeat" StatementList "until" Expression | 84 | "for" Ident ":=" Expression ("to" | "downto") Expression "do" 85 | Statement ]. 86 | 87 | StatementList = Statement {";" Statement} . 88 | 89 | CompoundStatement = "begin" StatementList "end" . 90 | 91 | CaseElement = CaseLabel {"," CaseLabel} ":" Statement . 92 | 93 | CaseLabel = ConstExpression [".." ConstExpression] . 94 | 95 | ConstExpression = Expression . 96 | 97 | Expression = SimpleExpression [("="|"<>"|"<"|"<="|">"|">=") SimpleExpression] . 98 | 99 | SimpleExpression = ["+"|"-"] Term {("+"|"-"|"or"|"xor") Term}. 100 | 101 | Term = Factor {("*"|"/"|"div"|"mod"|"shl"|"shr"|"and") Factor}. 102 | 103 | Factor = Ident [ActualParam] | 104 | Designator | 105 | "@" Designator | 106 | Number | 107 | CharLiteral | 108 | StringLiteral | 109 | "(" Expression ")" | 110 | "not" Factor | 111 | "nil" | 112 | TypeIdent "(" Expression ")" . 113 | 114 | TypeIdent = Ident . 115 | 116 | Ident = (Letter | "_") {Letter | "_" | Digit}. 117 | 118 | Number = "$" HexDigit {HexDigit} | 119 | Digit {Digit} ["." {Digit}] ["e" ["+" | "-"] Digit {Digit}] . 120 | 121 | CharLiteral = "'" (Character | "'" "'") "'" | 122 | "#" Number . 123 | 124 | StringLiteral = "'" {Character | "'" "'"} "'". 125 | ``` 126 | 127 | #### Predefined identifiers 128 | The following identifiers are implemented as a part of the compiler. Their names 129 | are not reserved words and can be locally redefined by the user. 130 | 131 | Constants: 132 | ```pascal 133 | TRUE 134 | FALSE 135 | ``` 136 | Types: 137 | ```pascal 138 | Integer 139 | SmallInt 140 | ShortInt 141 | Char 142 | Boolean 143 | Real 144 | Pointer 145 | Text 146 | String 147 | ``` 148 | Procedures (inlined): 149 | ```pascal 150 | procedure Inc(var x: Integer) 151 | procedure Dec(var x: Integer) 152 | procedure Read([F: Text;] var x1 {; var xi}) 153 | procedure Write([F: Text;] x1 {; xi}) 154 | procedure ReadLn([F: Text;] var x1 {; var xi}) 155 | procedure WriteLn([F: Text;] x1 {; xi}) 156 | procedure InP(port: Integer; var x: Char) 157 | procedure OutP(port: Integer; x: Char) 158 | procedure New(var P: Pointer) 159 | procedure Dispose(var P: Pointer) 160 | procedure Halt[(const error: Integer)] 161 | procedure Intr(const number: Integer; regs: ^TRegisters) 162 | ``` 163 | Functions (inlined): 164 | ```pascal 165 | function SizeOf(var x | T): Integer 166 | function Ord(x: T): Integer 167 | function Chr(x: Integer): Char 168 | function Pred(x: T): T 169 | function Succ(x: T): T 170 | function Round(x: Real): Integer 171 | function Abs(x: T): T 172 | function Sqr(x: T): T 173 | function Sin(x: Real): Real 174 | function Cos(x: Real): Real 175 | function Arctan(x: Real): Real 176 | function Exp(x: Real): Real 177 | function Ln(x: Real): Real 178 | function SqRt(x: Real): Real 179 | ``` 180 | ### Compiler 181 | The compiler builds a DOS .com executable file according to the small 182 | memory model. The program has the segments of code (pointed by CS), 183 | data (pointed by DS) and stack (pointed by SS): 184 | 185 | ![Memory map](memory.png) 186 | 187 | A program may have up to 64 Kb of code and up to 64 Kb of data. 188 | It contains machine instructions with 16-bit and 32-bit operands and 189 | can be run on a 80386+ machine in the real mode under DOS/NTVDM/DOSBox. 190 | By default, the compiler does some code optimization by eliminating 191 | procedures and functions which are never called. 192 | To detect them, two compilation passes are performed instead of one 193 | and a call graph is built. 194 | 195 | ### System library 196 | Items marked with * should not be used directly. 197 | 198 | Constants: 199 | ```pascal 200 | pi 201 | SEEKSTART * 202 | SEEKCUR * 203 | SEEKEND * 204 | ``` 205 | Types: 206 | ```pascal 207 | LongInt 208 | Single 209 | PChar 210 | TStream * 211 | PStream * 212 | TRegisters 213 | ``` 214 | Variables: 215 | ```pascal 216 | RandSeed: Integer 217 | IOError: Integer * 218 | LastReadChar: Char * 219 | ``` 220 | Procedures and functions: 221 | ```pascal 222 | function Timer: Integer 223 | function KeyPressed: Boolean 224 | procedure Randomize 225 | function Random: Real 226 | function Min(x, y: Real): Real 227 | function IMin(x, y: Integer): Integer 228 | function Max(x, y: Real): Real 229 | function IMax(x, y: Integer): Integer 230 | procedure ReadConsole(var Ch: Char) 231 | procedure WriteConsole(Ch: Char) 232 | procedure Rewrite(var F: Text; const Name: string) 233 | procedure Reset(var F: Text; const Name: string) 234 | procedure Close(F: Text) 235 | procedure BlockRead(F: Text; Buf: PChar; Len: SmallInt; var LenRead: SmallInt) 236 | procedure BlockWrite(F: Text; Buf: PChar; Len: SmallInt) 237 | procedure DeleteFile(const Name: string) 238 | function SeekFile(F: Text; Pos: Integer; Mode: ShortInt): Integer * 239 | procedure Seek(F: Text; Pos: Integer) 240 | function FilePos(F: Text): Integer 241 | function EOF(F: Text): Boolean 242 | function IOResult: Integer 243 | procedure WriteCh(F: Text; P: PStream; ch: Char) * 244 | procedure WriteInt(F: Text; P: PStream; Number: Integer) * 245 | procedure WriteHex(F: Text; P: PStream; Number: Integer; Digits: ShortInt); * 246 | procedure WritePointer(F: Text; P: PStream; Number: Integer) * 247 | procedure WriteReal(F: Text; P: PStream; Number: Real) * 248 | procedure WriteString(F: Text; P: PStream; const s: string) * 249 | procedure WriteBoolean(F: Text; P: PStream; Flag: Boolean) * 250 | procedure WriteNewLine(F: Text; P: PStream) * 251 | procedure ReadCh(F: Text; P: PStream; var ch: Char) * 252 | procedure ReadInt(F: Text; P: PStream; var Number: Integer) * 253 | procedure ReadReal(F: Text; P: PStream; var Number: Real) * 254 | procedure ReadString(F: Text; P: PStream; const s: string) * 255 | procedure ReadNewLine(F: Text; P: PStream) * 256 | function StrLen(const s: string): SmallInt 257 | procedure StrCopy(var Dest: string; const Source: string) 258 | procedure StrCat(var Dest: string; const Source: string) 259 | function StrComp(const s1, s2: string): Integer 260 | procedure Val(const s: string; var Number: Real; var Code: Integer) 261 | procedure Str(Number: Real; var s: string) 262 | procedure IVal(const s: string; var Number: Integer; var Code: Integer) 263 | procedure IStr(Number: Integer; var s: string) 264 | procedure SetScreenMode(mode: Integer) 265 | procedure PutPixel(x, y, clr: Integer) 266 | procedure Line(x1, y1, x2, y2, clr: Integer) 267 | procedure Circle(x, y, r, clr: Integer) 268 | procedure OutCharXY(x, y, clr: Integer; ch: Char) * 269 | procedure OutTextXY(x, y, clr: Integer; const s: string) 270 | ``` 271 | ### Samples 272 | * `FACTOR.PAS` - Integer factorization demo. 273 | * `LINEQ.PAS` - Linear algebraic equation systems solver. Uses `GAUSS.PAS` unit. Requires `EQ.DAT`, `EQERR.DAT`, or similar data file. 274 | * `LIFE.PAS` - The Game of life. 275 | * `CANNABIS.PAS` - Cannabola plot in polar coordinates. 276 | * `FRACTAL.PAS` - Mandelbrot set fragment plot. 277 | * `SORT.PAS` - Array sorting demo. 278 | * `FFT.PAS` - Fast Fourier Transform. 279 | * `CLOCK.PAS` - Clock demo. 280 | * `INSERR.PAS` - Inertial navigation system error estimator. Uses `KALMAN.PAS` unit. 281 | * `PALETTE.PAS` - Graphics palette usage demo. 282 | * `LIST.PAS` - Linked list operations demo. 283 | 284 | -------------------------------------------------------------------------------- /system.pas: -------------------------------------------------------------------------------- 1 | // System library 2 | 3 | 4 | 5 | const 6 | pi = 3.1415927; 7 | 8 | SEEKSTART = 0; 9 | SEEKCUR = 1; 10 | SEEKEND = 2; 11 | 12 | 13 | 14 | 15 | type 16 | LongInt = Integer; 17 | 18 | Single = Real; 19 | 20 | PChar = ^Char; 21 | 22 | TStream = record 23 | Data: PChar; 24 | Index: Integer; 25 | end; 26 | 27 | PStream = ^TStream; 28 | 29 | TRegisters = record 30 | AX, BX, CX, DX, DS, Flags: Integer; 31 | end; 32 | 33 | 34 | 35 | var 36 | RandSeed: Integer; 37 | IOError: Integer; 38 | LastReadChar: Char; 39 | 40 | 41 | 42 | 43 | // System timer and keyboard state 44 | 45 | 46 | function Timer: Integer; 47 | var 48 | Reg: TRegisters; 49 | begin 50 | Reg.AX := 0; 51 | Reg.CX := 0; 52 | Reg.DX := 0; 53 | Intr($1A, @Reg); 54 | Result := Reg.CX shl 16 + Reg.DX; 55 | end; 56 | 57 | 58 | 59 | 60 | function KeyPressed: Boolean; 61 | var 62 | Reg: TRegisters; 63 | begin 64 | Reg.AX := $0B00; 65 | Intr($21, @Reg); 66 | Result := (Reg.AX and $FF) <> 0; 67 | end; 68 | 69 | 70 | 71 | 72 | // Mathematical routines 73 | 74 | 75 | 76 | procedure Randomize; 77 | begin 78 | RandSeed := Timer; 79 | end; 80 | 81 | 82 | 83 | 84 | function Random: Real; 85 | begin 86 | RandSeed := 1975433173 * RandSeed; 87 | Result := 0.5 * (RandSeed / $7FFFFFFF + 1.0); 88 | end; 89 | 90 | 91 | 92 | 93 | function Min(x, y: Real): Real; 94 | begin 95 | if x < y then Result := x else Result := y; 96 | end; 97 | 98 | 99 | 100 | 101 | function IMin(x, y: Integer): Integer; 102 | begin 103 | if x < y then Result := x else Result := y; 104 | end; 105 | 106 | 107 | 108 | 109 | 110 | function Max(x, y: Real): Real; 111 | begin 112 | if x > y then Result := x else Result := y; 113 | end; 114 | 115 | 116 | 117 | 118 | function IMax(x, y: Integer): Integer; 119 | begin 120 | if x > y then Result := x else Result := y; 121 | end; 122 | 123 | 124 | 125 | 126 | 127 | // File and console I/O routines 128 | 129 | 130 | 131 | procedure ReadConsole(var Ch: Char); 132 | var 133 | Reg: TRegisters; 134 | begin 135 | Reg.AX := $0100; 136 | Intr($21, @Reg); 137 | Ch := Char(Reg.AX and $FF); 138 | end; 139 | 140 | 141 | 142 | 143 | procedure WriteConsole(Ch: Char); 144 | var 145 | Reg: TRegisters; 146 | begin 147 | Reg.AX := $0200; 148 | Reg.DX := Integer(Ch); 149 | Intr($21, @Reg); 150 | end; 151 | 152 | 153 | 154 | 155 | procedure Rewrite(var F: Text; const Name: string); 156 | var 157 | Reg: TRegisters; 158 | begin 159 | Reg.AX := $3C00; 160 | Reg.CX := $0000; 161 | Reg.DX := Integer(@Name) and $FFFF; 162 | Reg.DS := Integer(@Name) shr 16; 163 | Intr($21, @Reg); 164 | F := Text(Reg.AX); 165 | if Reg.Flags and 1 = 1 then IOError := Reg.AX else IOError := 0; // Error code 166 | end; 167 | 168 | 169 | 170 | 171 | procedure Reset(var F: Text; const Name: string); 172 | var 173 | Reg: TRegisters; 174 | begin 175 | Reg.AX := $3D02; 176 | Reg.DX := Integer(@Name) and $FFFF; 177 | Reg.DS := Integer(@Name) shr 16; 178 | Intr($21, @Reg); 179 | F := Text(Reg.AX); 180 | if Reg.Flags and 1 = 1 then IOError := Reg.AX else IOError := 0; // Error code 181 | end; 182 | 183 | 184 | 185 | 186 | procedure Close(F: Text); 187 | var 188 | Reg: TRegisters; 189 | begin 190 | Reg.AX := $3E00; 191 | Reg.BX := Integer(F); 192 | Intr($21, @Reg); 193 | end; 194 | 195 | 196 | 197 | 198 | procedure BlockRead(F: Text; Buf: PChar; Len: SmallInt; var LenRead: SmallInt); 199 | var 200 | Reg: TRegisters; 201 | begin 202 | Reg.AX := $3F00; 203 | Reg.BX := Integer(F); 204 | Reg.CX := Len; 205 | Reg.DX := Integer(Buf) and $FFFF; 206 | Reg.DS := Integer(Buf) shr 16; 207 | Intr($21, @Reg); 208 | LenRead := Reg.AX; 209 | end; 210 | 211 | 212 | 213 | 214 | procedure BlockWrite(F: Text; Buf: PChar; Len: SmallInt); 215 | var 216 | Reg: TRegisters; 217 | begin 218 | Reg.AX := $4000; 219 | Reg.BX := Integer(F); 220 | Reg.CX := Len; 221 | Reg.DX := Integer(Buf) and $FFFF; 222 | Reg.DS := Integer(Buf) shr 16; 223 | Intr($21, @Reg); 224 | end; 225 | 226 | 227 | 228 | 229 | procedure DeleteFile(const Name: string); 230 | var 231 | Reg: TRegisters; 232 | begin 233 | Reg.AX := $4100; 234 | Reg.DX := Integer(@Name) and $FFFF; 235 | Reg.DS := Integer(@Name) shr 16; 236 | Intr($21, @Reg); 237 | end; 238 | 239 | 240 | 241 | 242 | function SeekFile(F: Text; Pos: Integer; Mode: ShortInt): Integer; 243 | var 244 | Reg: TRegisters; 245 | begin 246 | Reg.AX := $4200 + Mode; 247 | Reg.BX := Integer(F); 248 | Reg.CX := Pos shr 16; 249 | Reg.DX := Pos and $FFFF; 250 | Intr($21, @Reg); 251 | Result := Reg.DX shl 16 + Reg.AX; 252 | if Reg.Flags and 1 = 1 then IOError := Reg.AX else IOError := 0; // Error code 253 | end; 254 | 255 | 256 | 257 | 258 | 259 | procedure Seek(F: Text; Pos: Integer); 260 | var 261 | NewPos: Integer; 262 | begin 263 | NewPos := SeekFile(F, Pos, SEEKSTART); 264 | if NewPos <> Pos then IOError := 1 else IOError := 0; 265 | end; 266 | 267 | 268 | 269 | 270 | 271 | function FilePos(F: Text): Integer; 272 | begin 273 | Result := SeekFile(F, 0, SEEKCUR); 274 | end; 275 | 276 | 277 | 278 | 279 | 280 | function EOF(F: Text): Boolean; 281 | var 282 | OldPos: Integer; 283 | begin 284 | if Integer(F) = 0 then 285 | Result := FALSE 286 | else 287 | begin 288 | OldPos := SeekFile(F, 0, SEEKCUR); 289 | Result := SeekFile(F, 0, SEEKEND) = OldPos; 290 | OldPos := SeekFile(F, OldPos, SEEKSTART); 291 | end; 292 | end; 293 | 294 | 295 | 296 | 297 | 298 | function IOResult: Integer; 299 | begin 300 | Result := IOError; 301 | IOError := 0; 302 | end; 303 | 304 | 305 | 306 | 307 | 308 | procedure WriteCh(F: Text; P: PStream; ch: Char); 309 | var 310 | Dest: PChar; 311 | begin 312 | if P <> nil then // String stream output 313 | begin 314 | Dest := PChar(Integer(P^.Data) + P^.Index); 315 | Dest^ := ch; 316 | Inc(P^.Index); 317 | end 318 | else 319 | if Integer(F) = 0 then // Console output 320 | WriteConsole(ch) 321 | else // File output 322 | BlockWrite(F, @ch, 1); 323 | end; 324 | 325 | 326 | 327 | 328 | procedure WriteInt(F: Text; P: PStream; Number: Integer); 329 | var 330 | Digit, Weight: Integer; 331 | Skip: Boolean; 332 | 333 | begin 334 | if Number = 0 then 335 | WriteCh(F, P, '0') 336 | else 337 | begin 338 | if Number < 0 then 339 | begin 340 | WriteCh(F, P, '-'); 341 | Number := -Number; 342 | end; 343 | 344 | Weight := 1000000000; 345 | Skip := TRUE; 346 | 347 | while Weight >= 1 do 348 | begin 349 | if Number >= Weight then Skip := FALSE; 350 | 351 | if not Skip then 352 | begin 353 | Digit := Number div Weight; 354 | WriteCh(F, P, Char(ShortInt('0') + Digit)); 355 | Number := Number - Weight * Digit; 356 | end; 357 | 358 | Weight := Weight div 10; 359 | end; // while 360 | end; // else 361 | 362 | end; 363 | 364 | 365 | 366 | 367 | 368 | procedure WriteHex(F: Text; P: PStream; Number: Integer; Digits: ShortInt); 369 | var 370 | i, Digit: ShortInt; 371 | begin 372 | for i := Digits - 1 downto 0 do 373 | begin 374 | Digit := (Number shr (i shl 2)) and $0F; 375 | if Digit <= 9 then Digit := ShortInt('0') + Digit else Digit := ShortInt('A') + Digit - 10; 376 | WriteCh(F, P, Char(Digit)); 377 | end; 378 | end; 379 | 380 | 381 | 382 | 383 | 384 | procedure WritePointer(F: Text; P: PStream; Number: Integer); 385 | begin 386 | WriteHex(F, P, Number, 8); 387 | end; 388 | 389 | 390 | 391 | 392 | 393 | procedure WriteReal(F: Text; P: PStream; Number: Real); 394 | const 395 | FracBits = 16; 396 | var 397 | Integ, Frac, InvWeight, Digit, IntegExpon: Integer; 398 | Expon: Real; 399 | 400 | begin 401 | // Write sign 402 | if Number < 0 then 403 | begin 404 | WriteCh(F, P, '-'); 405 | Number := -Number; 406 | end; 407 | 408 | // Normalize number 409 | if Number = 0 then Expon := 0 else Expon := ln(Number) / ln(10); 410 | if (Expon > 8) or (Expon < -3) then 411 | begin 412 | IntegExpon := Trunc(Expon); 413 | if IntegExpon < 0 then Dec(IntegExpon); 414 | Number := Number / exp(IntegExpon * ln(10)); 415 | end 416 | else 417 | IntegExpon := 0; 418 | 419 | // Write integer part 420 | Integ := Trunc(Number); 421 | Frac := Round((Number - Integ) * (1 shl FracBits)); 422 | 423 | WriteInt(F, P, Integ); WriteCh(F, P, '.'); 424 | 425 | // Write fractional part 426 | InvWeight := 10; 427 | 428 | while InvWeight <= 10000 do 429 | begin 430 | Digit := (Frac * InvWeight) shr FracBits; 431 | if Digit > 9 then Digit := 9; 432 | WriteCh(F, P, Char(ShortInt('0') + Digit)); 433 | Frac := Frac - (Digit shl FracBits) div InvWeight; 434 | InvWeight := InvWeight * 10; 435 | end; // while 436 | 437 | // Write exponent 438 | if IntegExpon <> 0 then 439 | begin 440 | WriteCh(F, P, 'e'); WriteInt(F, P, IntegExpon); 441 | end; 442 | 443 | end; 444 | 445 | 446 | 447 | 448 | procedure WriteString(F: Text; P: PStream; const s: string); 449 | var 450 | i: Integer; 451 | begin 452 | i := 0; 453 | while s[i] <> #0 do 454 | begin 455 | WriteCh(F, P, s[i]); 456 | Inc(i); 457 | end; 458 | end; 459 | 460 | 461 | 462 | 463 | procedure WriteBoolean(F: Text; P: PStream; Flag: Boolean); 464 | begin 465 | if Flag then WriteString(F, P, 'TRUE') else WriteString(F, P, 'FALSE'); 466 | end; 467 | 468 | 469 | 470 | 471 | procedure WriteNewLine(F: Text; P: PStream); 472 | begin 473 | WriteCh(F, P, #13); WriteCh(F, P, #10); 474 | end; 475 | 476 | 477 | 478 | 479 | procedure ReadCh(F: Text; P: PStream; var ch: Char); 480 | var 481 | Len: SmallInt; 482 | Dest: PChar; 483 | begin 484 | if P <> nil then // String stream input 485 | begin 486 | Dest := PChar(Integer(P^.Data) + P^.Index); 487 | ch := Dest^; 488 | Inc(P^.Index); 489 | end 490 | else 491 | if Integer(F) = 0 then // Console input 492 | begin 493 | ReadConsole(ch); 494 | if ch = #13 then WriteConsole(#10); 495 | end 496 | else // File input 497 | begin 498 | BlockRead(F, @ch, 1, Len); 499 | if ch = #10 then BlockRead(F, @ch, 1, Len); 500 | if Len <> 1 then ch := #0; 501 | end; 502 | LastReadChar := ch; // Required by ReadNewLine 503 | end; 504 | 505 | 506 | 507 | 508 | procedure ReadInt(F: Text; P: PStream; var Number: Integer); 509 | var 510 | Ch: Char; 511 | Negative: Boolean; 512 | 513 | begin 514 | Number := 0; 515 | 516 | // Read sign 517 | Negative := FALSE; 518 | ReadCh(F, P, Ch); 519 | if Ch = '+' then 520 | ReadCh(F, P, Ch) 521 | else if Ch = '-' then 522 | begin 523 | Negative := TRUE; 524 | ReadCh(F, P, Ch); 525 | end; 526 | 527 | // Read number 528 | while (Ch >= '0') and (Ch <= '9') do 529 | begin 530 | Number := Number * 10 + ShortInt(Ch) - ShortInt('0'); 531 | ReadCh(F, P, Ch); 532 | end; 533 | 534 | if Negative then Number := -Number; 535 | end; 536 | 537 | 538 | 539 | 540 | procedure ReadReal(F: Text; P: PStream; var Number: Real); 541 | var 542 | Ch: Char; 543 | Negative, ExponNegative: Boolean; 544 | Weight: Real; 545 | Expon: Integer; 546 | 547 | begin 548 | Number := 0; 549 | Expon := 0; 550 | 551 | // Read sign 552 | Negative := FALSE; 553 | ReadCh(F, P, Ch); 554 | if Ch = '+' then 555 | ReadCh(F, P, Ch) 556 | else if Ch = '-' then 557 | begin 558 | Negative := TRUE; 559 | ReadCh(F, P, Ch); 560 | end; 561 | 562 | // Read integer part 563 | while (Ch >= '0') and (Ch <= '9') do 564 | begin 565 | Number := Number * 10 + ShortInt(Ch) - ShortInt('0'); 566 | ReadCh(F, P, Ch); 567 | end; 568 | 569 | if Ch = '.' then // Fractional part found 570 | begin 571 | ReadCh(F, P, Ch); 572 | 573 | // Read fractional part 574 | Weight := 0.1; 575 | while (Ch >= '0') and (Ch <= '9') do 576 | begin 577 | Number := Number + Weight * (ShortInt(Ch) - ShortInt('0')); 578 | Weight := Weight / 10; 579 | ReadCh(F, P, Ch); 580 | end; 581 | end; 582 | 583 | if (Ch = 'E') or (Ch = 'e') then // Exponent found 584 | begin 585 | // Read exponent sign 586 | ExponNegative := FALSE; 587 | ReadCh(F, P, Ch); 588 | if Ch = '+' then 589 | ReadCh(F, P, Ch) 590 | else if Ch = '-' then 591 | begin 592 | ExponNegative := TRUE; 593 | ReadCh(F, P, Ch); 594 | end; 595 | 596 | // Read exponent 597 | while (Ch >= '0') and (Ch <= '9') do 598 | begin 599 | Expon := Expon * 10 + ShortInt(Ch) - ShortInt('0'); 600 | ReadCh(F, P, Ch); 601 | end; 602 | 603 | if ExponNegative then Expon := -Expon; 604 | end; 605 | 606 | if Expon <> 0 then Number := Number * exp(Expon * ln(10)); 607 | if Negative then Number := -Number; 608 | end; 609 | 610 | 611 | 612 | 613 | procedure ReadString(F: Text; P: PStream; const s: string); 614 | var 615 | i: Integer; 616 | Ch: Char; 617 | begin 618 | i := 0; 619 | ReadCh(F, P, Ch); 620 | 621 | while Ch <> #13 do 622 | begin 623 | s[i] := Ch; 624 | Inc(i); 625 | ReadCh(F, P, Ch); 626 | end; 627 | 628 | s[i] := #0; 629 | end; 630 | 631 | 632 | 633 | 634 | procedure ReadNewLine(F: Text; P: PStream); 635 | var 636 | Ch: Char; 637 | begin 638 | Ch := LastReadChar; 639 | while not EOF(F) and (Ch <> #13) do ReadCh(F, P, Ch); 640 | LastReadChar := #0; 641 | end; 642 | 643 | 644 | 645 | 646 | // String manipulation routines 647 | 648 | 649 | function StrLen(const s: string): SmallInt; 650 | begin 651 | Result := 0; 652 | while s[Result] <> #0 do Inc(Result); 653 | end; 654 | 655 | 656 | 657 | 658 | 659 | procedure StrCopy(var Dest: string; const Source: string); 660 | var 661 | i: Integer; 662 | begin 663 | i := -1; 664 | repeat 665 | Inc(i); 666 | Dest[i] := Source[i]; 667 | until Source[i] = #0; 668 | end; 669 | 670 | 671 | 672 | 673 | 674 | procedure StrCat(var Dest: string; const Source: string); 675 | var 676 | i, j: Integer; 677 | begin 678 | i := 0; 679 | while Dest[i] <> #0 do Inc(i); 680 | j := -1; 681 | repeat 682 | Inc(j); 683 | Dest[i + j] := Source[j]; 684 | until Source[j] = #0; 685 | end; 686 | 687 | 688 | 689 | 690 | 691 | function StrComp(const s1, s2: string): Integer; 692 | var 693 | i: Integer; 694 | begin 695 | Result := 0; 696 | i := -1; 697 | repeat 698 | Inc(i); 699 | Result := Integer(s1[i]) - Integer(s2[i]); 700 | until (s1[i] = #0) or (s2[i] = #0) or (Result <> 0); 701 | end; 702 | 703 | 704 | 705 | 706 | 707 | procedure Val(const s: string; var Number: Real; var Code: Integer); 708 | var 709 | Stream: TStream; 710 | begin 711 | Stream.Data := @s; 712 | Stream.Index := 0; 713 | 714 | ReadReal(Text(0), @Stream, Number); 715 | 716 | if Stream.Index - 1 <> StrLen(s) then Code := Stream.Index - 1 else Code := 0; 717 | end; 718 | 719 | 720 | 721 | 722 | 723 | procedure Str(Number: Real; var s: string); 724 | var 725 | Stream: TStream; 726 | begin 727 | Stream.Data := @s; 728 | Stream.Index := 0; 729 | 730 | WriteReal(Text(0), @Stream, Number); 731 | s[Stream.Index] := #0; 732 | end; 733 | 734 | 735 | 736 | 737 | 738 | procedure IVal(const s: string; var Number: Integer; var Code: Integer); 739 | var 740 | Stream: TStream; 741 | begin 742 | Stream.Data := @s; 743 | Stream.Index := 0; 744 | 745 | ReadInt(Text(0), @Stream, Number); 746 | 747 | if Stream.Index - 1 <> StrLen(s) then Code := Stream.Index - 1 else Code := 0; 748 | end; 749 | 750 | 751 | 752 | 753 | 754 | procedure IStr(Number: Integer; var s: string); 755 | var 756 | Stream: TStream; 757 | begin 758 | Stream.Data := @s; 759 | Stream.Index := 0; 760 | 761 | WriteInt(Text(0), @Stream, Number); 762 | s[Stream.Index] := #0; 763 | end; 764 | 765 | 766 | 767 | 768 | // Graphics routines 769 | 770 | 771 | procedure SetScreenMode(mode: Integer); 772 | var 773 | Reg: TRegisters; 774 | begin 775 | Reg.AX := $00 shl 8 + mode; 776 | Intr($10, @Reg); 777 | end; 778 | 779 | 780 | 781 | procedure PutPixel(x, y, clr: Integer); 782 | var 783 | Reg: TRegisters; 784 | begin 785 | Reg.AX := $0C shl 8 + clr; 786 | Reg.BX := 0; 787 | Reg.CX := x; 788 | Reg.DX := y; 789 | Intr($10, @Reg); 790 | end; 791 | 792 | 793 | 794 | procedure Line(x1, y1, x2, y2, clr: Integer); 795 | var 796 | x, y, xMax, xMin, yMax, yMin: Integer; 797 | begin 798 | if x1 > x2 then 799 | begin 800 | xMax := x1; xMin := x2; 801 | end 802 | else 803 | begin 804 | xMax := x2; xMin := x1; 805 | end; 806 | 807 | if y1 > y2 then 808 | begin 809 | yMax := y1; yMin := y2; 810 | end 811 | else 812 | begin 813 | yMax := y2; yMin := y1; 814 | end; 815 | 816 | if x1 = x2 then 817 | for y := yMin to yMax do 818 | PutPixel(x1, y, clr) 819 | else if y1 = y2 then 820 | for x := xMin to xMax do 821 | PutPixel(x, y1, clr) 822 | else if abs(yMax - yMin) < abs(xMax - xMin) then 823 | for x := xMin to xMax do 824 | begin 825 | y := y1 + (y2 - y1) * (x - x1) div (x2 - x1); 826 | PutPixel(x, y, clr); 827 | end 828 | else 829 | for y := yMin to yMax do 830 | begin 831 | x := x1 + (x2 - x1) * (y - y1) div (y2 - y1); 832 | PutPixel(x, y, clr); 833 | end 834 | 835 | end; 836 | 837 | 838 | 839 | 840 | procedure Circle(x, y, r, clr: Integer); 841 | var 842 | t, dt: Real; 843 | dx, dy: Integer; 844 | begin 845 | t := 0; dt := 0.5 / r; 846 | 847 | while t < Pi / 2 do 848 | begin 849 | dx := Round(r * cos(t)); 850 | dy := Round(r * sin(t)); 851 | 852 | PutPixel(x + dx, y + dy, clr); 853 | PutPixel(x - dx, y + dy, clr); 854 | PutPixel(x - dx, y - dy, clr); 855 | PutPixel(x + dx, y - dy, clr); 856 | 857 | t := t + dt; 858 | end; 859 | 860 | end; 861 | 862 | 863 | 864 | 865 | procedure OutCharXY(x, y, clr: Integer; ch: Char); 866 | const 867 | CharSetOrigin = $F000 shl 16 + $FA6E; 868 | 869 | type 870 | TCharBitmap = array [0..7] of ShortInt; 871 | PCharBitmap = ^TCharBitmap; 872 | 873 | var 874 | CharBitmap: PCharBitmap; 875 | i, j: Integer; 876 | 877 | begin 878 | CharBitmap := PCharBitmap(CharSetOrigin + Integer(ch) shl 3); 879 | 880 | for i := 0 to 7 do 881 | for j := 0 to 7 do 882 | if (CharBitmap^[i] and (1 shl j)) <> 0 then PutPixel(x + 7 - j, y + i, clr); 883 | end; 884 | 885 | 886 | 887 | 888 | procedure OutTextXY(x, y, clr: Integer; const s: string); 889 | var 890 | i: Integer; 891 | begin 892 | i := 0; 893 | while s[i] <> #0 do 894 | begin 895 | OutCharXY(x, y, clr, s[i]); 896 | x := x + 8; 897 | Inc(i); 898 | end; 899 | end; 900 | 901 | 902 | 903 | -------------------------------------------------------------------------------- /xdp.dpr: -------------------------------------------------------------------------------- 1 | // XD Pascal - a 32-bit compiler for MS-DOS (real CPU mode) 2 | // Developed by Vasiliy Tereshkov, 2009-2010 3 | 4 | 5 | {$APPTYPE CONSOLE} 6 | {$I-} 7 | 8 | 9 | program XDP; 10 | 11 | 12 | // uses SysUtils; // For debug purposes only 13 | 14 | 15 | const 16 | VERSION = '0.7.12'; 17 | 18 | NUMDELIMITERS = 22; 19 | NUMKEYWORDS = 31; 20 | 21 | // Standard token codes 22 | 23 | OPARTOK = 1; 24 | CPARTOK = 2; 25 | MULTOK = 3; 26 | PLUSTOK = 4; 27 | COMMATOK = 5; 28 | MINUSTOK = 6; 29 | PERIODTOK = 7; 30 | RANGETOK = 8; 31 | DIVTOK = 9; 32 | COLONTOK = 10; 33 | ASSIGNTOK = 11; 34 | SEMICOLONTOK = 12; 35 | LTTOK = 13; 36 | LETOK = 14; 37 | NETOK = 15; 38 | EQTOK = 16; 39 | GTTOK = 17; 40 | GETOK = 18; 41 | ADDRESSTOK = 19; 42 | OBRACKETTOK = 20; 43 | CBRACKETTOK = 21; 44 | DEREFERENCETOK = 22; 45 | 46 | ANDTOK = 23; 47 | ARRAYTOK = 24; 48 | BEGINTOK = 25; 49 | CASETOK = 26; 50 | CONSTTOK = 27; 51 | IDIVTOK = 28; 52 | DOTOK = 29; 53 | DOWNTOTOK = 30; 54 | ELSETOK = 31; 55 | ENDTOK = 32; 56 | FORTOK = 33; 57 | FUNCTIONTOK = 34; 58 | IFTOK = 35; 59 | MODTOK = 36; 60 | NILTOK = 37; 61 | NOTTOK = 38; 62 | OFTOK = 39; 63 | ORTOK = 40; 64 | PROCEDURETOK = 41; 65 | PROGRAMTOK = 42; 66 | RECORDTOK = 43; 67 | REPEATTOK = 44; 68 | SHLTOK = 45; 69 | SHRTOK = 46; 70 | THENTOK = 47; 71 | TOTOK = 48; 72 | TYPETOK = 49; 73 | UNTILTOK = 50; 74 | VARTOK = 51; 75 | WHILETOK = 52; 76 | XORTOK = 53; 77 | 78 | // Non-standard token codes 79 | 80 | IDENTTOK = 101; 81 | INTNUMBERTOK = 102; 82 | FRACNUMBERTOK = 103; 83 | CHARLITERALTOK = 104; 84 | STRINGLITERALTOK = 105; 85 | 86 | // Identifier kind codes 87 | 88 | CONSTANT = 1; 89 | USERTYPE = 2; 90 | VARIABLE = 3; 91 | PROC = 4; 92 | FUNC = 5; 93 | 94 | // Type kinds 95 | 96 | ANYTYPE = 1; 97 | INTEGERTYPE = 2; 98 | SMALLINTTYPE = 3; 99 | SHORTINTTYPE = 4; 100 | CHARTYPE = 5; 101 | BOOLEANTYPE = 6; 102 | REALTYPE = 7; 103 | POINTERTYPE = 8; 104 | TEXTTYPE = 9; 105 | ARRAYTYPE = 10; 106 | RECORDTYPE = 11; 107 | SUBRANGETYPE = 12; 108 | FORWARDTYPE = 101; 109 | 110 | IntegerTypes = [INTEGERTYPE, SMALLINTTYPE, SHORTINTTYPE]; 111 | OrdinalTypes = IntegerTypes + [CHARTYPE, BOOLEANTYPE, SUBRANGETYPE]; 112 | 113 | // Type indices 114 | 115 | ANYTYPEINDEX = 1; // Base type for untyped pointers 116 | INTEGERTYPEINDEX = 2; 117 | SMALLINTTYPEINDEX = 3; 118 | SHORTINTTYPEINDEX = 4; 119 | CHARTYPEINDEX = 5; 120 | BOOLEANTYPEINDEX = 6; 121 | REALTYPEINDEX = 7; 122 | POINTERTYPEINDEX = 8; // Untyped pointer, compatible with any other 123 | TEXTTYPEINDEX = 9; // Universal file type 124 | STRINGTYPEINDEX = 10; 125 | 126 | // Predefined routine codes 127 | 128 | INCPROC = 1; 129 | DECPROC = 2; 130 | READPROC = 3; 131 | WRITEPROC = 4; 132 | READLNPROC = 5; 133 | WRITELNPROC = 6; 134 | INPPROC = 7; // Read from a port 135 | OUTPPROC = 8; // Write to a port 136 | NEWPROC = 9; 137 | DISPOSEPROC = 10; 138 | HALTPROC = 11; 139 | INTRPROC = 12; 140 | 141 | SIZEOFFUNC = 15; 142 | ORDFUNC = 16; 143 | CHRFUNC = 17; 144 | PREDFUNC = 18; 145 | SUCCFUNC = 19; 146 | ROUNDFUNC = 20; 147 | TRUNCFUNC = 21; 148 | ABSFUNC = 22; 149 | SQRFUNC = 23; 150 | SINFUNC = 24; 151 | COSFUNC = 25; 152 | ARCTANFUNC = 26; 153 | EXPFUNC = 27; 154 | LNFUNC = 28; 155 | SQRTFUNC = 29; 156 | 157 | // Compiler parameters 158 | 159 | MAXSTRLENGTH = 80; 160 | MAXSTDTOKENLENGTH = 9; 161 | MAXNAMELENGTH = 32; 162 | MAXIDENTS = 1000; 163 | MAXTYPES = 1000; 164 | MAXBLOCKS = 128; // Must be a multiple of 8 165 | MAXNESTING = 10; 166 | MAXPARAMS = 20; 167 | MAXUNITNESTING = 5; 168 | MAXFIELDS = 100; 169 | 170 | PSPSIZE = $100; 171 | SEGMENTSIZE = $10000; 172 | MAXSTATICSTRDATASIZE = $4000; 173 | 174 | // Compilation pass codes 175 | 176 | CALLDETERMPASS = 1; 177 | CODEGENERATIONPASS = 2; 178 | 179 | // Scope levels 180 | 181 | GLOBAL = 1; 182 | LOCAL = 2; 183 | 184 | // Parameter passing 185 | 186 | VALPASSING = 1; 187 | CONSTPASSING = 2; 188 | VARPASSING = 3; 189 | 190 | 191 | 192 | type 193 | TString = string [MAXSTRLENGTH]; 194 | TKeyName = string [MAXSTDTOKENLENGTH]; 195 | TName = string [MAXNAMELENGTH]; 196 | 197 | TUnit = record 198 | FileName: TString; 199 | Pos, Line: Integer; 200 | end; 201 | 202 | TParam = record 203 | Name: TName; 204 | DataType: Byte; 205 | PassMethod: Byte; 206 | end; 207 | 208 | PParam = ^TParam; 209 | 210 | TField = record 211 | Name: TName; 212 | DataType: Byte; 213 | Offset: Integer; 214 | end; 215 | 216 | TType = record 217 | Block: Byte; 218 | case TypeKind: Byte of 219 | SUBRANGETYPE: 220 | (HostType: Byte; 221 | Low, High: Integer); 222 | POINTERTYPE, ARRAYTYPE: 223 | (BaseType, IndexType: Byte); 224 | RECORDTYPE: 225 | (NumFields: Integer; 226 | Field: array [1..MAXFIELDS] of ^TField); 227 | FORWARDTYPE: 228 | (TypeIdentName: TName); 229 | end; 230 | 231 | TConst = record 232 | case Kind: Byte of 233 | INTNUMBERTOK: 234 | (Value: LongInt); 235 | FRACNUMBERTOK: 236 | (FracValue: Single); 237 | end; 238 | 239 | TToken = record 240 | Kind: Byte; 241 | Name: TName; 242 | Value: LongInt; 243 | FracValue: Single; 244 | StrAddress: Integer; 245 | StrLength: Integer; 246 | end; 247 | 248 | TIdentifier = record 249 | Kind: Byte; 250 | Name: TName; 251 | Value: LongInt; // Value for a constant, address for a variable, procedure or function 252 | FracValue: Single; 253 | Block: Byte; // Index of a block in which the identifier is defined 254 | NestingLevel: Byte; 255 | DataType: Byte; 256 | RecType: Byte; // Parent record type code for a field 257 | Scope: Byte; 258 | PassMethod: Byte; // Value, CONST or VAR parameter status 259 | NumParams: Integer; 260 | Param: array [1..MAXPARAMS] of PParam; 261 | ProcAsBlock: Byte; 262 | PredefIndex: Byte; 263 | IsUnresolvedForward: Boolean; 264 | end; 265 | 266 | 267 | 268 | const 269 | Keyword: array [1..NUMKEYWORDS] of TKeyName = 270 | ( 271 | 'AND', 272 | 'ARRAY', 273 | 'BEGIN', 274 | 'CASE', 275 | 'CONST', 276 | 'DIV', 277 | 'DO', 278 | 'DOWNTO', 279 | 'ELSE', 280 | 'END', 281 | 'FOR', 282 | 'FUNCTION', 283 | 'IF', 284 | 'MOD', 285 | 'NIL', 286 | 'NOT', 287 | 'OF', 288 | 'OR', 289 | 'PROCEDURE', 290 | 'PROGRAM', 291 | 'RECORD', 292 | 'REPEAT', 293 | 'SHL', 294 | 'SHR', 295 | 'THEN', 296 | 'TO', 297 | 'TYPE', 298 | 'UNTIL', 299 | 'VAR', 300 | 'WHILE', 301 | 'XOR' 302 | ); 303 | 304 | 305 | 306 | var 307 | Ident: array [1..MAXIDENTS] of TIdentifier; 308 | Types: array [1..MAXTYPES] of TType; 309 | UnitStack: array [1..MAXUNITNESTING] of TUnit; 310 | StaticStringData: array [0..MAXSTATICSTRDATASIZE - 1] of Char; 311 | CodePosStack: array [0..1023] of Integer; 312 | BlockStack: array [1..MAXNESTING] of Byte; 313 | CallGraph: array [0..MAXBLOCKS - 1, 0..MAXBLOCKS div 8 - 1] of Byte; // Rows are callers, columns are callees 314 | BlockIsNotDead: array [1..MAXBLOCKS] of Boolean; 315 | 316 | Tok: TToken; 317 | 318 | NumIdent, NumTypes, NumStaticStrChars, VarDataOrigin, NumBlocks, BlockStackTop, 319 | CodeSize, CodePosStackTop, GlobalDataSize, 320 | Pass, UnitStackTop, Line: Integer; 321 | 322 | ProgramName, ExeName: TString; 323 | 324 | InFile: file of Char; 325 | OutFile: file of Byte; 326 | 327 | EndOfProgram: Boolean; 328 | 329 | ch, ch2: Char; 330 | 331 | 332 | 333 | 334 | // ----- GENERAL ROUTINES ----- 335 | 336 | 337 | 338 | 339 | procedure DisposeAll; 340 | var 341 | i, j: Integer; 342 | begin 343 | // Dispose dynamically allocated parameter data 344 | for i := 1 to NumIdent do 345 | if Ident[i].Kind in [PROC, FUNC] then 346 | for j := 1 to Ident[i].NumParams do 347 | Dispose(Ident[i].Param[j]); 348 | 349 | // Dispose dynamically allocated field data 350 | for i := 1 to NumTypes do 351 | if Types[i].TypeKind = RECORDTYPE then 352 | for j := 1 to Types[i].NumFields do 353 | Dispose(Types[i].Field[j]); 354 | end; 355 | 356 | 357 | 358 | 359 | 360 | procedure Error(const Msg: string); 361 | begin 362 | WriteLn('Error ', UnitStack[UnitStackTop].FileName, ' ', Line, ': ', Msg); 363 | WriteLn; 364 | DisposeAll; 365 | Close(InFile); 366 | Close(OutFile); 367 | Halt(1); 368 | end; 369 | 370 | 371 | 372 | 373 | 374 | function GetKeyword(const S: TKeyName): Integer; 375 | var 376 | Max, Mid, Min: Integer; 377 | Found: Boolean; 378 | begin 379 | Result := 0; 380 | 381 | // Binary search 382 | Min := 1; 383 | Max := NUMKEYWORDS; 384 | 385 | repeat 386 | Mid := (Min + Max) div 2; 387 | if S > Keyword[Mid] then 388 | Min := Mid + 1 389 | else 390 | Max := Mid - 1; 391 | Found := S = Keyword[Mid]; 392 | until Found or (Min > Max); 393 | 394 | if Found then Result := NUMDELIMITERS + Mid; 395 | end; 396 | 397 | 398 | 399 | 400 | 401 | function GetIdentUnsafe(const S: TName): Integer; 402 | var 403 | IdentIndex, BlockStackIndex: Integer; 404 | begin 405 | Result := 0; 406 | 407 | BlockStackIndex := BlockStackTop; 408 | while (BlockStackIndex > 0) and (Result = 0) do 409 | begin 410 | 411 | IdentIndex := NumIdent; 412 | while (IdentIndex > 0) and (Result = 0) do 413 | begin 414 | if (Ident[IdentIndex].Name = S) and (Ident[IdentIndex].Block = BlockStack[BlockStackIndex]) then Result := IdentIndex; 415 | Dec(IdentIndex); 416 | end;// while 417 | 418 | Dec(BlockStackIndex); 419 | end;// while 420 | end; 421 | 422 | 423 | 424 | 425 | function GetIdent(const S: TName): Integer; 426 | begin 427 | Result := GetIdentUnsafe(S); 428 | if Result = 0 then 429 | Error('Unknown identifier: ' + S); 430 | end; 431 | 432 | 433 | 434 | 435 | function GetField(RecType: Byte; const S: TName): Integer; 436 | var 437 | FieldIndex: Integer; 438 | begin 439 | Result := 0; 440 | 441 | FieldIndex := 1; 442 | while (FieldIndex <= Types[RecType].NumFields) and (Result = 0) do 443 | begin 444 | if Types[RecType].Field[FieldIndex]^.Name = S then Result := FieldIndex; 445 | Inc(FieldIndex); 446 | end;// while 447 | 448 | if Result = 0 then 449 | Error('Unknown field: ' + S); 450 | end; 451 | 452 | 453 | 454 | 455 | function GetSpelling(var Tok: TToken): TString; 456 | begin 457 | if Tok.Kind = 0 then 458 | Result := 'no token' 459 | else if Tok.Kind <= NUMDELIMITERS then 460 | case Tok.Kind of 461 | OPARTOK: Result := '('; 462 | CPARTOK: Result := ')'; 463 | MULTOK: Result := '*'; 464 | PLUSTOK: Result := '+'; 465 | COMMATOK: Result := ','; 466 | MINUSTOK: Result := '-'; 467 | PERIODTOK: Result := '.'; 468 | RANGETOK: Result := '..'; 469 | DIVTOK: Result := '/'; 470 | COLONTOK: Result := ':'; 471 | ASSIGNTOK: Result := ':='; 472 | SEMICOLONTOK: Result := ';'; 473 | LTTOK: Result := '<'; 474 | LETOK: Result := '<='; 475 | NETOK: Result := '<>'; 476 | EQTOK: Result := '='; 477 | GTTOK: Result := '>'; 478 | GETOK: Result := '>='; 479 | ADDRESSTOK: Result := '@'; 480 | OBRACKETTOK: Result := '['; 481 | CBRACKETTOK: Result := ']'; 482 | DEREFERENCETOK: Result := '^'; 483 | end // case 484 | else if Tok.Kind <= NUMDELIMITERS + NUMKEYWORDS then 485 | Result := Keyword[Tok.Kind - NUMDELIMITERS] 486 | else if Tok.Kind = IDENTTOK then 487 | Result := 'identifier' 488 | else if (Tok.Kind = INTNUMBERTOK) or (Tok.Kind = FRACNUMBERTOK) then 489 | Result := 'number' 490 | else if (Tok.Kind = CHARLITERALTOK) or (Tok.Kind = STRINGLITERALTOK) then 491 | Result := 'literal' 492 | else 493 | Result := 'unknown token'; 494 | end; 495 | 496 | 497 | 498 | 499 | 500 | procedure DefineStaticString(var Tok: TToken; const StrValue: TString); 501 | var 502 | i: Integer; 503 | begin 504 | Tok.StrAddress := NumStaticStrChars; 505 | Tok.StrLength := Length(StrValue); 506 | 507 | for i := 1 to Length(StrValue) do 508 | begin 509 | StaticStringData[NumStaticStrChars] := StrValue[i]; 510 | Inc(NumStaticStrChars); 511 | if NumStaticStrChars > MAXSTATICSTRDATASIZE - 1 then 512 | Error('Maximum string data size exceeded'); 513 | end; 514 | 515 | // Add string termination character 516 | StaticStringData[NumStaticStrChars] := #0; 517 | Inc(NumStaticStrChars); 518 | end; 519 | 520 | 521 | 522 | 523 | 524 | function LowBound(DataType: Byte): Integer; 525 | begin 526 | Result := 0; 527 | case Types[DataType].TypeKind of 528 | INTEGERTYPE: Result := Low(Integer); 529 | SMALLINTTYPE: Result := Low(SmallInt); 530 | SHORTINTTYPE: Result := Low(ShortInt); 531 | CHARTYPE: Result := 0; 532 | BOOLEANTYPE: Result := -1; 533 | SUBRANGETYPE: Result := Types[DataType].Low; 534 | else 535 | Error('Ordinal type expected'); 536 | end;// case 537 | end; 538 | 539 | 540 | 541 | 542 | 543 | function HighBound(DataType: Byte): Integer; 544 | begin 545 | Result := 0; 546 | case Types[DataType].TypeKind of 547 | INTEGERTYPE: Result := High(Integer); 548 | SMALLINTTYPE: Result := High(SmallInt); 549 | SHORTINTTYPE: Result := High(ShortInt); 550 | CHARTYPE: Result := 255; 551 | BOOLEANTYPE: Result := 0; 552 | SUBRANGETYPE: Result := Types[DataType].High; 553 | else 554 | Error('Ordinal type expected'); 555 | end;// case 556 | end; 557 | 558 | 559 | 560 | 561 | 562 | function TypeSize(DataType: Byte): Integer; 563 | var 564 | i: Integer; 565 | begin 566 | Result := 0; 567 | case Types[DataType].TypeKind of 568 | INTEGERTYPE: Result := SizeOf(Integer); 569 | SMALLINTTYPE: Result := SizeOf(SmallInt); 570 | SHORTINTTYPE: Result := SizeOf(ShortInt); 571 | CHARTYPE: Result := SizeOf(Char); 572 | BOOLEANTYPE: Result := SizeOf(Boolean); 573 | REALTYPE: Result := SizeOf(Single); 574 | POINTERTYPE: Result := SizeOf(Pointer); 575 | TEXTTYPE: Result := SizeOf(Integer); 576 | ARRAYTYPE: Result := (HighBound(Types[DataType].IndexType) - LowBound(Types[DataType].IndexType) + 1) * TypeSize(Types[DataType].BaseType); 577 | RECORDTYPE: begin 578 | Result := 0; 579 | for i := 1 to Types[DataType].NumFields do 580 | Result := Result + TypeSize(Types[DataType].Field[i]^.DataType); 581 | end; 582 | SUBRANGETYPE: Result := SizeOf(Integer); 583 | else 584 | Error('Illegal type'); 585 | end;// case 586 | end; 587 | 588 | 589 | 590 | 591 | function GetCompatibleType(LeftType, RightType: Byte): Byte; 592 | begin 593 | Result := 0; 594 | 595 | if LeftType = RightType then // General rule 596 | Result := LeftType 597 | else // Special cases 598 | begin 599 | // Untyped pointers compatible with any other pointers 600 | if (Types[LeftType].TypeKind = POINTERTYPE) and (Types[RightType].TypeKind = POINTERTYPE) and 601 | ((Types[LeftType].BaseType = ANYTYPE) or (Types[RightType].BaseType = ANYTYPE)) then 602 | Result := LeftType; 603 | 604 | // Subranges compatible with their host types 605 | if Types[LeftType].TypeKind = SUBRANGETYPE then 606 | Result := GetCompatibleType(Types[LeftType].HostType, RightType); 607 | if Types[RightType].TypeKind = SUBRANGETYPE then 608 | Result := GetCompatibleType(LeftType, Types[RightType].HostType); 609 | 610 | // Integers 611 | if (Types[LeftType].TypeKind in IntegerTypes) and 612 | (Types[RightType].TypeKind in IntegerTypes) then 613 | Result := LeftType; 614 | 615 | // Booleans 616 | if (Types[LeftType].TypeKind = BOOLEANTYPE) and 617 | (Types[RightType].TypeKind = BOOLEANTYPE) then 618 | Result := LeftType; 619 | 620 | // Characters 621 | if (Types[LeftType].TypeKind = CHARTYPE) and 622 | (Types[RightType].TypeKind = CHARTYPE) then 623 | Result := LeftType; 624 | end;// if 625 | 626 | if Result = 0 then 627 | Error('Incompatible types'); 628 | end; 629 | 630 | 631 | 632 | 633 | function ConversionIsPossible(SrcType, DestType: Byte): Boolean; 634 | begin 635 | // Implicit type conversion is possible if DestType is real and SrcType is integer or a subrange of integer 636 | Result := (Types[DestType].TypeKind = REALTYPE) and 637 | ((Types[SrcType].TypeKind in IntegerTypes) or 638 | ((Types[SrcType].TypeKind = SUBRANGETYPE) and (Types[Types[SrcType].HostType].TypeKind in IntegerTypes))); 639 | end; 640 | 641 | 642 | 643 | 644 | 645 | procedure AssertIdent; 646 | begin 647 | if Tok.Kind <> IDENTTOK then 648 | Error('Identifier expected but ' + GetSpelling(Tok) + ' found'); 649 | end; 650 | 651 | 652 | 653 | 654 | procedure CheckOperator(op: Byte; DataType: Byte); 655 | begin 656 | if Types[DataType].TypeKind = SUBRANGETYPE then 657 | CheckOperator(op, Types[DataType].HostType) 658 | else if (not (Types[DataType].TypeKind in (OrdinalTypes + [REALTYPE, POINTERTYPE]))) or 659 | ((Types[DataType].TypeKind = REALTYPE) and 660 | not (op in [MULTOK, DIVTOK, PLUSTOK, MINUSTOK, GTTOK, GETOK, EQTOK, NETOK, LETOK, LTTOK])) or 661 | ((Types[DataType].TypeKind in IntegerTypes) and 662 | not (op in [MULTOK, IDIVTOK, MODTOK, SHLTOK, SHRTOK, ANDTOK, PLUSTOK, MINUSTOK, ORTOK, XORTOK, NOTTOK, GTTOK, GETOK, EQTOK, NETOK, LETOK, LTTOK])) or 663 | ((Types[DataType].TypeKind = CHARTYPE) and 664 | not (op in [GTTOK, GETOK, EQTOK, NETOK, LETOK, LTTOK])) or 665 | ((Types[DataType].TypeKind = BOOLEANTYPE) and 666 | not (op in [ANDTOK, ORTOK, XORTOK, NOTTOK, GTTOK, GETOK, EQTOK, NETOK, LETOK, LTTOK])) or 667 | ((Types[DataType].TypeKind = POINTERTYPE) and 668 | not (op in [GTTOK, GETOK, EQTOK, NETOK, LETOK, LTTOK])) 669 | then 670 | Error('Operator is not applicable'); 671 | end; 672 | 673 | 674 | 675 | 676 | procedure AddCallGraphChild(ParentBlock, ChildBlock: Integer); 677 | begin 678 | // Set bit at ParentBlock row, ChildBlock column 679 | CallGraph[ParentBlock, ChildBlock div 8] := CallGraph[ParentBlock, ChildBlock div 8] or (1 shl (ChildBlock mod 8)); 680 | end; 681 | 682 | 683 | 684 | 685 | 686 | 687 | // ----- SCANNER ----- 688 | 689 | 690 | 691 | procedure InitScanner; 692 | begin 693 | EndOfProgram := FALSE; 694 | UnitStackTop := 1; 695 | UnitStack[UnitStackTop].FileName := ProgramName; 696 | Assign(InFile, ProgramName); 697 | Reset(InFile); 698 | 699 | if IOResult <> 0 then 700 | Error('Unable to open source file ' + ProgramName); 701 | 702 | Line := 1; 703 | 704 | ch := ' '; 705 | ch2 := ' '; 706 | end; 707 | 708 | 709 | 710 | 711 | procedure EnterIncludedFile(const Name: TString); 712 | begin 713 | UnitStack[UnitStackTop].Pos := FilePos(InFile); 714 | UnitStack[UnitStackTop].Line := Line; 715 | 716 | Close(InFile); 717 | Assign(InFile, Name); 718 | Reset(InFile); 719 | 720 | if IOResult <> 0 then 721 | Error('Unable to open source file ' + Name); 722 | 723 | Inc(UnitStackTop); 724 | UnitStack[UnitStackTop].FileName := Name; 725 | 726 | Line := 1; 727 | end; 728 | 729 | 730 | 731 | 732 | procedure LeaveIncludedFile(var ch: Char); 733 | begin 734 | if UnitStackTop > 1 then 735 | begin 736 | Dec(UnitStackTop); 737 | Assign(InFile, UnitStack[UnitStackTop].FileName); 738 | Reset(InFile); 739 | Seek(InFile, UnitStack[UnitStackTop].Pos); 740 | Line := UnitStack[UnitStackTop].Line; 741 | Read(InFile, ch); 742 | end 743 | else 744 | begin 745 | EndOfProgram := TRUE; 746 | ch := #0; 747 | end; 748 | end; 749 | 750 | 751 | 752 | 753 | procedure ReadChar(var ch: Char); 754 | begin 755 | if EndOfProgram then 756 | ch := #0 757 | else 758 | if EOF(InFile) then 759 | begin 760 | Close(InFile); 761 | LeaveIncludedFile(ch); 762 | end 763 | else 764 | Read(InFile, ch); 765 | if ch = #10 then Inc(Line); // End of line found 766 | end; 767 | 768 | 769 | 770 | 771 | procedure ReadValidChar(var ch: Char); 772 | begin 773 | ReadChar(ch); 774 | ch := UpCase(ch); 775 | end; 776 | 777 | 778 | 779 | 780 | procedure ReadLiteralChar(var ch: Char); 781 | begin 782 | ReadChar(ch); 783 | if (ch = #0) or (ch = #10) then 784 | Error('Unterminated string'); 785 | end; 786 | 787 | 788 | 789 | 790 | 791 | procedure ReadSingleLineComment; 792 | begin 793 | while (ch <> #10) and not EndOfProgram do 794 | ReadChar(ch); 795 | end; 796 | 797 | 798 | 799 | 800 | procedure ReadMultiLineComment; 801 | begin 802 | while (ch <> '}') and not EndOfProgram do 803 | ReadChar(ch); 804 | end; 805 | 806 | 807 | 808 | 809 | procedure ReadDirective; 810 | var 811 | Text: TString; 812 | begin 813 | ReadChar(ch); 814 | if UpCase(ch) = 'I' then // Include directive found 815 | begin 816 | Text := ''; 817 | ReadChar(ch); 818 | while (ch <> '}') and not EndOfProgram do 819 | begin 820 | if not (ch in [#1..#31, ' ']) then Text := Text + ch; 821 | ReadChar(ch); 822 | end; 823 | EnterIncludedFile(Text); 824 | end 825 | else 826 | Error('Unknown compiler directive'); 827 | end; 828 | 829 | 830 | 831 | 832 | procedure ReadHexadecimalNumber; 833 | var 834 | Num: Integer; 835 | NumFound: Boolean; 836 | begin 837 | Num := 0; 838 | 839 | NumFound := FALSE; 840 | while ch in ['0'..'9', 'A'..'F'] do 841 | begin 842 | if ch in ['0'..'9'] then 843 | Num := 16 * Num + Ord(ch) - Ord('0') 844 | else 845 | Num := 16 * Num + Ord(ch) - Ord('A') + 10; 846 | NumFound := TRUE; 847 | ReadValidChar(ch); 848 | end; 849 | 850 | if not NumFound then 851 | Error('Hexadecimal constant is not found'); 852 | 853 | Tok.Kind := INTNUMBERTOK; 854 | Tok.Value := Num; 855 | end; 856 | 857 | 858 | 859 | 860 | procedure ReadDecimalNumber; 861 | var 862 | Num, Expon: Integer; 863 | Frac, FracWeight: Single; 864 | NegExpon, RangeFound, ExponFound: Boolean; 865 | begin 866 | Num := 0; 867 | Frac := 0; 868 | Expon := 0; 869 | NegExpon := FALSE; 870 | 871 | while ch in ['0'..'9'] do 872 | begin 873 | Num := 10 * Num + Ord(ch) - Ord('0'); 874 | ReadValidChar(ch); 875 | end; 876 | 877 | if (ch <> '.') and (ch <> 'E') then // Integer number 878 | begin 879 | Tok.Kind := INTNUMBERTOK; 880 | Tok.Value := Num; 881 | end 882 | else 883 | begin 884 | 885 | // Check for '..' token 886 | RangeFound := FALSE; 887 | if ch = '.' then 888 | begin 889 | ReadValidChar(ch2); 890 | if ch2 = '.' then // Integer number followed by '..' token 891 | begin 892 | Tok.Kind := INTNUMBERTOK; 893 | Tok.Value := Num; 894 | RangeFound := TRUE; 895 | end; 896 | if not EndOfProgram then Seek(InFile, FilePos(InFile) - 1); 897 | end; // if ch = '.' 898 | 899 | if not RangeFound then // Fractional number 900 | begin 901 | 902 | // Check for fractional part 903 | if ch = '.' then 904 | begin 905 | FracWeight := 0.1; 906 | ReadValidChar(ch); 907 | 908 | while ch in ['0'..'9'] do 909 | begin 910 | Frac := Frac + FracWeight * (Ord(ch) - Ord('0')); 911 | FracWeight := FracWeight / 10; 912 | ReadValidChar(ch); 913 | end; 914 | end; // if ch = '.' 915 | 916 | // Check for exponent 917 | if ch = 'E' then 918 | begin 919 | ReadValidChar(ch); 920 | 921 | // Check for exponent sign 922 | if ch = '+' then 923 | ReadValidChar(ch) 924 | else if ch = '-' then 925 | begin 926 | NegExpon := TRUE; 927 | ReadValidChar(ch); 928 | end; 929 | 930 | ExponFound := FALSE; 931 | while ch in ['0'..'9'] do 932 | begin 933 | Expon := 10 * Expon + Ord(ch) - Ord('0'); 934 | ReadValidChar(ch); 935 | ExponFound := TRUE; 936 | end; 937 | 938 | if not ExponFound then 939 | Error('Exponent is not found'); 940 | 941 | if NegExpon then Expon := -Expon; 942 | end; // if ch = 'E' 943 | 944 | Tok.Kind := FRACNUMBERTOK; 945 | Tok.FracValue := (Num + Frac) * exp(Expon * ln(10)); 946 | end; // if not RangeFound 947 | end; // else 948 | end; 949 | 950 | 951 | 952 | 953 | procedure ReadNumber; 954 | begin 955 | if ch = '$' then 956 | begin 957 | ReadValidChar(ch); 958 | ReadHexadecimalNumber; 959 | end 960 | else 961 | ReadDecimalNumber; 962 | end; 963 | 964 | 965 | 966 | 967 | procedure ReadCharCode; 968 | begin 969 | ReadValidChar(ch); 970 | 971 | if not (ch in ['0'..'9', '$']) then 972 | Error('Character code is not found'); 973 | 974 | ReadNumber; 975 | 976 | if Tok.Kind = FRACNUMBERTOK then 977 | Error('Integer character code expected'); 978 | 979 | Tok.Kind := CHARLITERALTOK; 980 | end; 981 | 982 | 983 | 984 | 985 | procedure ReadKeywordOrIdentifier; 986 | var 987 | Text: TString; 988 | CurToken: Integer; 989 | begin 990 | Text := ''; 991 | repeat 992 | Text := Text + ch; 993 | ReadValidChar(ch); 994 | until not (ch in ['A'..'Z', '_', '0'..'9']); 995 | 996 | CurToken := GetKeyword(Text); 997 | if CurToken <> 0 then // Keyword found 998 | Tok.Kind := CurToken 999 | else 1000 | begin // Identifier found 1001 | Tok.Kind := IDENTTOK; 1002 | Tok.Name := Text; 1003 | end; 1004 | end; 1005 | 1006 | 1007 | 1008 | 1009 | procedure ReadCharOrStringLiteral; 1010 | var 1011 | Text: TString; 1012 | EndOfLiteral: Boolean; 1013 | begin 1014 | Text := ''; 1015 | EndOfLiteral := FALSE; 1016 | 1017 | repeat 1018 | ReadLiteralChar(ch); 1019 | if ch <> '''' then 1020 | Text := Text + ch 1021 | else 1022 | begin 1023 | Read(InFile, ch2); 1024 | if ch2 = '''' then // Apostrophe character found 1025 | Text := Text + ch 1026 | else 1027 | begin 1028 | if not EndOfProgram then Seek(InFile, FilePos(InFile) - 1); // Discard ch2 1029 | EndOfLiteral := TRUE; 1030 | end; 1031 | end; 1032 | until EndOfLiteral; 1033 | 1034 | if Length(Text) = 1 then 1035 | begin 1036 | Tok.Kind := CHARLITERALTOK; 1037 | Tok.Value := Ord(Text[1]); 1038 | end 1039 | else 1040 | Tok.Kind := STRINGLITERALTOK; 1041 | 1042 | DefineStaticString(Tok, Text); // A character literal is also copied to a single-character static string so this string can be passed to subroutines 1043 | 1044 | ReadValidChar(ch); 1045 | end; 1046 | 1047 | 1048 | 1049 | 1050 | procedure NextTok; 1051 | var 1052 | DivFound: Boolean; 1053 | begin 1054 | Tok.Kind := 0; 1055 | 1056 | // Skip spaces, comments, directives 1057 | DivFound := FALSE; 1058 | while (ch in [#1..#31, ' ', '{']) or ((ch = '/') and not DivFound) do 1059 | begin 1060 | if ch = '{' then // Multi-line comment or directive 1061 | begin 1062 | ReadValidChar(ch); 1063 | if ch = '$' then ReadDirective else ReadMultiLineComment; 1064 | end 1065 | else if ch = '/' then 1066 | begin 1067 | ReadValidChar(ch2); 1068 | if ch2 = '/' then 1069 | ReadSingleLineComment // Single-line comment 1070 | else 1071 | begin 1072 | if not EndOfProgram then Seek(InFile, FilePos(InFile) - 2); // Discard ch and ch2 1073 | DivFound := TRUE; 1074 | end; 1075 | end; 1076 | ReadValidChar(ch); 1077 | end; 1078 | 1079 | // Read token 1080 | case ch of 1081 | '0'..'9', '$': 1082 | ReadNumber; 1083 | '#': 1084 | ReadCharCode; 1085 | 'A'..'Z', '_': 1086 | ReadKeywordOrIdentifier; 1087 | '''': 1088 | ReadCharOrStringLiteral; 1089 | ':': // Single- or double-character tokens 1090 | begin 1091 | Tok.Kind := COLONTOK; 1092 | ReadValidChar(ch); 1093 | if ch = '=' then 1094 | begin 1095 | Tok.Kind := ASSIGNTOK; 1096 | ReadValidChar(ch); 1097 | end; 1098 | end; 1099 | '>': 1100 | begin 1101 | Tok.Kind := GTTOK; 1102 | ReadValidChar(ch); 1103 | if ch = '=' then 1104 | begin 1105 | Tok.Kind := GETOK; 1106 | ReadValidChar(ch); 1107 | end; 1108 | end; 1109 | '<': 1110 | begin 1111 | Tok.Kind := LTTOK; 1112 | ReadValidChar(ch); 1113 | if ch = '=' then 1114 | begin 1115 | Tok.Kind := LETOK; 1116 | ReadValidChar(ch); 1117 | end 1118 | else if ch = '>' then 1119 | begin 1120 | Tok.Kind := NETOK; 1121 | ReadValidChar(ch); 1122 | end; 1123 | end; 1124 | '.': 1125 | begin 1126 | Tok.Kind := PERIODTOK; 1127 | ReadValidChar(ch); 1128 | if ch = '.' then 1129 | begin 1130 | Tok.Kind := RANGETOK; 1131 | ReadValidChar(ch); 1132 | end; 1133 | end; 1134 | else // Single-character tokens 1135 | case ch of 1136 | '=': Tok.Kind := EQTOK; 1137 | ',': Tok.Kind := COMMATOK; 1138 | ';': Tok.Kind := SEMICOLONTOK; 1139 | '(': Tok.Kind := OPARTOK; 1140 | ')': Tok.Kind := CPARTOK; 1141 | '*': Tok.Kind := MULTOK; 1142 | '/': Tok.Kind := DIVTOK; 1143 | '+': Tok.Kind := PLUSTOK; 1144 | '-': Tok.Kind := MINUSTOK; 1145 | '^': Tok.Kind := DEREFERENCETOK; 1146 | '@': Tok.Kind := ADDRESSTOK; 1147 | '[': Tok.Kind := OBRACKETTOK; 1148 | ']': Tok.Kind := CBRACKETTOK; 1149 | else 1150 | Error('Unexpected end of program'); 1151 | end; // case 1152 | 1153 | ReadValidChar(ch); 1154 | end; // case 1155 | 1156 | end; // NextTok 1157 | 1158 | 1159 | 1160 | 1161 | 1162 | procedure CheckTok(ExpectedTokKind: Byte); 1163 | var 1164 | ExpectedTok: TToken; 1165 | begin 1166 | if Tok.Kind <> ExpectedTokKind then 1167 | begin 1168 | ExpectedTok.Kind := ExpectedTokKind; 1169 | Error(GetSpelling(ExpectedTok) + ' expected but ' + GetSpelling(Tok) + ' found'); 1170 | end; 1171 | end; 1172 | 1173 | 1174 | 1175 | 1176 | procedure EatTok(ExpectedTokKind: Byte); 1177 | begin 1178 | CheckTok(ExpectedTokKind); 1179 | NextTok; 1180 | end; 1181 | 1182 | 1183 | 1184 | 1185 | 1186 | 1187 | // ----- CODE GENERATOR ----- 1188 | 1189 | 1190 | 1191 | procedure Gen(b: Byte); 1192 | begin 1193 | if (Pass = CALLDETERMPASS) or BlockIsNotDead[BlockStack[BlockStackTop]] then 1194 | begin 1195 | Inc(CodeSize); 1196 | if Pass = CODEGENERATIONPASS then 1197 | begin 1198 | if CodeSize > SEGMENTSIZE - PSPSIZE then 1199 | Error('Maximum code size exceeded'); 1200 | Write(OutFile, b); 1201 | end; 1202 | end; 1203 | end; 1204 | 1205 | 1206 | 1207 | procedure GenAt(Pos: LongInt; b: Byte); 1208 | var 1209 | PrevPos: LongInt; 1210 | begin 1211 | if (Pass = CODEGENERATIONPASS) and BlockIsNotDead[BlockStack[BlockStackTop]] then 1212 | begin 1213 | PrevPos := FilePos(OutFile); 1214 | Seek(OutFile, Pos); 1215 | Write(OutFile, b); 1216 | Seek(OutFile, PrevPos); 1217 | end; 1218 | end; 1219 | 1220 | 1221 | 1222 | 1223 | procedure GenWord(w: Integer); 1224 | begin 1225 | Gen(Lo(w)); Gen(Hi(w)); 1226 | end; 1227 | 1228 | 1229 | 1230 | 1231 | procedure GenWordAt(Pos: LongInt; w: Integer); 1232 | begin 1233 | GenAt(Pos, Lo(w)); GenAt(Pos + 1, Hi(w)); 1234 | end; 1235 | 1236 | 1237 | 1238 | 1239 | procedure GenDWord(dw: LongInt); 1240 | begin 1241 | Gen(Lo(dw)); Gen(Hi(dw)); 1242 | dw := dw shr 16; 1243 | Gen(Lo(dw)); Gen(Hi(dw)); 1244 | end; 1245 | 1246 | 1247 | 1248 | 1249 | procedure PushConst(Value: LongInt); 1250 | begin 1251 | Gen($66); Gen($68); GenDWord(Value); // push Value 1252 | end; 1253 | 1254 | 1255 | 1256 | 1257 | procedure PushVarPtr(Addr: Integer; Scope: Byte; DeltaNesting: Byte); 1258 | const 1259 | StaticLinkAddr = 2 * SizeOf(LongInt); 1260 | var 1261 | i: Integer; 1262 | begin 1263 | case Scope of 1264 | GLOBAL: // Global variable 1265 | begin 1266 | Gen($1E); // push ds 1267 | Gen($68); GenWord(Addr); // push Addr 1268 | end; 1269 | LOCAL: 1270 | begin 1271 | Gen($16); // push ss 1272 | if DeltaNesting = 0 then // Strictly local variable 1273 | begin 1274 | Gen($8D); Gen($86); GenWord(Addr); // lea ax, [bp + Addr] 1275 | end 1276 | else // Intermediate level variable 1277 | begin 1278 | Gen($8B); Gen($76); Gen(StaticLinkAddr); // mov si, [bp + StaticLinkAddr] 1279 | for i := 1 to DeltaNesting - 1 do 1280 | begin 1281 | Gen($36); Gen($8B); Gen($74); Gen(StaticLinkAddr); // mov si, ss:[si + StaticLinkAddr] 1282 | end; 1283 | Gen($8D); Gen($84); GenWord(Addr); // lea ax, [si + Addr] 1284 | end; 1285 | Gen($50); // push ax 1286 | end;// if 1287 | end;// case 1288 | end; 1289 | 1290 | 1291 | 1292 | 1293 | procedure DerefPtr(DataType: Byte); 1294 | begin 1295 | Gen($5E); // pop si 1296 | Gen($07); // pop es 1297 | 1298 | case TypeSize(DataType) of 1299 | 1: begin 1300 | Gen($26); Gen($8A); Gen($04); // mov al, es:[si] 1301 | Gen($98); // cbw 1302 | Gen($66); Gen($98); // cwde 1303 | end; 1304 | 2: begin 1305 | Gen($26); Gen($8B); Gen($04); // mov ax, es:[si] 1306 | Gen($66); Gen($98); // cwde 1307 | end; 1308 | 4: begin 1309 | Gen($66); Gen($26); Gen($8B); Gen($04); // mov eax, es:[si] 1310 | end; 1311 | else 1312 | Error('Internal fault: Illegal designator size'); 1313 | end; 1314 | 1315 | Gen($66); Gen($50); // push eax 1316 | end; 1317 | 1318 | 1319 | 1320 | 1321 | procedure GetArrayElementPtr(ArrType: Byte); 1322 | 1323 | function Log2(x: LongWord): ShortInt; 1324 | var 1325 | i: Integer; 1326 | begin 1327 | Result := -1; 1328 | i := 0; 1329 | while (i <= 31) and (Result = -1) do 1330 | begin 1331 | if x = 1 shl i then Result := i; 1332 | Inc(i); 1333 | end; 1334 | end; 1335 | 1336 | var 1337 | BaseTypeSize, IndexLowBound: Integer; 1338 | Log2BaseTypeSize: ShortInt; 1339 | 1340 | begin 1341 | Gen($66); Gen($58); // pop eax ; Array index 1342 | 1343 | IndexLowBound := LowBound(Types[ArrType].IndexType); 1344 | if IndexLowBound = 1 then 1345 | Gen($48) // dec ax 1346 | else if IndexLowBound <> 0 then 1347 | begin 1348 | Gen($2D); GenWord(IndexLowBound); // sub ax, IndexLowBound 1349 | end; 1350 | 1351 | BaseTypeSize := TypeSize(Types[ArrType].BaseType); 1352 | Log2BaseTypeSize := Log2(BaseTypeSize); 1353 | 1354 | if Log2BaseTypeSize > 0 then 1355 | begin 1356 | Gen($C1); Gen($E0); Gen(Log2BaseTypeSize); // shl ax, Log2BaseTypeSize 1357 | end 1358 | else if Log2BaseTypeSize < 0 then 1359 | begin 1360 | Gen($B9); GenWord(BaseTypeSize); // mov cx, BaseTypeSize 1361 | Gen($F7); Gen($E1); // mul cx 1362 | end; 1363 | 1364 | Gen($5B); // pop bx ; Array base offset 1365 | Gen($03); Gen($D8); // add bx, ax 1366 | Gen($53); // push bx 1367 | end; 1368 | 1369 | 1370 | 1371 | 1372 | procedure GetFieldPtr(RecType: Byte; FieldIndex: Integer); 1373 | var 1374 | Offset: Integer; 1375 | begin 1376 | Offset := Types[RecType].Field[FieldIndex]^.Offset; 1377 | if Offset > 0 then 1378 | begin 1379 | Gen($58); // pop ax 1380 | Gen($05); GenWord(Offset); // add ax, Offset 1381 | Gen($50); // push ax 1382 | end; 1383 | end; 1384 | 1385 | 1386 | 1387 | 1388 | procedure SaveStackTop; 1389 | begin 1390 | Gen($66); Gen($5A); // pop edx 1391 | end; 1392 | 1393 | 1394 | 1395 | 1396 | procedure RestoreStackTop; 1397 | begin 1398 | Gen($66); Gen($52); // push edx 1399 | end; 1400 | 1401 | 1402 | 1403 | procedure SaveFileHandle; 1404 | begin 1405 | Gen($66); Gen($5F); // pop edi 1406 | Gen($66); Gen($58); // pop eax ; pop and discard unnecessary stream handle, i.e. 0 1407 | Gen($66); Gen($58); // pop eax ; pop and discard unnecessary console handle, i.e. 0 1408 | end; 1409 | 1410 | 1411 | 1412 | 1413 | procedure RestoreFileHandle; 1414 | begin 1415 | Gen($66); Gen($57); // push edi 1416 | end; 1417 | 1418 | 1419 | 1420 | 1421 | procedure GenerateIncDec(proc, Size: Byte); 1422 | begin 1423 | Gen($5E); // pop si 1424 | Gen($07); // pop es 1425 | 1426 | case Size of 1427 | 1: begin 1428 | Gen($26); Gen($FE); // ... byte ptr es: ... 1429 | end; 1430 | 2: begin 1431 | Gen($26); Gen($FF); // ... word ptr es: ... 1432 | end; 1433 | 4: begin 1434 | Gen($66); Gen($26); Gen($FF); // ... dword ptr es: ... 1435 | end; 1436 | end; 1437 | 1438 | case proc of 1439 | INCPROC: Gen($04); // inc ... [si] 1440 | DECPROC: Gen($0C); // dec ... [si] 1441 | end; 1442 | end; 1443 | 1444 | 1445 | 1446 | 1447 | procedure GenerateInpOutp(proc: Byte); 1448 | begin 1449 | case proc of 1450 | INPPROC: 1451 | begin 1452 | Gen($5E); // pop si 1453 | Gen($07); // pop es 1454 | Gen($66); Gen($5A); // pop edx 1455 | Gen($EC); // in al, dx 1456 | Gen($26); Gen($88); Gen($04); // mov es:[si], al 1457 | end; 1458 | OUTPPROC: 1459 | begin 1460 | Gen($66); Gen($5B); // pop ebx 1461 | Gen($66); Gen($5A); // pop edx 1462 | Gen($8A); Gen($C3); // mov al, bl 1463 | Gen($EE); // out dx, al 1464 | end; 1465 | end;// case 1466 | end; 1467 | 1468 | 1469 | 1470 | 1471 | procedure GenerateNewDispose(proc: Byte; Size: Integer); 1472 | begin 1473 | Gen($5E); // pop si 1474 | Gen($07); // pop es 1475 | case proc of 1476 | NEWPROC: 1477 | begin 1478 | Gen($B4); Gen($48); // mov ah, 48h 1479 | Gen($BB); GenWord((Size - 1) div 16 + 1); // mov bx, (Size - 1) div 16 + 1 ; paragraphs to allocate 1480 | Gen($CD); Gen($21); // int 21h 1481 | Gen($66); Gen($C1); Gen($E0); Gen(16); // shl eax, 16 ; get total address from segment address 1482 | Gen($66); Gen($26); Gen($89); Gen($04); // mov es:[si], eax 1483 | end; 1484 | DISPOSEPROC: 1485 | begin 1486 | Gen($B4); Gen($49); // mov ah, 49h 1487 | Gen($26); Gen($C4); Gen($34); // les si, es:[si] 1488 | Gen($CD); Gen($21); // int 21h 1489 | end; 1490 | end;// case 1491 | end;// GenerateNewDispose 1492 | 1493 | 1494 | 1495 | 1496 | procedure GenerateHalt(err: Byte); 1497 | begin 1498 | Gen($B4); Gen($4C); // mov ah, 4Ch 1499 | Gen($B0); Gen(err); // mov al, err 1500 | Gen($CD); Gen($21); // int 21h 1501 | end;// GenerateHalt 1502 | 1503 | 1504 | 1505 | 1506 | procedure GenerateInterrupt(InterruptNumber: Byte); 1507 | begin 1508 | Gen($5E); // pop si 1509 | Gen($07); // pop es 1510 | Gen($26); Gen($8B); Gen($44); Gen($10); // mov ax, es:[si + 16] ; ds 1511 | Gen($1E); // push ds 1512 | Gen($8E); Gen($D8); // mov ds, ax 1513 | Gen($26); Gen($8B); Gen($04); // mov ax, es:[si] 1514 | Gen($26); Gen($8B); Gen($5C); Gen($04); // mov bx, es:[si + 4] 1515 | Gen($26); Gen($8B); Gen($4C); Gen($08); // mov cx, es:[si + 8] 1516 | Gen($26); Gen($8B); Gen($54); Gen($0C); // mov dx, es:[si + 12] 1517 | Gen($CD); Gen(InterruptNumber); // int InterruptNumber 1518 | Gen($9C); // pushf 1519 | Gen($26); Gen($89); Gen($04); // mov es:[si], ax 1520 | Gen($26); Gen($89); Gen($5C); Gen($04); // mov es:[si + 4], bx 1521 | Gen($26); Gen($89); Gen($4C); Gen($08); // mov es:[si + 8], cx 1522 | Gen($26); Gen($89); Gen($54); Gen($0C); // mov es:[si + 12], dx 1523 | Gen($26); Gen($8F); Gen($44); Gen($14); // pop es:[si + 20] ; flags 1524 | Gen($1F); // pop ds 1525 | end;// GenerateInterrupt 1526 | 1527 | 1528 | 1529 | 1530 | procedure GenerateRound(TruncMode: Boolean); 1531 | begin 1532 | Gen($8B); Gen($DC); // mov bx, sp 1533 | Gen($36); Gen($D9); Gen($07); // fld ss:[bx] ; st := operand 1534 | if TruncMode then 1535 | begin 1536 | Gen($36); Gen($C7); Gen($87); GenWord(-4); GenWord($0F7F); // mov ss:[bx - 4], 0F7Fh 1537 | Gen($36); Gen($D9); Gen($AF); GenWord(-4); // fldcw ss:[bx - 4] 1538 | end; 1539 | Gen($36); Gen($DB); Gen($1F); // fistp ss:[bx] ; ss:[bx] := round(result); pop 1540 | if TruncMode then 1541 | begin 1542 | Gen($36); Gen($C7); Gen($87); GenWord(-4); GenWord($037F); // mov ss:[bx - 4], 037Fh 1543 | Gen($36); Gen($D9); Gen($AF); GenWord(-4); // fldcw ss:[bx - 4] 1544 | end; 1545 | end;// GenerateRound 1546 | 1547 | 1548 | 1549 | 1550 | procedure GenerateFloat(Depth: Byte); 1551 | begin 1552 | Gen($8B); Gen($DC); // mov bx, sp 1553 | 1554 | if Depth > 0 then 1555 | begin 1556 | Gen($83); Gen($C3); Gen(Depth); // add bx, Depth 1557 | end; 1558 | 1559 | Gen($36); Gen($DB); Gen($07); // fild ss:[bx] ; st := float(operand) 1560 | Gen($36); Gen($D9); Gen($1F); // fstp ss:[bx] ; ss:[bx] := result; pop 1561 | end;// GenerateFloat 1562 | 1563 | 1564 | 1565 | 1566 | procedure GenerateMathFunction(func, ResultType: Byte); 1567 | begin 1568 | if Types[ResultType].TypeKind = REALTYPE then // Real type 1569 | begin 1570 | Gen($8B); Gen($DC); // mov bx, sp 1571 | Gen($36); Gen($D9); Gen($07); // fld ss:[bx] ; st := x 1572 | case func of 1573 | ABSFUNC: 1574 | begin 1575 | Gen($D9); Gen($E1); // fabs 1576 | end; 1577 | SQRFUNC: 1578 | begin 1579 | Gen($DC); Gen($C8); // fmul st, st 1580 | end; 1581 | SINFUNC: 1582 | begin 1583 | Gen($D9); Gen($FE); // fsin 1584 | end; 1585 | COSFUNC: 1586 | begin 1587 | Gen($D9); Gen($FF); // fcos 1588 | end; 1589 | ARCTANFUNC: 1590 | begin 1591 | Gen($D9); Gen($E8); // fld1 1592 | Gen($D9); Gen($F3); // fpatan ; st := arctan(x / 1.0) 1593 | end; 1594 | EXPFUNC: 1595 | begin 1596 | Gen($D9); Gen($EA); // fldl2e 1597 | Gen($DE); Gen($C9); // fmul 1598 | Gen($D9); Gen($C0); // fld st 1599 | Gen($D9); Gen($FC); // frndint 1600 | Gen($DD); Gen($D2); // fst st(2) ; st(2) := round(x * log2(e)) 1601 | Gen($DE); Gen($E9); // fsub 1602 | Gen($D9); Gen($F0); // f2xm1 ; st := 2 ^ frac(x * log2(e)) - 1 1603 | Gen($D9); Gen($E8); // fld1 1604 | Gen($DE); Gen($C1); // fadd 1605 | Gen($D9); Gen($FD); // fscale ; st := 2 ^ frac(x * log2(e)) * 2 ^ round(x * log2(e)) = exp(x) 1606 | end; 1607 | LNFUNC: 1608 | begin 1609 | Gen($D9); Gen($ED); // fldln2 1610 | Gen($D9); Gen($C9); // fxch 1611 | Gen($D9); Gen($F1); // fyl2x ; st := ln(2) * log2(x) = ln(x) 1612 | end; 1613 | SQRTFUNC: 1614 | begin 1615 | Gen($D9); Gen($FA); // fsqrt 1616 | end; 1617 | 1618 | end;// case 1619 | 1620 | Gen($36); Gen($D9); Gen($1F); // fstp ss:[bx] ; ss:[bx] := result; pop 1621 | end 1622 | else // Ordinal types 1623 | case func of 1624 | ABSFUNC: 1625 | begin 1626 | Gen($66); Gen($58); // pop eax 1627 | Gen($66); Gen($83); Gen($F8); Gen($00); // cmp eax, 0 1628 | Gen($7D); Gen($03); // jge +3 1629 | Gen($66); Gen($F7); Gen($D8); // neg eax 1630 | Gen($66); Gen($50); // push eax 1631 | end; 1632 | SQRFUNC: 1633 | begin 1634 | Gen($66); Gen($58); // pop eax 1635 | Gen($66); Gen($F7); Gen($E8); // imul eax 1636 | Gen($66); Gen($50); // push eax 1637 | end; 1638 | end;// case 1639 | end;// GenerateMathFunction 1640 | 1641 | 1642 | 1643 | 1644 | 1645 | procedure GenerateUnaryOperator(op: Byte; ResultType: Byte); 1646 | begin 1647 | if Types[ResultType].TypeKind = REALTYPE then // Real type 1648 | begin 1649 | if op = MINUSTOK then 1650 | begin 1651 | Gen($8B); Gen($DC); // mov bx, sp 1652 | Gen($36); Gen($D9); Gen($07); // fld ss:[bx] ; st := operand 1653 | Gen($D9); Gen($E0); // fchs 1654 | Gen($36); Gen($D9); Gen($1F); // fstp ss:[bx] ; ss:[bx] := result; pop 1655 | end; 1656 | end 1657 | else // Ordinal types 1658 | begin 1659 | Gen($66); Gen($58); // pop eax 1660 | case op of 1661 | MINUSTOK: 1662 | begin 1663 | Gen($66); Gen($F7); Gen($D8); // neg eax 1664 | end; 1665 | NOTTOK: 1666 | begin 1667 | Gen($66); Gen($F7); Gen($D0); // not eax 1668 | end; 1669 | end;// case 1670 | Gen($66); Gen($50); // push eax 1671 | end;// else 1672 | 1673 | end; 1674 | 1675 | 1676 | 1677 | 1678 | procedure GenerateBinaryOperator(op: Byte; ResultType: Byte); 1679 | begin 1680 | if Types[ResultType].TypeKind = REALTYPE then // Real type 1681 | begin 1682 | Gen($8B); Gen($DC); // mov bx, sp 1683 | Gen($36); Gen($D9); Gen($07); // fld ss:[bx] ; st := operand2 1684 | Gen($66); Gen($58); // pop eax 1685 | Gen($8B); Gen($DC); // mov bx, sp 1686 | Gen($36); Gen($D9); Gen($07); // fld ss:[bx] ; st(1) := operand2; st := operand1 1687 | Gen($D9); Gen($C9); // fxch ; st := operand2; st(1) := operand1 1688 | 1689 | case op of 1690 | PLUSTOK: 1691 | begin 1692 | Gen($DE); Gen($C1); // fadd ; st(1) := st(1) + st; pop 1693 | end; 1694 | MINUSTOK: 1695 | begin 1696 | Gen($DE); Gen($E9); // fsub ; st(1) := st(1) - st; pop 1697 | end; 1698 | MULTOK: 1699 | begin 1700 | Gen($DE); Gen($C9); // fmul ; st(1) := st(1) * st; pop 1701 | end; 1702 | DIVTOK: 1703 | begin 1704 | Gen($DE); Gen($F9); // fdiv ; st(1) := st(1) / st; pop 1705 | end; 1706 | end;// case 1707 | 1708 | Gen($36); Gen($D9); Gen($1F); // fstp ss:[bx] ; ss:[bx] := result; pop 1709 | 1710 | end // if 1711 | else // Ordinal types 1712 | begin 1713 | Gen($66); Gen($59); // pop ecx 1714 | Gen($66); Gen($58); // pop eax 1715 | 1716 | case op of 1717 | PLUSTOK: 1718 | begin 1719 | Gen($66); Gen($03); Gen($C1); // add eax, ecx 1720 | end; 1721 | MINUSTOK: 1722 | begin 1723 | Gen($66); Gen($2B); Gen($C1); // sub eax, ecx 1724 | end; 1725 | MULTOK: 1726 | begin 1727 | Gen($66); Gen($F7); Gen($E9); // imul ecx 1728 | end; 1729 | IDIVTOK, MODTOK: 1730 | begin 1731 | Gen($66); Gen($99); // cdq 1732 | Gen($66); Gen($F7); Gen($F9); // idiv ecx 1733 | if op = MODTOK then 1734 | begin 1735 | Gen($66); Gen($8B); Gen($C2); // mov eax, edx ; save remainder 1736 | end; 1737 | end; 1738 | SHLTOK: 1739 | begin 1740 | Gen($66); Gen($D3); Gen($E0); // shl eax, cl 1741 | end; 1742 | SHRTOK: 1743 | begin 1744 | Gen($66); Gen($D3); Gen($E8); // shr eax, cl 1745 | end; 1746 | ANDTOK: 1747 | begin 1748 | Gen($66); Gen($23); Gen($C1); // and eax, ecx 1749 | end; 1750 | ORTOK: 1751 | begin 1752 | Gen($66); Gen($0B); Gen($C1); // or eax, ecx 1753 | end; 1754 | XORTOK: 1755 | begin 1756 | Gen($66); Gen($33); Gen($C1); // xor eax, ecx 1757 | end; 1758 | 1759 | end;// case 1760 | 1761 | Gen($66); Gen($50); // push eax 1762 | end;// else 1763 | end; 1764 | 1765 | 1766 | 1767 | 1768 | procedure GenerateRelation(rel: Byte; ValType: Byte); 1769 | begin 1770 | if Types[ValType].TypeKind = REALTYPE then // Real type 1771 | begin 1772 | Gen($8B); Gen($DC); // mov bx, sp 1773 | Gen($36); Gen($D9); Gen($07); // fld ss:[bx] ; st := operand2 1774 | Gen($66); Gen($58); // pop eax 1775 | Gen($8B); Gen($DC); // mov bx, sp 1776 | Gen($36); Gen($D9); Gen($07); // fld ss:[bx] ; st(1) := operand2; st := operand1 1777 | Gen($66); Gen($58); // pop eax 1778 | Gen($8B); Gen($DC); // mov bx, sp 1779 | Gen($DE); Gen($D9); // fcompp ; test st - st(1) 1780 | Gen($DF); Gen($E0); // fstsw ax 1781 | Gen($66); Gen($68); GenDWord(-1); // push FFFFFFFFh ; TRUE 1782 | Gen($9E); // sahf 1783 | case rel of 1784 | EQTOK: Gen($74); // je ... 1785 | NETOK: Gen($75); // jne ... 1786 | GTTOK: Gen($77); // ja ... 1787 | GETOK: Gen($73); // jae ... 1788 | LTTOK: Gen($72); // jb ... 1789 | LETOK: Gen($76); // jbe ... 1790 | end;// case 1791 | end 1792 | else // Ordinal types 1793 | begin 1794 | Gen($66); Gen($59); // pop ecx 1795 | Gen($66); Gen($58); // pop eax 1796 | Gen($66); Gen($68); GenDWord(-1); // push FFFFFFFFh ; TRUE 1797 | Gen($66); Gen($3B); Gen($C1); // cmp eax, ecx 1798 | case rel of 1799 | EQTOK: Gen($74); // je ... 1800 | NETOK: Gen($75); // jne ... 1801 | GTTOK: Gen($7F); // jg ... 1802 | GETOK: Gen($7D); // jge ... 1803 | LTTOK: Gen($7C); // jl ... 1804 | LETOK: Gen($7E); // jle ... 1805 | end;// case 1806 | end;// else 1807 | 1808 | Gen($08); // ... +8 1809 | Gen($66); Gen($59); // pop ecx 1810 | Gen($66); Gen($68); GenDWord(0); // push 00000000h ; FALSE 1811 | end; 1812 | 1813 | 1814 | 1815 | 1816 | 1817 | procedure GenerateAssignment(DesignatorType: Byte); 1818 | begin 1819 | // EDX should be preserved 1820 | 1821 | // Source value 1822 | Gen($66); Gen($58); // pop eax 1823 | // Destination address 1824 | Gen($5E); // pop si 1825 | Gen($07); // pop es 1826 | 1827 | case TypeSize(DesignatorType) of 1828 | 1: begin 1829 | Gen($26); Gen($88); Gen($04); // mov es:[si], al 1830 | end; 1831 | 2: begin 1832 | Gen($26); Gen($89); Gen($04); // mov es:[si], ax 1833 | end; 1834 | 4: begin 1835 | Gen($66); Gen($26); Gen($89); Gen($04); // mov es:[si], eax 1836 | end; 1837 | else 1838 | Error('Internal fault: Illegal designator size'); 1839 | end; 1840 | 1841 | end; 1842 | 1843 | 1844 | 1845 | 1846 | procedure GenerateStructuredAssignment(DesignatorType: Byte); 1847 | begin 1848 | Gen($8C); Gen($D8); // mov ax, ds 1849 | Gen($8B); Gen($DF); // mov bx, di ; edi is used in Write, Read, etc. and should be preserved 1850 | 1851 | // Source address 1852 | Gen($5E); // pop si 1853 | Gen($1F); // pop ds 1854 | // Destination address 1855 | Gen($5F); // pop di 1856 | Gen($07); // pop es 1857 | 1858 | // Copy source to destination 1859 | Gen($B9); GenWord(TypeSize(DesignatorType)); // mov cx, TypeSize(DesignatorType) 1860 | Gen($FC); // cld ; increment si, di after each step 1861 | Gen($F3); Gen($A4); // rep movsb 1862 | 1863 | Gen($8E); Gen($D8); // mov ds, ax 1864 | Gen($8B); Gen($FB); // mov di, bx 1865 | end; 1866 | 1867 | 1868 | 1869 | 1870 | 1871 | 1872 | procedure GenerateCall(EntryPoint: LongInt; DeltaNesting: Byte); 1873 | const 1874 | StaticLinkAddr = 2 * SizeOf(LongInt); 1875 | var 1876 | CodePos: Integer; 1877 | i: Integer; 1878 | begin 1879 | // Push routine static link as the last hidden parameter (needed for nested routines) 1880 | if DeltaNesting = 0 then // The caller and the callee's enclosing routine are at the same nesting level 1881 | begin 1882 | Gen($66); Gen($55); // push ebp 1883 | end 1884 | else // The caller is deeper 1885 | begin 1886 | Gen($8B); Gen($76); Gen(StaticLinkAddr); // mov si, [bp + StaticLinkAddr] 1887 | for i := 1 to DeltaNesting - 1 do 1888 | begin 1889 | Gen($36); Gen($8B); Gen($74); Gen(StaticLinkAddr); // mov si, ss:[si + StaticLinkAddr] 1890 | end; 1891 | Gen($66); Gen($56); // push esi 1892 | end; 1893 | 1894 | // Call the routine 1895 | Gen($50); // push ax ; align stack data on 32-bit bound 1896 | CodePos := CodeSize; 1897 | Gen($E8); GenWord(EntryPoint - (CodePos + 3)); // call EntryPoint 1898 | Gen($58); // pop ax ; align stack data on 32-bit bound 1899 | end; 1900 | 1901 | 1902 | 1903 | 1904 | procedure GenerateReturn(TotalParamsSize: Integer); 1905 | begin 1906 | Gen($C2); GenWord(TotalParamsSize + SizeOf(LongInt)); // ret TotalParamsSize + 4 ; + 4 is for static link 1907 | end; 1908 | 1909 | 1910 | 1911 | 1912 | procedure GenerateIfCondition; 1913 | begin 1914 | Gen($66); Gen($58); // pop eax 1915 | Gen($66); Gen($83); Gen($F8); Gen($00); // cmp eax, 0 1916 | Gen($75); Gen($03); // jne +3 1917 | end; 1918 | 1919 | 1920 | 1921 | 1922 | procedure GenerateWhileCondition; 1923 | begin 1924 | GenerateIfCondition; 1925 | end; 1926 | 1927 | 1928 | 1929 | procedure GenerateRepeatCondition; 1930 | begin 1931 | GenerateIfCondition; 1932 | end; 1933 | 1934 | 1935 | 1936 | 1937 | procedure GenerateForCondition(CounterAddress: Integer; Scope, CounterSize: Byte; Down: Boolean); 1938 | begin 1939 | Gen($66); Gen($59); // pop ecx 1940 | Gen($66); Gen($51); // push ecx ; The final value of the counter will be removed from stack by GenerateForEpilog 1941 | case Scope of 1942 | GLOBAL: 1943 | case CounterSize of 1944 | 1: begin 1945 | Gen($A0); // mov al, [...] 1946 | end; 1947 | 2: begin 1948 | Gen($A1); // mov ax, [...] 1949 | end; 1950 | 4: begin 1951 | Gen($66); Gen($A1); // mov eax, [...] 1952 | end; 1953 | end; 1954 | LOCAL: 1955 | case CounterSize of 1956 | 1: begin 1957 | Gen($8A); Gen($86); // mov al, [bp + ...] 1958 | end; 1959 | 2: begin 1960 | Gen($8B); Gen($86); // mov ax, [bp + ...] 1961 | end; 1962 | 4: begin 1963 | Gen($66); Gen($8B); Gen($86); // mov eax, [bp + ...] 1964 | end; 1965 | end; 1966 | end; 1967 | 1968 | GenWord(CounterAddress); // ... CounterAddress ... 1969 | 1970 | if CounterSize < 2 then 1971 | Gen($98); // cbw 1972 | if CounterSize < 4 then 1973 | begin 1974 | Gen($66); Gen($98); // cwde 1975 | end; 1976 | 1977 | Gen($66); Gen($3B); Gen($C1); // cmp eax, ecx 1978 | if Down then 1979 | begin 1980 | Gen($7D); Gen($03); // jge +3 1981 | end 1982 | else 1983 | begin 1984 | Gen($7E); Gen($03); // jle +3 1985 | end; 1986 | end; 1987 | 1988 | 1989 | 1990 | 1991 | procedure GenerateIfProlog; 1992 | begin 1993 | Inc(CodePosStackTop); 1994 | CodePosStack[CodePosStackTop] := CodeSize; 1995 | 1996 | Gen($90); // nop ; jump to the IF block end will be inserted here 1997 | Gen($90); // nop 1998 | Gen($90); // nop 1999 | end; 2000 | 2001 | 2002 | 2003 | 2004 | procedure GenerateElseProlog; 2005 | var 2006 | CodePos: Integer; 2007 | begin 2008 | CodePos := CodePosStack[CodePosStackTop]; 2009 | Dec(CodePosStackTop); 2010 | 2011 | GenAt(CodePos, $E9); GenWordAt(CodePos + 1, CodeSize - (CodePos + 3) + 3); // jmp (IF..THEN block end) 2012 | 2013 | GenerateIfProlog; 2014 | end; 2015 | 2016 | 2017 | 2018 | 2019 | procedure GenerateIfElseEpilog; 2020 | var 2021 | CodePos: Integer; 2022 | begin 2023 | CodePos := CodePosStack[CodePosStackTop]; 2024 | Dec(CodePosStackTop); 2025 | 2026 | GenAt(CodePos, $E9); GenWordAt(CodePos + 1, CodeSize - (CodePos + 3)); // jmp (IF..THEN block end) 2027 | end; 2028 | 2029 | 2030 | 2031 | 2032 | procedure GenerateCaseProlog; 2033 | begin 2034 | Gen($66); Gen($59); // pop ecx ; CASE switch value 2035 | Gen($B0); Gen($00); // mov al, 00h ; initial flag mask 2036 | end; 2037 | 2038 | 2039 | 2040 | 2041 | procedure GenerateCaseEpilog(NumCaseStatements: Integer); 2042 | var 2043 | i: Integer; 2044 | begin 2045 | for i := 1 to NumCaseStatements do 2046 | GenerateIfElseEpilog; 2047 | end; 2048 | 2049 | 2050 | 2051 | 2052 | procedure GenerateCaseEqualityCheck(Value: LongInt); 2053 | begin 2054 | Gen($66); Gen($81); Gen($F9); GenDWord(Value); // cmp ecx, Value 2055 | Gen($9F); // lahf 2056 | Gen($0A); Gen($C4); // or al, ah 2057 | end; 2058 | 2059 | 2060 | 2061 | 2062 | procedure GenerateCaseRangeCheck(Value1, Value2: LongInt); 2063 | begin 2064 | Gen($66); Gen($81); Gen($F9); GenDWord(Value1); // cmp ecx, Value1 2065 | Gen($7C); Gen($0B); // jl +11 2066 | Gen($66); Gen($81); Gen($F9); GenDWord(Value2); // cmp ecx, Value2 2067 | Gen($7F); Gen($02); // jg +2 2068 | Gen($0C); Gen($40); // or al, 40h ; set zero flag on success 2069 | end; 2070 | 2071 | 2072 | 2073 | 2074 | procedure GenerateCaseStatementProlog; 2075 | begin 2076 | Gen($24); Gen($40); // and al, 40h ; test zero flag 2077 | Gen($75); Gen($03); // jnz +3 ; if set, jump to the case statement 2078 | GenerateIfProlog; 2079 | end; 2080 | 2081 | 2082 | 2083 | 2084 | procedure GenerateCaseStatementEpilog; 2085 | var 2086 | StoredCodeSize: LongInt; 2087 | begin 2088 | StoredCodeSize := CodeSize; 2089 | 2090 | Gen($90); // nop ; jump to the CASE block end will be inserted here 2091 | Gen($90); // nop 2092 | Gen($90); // nop 2093 | 2094 | GenerateIfElseEpilog; 2095 | 2096 | Inc(CodePosStackTop); 2097 | CodePosStack[CodePosStackTop] := StoredCodeSize; 2098 | end; 2099 | 2100 | 2101 | 2102 | 2103 | procedure GenerateWhileEpilog; 2104 | var 2105 | CodePos, CurPos, ReturnPos: Integer; 2106 | begin 2107 | CodePos := CodePosStack[CodePosStackTop]; 2108 | Dec(CodePosStackTop); 2109 | 2110 | GenAt(CodePos, $E9); GenWordAt(CodePos + 1, CodeSize - (CodePos + 3) + 3); // jmp (WHILE..DO block end) 2111 | 2112 | ReturnPos := CodePosStack[CodePosStackTop]; 2113 | Dec(CodePosStackTop); 2114 | 2115 | CurPos := CodeSize; 2116 | 2117 | Gen($E9); GenWord(ReturnPos - (CurPos + 3)); // jmp ReturnPos 2118 | end; 2119 | 2120 | 2121 | 2122 | 2123 | procedure GenerateRepeatProlog; 2124 | begin 2125 | Inc(CodePosStackTop); 2126 | CodePosStack[CodePosStackTop] := CodeSize; 2127 | end; 2128 | 2129 | 2130 | 2131 | 2132 | procedure GenerateRepeatEpilog; 2133 | var 2134 | CurPos, ReturnPos: Integer; 2135 | begin 2136 | ReturnPos := CodePosStack[CodePosStackTop]; 2137 | Dec(CodePosStackTop); 2138 | 2139 | CurPos := CodeSize; 2140 | 2141 | Gen($E9); GenWord(ReturnPos - (CurPos + 3)); // jmp ReturnPos 2142 | end; 2143 | 2144 | 2145 | 2146 | 2147 | 2148 | 2149 | procedure GenerateForEpilog(CounterAddress: Integer; Scope, CounterSize: Byte; Down: Boolean); 2150 | begin 2151 | PushVarPtr(CounterAddress, Scope, 0); 2152 | if Down then 2153 | GenerateIncDec(DECPROC, CounterSize) 2154 | else 2155 | GenerateIncDec(INCPROC, CounterSize); 2156 | GenerateWhileEpilog; 2157 | 2158 | Gen($66); Gen($59); // pop ecx ; Remove the final value of the counter from the stack 2159 | end; 2160 | 2161 | 2162 | 2163 | 2164 | procedure GenerateDeclarationProlog; 2165 | begin 2166 | GenerateIfProlog; 2167 | end; 2168 | 2169 | 2170 | 2171 | 2172 | procedure GenerateDeclarationEpilog; 2173 | begin 2174 | GenerateIfElseEpilog; 2175 | end; 2176 | 2177 | 2178 | 2179 | 2180 | procedure GenerateProgramProlog; 2181 | begin 2182 | // Initialize segment registers 2183 | Gen($8C); Gen($C8); // mov ax, cs 2184 | Gen($8E); Gen($C0); // mov es, ax ; Extra data segment base 2185 | Gen($90); // nop 2186 | Gen($90); // nop 2187 | Gen($90); // nop ; Reserved space for add ax, CodeSegmentSize 2188 | Gen($8E); Gen($D8); // mov ds, ax ; Data segment base 2189 | Gen($05); GenWord($1000); // add ax, 1000h ; Allocate 64 Kbytes for static data 2190 | Gen($8E); Gen($D0); // mov ss, ax ; Stack segment base 2191 | 2192 | // Initialize FPU 2193 | Gen($DB); Gen($E3); // finit 2194 | 2195 | // Shrink allocated memory block to the maximum total size of code, data and stack segments (needed by New and Dispose) 2196 | Gen($B4); Gen($4A); // mov ah, 4Ah 2197 | Gen($BB); GenWord($3000); // mov bx, 3000h ; New block size in paragraphs 2198 | Gen($CD); Gen($21); // int 21h ; Block segment address is in ES 2199 | 2200 | end; 2201 | 2202 | 2203 | 2204 | 2205 | procedure GenerateProgramEpilog; 2206 | var 2207 | i, StoredCodeSize, CodeSegmentSize: Integer; 2208 | begin 2209 | GenerateHalt(0); 2210 | // End of pure code 2211 | 2212 | StoredCodeSize := CodeSize; 2213 | 2214 | // Complete program prolog 2215 | CodeSegmentSize := (PSPSIZE + StoredCodeSize) div 16 + 1; // in paragraphs 2216 | 2217 | GenAt(4, $05); GenAt(5, Lo(CodeSegmentSize)); GenAt(6, Hi(CodeSegmentSize)); // add ax, CodeSegmentSize 2218 | 2219 | // Align code segment 2220 | for i := 1 to CodeSegmentSize * 16 - (PSPSIZE + StoredCodeSize) do 2221 | Gen($90); // nop 2222 | 2223 | // Build static string data table at the end of the executable file (i.e. at the beginning of data segment) 2224 | StoredCodeSize := CodeSize; 2225 | for i := 0 to NumStaticStrChars - 1 do 2226 | Gen(Ord(StaticStringData[i])); // db StaticStringData[i] 2227 | CodeSize := StoredCodeSize; 2228 | end; 2229 | 2230 | 2231 | 2232 | 2233 | procedure GenerateStackFrameProlog(TotalLocalVarsSize: Integer); 2234 | begin 2235 | Gen($66); Gen($55); // push ebp 2236 | Gen($66); Gen($8B); Gen($EC); // mov ebp, esp 2237 | Gen($66); Gen($81); Gen($EC); GenDWord(TotalLocalVarsSize); // sub esp, TotalLocalVarsSize 2238 | end; 2239 | 2240 | 2241 | 2242 | 2243 | 2244 | procedure GenerateStackFrameEpilog; 2245 | begin 2246 | Gen($66); Gen($8B); Gen($E5); // mov esp, ebp 2247 | Gen($66); Gen($5D); // pop ebp 2248 | end; 2249 | 2250 | 2251 | 2252 | 2253 | procedure GenerateForwardReference; 2254 | begin 2255 | Gen($90); // nop ; jump to the procedure entry point will be inserted here 2256 | Gen($90); // nop 2257 | Gen($90); // nop 2258 | end; 2259 | 2260 | 2261 | 2262 | 2263 | procedure GenerateForwardResolution(IdentIndex: Integer); 2264 | var 2265 | CodePos: Integer; 2266 | begin 2267 | CodePos := Ident[IdentIndex].Value; 2268 | GenAt(CodePos, $E9); GenWordAt(CodePos + 1, CodeSize - (CodePos + 3)); // jmp Ident[IdentIndex].Value 2269 | end; 2270 | 2271 | 2272 | 2273 | 2274 | 2275 | 2276 | // ----- PARSER ----- 2277 | 2278 | 2279 | 2280 | procedure CompileConstExpression(var ConstVal: TConst; var ConstValType: Byte); forward; 2281 | procedure CompileDesignator(var ValType: Byte); forward; 2282 | procedure CompileExpression(var ValType: Byte); forward; 2283 | procedure CompileStatement; forward; 2284 | procedure CompileType(var DataType: Byte); forward; 2285 | 2286 | 2287 | 2288 | 2289 | procedure CompileConstFactor(var ConstVal: TConst; var ConstValType: Byte); 2290 | var 2291 | IdentIndex: Integer; 2292 | begin 2293 | case Tok.Kind of 2294 | IDENTTOK: 2295 | begin 2296 | IdentIndex := GetIdent(Tok.Name); 2297 | if Ident[IdentIndex].Kind <> CONSTANT then 2298 | Error('Constant expected but ' + Ident[IdentIndex].Name + ' found') 2299 | else 2300 | begin 2301 | ConstValType := Ident[IdentIndex].DataType; 2302 | if Types[ConstValType].TypeKind = REALTYPE then 2303 | ConstVal.FracValue := Ident[IdentIndex].FracValue 2304 | else 2305 | ConstVal.Value := Ident[IdentIndex].Value; 2306 | NextTok; 2307 | end; 2308 | end; 2309 | 2310 | 2311 | INTNUMBERTOK: 2312 | begin 2313 | ConstVal.Value := Tok.Value; 2314 | ConstValType := INTEGERTYPEINDEX; 2315 | NextTok; 2316 | end; 2317 | 2318 | 2319 | FRACNUMBERTOK: 2320 | begin 2321 | ConstVal.FracValue := Tok.FracValue; 2322 | ConstValType := REALTYPEINDEX; 2323 | NextTok; 2324 | end; 2325 | 2326 | 2327 | CHARLITERALTOK: 2328 | begin 2329 | ConstVal.Value := Tok.Value; 2330 | ConstValType := CHARTYPEINDEX; 2331 | NextTok; 2332 | end; 2333 | 2334 | 2335 | OPARTOK: // Expression in parentheses expected 2336 | begin 2337 | NextTok; 2338 | CompileConstExpression(ConstVal, ConstValType); 2339 | EatTok(CPARTOK); 2340 | end; 2341 | 2342 | 2343 | NOTTOK: 2344 | begin 2345 | CompileConstFactor(ConstVal, ConstValType); 2346 | ConstVal.Value := not ConstVal.Value; 2347 | end; 2348 | 2349 | else 2350 | Error('Expression expected but ' + GetSpelling(Tok) + ' found'); 2351 | end;// case 2352 | 2353 | end;// CompileConstFactor 2354 | 2355 | 2356 | 2357 | 2358 | procedure CompileConstTerm(var ConstVal: TConst; var ConstValType: Byte); 2359 | var 2360 | OpTok: TToken; 2361 | RightConstVal: TConst; 2362 | RightConstValType: Byte; 2363 | 2364 | begin 2365 | CompileConstFactor(ConstVal, ConstValType); 2366 | 2367 | while Tok.Kind in [MULTOK, DIVTOK, IDIVTOK, MODTOK, SHLTOK, SHRTOK, ANDTOK] do 2368 | begin 2369 | OpTok := Tok; 2370 | NextTok; 2371 | CompileConstFactor(RightConstVal, RightConstValType); 2372 | 2373 | // Try to convert integer to real 2374 | if ConversionIsPossible(ConstValType, RightConstValType) then 2375 | begin 2376 | ConstVal.FracValue := ConstVal.Value; 2377 | ConstValType := REALTYPEINDEX; 2378 | end; 2379 | if ConversionIsPossible(RightConstValType, ConstValType) then 2380 | begin 2381 | RightConstVal.FracValue := RightConstVal.Value; 2382 | RightConstValType := REALTYPEINDEX; 2383 | end; 2384 | 2385 | // Special case: real division of two integers 2386 | if (OpTok.Kind = DIVTOK) and ConversionIsPossible(ConstValType, REALTYPEINDEX) and ConversionIsPossible(RightConstValType, REALTYPEINDEX) then 2387 | begin 2388 | ConstVal.FracValue := ConstVal.Value; 2389 | RightConstVal.FracValue := RightConstVal.Value; 2390 | ConstValType := REALTYPEINDEX; 2391 | RightConstValType := REALTYPEINDEX; 2392 | end; 2393 | 2394 | ConstValType := GetCompatibleType(ConstValType, RightConstValType); 2395 | CheckOperator(OpTok.Kind, ConstValType); 2396 | 2397 | if Types[ConstValType].TypeKind = REALTYPE then // Real constants 2398 | case OpTok.Kind of 2399 | MULTOK: ConstVal.FracValue := ConstVal.FracValue * RightConstVal.FracValue; 2400 | DIVTOK: if RightConstVal.FracValue <> 0 then 2401 | ConstVal.FracValue := ConstVal.FracValue / RightConstVal.FracValue 2402 | else 2403 | Error('Constant division by zero'); 2404 | end 2405 | else // Integer constants 2406 | case OpTok.Kind of 2407 | MULTOK: ConstVal.Value := ConstVal.Value * RightConstVal.Value; 2408 | IDIVTOK: if RightConstVal.Value <> 0 then 2409 | ConstVal.Value := ConstVal.Value div RightConstVal.Value 2410 | else 2411 | Error('Constant division by zero'); 2412 | MODTOK: if RightConstVal.Value <> 0 then 2413 | ConstVal.Value := ConstVal.Value mod RightConstVal.Value 2414 | else 2415 | Error('Constant division by zero'); 2416 | SHLTOK: ConstVal.Value := ConstVal.Value shl RightConstVal.Value; 2417 | SHRTOK: ConstVal.Value := ConstVal.Value shr RightConstVal.Value; 2418 | ANDTOK: ConstVal.Value := ConstVal.Value and RightConstVal.Value; 2419 | end; 2420 | 2421 | end;// while 2422 | 2423 | end;// CompileConstTerm 2424 | 2425 | 2426 | 2427 | procedure CompileSimpleConstExpression(var ConstVal: TConst; var ConstValType: Byte); 2428 | var 2429 | UnaryOpTok, OpTok: TToken; 2430 | RightConstVal: TConst; 2431 | RightConstValType: Byte; 2432 | 2433 | begin 2434 | UnaryOpTok := Tok; 2435 | if UnaryOpTok.Kind in [PLUSTOK, MINUSTOK] then 2436 | NextTok; 2437 | 2438 | CompileConstTerm(ConstVal, ConstValType); 2439 | 2440 | if UnaryOpTok.Kind in [PLUSTOK, MINUSTOK] then 2441 | CheckOperator(UnaryOpTok.Kind, ConstValType); 2442 | 2443 | if UnaryOpTok.Kind = MINUSTOK then // Unary minus 2444 | if Types[ConstValType].TypeKind = REALTYPE then 2445 | ConstVal.FracValue := -ConstVal.FracValue 2446 | else 2447 | ConstVal.Value := -ConstVal.Value; 2448 | 2449 | while Tok.Kind in [PLUSTOK, MINUSTOK, ORTOK, XORTOK] do 2450 | begin 2451 | OpTok := Tok; 2452 | NextTok; 2453 | CompileConstTerm(RightConstVal, RightConstValType); 2454 | 2455 | // Try to convert integer to real 2456 | if ConversionIsPossible(ConstValType, RightConstValType) then 2457 | begin 2458 | ConstVal.FracValue := ConstVal.Value; 2459 | ConstValType := REALTYPEINDEX; 2460 | end; 2461 | if ConversionIsPossible(RightConstValType, ConstValType) then 2462 | begin 2463 | RightConstVal.FracValue := RightConstVal.Value; 2464 | RightConstValType := REALTYPEINDEX; 2465 | end; 2466 | 2467 | ConstValType := GetCompatibleType(ConstValType, RightConstValType); 2468 | CheckOperator(OpTok.Kind, ConstValType); 2469 | 2470 | if Types[ConstValType].TypeKind = REALTYPE then // Real constants 2471 | case OpTok.Kind of 2472 | PLUSTOK: ConstVal.FracValue := ConstVal.FracValue + RightConstVal.FracValue; 2473 | MINUSTOK: ConstVal.FracValue := ConstVal.FracValue - RightConstVal.FracValue; 2474 | end 2475 | else // Integer constants 2476 | case OpTok.Kind of 2477 | PLUSTOK: ConstVal.Value := ConstVal.Value + RightConstVal.Value; 2478 | MINUSTOK: ConstVal.Value := ConstVal.Value - RightConstVal.Value; 2479 | ORTOK: ConstVal.Value := ConstVal.Value or RightConstVal.Value; 2480 | XORTOK: ConstVal.Value := ConstVal.Value xor RightConstVal.Value; 2481 | end; 2482 | 2483 | end;// while 2484 | 2485 | end;// CompileSimpleConstExpression 2486 | 2487 | 2488 | 2489 | procedure CompileConstExpression(var ConstVal: TConst; var ConstValType: Byte); 2490 | var 2491 | OpTok: TToken; 2492 | RightConstVal: TConst; 2493 | RightConstValType: Byte; 2494 | Yes: Boolean; 2495 | 2496 | begin 2497 | Yes := FALSE; 2498 | CompileSimpleConstExpression(ConstVal, ConstValType); 2499 | 2500 | if Tok.Kind in [EQTOK, NETOK, LTTOK, LETOK, GTTOK, GETOK] then 2501 | begin 2502 | OpTok := Tok; 2503 | NextTok; 2504 | CompileSimpleConstExpression(RightConstVal, RightConstValType); 2505 | 2506 | // Try to convert integer to real 2507 | if ConversionIsPossible(ConstValType, RightConstValType) then 2508 | begin 2509 | ConstVal.FracValue := ConstVal.Value; 2510 | ConstValType := REALTYPEINDEX; 2511 | end; 2512 | if ConversionIsPossible(RightConstValType, ConstValType) then 2513 | begin 2514 | RightConstVal.FracValue := RightConstVal.Value; 2515 | RightConstValType := REALTYPEINDEX; 2516 | end; 2517 | 2518 | GetCompatibleType(ConstValType, RightConstValType); 2519 | CheckOperator(OpTok.Kind, ConstValType); 2520 | 2521 | if Types[ConstValType].TypeKind = REALTYPE then 2522 | case OpTok.Kind of 2523 | EQTOK: Yes := ConstVal.FracValue = RightConstVal.FracValue; 2524 | NETOK: Yes := ConstVal.FracValue <> RightConstVal.FracValue; 2525 | LTTOK: Yes := ConstVal.FracValue < RightConstVal.FracValue; 2526 | LETOK: Yes := ConstVal.FracValue <= RightConstVal.FracValue; 2527 | GTTOK: Yes := ConstVal.FracValue > RightConstVal.FracValue; 2528 | GETOK: Yes := ConstVal.FracValue >= RightConstVal.FracValue; 2529 | end 2530 | else 2531 | case OpTok.Kind of 2532 | EQTOK: Yes := ConstVal.Value = RightConstVal.Value; 2533 | NETOK: Yes := ConstVal.Value <> RightConstVal.Value; 2534 | LTTOK: Yes := ConstVal.Value < RightConstVal.Value; 2535 | LETOK: Yes := ConstVal.Value <= RightConstVal.Value; 2536 | GTTOK: Yes := ConstVal.Value > RightConstVal.Value; 2537 | GETOK: Yes := ConstVal.Value >= RightConstVal.Value; 2538 | end; 2539 | 2540 | if Yes then ConstVal.Value := -1 else ConstVal.Value := 0; 2541 | 2542 | ConstValType := BOOLEANTYPEINDEX; 2543 | end; 2544 | 2545 | end;// CompileConstExpression 2546 | 2547 | 2548 | 2549 | 2550 | procedure CompilePredefinedProc(proc: Byte); 2551 | var 2552 | DesignatorType, ExpressionType, ActualParamType: Byte; 2553 | InterruptNumber, ErrorCode: TConst; 2554 | ExitLoop: Boolean; 2555 | LibProcIdentIndex: Integer; 2556 | IsFirstParam, FileSpecified: Boolean; 2557 | begin 2558 | NextTok; 2559 | 2560 | case proc of 2561 | INCPROC, DECPROC: 2562 | begin 2563 | EatTok(OPARTOK); 2564 | AssertIdent; 2565 | CompileDesignator(DesignatorType); 2566 | GetCompatibleType(DesignatorType, INTEGERTYPEINDEX); 2567 | GenerateIncDec(proc, TypeSize(DesignatorType)); 2568 | EatTok(CPARTOK); 2569 | end; 2570 | 2571 | READPROC, READLNPROC: 2572 | begin 2573 | FileSpecified := FALSE; // By default, use standard output device, i.e. console 2574 | IsFirstParam := TRUE; 2575 | 2576 | if Tok.Kind = OPARTOK then 2577 | begin 2578 | NextTok; 2579 | repeat 2580 | // 1st argument - file handle 2581 | if FileSpecified then 2582 | RestoreFileHandle 2583 | else 2584 | PushConst(0); // Console handle 2585 | 2586 | // 2nd argument - string stream handle 2587 | PushConst(0); 2588 | 2589 | // 3rd argument - designator 2590 | CompileDesignator(DesignatorType); 2591 | 2592 | if Types[DesignatorType].TypeKind = TEXTTYPE then // Text file handle 2593 | begin 2594 | if not IsFirstParam then 2595 | Error('Incompatible types'); 2596 | FileSpecified := TRUE; 2597 | DerefPtr(DesignatorType); 2598 | SaveFileHandle; 2599 | end 2600 | else // Any output expression 2601 | begin 2602 | LibProcIdentIndex := 0; 2603 | 2604 | if (Types[DesignatorType].TypeKind in IntegerTypes) or 2605 | ((Types[DesignatorType].TypeKind = SUBRANGETYPE) and 2606 | (Types[Types[DesignatorType].HostType].TypeKind in IntegerTypes)) then 2607 | LibProcIdentIndex := GetIdent('READINT') // Integer or boolean argument 2608 | else if (Types[DesignatorType].TypeKind = CHARTYPE) or 2609 | ((Types[DesignatorType].TypeKind = SUBRANGETYPE) and 2610 | (Types[Types[DesignatorType].HostType].TypeKind = CHARTYPE)) then 2611 | LibProcIdentIndex := GetIdent('READCH') // Character argument 2612 | else if Types[DesignatorType].TypeKind = REALTYPE then 2613 | LibProcIdentIndex := GetIdent('READREAL') // Real argument 2614 | else if (Types[DesignatorType].TypeKind = ARRAYTYPE) and (Types[DesignatorType].BaseType = CHARTYPEINDEX) then 2615 | LibProcIdentIndex := GetIdent('READSTRING') // String argument 2616 | else 2617 | Error('Incompatible types'); 2618 | 2619 | // Call the specific output subroutine. Interface: FileHandle; StreamHandle; var Designator 2620 | if Pass = CALLDETERMPASS then AddCallGraphChild(BlockStack[BlockStackTop], Ident[LibProcIdentIndex].ProcAsBlock); 2621 | GenerateCall(Ident[LibProcIdentIndex].Value, BlockStackTop - Ident[LibProcIdentIndex].NestingLevel); 2622 | end; // else 2623 | 2624 | IsFirstParam := FALSE; 2625 | 2626 | ExitLoop := FALSE; 2627 | if Tok.Kind = COMMATOK then 2628 | NextTok 2629 | else 2630 | ExitLoop := TRUE; 2631 | until ExitLoop; 2632 | EatTok(CPARTOK); 2633 | end; // if OPARTOR 2634 | 2635 | // Add CR+LF, if necessary 2636 | if proc = READLNPROC then 2637 | begin 2638 | LibProcIdentIndex := GetIdent('READNEWLINE'); 2639 | 2640 | // 1st argument - file handle 2641 | if FileSpecified then 2642 | RestoreFileHandle 2643 | else 2644 | PushConst(0); // Console handle 2645 | 2646 | // 2nd argument - string stream handle 2647 | PushConst(0); 2648 | 2649 | if Pass = CALLDETERMPASS then AddCallGraphChild(BlockStack[BlockStackTop], Ident[LibProcIdentIndex].ProcAsBlock); 2650 | GenerateCall(Ident[LibProcIdentIndex].Value, BlockStackTop - Ident[LibProcIdentIndex].NestingLevel); 2651 | end; 2652 | 2653 | end;// READPROC, READLNPROC 2654 | 2655 | 2656 | WRITEPROC, WRITELNPROC: 2657 | begin 2658 | FileSpecified := FALSE; // By default, use standard output device, i.e. console 2659 | IsFirstParam := TRUE; 2660 | 2661 | if Tok.Kind = OPARTOK then 2662 | begin 2663 | NextTok; 2664 | repeat 2665 | // 1st argument - file handle 2666 | if FileSpecified then 2667 | RestoreFileHandle 2668 | else 2669 | PushConst(0); // Console handle 2670 | 2671 | // 2nd argument - string stream handle 2672 | PushConst(0); 2673 | 2674 | // 3rd argument - expression 2675 | CompileExpression(ExpressionType); 2676 | 2677 | if Types[ExpressionType].TypeKind = TEXTTYPE then // Text file handle 2678 | begin 2679 | if not IsFirstParam then 2680 | Error('Incompatible types'); 2681 | FileSpecified := TRUE; 2682 | SaveFileHandle; 2683 | end 2684 | else // Any output expression 2685 | begin 2686 | LibProcIdentIndex := 0; 2687 | 2688 | if (Types[ExpressionType].TypeKind in IntegerTypes) or 2689 | ((Types[ExpressionType].TypeKind = SUBRANGETYPE) and 2690 | (Types[Types[ExpressionType].HostType].TypeKind in IntegerTypes)) then 2691 | LibProcIdentIndex := GetIdent('WRITEINT') // Integer or boolean argument 2692 | else if (Types[ExpressionType].TypeKind = BOOLEANTYPE) or 2693 | ((Types[ExpressionType].TypeKind = SUBRANGETYPE) and 2694 | (Types[Types[ExpressionType].HostType].TypeKind = BOOLEANTYPE)) then 2695 | LibProcIdentIndex := GetIdent('WRITEBOOLEAN') // Boolean argument 2696 | else if (Types[ExpressionType].TypeKind = CHARTYPE) or 2697 | ((Types[ExpressionType].TypeKind = SUBRANGETYPE) and 2698 | (Types[Types[ExpressionType].HostType].TypeKind = CHARTYPE)) then 2699 | LibProcIdentIndex := GetIdent('WRITECH') // Character argument 2700 | else if Types[ExpressionType].TypeKind = REALTYPE then 2701 | LibProcIdentIndex := GetIdent('WRITEREAL') // Real argument 2702 | else if Types[ExpressionType].TypeKind = POINTERTYPE then 2703 | LibProcIdentIndex := GetIdent('WRITEPOINTER') // Pointer argument 2704 | else if (Types[ExpressionType].TypeKind = ARRAYTYPE) and (Types[ExpressionType].BaseType = CHARTYPEINDEX) then 2705 | LibProcIdentIndex := GetIdent('WRITESTRING') // String argument 2706 | else 2707 | Error('Incompatible types'); 2708 | 2709 | // Call the specific output subroutine. Interface: FileHandle; StreamHandle; Expression 2710 | if Pass = CALLDETERMPASS then AddCallGraphChild(BlockStack[BlockStackTop], Ident[LibProcIdentIndex].ProcAsBlock); 2711 | GenerateCall(Ident[LibProcIdentIndex].Value, BlockStackTop - Ident[LibProcIdentIndex].NestingLevel); 2712 | end; // else 2713 | 2714 | IsFirstParam := FALSE; 2715 | 2716 | ExitLoop := FALSE; 2717 | if Tok.Kind = COMMATOK then 2718 | NextTok 2719 | else 2720 | ExitLoop := TRUE; 2721 | until ExitLoop; 2722 | EatTok(CPARTOK); 2723 | end; // if OPARTOR 2724 | 2725 | // Add CR+LF, if necessary 2726 | if proc = WRITELNPROC then 2727 | begin 2728 | LibProcIdentIndex := GetIdent('WRITENEWLINE'); 2729 | 2730 | // 1st argument - file handle 2731 | if FileSpecified then 2732 | RestoreFileHandle 2733 | else 2734 | PushConst(0); // Console handle 2735 | 2736 | // 2nd argument - string stream handle 2737 | PushConst(0); 2738 | 2739 | if Pass = CALLDETERMPASS then AddCallGraphChild(BlockStack[BlockStackTop], Ident[LibProcIdentIndex].ProcAsBlock); 2740 | GenerateCall(Ident[LibProcIdentIndex].Value, BlockStackTop - Ident[LibProcIdentIndex].NestingLevel); 2741 | end; 2742 | 2743 | end;// WRITEPROC, WRITELNPROC 2744 | 2745 | 2746 | INPPROC, OUTPPROC: 2747 | begin 2748 | EatTok(OPARTOK); 2749 | CompileExpression(ExpressionType); 2750 | GetCompatibleType(ExpressionType, INTEGERTYPEINDEX); 2751 | EatTok(COMMATOK); 2752 | if proc = INPPROC then 2753 | CompileDesignator(ExpressionType) 2754 | else 2755 | CompileExpression(ExpressionType); 2756 | GetCompatibleType(ExpressionType, SHORTINTTYPEINDEX); 2757 | GenerateInpOutp(proc); 2758 | EatTok(CPARTOK); 2759 | end; 2760 | 2761 | NEWPROC, DISPOSEPROC: 2762 | begin 2763 | EatTok(OPARTOK); 2764 | AssertIdent; 2765 | CompileDesignator(DesignatorType); 2766 | GetCompatibleType(DesignatorType, POINTERTYPEINDEX); 2767 | GenerateNewDispose(proc, TypeSize(Types[DesignatorType].BaseType)); 2768 | EatTok(CPARTOK); 2769 | end; 2770 | 2771 | HALTPROC: 2772 | begin 2773 | if Tok.Kind = OPARTOK then 2774 | begin 2775 | NextTok; 2776 | CompileConstExpression(ErrorCode, ExpressionType); 2777 | GetCompatibleType(ExpressionType, INTEGERTYPEINDEX); 2778 | EatTok(CPARTOK); 2779 | end 2780 | else 2781 | ErrorCode.Value := 0; 2782 | GenerateHalt(ErrorCode.Value); 2783 | end; 2784 | 2785 | INTRPROC: 2786 | begin 2787 | EatTok(OPARTOK); 2788 | CompileConstExpression(InterruptNumber, ActualParamType); 2789 | GetCompatibleType(ActualParamType, INTEGERTYPEINDEX); 2790 | EatTok(COMMATOK); 2791 | CompileExpression(ActualParamType); 2792 | GetCompatibleType(ActualParamType, POINTERTYPEINDEX); 2793 | GenerateInterrupt(InterruptNumber.Value); 2794 | EatTok(CPARTOK); 2795 | end; 2796 | end;// case 2797 | 2798 | end;// CompilePredefinedProc 2799 | 2800 | 2801 | 2802 | 2803 | procedure CompilePredefinedFunc(func: Byte; var ValType: Byte); 2804 | var 2805 | IdentIndex: Integer; 2806 | begin 2807 | NextTok; 2808 | EatTok(OPARTOK); 2809 | 2810 | case func of 2811 | SIZEOFFUNC: 2812 | begin 2813 | AssertIdent; 2814 | IdentIndex := GetIdent(Tok.Name); 2815 | if Ident[IdentIndex].Kind = USERTYPE then 2816 | begin 2817 | NextTok; 2818 | PushConst(TypeSize(Ident[IdentIndex].DataType)); 2819 | end 2820 | else 2821 | begin 2822 | CompileDesignator(ValType); 2823 | SaveStackTop; // Save result to EDX 2824 | PushConst(TypeSize(ValType)); 2825 | end; 2826 | ValType := INTEGERTYPEINDEX; 2827 | end; 2828 | 2829 | ROUNDFUNC, TRUNCFUNC: 2830 | begin 2831 | CompileExpression(ValType); 2832 | 2833 | // Try to convert integer to real 2834 | if ConversionIsPossible(ValType, REALTYPEINDEX) then 2835 | begin 2836 | GenerateFloat(0); 2837 | ValType := REALTYPEINDEX; 2838 | end; 2839 | 2840 | GetCompatibleType(ValType, REALTYPEINDEX); 2841 | GenerateRound(func = TRUNCFUNC); 2842 | ValType := INTEGERTYPEINDEX; 2843 | end; 2844 | 2845 | ORDFUNC: 2846 | begin 2847 | CompileExpression(ValType); 2848 | if not (Types[ValType].TypeKind in OrdinalTypes) then 2849 | Error('Ordinal type expected'); 2850 | ValType := INTEGERTYPEINDEX; 2851 | end; 2852 | 2853 | CHRFUNC: 2854 | begin 2855 | CompileExpression(ValType); 2856 | GetCompatibleType(ValType, INTEGERTYPEINDEX); 2857 | ValType := CHARTYPEINDEX; 2858 | end; 2859 | 2860 | PREDFUNC, SUCCFUNC: 2861 | begin 2862 | CompileExpression(ValType); 2863 | if not (Types[ValType].TypeKind in OrdinalTypes) then 2864 | Error('Ordinal type expected'); 2865 | if func = SUCCFUNC then 2866 | PushConst(1) 2867 | else 2868 | PushConst(-1); 2869 | GenerateBinaryOperator(PLUSTOK, INTEGERTYPEINDEX); 2870 | end; 2871 | 2872 | ABSFUNC, SQRFUNC, SINFUNC, COSFUNC, ARCTANFUNC, EXPFUNC, LNFUNC, SQRTFUNC: 2873 | begin 2874 | CompileExpression(ValType); 2875 | if func in [ABSFUNC, SQRFUNC] then // Abs and Sqr accept real or integer parameters 2876 | begin 2877 | if not ((Types[ValType].TypeKind in (IntegerTypes + [REALTYPE])) or 2878 | ((Types[ValType].TypeKind = SUBRANGETYPE) and 2879 | (Types[Types[ValType].HostType].TypeKind in IntegerTypes))) then 2880 | Error('Numeric type expected') 2881 | end 2882 | else 2883 | begin 2884 | 2885 | // Try to convert integer to real 2886 | if ConversionIsPossible(ValType, REALTYPEINDEX) then 2887 | begin 2888 | GenerateFloat(0); 2889 | ValType := REALTYPEINDEX; 2890 | end; 2891 | 2892 | GetCompatibleType(ValType, REALTYPEINDEX); 2893 | end; 2894 | 2895 | GenerateMathFunction(func, ValType); 2896 | end; 2897 | end;// case 2898 | 2899 | EatTok(CPARTOK); 2900 | end;// CompilePredefinedFunc 2901 | 2902 | 2903 | 2904 | 2905 | 2906 | procedure CompileDesignator(var ValType: Byte); 2907 | var 2908 | IdentIndex, FieldIndex: Integer; 2909 | ArrayIndexType: Byte; 2910 | IsRefParam: Boolean; 2911 | begin 2912 | AssertIdent; 2913 | 2914 | IdentIndex := GetIdent(Tok.Name); 2915 | 2916 | if Ident[IdentIndex].Kind <> VARIABLE then 2917 | Error('Variable expected but ' + Tok.Name + ' found'); 2918 | 2919 | PushVarPtr(Ident[IdentIndex].Value, Ident[IdentIndex].Scope, BlockStackTop - Ident[IdentIndex].NestingLevel); 2920 | ValType := Ident[IdentIndex].DataType; 2921 | 2922 | 2923 | if Types[Ident[IdentIndex].DataType].TypeKind in [ARRAYTYPE, RECORDTYPE] then 2924 | IsRefParam := Ident[IdentIndex].PassMethod in [CONSTPASSING, VARPASSING] // For structured parameters, CONST is equivalent to VAR 2925 | else 2926 | IsRefParam := Ident[IdentIndex].PassMethod = VARPASSING; // For scalar parameters, CONST is equivalent to passing by value 2927 | 2928 | if IsRefParam then DerefPtr(POINTERTYPEINDEX); // Parameter is passed by reference 2929 | 2930 | 2931 | NextTok; 2932 | 2933 | while Tok.Kind in [DEREFERENCETOK, OBRACKETTOK, PERIODTOK] do 2934 | if Tok.Kind = DEREFERENCETOK then // Pointer dereferencing 2935 | begin 2936 | if (Types[ValType].TypeKind <> POINTERTYPE) or (Types[ValType].BaseType = ANYTYPEINDEX) then 2937 | Error('Typed pointer expected'); 2938 | DerefPtr(ValType); 2939 | ValType := Types[ValType].BaseType; 2940 | NextTok; 2941 | end 2942 | else if Tok.Kind = OBRACKETTOK then // Array element access 2943 | begin 2944 | repeat 2945 | if Types[ValType].TypeKind <> ARRAYTYPE then 2946 | Error('Array expected'); 2947 | NextTok; 2948 | CompileExpression(ArrayIndexType); // Array index 2949 | GetCompatibleType(ArrayIndexType, Types[ValType].IndexType); 2950 | GetArrayElementPtr(ValType); 2951 | ValType := Types[ValType].BaseType; 2952 | until Tok.Kind <> COMMATOK; 2953 | EatTok(CBRACKETTOK); 2954 | end 2955 | else if Tok.Kind = PERIODTOK then // Record field access 2956 | begin 2957 | if Types[ValType].TypeKind <> RECORDTYPE then 2958 | Error('Record expected'); 2959 | NextTok; 2960 | AssertIdent; 2961 | FieldIndex := GetField(ValType, Tok.Name); 2962 | GetFieldPtr(ValType, FieldIndex); 2963 | ValType := Types[ValType].Field[FieldIndex]^.DataType; 2964 | NextTok; 2965 | end; 2966 | end; // CompileDesignator 2967 | 2968 | 2969 | 2970 | 2971 | procedure CompileActualParameters(IdentIndex: Integer); 2972 | var 2973 | NumActualParams: Integer; 2974 | ActualParamType: Byte; 2975 | IsRefParam, TreatCharAsString: Boolean; 2976 | CurParam: PParam; 2977 | begin 2978 | NumActualParams := 0; 2979 | 2980 | if Tok.Kind = OPARTOK then // Actual parameter list found 2981 | begin 2982 | repeat 2983 | NextTok; 2984 | 2985 | if NumActualParams + 1 > Ident[IdentIndex].NumParams then 2986 | Error('Too many actual parameters'); 2987 | 2988 | CurParam := Ident[IdentIndex].Param[NumActualParams + 1]; 2989 | 2990 | // Evaluate actual parameters and push them onto the stack 2991 | 2992 | TreatCharAsString := (Tok.Kind = CHARLITERALTOK) and (CurParam^.DataType = STRINGTYPEINDEX); 2993 | 2994 | if (Tok.Kind = STRINGLITERALTOK) or TreatCharAsString then 2995 | begin 2996 | if CurParam^.PassMethod <> CONSTPASSING then 2997 | Error('String literals can be passed as CONST only'); 2998 | IsRefParam := FALSE; 2999 | end 3000 | else 3001 | if Types[CurParam^.DataType].TypeKind in [ARRAYTYPE, RECORDTYPE] then 3002 | IsRefParam := CurParam^.PassMethod in [CONSTPASSING, VARPASSING] // For structured parameters, CONST is equivalent to VAR 3003 | else 3004 | IsRefParam := CurParam^.PassMethod = VARPASSING; // For scalar parameters, CONST is equivalent to passing by value 3005 | 3006 | if TreatCharAsString then 3007 | begin // Special case 3008 | PushVarPtr(Tok.StrAddress, GLOBAL, 0); 3009 | ActualParamType := STRINGTYPEINDEX; 3010 | NextTok; 3011 | end 3012 | else 3013 | if IsRefParam then // General rule 3014 | CompileDesignator(ActualParamType) 3015 | else 3016 | CompileExpression(ActualParamType); 3017 | 3018 | Inc(NumActualParams); 3019 | 3020 | // Try to convert integer to real 3021 | if ConversionIsPossible(ActualParamType, CurParam^.DataType) and not IsRefParam then 3022 | begin 3023 | GenerateFloat(0); 3024 | ActualParamType := REALTYPEINDEX; 3025 | end; 3026 | 3027 | GetCompatibleType(CurParam^.DataType, ActualParamType); 3028 | until Tok.Kind <> COMMATOK; 3029 | 3030 | EatTok(CPARTOK); 3031 | end;// if Tok.Kind = OPARTOR 3032 | 3033 | if NumActualParams < Ident[IdentIndex].NumParams then 3034 | Error('Too few actual parameters'); 3035 | 3036 | end;// CompileActualParameters 3037 | 3038 | 3039 | 3040 | 3041 | 3042 | procedure CompileFactor(var ValType: Byte); 3043 | var 3044 | IdentIndex: Integer; 3045 | begin 3046 | case Tok.Kind of 3047 | IDENTTOK: 3048 | begin 3049 | IdentIndex := GetIdent(Tok.Name); 3050 | if Ident[IdentIndex].Kind = PROC then 3051 | Error('Expression expected but procedure ' + Ident[IdentIndex].Name + ' found') 3052 | else if Ident[IdentIndex].Kind = FUNC then // Function call 3053 | if Ident[IdentIndex].PredefIndex <> 0 then // Predefined function call 3054 | CompilePredefinedFunc(Ident[IdentIndex].PredefIndex, ValType) 3055 | else // User-defined function call 3056 | begin 3057 | NextTok; 3058 | CompileActualParameters(IdentIndex); 3059 | if Pass = CALLDETERMPASS then AddCallGraphChild(BlockStack[BlockStackTop], Ident[IdentIndex].ProcAsBlock); 3060 | GenerateCall(Ident[IdentIndex].Value, BlockStackTop - Ident[IdentIndex].NestingLevel); 3061 | RestoreStackTop; 3062 | ValType := Ident[IdentIndex].DataType; 3063 | end // FUNC 3064 | else if Ident[IdentIndex].Kind = VARIABLE then // Designator 3065 | begin 3066 | CompileDesignator(ValType); 3067 | if not (Types[ValType].TypeKind in [ARRAYTYPE, RECORDTYPE]) then // Factors of type 'array' or 'record' should contain a pointer to them 3068 | DerefPtr(ValType); 3069 | end 3070 | else if Ident[IdentIndex].Kind = CONSTANT then // Constant 3071 | begin 3072 | ValType := Ident[IdentIndex].DataType; 3073 | if ValType = REALTYPE then 3074 | PushConst(Integer((Pointer(@Ident[IdentIndex].FracValue))^)) 3075 | else 3076 | PushConst(Ident[IdentIndex].Value); 3077 | NextTok; 3078 | end 3079 | else // Type cast 3080 | begin 3081 | NextTok; 3082 | EatTok(OPARTOK); 3083 | CompileExpression(ValType); 3084 | EatTok(CPARTOK); 3085 | 3086 | if not ((Types[Ident[IdentIndex].DataType].TypeKind in OrdinalTypes + [TEXTTYPE, POINTERTYPE]) and 3087 | (Types[ValType].TypeKind in OrdinalTypes + [TEXTTYPE, POINTERTYPE])) then 3088 | Error('Invalid typecast'); 3089 | 3090 | ValType := Ident[IdentIndex].DataType; 3091 | end; 3092 | end; 3093 | 3094 | 3095 | ADDRESSTOK: 3096 | begin 3097 | NextTok; 3098 | CompileDesignator(ValType); 3099 | ValType := POINTERTYPEINDEX; 3100 | end; 3101 | 3102 | 3103 | INTNUMBERTOK: 3104 | begin 3105 | PushConst(Tok.Value); 3106 | ValType := INTEGERTYPEINDEX; 3107 | NextTok; 3108 | end; 3109 | 3110 | 3111 | FRACNUMBERTOK: 3112 | begin 3113 | PushConst(Integer((Pointer(@Tok.FracValue))^)); 3114 | ValType := REALTYPEINDEX; 3115 | NextTok; 3116 | end; 3117 | 3118 | 3119 | CHARLITERALTOK: 3120 | begin 3121 | PushConst(Tok.Value); 3122 | ValType := CHARTYPEINDEX; 3123 | NextTok; 3124 | end; 3125 | 3126 | 3127 | STRINGLITERALTOK: 3128 | begin 3129 | PushVarPtr(Tok.StrAddress, GLOBAL, 0); 3130 | ValType := STRINGTYPEINDEX; 3131 | NextTok; 3132 | end; 3133 | 3134 | 3135 | OPARTOK: // Expression in parentheses expected 3136 | begin 3137 | NextTok; 3138 | CompileExpression(ValType); 3139 | EatTok(CPARTOK); 3140 | end; 3141 | 3142 | 3143 | NOTTOK: 3144 | begin 3145 | NextTok; 3146 | CompileFactor(ValType); 3147 | CheckOperator(NOTTOK, ValType); 3148 | GenerateUnaryOperator(NOTTOK, ValType); 3149 | end; 3150 | 3151 | 3152 | NILTOK: 3153 | begin 3154 | PushConst(0); 3155 | ValType := POINTERTYPEINDEX; 3156 | NextTok; 3157 | end; 3158 | 3159 | else 3160 | Error('Expression expected but ' + GetSpelling(Tok) + ' found'); 3161 | end;// case 3162 | 3163 | end;// CompileFactor 3164 | 3165 | 3166 | 3167 | 3168 | procedure CompileTerm(var ValType: Byte); 3169 | var 3170 | OpTok: TToken; 3171 | RightValType: Byte; 3172 | begin 3173 | CompileFactor(ValType); 3174 | 3175 | while Tok.Kind in [MULTOK, DIVTOK, IDIVTOK, MODTOK, SHLTOK, SHRTOK, ANDTOK] do 3176 | begin 3177 | OpTok := Tok; 3178 | NextTok; 3179 | CompileFactor(RightValType); 3180 | 3181 | // Try to convert integer to real 3182 | if ConversionIsPossible(ValType, RightValType) then 3183 | begin 3184 | GenerateFloat(SizeOf(Single)); 3185 | ValType := REALTYPEINDEX; 3186 | end; 3187 | if ConversionIsPossible(RightValType, ValType) then 3188 | begin 3189 | GenerateFloat(0); 3190 | RightValType := REALTYPEINDEX; 3191 | end; 3192 | 3193 | // Special case: real division of two integers 3194 | if (OpTok.Kind = DIVTOK) and ConversionIsPossible(ValType, REALTYPEINDEX) and ConversionIsPossible(RightValType, REALTYPEINDEX) then 3195 | begin 3196 | GenerateFloat(SizeOf(Single)); 3197 | GenerateFloat(0); 3198 | ValType := REALTYPEINDEX; 3199 | RightValType := REALTYPEINDEX; 3200 | end; 3201 | 3202 | 3203 | ValType := GetCompatibleType(ValType, RightValType); 3204 | CheckOperator(OpTok.Kind, ValType); 3205 | GenerateBinaryOperator(OpTok.Kind, ValType); 3206 | end;// while 3207 | 3208 | end;// CompileTerm 3209 | 3210 | 3211 | 3212 | 3213 | procedure CompileSimpleExpression(var ValType: Byte); 3214 | var 3215 | UnaryOpTok, OpTok: TToken; 3216 | RightValType: Byte; 3217 | begin 3218 | UnaryOpTok := Tok; 3219 | if UnaryOpTok.Kind in [PLUSTOK, MINUSTOK] then 3220 | NextTok; 3221 | 3222 | CompileTerm(ValType); 3223 | 3224 | if UnaryOpTok.Kind in [PLUSTOK, MINUSTOK] then 3225 | CheckOperator(UnaryOpTok.Kind, ValType); 3226 | 3227 | if UnaryOpTok.Kind = MINUSTOK then GenerateUnaryOperator(MINUSTOK, ValType); // Unary minus 3228 | 3229 | while Tok.Kind in [PLUSTOK, MINUSTOK, ORTOK, XORTOK] do 3230 | begin 3231 | OpTok := Tok; 3232 | NextTok; 3233 | CompileTerm(RightValType); 3234 | 3235 | // Try to convert integer to real 3236 | if ConversionIsPossible(ValType, RightValType) then 3237 | begin 3238 | GenerateFloat(SizeOf(Single)); 3239 | ValType := REALTYPEINDEX; 3240 | end; 3241 | if ConversionIsPossible(RightValType, ValType) then 3242 | begin 3243 | GenerateFloat(0); 3244 | RightValType := REALTYPEINDEX; 3245 | end; 3246 | 3247 | ValType := GetCompatibleType(ValType, RightValType); 3248 | CheckOperator(OpTok.Kind, ValType); 3249 | GenerateBinaryOperator(OpTok.Kind, ValType); 3250 | end;// while 3251 | 3252 | end;// CompileSimpleExpression 3253 | 3254 | 3255 | 3256 | 3257 | procedure CompileExpression(var ValType: Byte); 3258 | var 3259 | OpTok: TToken; 3260 | RightValType: Byte; 3261 | begin 3262 | CompileSimpleExpression(ValType); 3263 | 3264 | if Tok.Kind in [EQTOK, NETOK, LTTOK, LETOK, GTTOK, GETOK] then 3265 | begin 3266 | OpTok := Tok; 3267 | NextTok; 3268 | CompileSimpleExpression(RightValType); 3269 | 3270 | // Try to convert integer to real 3271 | if ConversionIsPossible(ValType, RightValType) then 3272 | begin 3273 | GenerateFloat(SizeOf(Single)); 3274 | ValType := REALTYPEINDEX; 3275 | end; 3276 | if ConversionIsPossible(RightValType, ValType) then 3277 | begin 3278 | GenerateFloat(0); 3279 | RightValType := REALTYPEINDEX; 3280 | end; 3281 | 3282 | GetCompatibleType(ValType, RightValType); 3283 | CheckOperator(OpTok.Kind, ValType); 3284 | ValType := BOOLEANTYPEINDEX; 3285 | GenerateRelation(OpTok.Kind, RightValType); 3286 | end;// while 3287 | 3288 | end;// CompileExpression 3289 | 3290 | 3291 | 3292 | 3293 | procedure CompileStatementList; 3294 | begin 3295 | CompileStatement; 3296 | while Tok.Kind = SEMICOLONTOK do 3297 | begin 3298 | NextTok; 3299 | CompileStatement; 3300 | end; 3301 | end; // CompileStatementList 3302 | 3303 | 3304 | 3305 | 3306 | procedure CompileCompoundStatement; 3307 | begin 3308 | EatTok(BEGINTOK); 3309 | CompileStatementList; 3310 | EatTok(ENDTOK); 3311 | end; // CompileCompoundStatement 3312 | 3313 | 3314 | 3315 | 3316 | procedure CompileStatement; 3317 | var 3318 | IdentIndex, ResultIdentIndex, NumCaseStatements: Integer; 3319 | ConstVal, ConstVal2: TConst; 3320 | ExpressionType, DesignatorType, ConstValType, SelectorType: Byte; 3321 | Down, ExitLoop, TreatCharAsString: Boolean; 3322 | begin 3323 | 3324 | case Tok.Kind of 3325 | IDENTTOK: 3326 | begin 3327 | IdentIndex := GetIdent(Tok.Name); 3328 | case Ident[IdentIndex].Kind of 3329 | 3330 | VARIABLE, FUNC: // Variable or function result assignment 3331 | begin 3332 | if Ident[IdentIndex].Kind = VARIABLE then 3333 | CompileDesignator(DesignatorType) 3334 | else 3335 | begin 3336 | if Ident[IdentIndex].ProcAsBlock <> BlockStack[BlockStackTop] then 3337 | Error('Current function name expected but ' + Ident[IdentIndex].Name + ' found'); 3338 | 3339 | ResultIdentIndex := GetIdent('RESULT'); 3340 | PushVarPtr(Ident[ResultIdentIndex].Value, LOCAL, 0); 3341 | DesignatorType := Ident[ResultIdentIndex].DataType; 3342 | 3343 | NextTok; 3344 | end; 3345 | 3346 | EatTok(ASSIGNTOK); 3347 | 3348 | TreatCharAsString := (Tok.Kind = CHARLITERALTOK) and (DesignatorType = STRINGTYPEINDEX); 3349 | if TreatCharAsString then 3350 | begin // Special case 3351 | PushVarPtr(Tok.StrAddress, GLOBAL, 0); 3352 | ExpressionType := STRINGTYPEINDEX; 3353 | NextTok; 3354 | end 3355 | else 3356 | CompileExpression(ExpressionType); // General rule - right-hand side expression 3357 | 3358 | // Try to convert integer to real 3359 | if ConversionIsPossible(ExpressionType, DesignatorType) then 3360 | begin 3361 | GenerateFloat(0); 3362 | ExpressionType := REALTYPEINDEX; 3363 | end; 3364 | 3365 | GetCompatibleType(DesignatorType, ExpressionType); 3366 | 3367 | if Types[DesignatorType].TypeKind in [ARRAYTYPE, RECORDTYPE] then 3368 | GenerateStructuredAssignment(DesignatorType) 3369 | else 3370 | GenerateAssignment(DesignatorType); 3371 | end;// VARIABLE 3372 | 3373 | PROC: // Procedure call 3374 | if Ident[IdentIndex].PredefIndex <> 0 then // Predefined procedure call 3375 | CompilePredefinedProc(Ident[IdentIndex].PredefIndex) 3376 | else // User-defined procedure call 3377 | begin 3378 | NextTok; 3379 | CompileActualParameters(IdentIndex); 3380 | if Pass = CALLDETERMPASS then AddCallGraphChild(BlockStack[BlockStackTop], Ident[IdentIndex].ProcAsBlock); 3381 | GenerateCall(Ident[IdentIndex].Value, BlockStackTop - Ident[IdentIndex].NestingLevel); 3382 | end;// PROC 3383 | else 3384 | Error('Statement expected but ' + Ident[IdentIndex].Name + ' found'); 3385 | end// case Ident[IdentIndex].Kind 3386 | end; 3387 | 3388 | BEGINTOK: 3389 | CompileCompoundStatement; 3390 | 3391 | IFTOK: 3392 | begin 3393 | NextTok; 3394 | CompileExpression(ExpressionType); 3395 | GetCompatibleType(ExpressionType, BOOLEANTYPEINDEX); 3396 | EatTok(THENTOK); 3397 | 3398 | GenerateIfCondition; // Satisfied if expression is not zero 3399 | GenerateIfProlog; 3400 | CompileStatement; 3401 | 3402 | if Tok.Kind = ELSETOK then 3403 | begin 3404 | NextTok; 3405 | GenerateElseProlog; 3406 | CompileStatement; 3407 | end; 3408 | 3409 | GenerateIfElseEpilog; 3410 | end; 3411 | 3412 | CASETOK: 3413 | begin 3414 | NextTok; 3415 | CompileExpression(SelectorType); 3416 | if not (Types[SelectorType].TypeKind in OrdinalTypes) then 3417 | Error('Ordinal variable expected as CASE selector'); 3418 | EatTok(OFTOK); 3419 | 3420 | GenerateCaseProlog; 3421 | 3422 | NumCaseStatements := 0; 3423 | 3424 | repeat // Loop over all cases 3425 | 3426 | repeat // Loop over all constants for the current case 3427 | CompileConstExpression(ConstVal, ConstValType); 3428 | GetCompatibleType(ConstValType, SelectorType); 3429 | 3430 | if Tok.Kind = RANGETOK then // Range check 3431 | begin 3432 | NextTok; 3433 | CompileConstExpression(ConstVal2, ConstValType); 3434 | GetCompatibleType(ConstValType, SelectorType); 3435 | GenerateCaseRangeCheck(ConstVal.Value, ConstVal2.Value); 3436 | end 3437 | else 3438 | GenerateCaseEqualityCheck(ConstVal.Value); // Equality check 3439 | 3440 | ExitLoop := FALSE; 3441 | if Tok.Kind = COMMATOK then 3442 | NextTok 3443 | else 3444 | ExitLoop := TRUE; 3445 | until ExitLoop; 3446 | 3447 | EatTok(COLONTOK); 3448 | 3449 | GenerateCaseStatementProlog; 3450 | CompileStatement; 3451 | GenerateCaseStatementEpilog; 3452 | 3453 | Inc(NumCaseStatements); 3454 | 3455 | ExitLoop := FALSE; 3456 | if Tok.Kind <> SEMICOLONTOK then 3457 | begin 3458 | if Tok.Kind = ELSETOK then // Default statements 3459 | begin 3460 | NextTok; 3461 | CompileStatementList; 3462 | end; 3463 | ExitLoop := TRUE; 3464 | end 3465 | else 3466 | begin 3467 | NextTok; 3468 | if Tok.Kind = ENDTOK then ExitLoop := TRUE; 3469 | end 3470 | until ExitLoop; 3471 | 3472 | EatTok(ENDTOK); 3473 | 3474 | GenerateCaseEpilog(NumCaseStatements); 3475 | end; 3476 | 3477 | WHILETOK: 3478 | begin 3479 | Inc(CodePosStackTop); 3480 | CodePosStack[CodePosStackTop] := CodeSize; // Save return address used by GenerateWhileEpilog 3481 | 3482 | NextTok; 3483 | CompileExpression(ExpressionType); 3484 | GetCompatibleType(ExpressionType, BOOLEANTYPEINDEX); 3485 | EatTok(DOTOK); 3486 | 3487 | GenerateWhileCondition; // Satisfied if expression is not zero 3488 | GenerateIfProlog; 3489 | CompileStatement; 3490 | GenerateWhileEpilog; 3491 | end; 3492 | 3493 | REPEATTOK: 3494 | begin 3495 | GenerateRepeatProlog; 3496 | 3497 | NextTok; 3498 | CompileStatementList; 3499 | 3500 | EatTok(UNTILTOK); 3501 | 3502 | CompileExpression(ExpressionType); 3503 | GetCompatibleType(ExpressionType, BOOLEANTYPEINDEX); 3504 | GenerateRepeatCondition; 3505 | GenerateRepeatEpilog; 3506 | end; 3507 | 3508 | FORTOK: 3509 | begin 3510 | NextTok; 3511 | AssertIdent; 3512 | IdentIndex := GetIdent(Tok.Name); 3513 | 3514 | if (Ident[IdentIndex].Kind <> VARIABLE) or 3515 | ((Ident[IdentIndex].NestingLevel <> 1) and (Ident[IdentIndex].NestingLevel <> BlockStackTop)) or 3516 | (Ident[IdentIndex].PassMethod <> VALPASSING) then 3517 | Error('Simple local variable expected as FOR loop counter'); 3518 | 3519 | if not (Types[Ident[IdentIndex].DataType].TypeKind in OrdinalTypes) then 3520 | Error('Ordinal variable expected as FOR loop counter'); 3521 | 3522 | PushVarPtr(Ident[IdentIndex].Value, Ident[IdentIndex].Scope, 0); 3523 | 3524 | NextTok; 3525 | EatTok(ASSIGNTOK); 3526 | CompileExpression(ExpressionType); 3527 | GetCompatibleType(ExpressionType, Ident[IdentIndex].DataType); 3528 | 3529 | if not (Tok.Kind in [TOTOK, DOWNTOTOK]) then 3530 | Error('TO or DOWNTO expected but ' + GetSpelling(Tok) + ' found'); 3531 | 3532 | Down := Tok.Kind = DOWNTOTOK; 3533 | 3534 | NextTok; 3535 | CompileExpression(ExpressionType); 3536 | GetCompatibleType(ExpressionType, Ident[IdentIndex].DataType); 3537 | 3538 | SaveStackTop; // Save final value 3539 | GenerateAssignment(Ident[IdentIndex].DataType); // Assign initial value to the counter 3540 | RestoreStackTop; // Restore final value 3541 | 3542 | Inc(CodePosStackTop); 3543 | CodePosStack[CodePosStackTop] := CodeSize; // Save return address used by GenerateForEpilog 3544 | 3545 | GenerateForCondition(Ident[IdentIndex].Value, Ident[IdentIndex].Scope, TypeSize(Ident[IdentIndex].DataType), Down); // Satisfied if counter does not reach the second expression value 3546 | 3547 | EatTok(DOTOK); 3548 | 3549 | GenerateIfProlog; 3550 | CompileStatement; 3551 | GenerateForEpilog(Ident[IdentIndex].Value, Ident[IdentIndex].Scope, TypeSize(Ident[IdentIndex].DataType), Down); 3552 | end; 3553 | 3554 | end;// case 3555 | 3556 | end;// CompileStatement 3557 | 3558 | 3559 | 3560 | 3561 | procedure CompileType(var DataType: Byte); 3562 | var 3563 | FieldInListName: array [1..MAXFIELDS] of TName; 3564 | IdentIndex, NumFieldsInList, FieldInListIndex: LongInt; 3565 | NestedDataType, LowBoundType, HighBoundType, ArrType, IndexType, FieldType: Byte; 3566 | ConstVal: TConst; 3567 | TypeNameGiven, ExitLoop: Boolean; 3568 | 3569 | procedure DeclareField(const Name: TName; RecType, FieldType: Byte); 3570 | var 3571 | i: Integer; 3572 | begin 3573 | for i := 1 to Types[RecType].NumFields do 3574 | if Types[RecType].Field[i]^.Name = Name then 3575 | Error('Duplicate field'); 3576 | 3577 | // Add new field 3578 | Inc(Types[RecType].NumFields); 3579 | New(Types[RecType].Field[Types[RecType].NumFields]); 3580 | 3581 | Types[RecType].Field[Types[RecType].NumFields]^.Name := Name; 3582 | Types[RecType].Field[Types[RecType].NumFields]^.DataType := FieldType; 3583 | Types[RecType].Field[Types[RecType].NumFields]^.Offset := TypeSize(RecType) - TypeSize(FieldType); 3584 | end; 3585 | 3586 | 3587 | begin 3588 | if Tok.Kind = DEREFERENCETOK then // Typed pointer 3589 | begin 3590 | // Add new anonymous type 3591 | Inc(NumTypes); 3592 | Types[NumTypes].TypeKind := POINTERTYPE; 3593 | DataType := NumTypes; 3594 | 3595 | // Compile pointer base type 3596 | NextTok; 3597 | AssertIdent; 3598 | IdentIndex := GetIdentUnsafe(Tok.Name); 3599 | 3600 | if IdentIndex = 0 then // Check for a forward-referenced base type 3601 | begin 3602 | // Add new forward-referenced type 3603 | Inc(NumTypes); 3604 | Types[NumTypes].TypeKind := FORWARDTYPE; 3605 | Types[NumTypes].TypeIdentName := Tok.Name; 3606 | Types[NumTypes].Block := BlockStack[BlockStackTop]; 3607 | NestedDataType := NumTypes; 3608 | end 3609 | else 3610 | begin 3611 | if Ident[IdentIndex].Kind <> USERTYPE then 3612 | Error('Type name expected'); 3613 | NestedDataType := Ident[IdentIndex].DataType; // Usual base type 3614 | end; 3615 | 3616 | Types[DataType].BaseType := NestedDataType; 3617 | Types[DataType].Block := BlockStack[BlockStackTop]; 3618 | 3619 | NextTok; 3620 | end// if DEREFERENCETOK 3621 | else if Tok.Kind = ARRAYTOK then // Array 3622 | begin 3623 | NextTok; 3624 | EatTok(OBRACKETTOK); 3625 | 3626 | DataType := NumTypes + 1; 3627 | 3628 | repeat 3629 | // Add new anonymous type 3630 | Inc(NumTypes); 3631 | Types[NumTypes].TypeKind := ARRAYTYPE; 3632 | Types[NumTypes].Block := BlockStack[BlockStackTop]; 3633 | ArrType := NumTypes; 3634 | 3635 | CompileType(IndexType); 3636 | if not (Types[IndexType].TypeKind in OrdinalTypes) then 3637 | Error('Ordinal type expected'); 3638 | Types[ArrType].IndexType := IndexType; 3639 | 3640 | ExitLoop := FALSE; 3641 | if Tok.Kind = COMMATOK then 3642 | begin 3643 | Types[ArrType].BaseType := NumTypes + 1; 3644 | NextTok; 3645 | end 3646 | else 3647 | ExitLoop := TRUE; 3648 | until ExitLoop; 3649 | 3650 | EatTok(CBRACKETTOK); 3651 | EatTok(OFTOK); 3652 | 3653 | CompileType(NestedDataType); 3654 | Types[ArrType].BaseType := NestedDataType; 3655 | end // if ARRAYTOK 3656 | else if Tok.Kind = RECORDTOK then // Record 3657 | begin 3658 | // Add new anonymous type 3659 | Inc(NumTypes); 3660 | Types[NumTypes].TypeKind := RECORDTYPE; 3661 | DataType := NumTypes; 3662 | 3663 | NextTok; 3664 | 3665 | Types[DataType].NumFields := 0; 3666 | repeat 3667 | NumFieldsInList := 0; 3668 | repeat 3669 | AssertIdent; 3670 | 3671 | Inc(NumFieldsInList); 3672 | FieldInListName[NumFieldsInList] := Tok.Name; 3673 | 3674 | NextTok; 3675 | 3676 | ExitLoop := FALSE; 3677 | if Tok.Kind = COMMATOK then 3678 | NextTok 3679 | else 3680 | ExitLoop := TRUE; 3681 | until ExitLoop; 3682 | 3683 | EatTok(COLONTOK); 3684 | 3685 | CompileType(FieldType); 3686 | 3687 | for FieldInListIndex := 1 to NumFieldsInList do 3688 | DeclareField(FieldInListName[FieldInListIndex], DataType, FieldType); 3689 | 3690 | ExitLoop := FALSE; 3691 | if Tok.Kind <> SEMICOLONTOK then 3692 | ExitLoop := TRUE 3693 | else 3694 | begin 3695 | NextTok; 3696 | if Tok.Kind = ENDTOK then ExitLoop := TRUE; 3697 | end 3698 | until ExitLoop; 3699 | 3700 | EatTok(ENDTOK); 3701 | 3702 | Types[DataType].Block := BlockStack[BlockStackTop]; 3703 | end// if RECORDTOK 3704 | else // Subrange or type name 3705 | begin 3706 | TypeNameGiven := FALSE; 3707 | IdentIndex := 0; 3708 | if Tok.Kind = IDENTTOK then 3709 | begin 3710 | IdentIndex := GetIdent(Tok.Name); 3711 | if Ident[IdentIndex].Kind = USERTYPE then TypeNameGiven := TRUE; 3712 | end; 3713 | 3714 | if TypeNameGiven then // Type identifier 3715 | begin 3716 | DataType := Ident[IdentIndex].DataType; 3717 | NextTok; 3718 | end 3719 | else // Subrange 3720 | begin 3721 | // Add new anonymous type 3722 | Inc(NumTypes); 3723 | Types[NumTypes].TypeKind := SUBRANGETYPE; 3724 | DataType := NumTypes; 3725 | 3726 | CompileConstExpression(ConstVal, LowBoundType); // Subrange lower bound 3727 | if not (Types[LowBoundType].TypeKind in (OrdinalTypes - [SUBRANGETYPE])) then 3728 | Error('Ordinal type expected'); 3729 | Types[DataType].Low := ConstVal.Value; 3730 | 3731 | EatTok(RANGETOK); 3732 | 3733 | CompileConstExpression(ConstVal, HighBoundType); // Subrange upper bound 3734 | if not (Types[HighBoundType].TypeKind in (OrdinalTypes - [SUBRANGETYPE])) then 3735 | Error('Ordinal type expected'); 3736 | Types[DataType].High := ConstVal.Value; 3737 | 3738 | GetCompatibleType(LowBoundType, HighBoundType); 3739 | 3740 | if Types[DataType].High < Types[DataType].Low then 3741 | Error('Illegal subrange bounds'); 3742 | 3743 | Types[DataType].HostType := LowBoundType; 3744 | Types[DataType].Block := BlockStack[BlockStackTop]; 3745 | end;// else 3746 | end;// else 3747 | 3748 | end;// CompileType 3749 | 3750 | 3751 | 3752 | 3753 | procedure CompileBlock(BlockIdentIndex: Integer); 3754 | var 3755 | NameTok, ProcFuncTok: TToken; 3756 | IdentInListName: array [1..MAXPARAMS] of TName; 3757 | LocalDataSize, ParamDataSize: Integer; 3758 | NumIdentInList, IdentInListIndex, ForwardIdentIndex, IdentIndex, ParamIndex, FieldIndex, TypeIndex: Integer; 3759 | ConstVal: TConst; 3760 | ExitLoop: Boolean; 3761 | ListPassMethod: Byte; 3762 | VarType, ConstValType: Byte; 3763 | 3764 | 3765 | procedure DeclareId(const Name: TName; Kind: Byte; TotalNumParams: Integer; DataType: Byte; PassMethod: Byte; ConstValue: LongInt; FracConstValue: Single; PredefIndex: Byte); 3766 | var 3767 | i: Integer; 3768 | Scope: Byte; 3769 | begin 3770 | if BlockStack[BlockStackTop] = 1 then Scope := GLOBAL else Scope := LOCAL; 3771 | 3772 | i := GetIdentUnsafe(Name); 3773 | 3774 | if (i > 0) and (Ident[i].Block = BlockStack[BlockStackTop]) then 3775 | Error('Duplicate identifier: ' + Name); 3776 | 3777 | Inc(NumIdent); 3778 | Ident[NumIdent].Name := Name; 3779 | Ident[NumIdent].Kind := Kind; 3780 | Ident[NumIdent].Scope := Scope; 3781 | Ident[NumIdent].DataType := DataType; 3782 | Ident[NumIdent].Block := BlockStack[BlockStackTop]; 3783 | Ident[NumIdent].NestingLevel := BlockStackTop; 3784 | Ident[NumIdent].NumParams := 0; 3785 | Ident[NumIdent].PassMethod := PassMethod; 3786 | Ident[NumIdent].IsUnresolvedForward := FALSE; 3787 | 3788 | case Kind of 3789 | PROC, FUNC: 3790 | if PredefIndex = 0 then 3791 | Ident[NumIdent].Value := CodeSize // Routine entry point address 3792 | else 3793 | Ident[NumIdent].PredefIndex := PredefIndex; // Predefined routine index 3794 | 3795 | VARIABLE: 3796 | if (Pass = CALLDETERMPASS) or BlockIsNotDead[BlockStack[BlockStackTop]] then 3797 | case Scope of 3798 | GLOBAL: 3799 | begin 3800 | Ident[NumIdent].Value := VarDataOrigin + GlobalDataSize; // Variable address 3801 | GlobalDataSize := GlobalDataSize + TypeSize(DataType); 3802 | end;// else 3803 | 3804 | LOCAL: 3805 | if TotalNumParams > 0 then 3806 | begin 3807 | ParamDataSize := ParamDataSize + SizeOf(LongInt); // Parameters always occupy 4 bytes each 3808 | Ident[NumIdent].Value := (3 + TotalNumParams) * SizeOf(LongInt) - ParamDataSize; // Parameter offset from bp (>0); the last (hidden) parameter is the static link 3809 | end 3810 | else 3811 | begin 3812 | Ident[NumIdent].Value := -LocalDataSize - TypeSize(DataType); // Local variable offset from bp (<0) 3813 | LocalDataSize := LocalDataSize + TypeSize(DataType); 3814 | end; 3815 | end// case 3816 | else 3817 | Ident[NumIdent].Value := 0; 3818 | 3819 | CONSTANT: 3820 | if Types[DataType].TypeKind = REALTYPE then 3821 | Ident[NumIdent].FracValue := FracConstValue // Real constant value 3822 | else 3823 | Ident[NumIdent].Value := ConstValue; // Ordinal constant value 3824 | 3825 | end;// case 3826 | 3827 | if VarDataOrigin + GlobalDataSize > SEGMENTSIZE then 3828 | Error('Maximum global data size exceeded'); 3829 | 3830 | if LocalDataSize > SEGMENTSIZE then 3831 | Error('Maximum local data size exceeded'); 3832 | 3833 | if ParamDataSize > SEGMENTSIZE then 3834 | Error('Maximum parameter data size exceeded'); 3835 | 3836 | end;// DeclareId 3837 | 3838 | 3839 | 3840 | procedure DeclarePredefinedIdents; 3841 | begin 3842 | // Constants 3843 | DeclareId('TRUE', CONSTANT, 0, BOOLEANTYPEINDEX, VALPASSING, -1, 0.0, 0); 3844 | DeclareId('FALSE', CONSTANT, 0, BOOLEANTYPEINDEX, VALPASSING, 0, 0.0, 0); 3845 | 3846 | // Types 3847 | DeclareId('INTEGER', USERTYPE, 0, INTEGERTYPEINDEX, VALPASSING, 0, 0.0, 0); 3848 | DeclareId('SMALLINT', USERTYPE, 0, SMALLINTTYPEINDEX, VALPASSING, 0, 0.0, 0); 3849 | DeclareId('SHORTINT', USERTYPE, 0, SHORTINTTYPEINDEX, VALPASSING, 0, 0.0, 0); 3850 | DeclareId('CHAR', USERTYPE, 0, CHARTYPEINDEX, VALPASSING, 0, 0.0, 0); 3851 | DeclareId('BOOLEAN', USERTYPE, 0, BOOLEANTYPEINDEX, VALPASSING, 0, 0.0, 0); 3852 | DeclareId('REAL', USERTYPE, 0, REALTYPEINDEX, VALPASSING, 0, 0.0, 0); 3853 | DeclareId('POINTER', USERTYPE, 0, POINTERTYPEINDEX, VALPASSING, 0, 0.0, 0); 3854 | DeclareId('TEXT', USERTYPE, 0, TEXTTYPEINDEX, VALPASSING, 0, 0.0, 0); 3855 | DeclareId('STRING', USERTYPE, 0, STRINGTYPEINDEX, VALPASSING, 0, 0.0, 0); 3856 | 3857 | // Procedures 3858 | DeclareId('INC', PROC, 0, 0, VALPASSING, 0, 0.0, INCPROC); 3859 | DeclareId('DEC', PROC, 0, 0, VALPASSING, 0, 0.0, DECPROC); 3860 | DeclareId('READ', PROC, 0, 0, VALPASSING, 0, 0.0, READPROC); 3861 | DeclareId('WRITE', PROC, 0, 0, VALPASSING, 0, 0.0, WRITEPROC); 3862 | DeclareId('READLN', PROC, 0, 0, VALPASSING, 0, 0.0, READLNPROC); 3863 | DeclareId('WRITELN', PROC, 0, 0, VALPASSING, 0, 0.0, WRITELNPROC); 3864 | DeclareId('INP', PROC, 0, 0, VALPASSING, 0, 0.0, INPPROC); 3865 | DeclareId('OUTP', PROC, 0, 0, VALPASSING, 0, 0.0, OUTPPROC); 3866 | DeclareId('NEW', PROC, 0, 0, VALPASSING, 0, 0.0, NEWPROC); 3867 | DeclareId('DISPOSE', PROC, 0, 0, VALPASSING, 0, 0.0, DISPOSEPROC); 3868 | DeclareId('HALT', PROC, 0, 0, VALPASSING, 0, 0.0, HALTPROC); 3869 | DeclareId('INTR', PROC, 0, 0, VALPASSING, 0, 0.0, INTRPROC); 3870 | 3871 | // Functions 3872 | DeclareId('SIZEOF', FUNC, 0, 0, VALPASSING, 0, 0.0, SIZEOFFUNC); 3873 | DeclareId('ORD', FUNC, 0, 0, VALPASSING, 0, 0.0, ORDFUNC); 3874 | DeclareId('CHR', FUNC, 0, 0, VALPASSING, 0, 0.0, CHRFUNC); 3875 | DeclareId('PRED', FUNC, 0, 0, VALPASSING, 0, 0.0, PREDFUNC); 3876 | DeclareId('SUCC', FUNC, 0, 0, VALPASSING, 0, 0.0, SUCCFUNC); 3877 | DeclareId('ROUND', FUNC, 0, 0, VALPASSING, 0, 0.0, ROUNDFUNC); 3878 | DeclareId('TRUNC', FUNC, 0, 0, VALPASSING, 0, 0.0, TRUNCFUNC); 3879 | DeclareId('ABS', FUNC, 0, 0, VALPASSING, 0, 0.0, ABSFUNC); 3880 | DeclareId('SQR', FUNC, 0, 0, VALPASSING, 0, 0.0, SQRFUNC); 3881 | DeclareId('SIN', FUNC, 0, 0, VALPASSING, 0, 0.0, SINFUNC); 3882 | DeclareId('COS', FUNC, 0, 0, VALPASSING, 0, 0.0, COSFUNC); 3883 | DeclareId('ARCTAN', FUNC, 0, 0, VALPASSING, 0, 0.0, ARCTANFUNC); 3884 | DeclareId('EXP', FUNC, 0, 0, VALPASSING, 0, 0.0, EXPFUNC); 3885 | DeclareId('LN', FUNC, 0, 0, VALPASSING, 0, 0.0, LNFUNC); 3886 | DeclareId('SQRT', FUNC, 0, 0, VALPASSING, 0, 0.0, SQRTFUNC); 3887 | end;// DeclarePredefinedIdents 3888 | 3889 | 3890 | 3891 | procedure DeclarePredefinedTypes; 3892 | begin 3893 | NumTypes := STRINGTYPEINDEX; 3894 | 3895 | Types[ANYTYPEINDEX].TypeKind := ANYTYPE; 3896 | Types[INTEGERTYPEINDEX].TypeKind := INTEGERTYPE; 3897 | Types[SMALLINTTYPEINDEX].TypeKind := SMALLINTTYPE; 3898 | Types[SHORTINTTYPEINDEX].TypeKind := SHORTINTTYPE; 3899 | Types[CHARTYPEINDEX].TypeKind := CHARTYPE; 3900 | Types[BOOLEANTYPEINDEX].TypeKind := BOOLEANTYPE; 3901 | Types[REALTYPEINDEX].TypeKind := REALTYPE; 3902 | Types[POINTERTYPEINDEX].TypeKind := POINTERTYPE; 3903 | Types[TEXTTYPEINDEX].TypeKind := TEXTTYPE; 3904 | Types[STRINGTYPEINDEX].TypeKind := ARRAYTYPE; 3905 | 3906 | Types[POINTERTYPEINDEX].BaseType := ANYTYPEINDEX; 3907 | 3908 | // Add new anonymous type: 0..MAXSTRLENGTH 3909 | Inc(NumTypes); 3910 | Types[NumTypes].TypeKind := SUBRANGETYPE; 3911 | Types[NumTypes].HostType := INTEGERTYPEINDEX; 3912 | Types[NumTypes].Low := 0; 3913 | Types[NumTypes].High := MAXSTRLENGTH; 3914 | Types[NumTypes].Block := BlockStack[BlockStackTop]; 3915 | 3916 | Types[STRINGTYPEINDEX].BaseType := CHARTYPEINDEX; 3917 | Types[STRINGTYPEINDEX].IndexType := NumTypes; 3918 | end;// DeclarePredefinedTypes 3919 | 3920 | 3921 | 3922 | procedure CheckForwardResolutions; 3923 | var 3924 | TypeIndex: Integer; 3925 | begin 3926 | // Search for unresolved forward references 3927 | for TypeIndex := 1 to NumTypes do 3928 | if (Types[TypeIndex].TypeKind = FORWARDTYPE) and 3929 | (Types[TypeIndex].Block = BlockStack[BlockStackTop]) then 3930 | Error('Unresolved forward reference to type ' + Types[TypeIndex].TypeIdentName); 3931 | end; // CheckForwardResolutions 3932 | 3933 | 3934 | // DeclareId 3935 | begin 3936 | Inc(BlockStackTop); 3937 | 3938 | if BlockIdentIndex = 0 then 3939 | BlockStack[BlockStackTop] := 1 3940 | else 3941 | BlockStack[BlockStackTop] := Ident[BlockIdentIndex].ProcAsBlock; 3942 | 3943 | ParamDataSize := 0; 3944 | LocalDataSize := 0; 3945 | 3946 | if BlockStack[BlockStackTop] = 1 then // Main program 3947 | begin 3948 | DeclarePredefinedTypes; 3949 | DeclarePredefinedIdents; 3950 | GenerateProgramProlog; 3951 | end 3952 | else 3953 | begin 3954 | // DeclareId parameters like local variables 3955 | for ParamIndex := 1 to Ident[BlockIdentIndex].NumParams do 3956 | DeclareId(Ident[BlockIdentIndex].Param[ParamIndex]^.Name, 3957 | VARIABLE, 3958 | Ident[BlockIdentIndex].NumParams, 3959 | Ident[BlockIdentIndex].Param[ParamIndex]^.DataType, 3960 | Ident[BlockIdentIndex].Param[ParamIndex]^.PassMethod, 3961 | 0, 3962 | 0.0, 3963 | 0); 3964 | 3965 | // Allocate Result variable if the current block is a function 3966 | if Ident[BlockIdentIndex].Kind = FUNC then DeclareId('RESULT', VARIABLE, 0, Ident[BlockIdentIndex].DataType, VALPASSING, 0, 0.0, 0); 3967 | end;// else 3968 | 3969 | GenerateDeclarationProlog; 3970 | 3971 | 3972 | while Tok.Kind in [CONSTTOK, TYPETOK, VARTOK, PROCEDURETOK, FUNCTIONTOK] do 3973 | begin 3974 | if Tok.Kind = CONSTTOK then 3975 | begin 3976 | NextTok; 3977 | repeat 3978 | AssertIdent; 3979 | 3980 | NameTok := Tok; 3981 | NextTok; 3982 | EatTok(EQTOK); 3983 | 3984 | CompileConstExpression(ConstVal, ConstValType); 3985 | DeclareId(NameTok.Name, CONSTANT, 0, ConstValType, VALPASSING, ConstVal.Value, ConstVal.FracValue, 0); 3986 | 3987 | EatTok(SEMICOLONTOK); 3988 | until Tok.Kind <> IDENTTOK; 3989 | 3990 | end;// if CONSTTOK 3991 | 3992 | 3993 | if Tok.Kind = TYPETOK then 3994 | begin 3995 | NextTok; 3996 | repeat 3997 | AssertIdent; 3998 | 3999 | NameTok := Tok; 4000 | NextTok; 4001 | EatTok(EQTOK); 4002 | 4003 | CompileType(VarType); 4004 | DeclareId(NameTok.Name, USERTYPE, 0, VarType, VALPASSING, 0, 0.0, 0); 4005 | 4006 | // Check if this type was forward-referenced 4007 | for TypeIndex := 1 to NumTypes do 4008 | if (Types[TypeIndex].TypeKind = FORWARDTYPE) and 4009 | (Types[TypeIndex].TypeIdentName = NameTok.Name) and 4010 | (Types[TypeIndex].Block = BlockStack[BlockStackTop]) then 4011 | begin 4012 | // Forward type reference resolution 4013 | Types[TypeIndex] := Types[VarType]; 4014 | if Types[VarType].TypeKind = RECORDTYPE then 4015 | for FieldIndex := 1 to Types[VarType].NumFields do 4016 | begin 4017 | New(Types[TypeIndex].Field[FieldIndex]); 4018 | Types[TypeIndex].Field[FieldIndex]^ := Types[VarType].Field[FieldIndex]^; 4019 | end; 4020 | end;// if 4021 | 4022 | EatTok(SEMICOLONTOK); 4023 | until Tok.Kind <> IDENTTOK; 4024 | 4025 | CheckForwardResolutions; 4026 | 4027 | end;// if TYPETOK 4028 | 4029 | 4030 | if Tok.Kind = VARTOK then 4031 | begin 4032 | NextTok; 4033 | repeat 4034 | NumIdentInList := 0; 4035 | repeat 4036 | AssertIdent; 4037 | 4038 | Inc(NumIdentInList); 4039 | IdentInListName[NumIdentInList] := Tok.Name; 4040 | 4041 | NextTok; 4042 | 4043 | ExitLoop := FALSE; 4044 | if Tok.Kind = COMMATOK then 4045 | NextTok 4046 | else 4047 | ExitLoop := TRUE; 4048 | until ExitLoop; 4049 | 4050 | EatTok(COLONTOK); 4051 | 4052 | CompileType(VarType); 4053 | 4054 | for IdentInListIndex := 1 to NumIdentInList do 4055 | DeclareId(IdentInListName[IdentInListIndex], VARIABLE, 0, VarType, VALPASSING, 0, 0.0, 0); 4056 | 4057 | EatTok(SEMICOLONTOK); 4058 | until Tok.Kind <> IDENTTOK; 4059 | 4060 | CheckForwardResolutions; 4061 | 4062 | end;// if VARTOK 4063 | 4064 | 4065 | if Tok.Kind in [PROCEDURETOK, FUNCTIONTOK] then 4066 | begin 4067 | ProcFuncTok := Tok; 4068 | NextTok; 4069 | 4070 | AssertIdent; 4071 | 4072 | // Check for forward declaration resolution 4073 | ForwardIdentIndex := GetIdentUnsafe(Tok.Name); 4074 | if ForwardIdentIndex <> 0 then 4075 | if not Ident[ForwardIdentIndex].IsUnresolvedForward or 4076 | (Ident[ForwardIdentIndex].Block <> BlockStack[BlockStackTop]) or 4077 | ((ProcFuncTok.Kind = PROCEDURETOK) and (Ident[ForwardIdentIndex].Kind <> PROC)) or 4078 | ((ProcFuncTok.Kind = FUNCTIONTOK) and (Ident[ForwardIdentIndex].Kind <> FUNC)) then 4079 | ForwardIdentIndex := 0; // Found an identifier of another kind or scope, or it is already resolved 4080 | 4081 | if ForwardIdentIndex = 0 then 4082 | begin 4083 | 4084 | if ProcFuncTok.Kind = PROCEDURETOK then 4085 | DeclareId(Tok.Name, PROC, 0, 0, VALPASSING, 0, 0.0, 0) 4086 | else 4087 | DeclareId(Tok.Name, FUNC, 0, 0, VALPASSING, 0, 0.0, 0); 4088 | 4089 | NextTok; 4090 | 4091 | if Tok.Kind = OPARTOK then // Formal parameter list found 4092 | begin 4093 | NextTok; 4094 | repeat 4095 | NumIdentInList := 0; 4096 | ListPassMethod := VALPASSING; 4097 | 4098 | if Tok.Kind = CONSTTOK then 4099 | begin 4100 | ListPassMethod := CONSTPASSING; 4101 | NextTok; 4102 | end 4103 | else if Tok.Kind = VARTOK then 4104 | begin 4105 | ListPassMethod := VARPASSING; 4106 | NextTok; 4107 | end; 4108 | 4109 | repeat 4110 | AssertIdent; 4111 | 4112 | Inc(NumIdentInList); 4113 | IdentInListName[NumIdentInList] := Tok.Name; 4114 | 4115 | NextTok; 4116 | 4117 | ExitLoop := FALSE; 4118 | if Tok.Kind = COMMATOK then 4119 | NextTok 4120 | else 4121 | ExitLoop := TRUE; 4122 | until ExitLoop; 4123 | 4124 | EatTok(COLONTOK); 4125 | 4126 | // Only type names are allowed for formal parameters 4127 | AssertIdent; 4128 | IdentIndex := GetIdent(Tok.Name); 4129 | if Ident[IdentIndex].Kind = USERTYPE then 4130 | VarType := Ident[IdentIndex].DataType 4131 | else 4132 | Error('Type name expected'); 4133 | NextTok; 4134 | 4135 | 4136 | if (ListPassMethod = VALPASSING) and (Types[VarType].TypeKind in [ARRAYTYPE, RECORDTYPE]) then 4137 | Error('Structured parameters cannot be passed by value'); 4138 | 4139 | for IdentInListIndex := 1 to NumIdentInList do 4140 | begin 4141 | Inc(Ident[NumIdent].NumParams); 4142 | 4143 | if Ident[NumIdent].NumParams > MAXPARAMS then 4144 | Error('Too many formal parameters in ' + Ident[NumIdent].Name); 4145 | 4146 | New(Ident[NumIdent].Param[Ident[NumIdent].NumParams]); 4147 | 4148 | Ident[NumIdent].Param[Ident[NumIdent].NumParams]^.DataType := VarType; 4149 | Ident[NumIdent].Param[Ident[NumIdent].NumParams]^.PassMethod := ListPassMethod; 4150 | Ident[NumIdent].Param[Ident[NumIdent].NumParams]^.Name := IdentInListName[IdentInListIndex]; 4151 | end;// for 4152 | 4153 | ExitLoop := FALSE; 4154 | if Tok.Kind = SEMICOLONTOK then 4155 | NextTok 4156 | else 4157 | ExitLoop := TRUE; 4158 | until ExitLoop; 4159 | 4160 | EatTok(CPARTOK); 4161 | end;// if Tok.Kind = OPARTOR 4162 | 4163 | Ident[NumIdent].DataType := 0; 4164 | 4165 | if ProcFuncTok.Kind = FUNCTIONTOK then 4166 | begin 4167 | EatTok(COLONTOK); 4168 | 4169 | // Only type names are allowed for function results 4170 | AssertIdent; 4171 | IdentIndex := GetIdent(Tok.Name); 4172 | if Ident[IdentIndex].Kind = USERTYPE then 4173 | VarType := Ident[IdentIndex].DataType 4174 | else 4175 | Error('Type name expected'); 4176 | NextTok; 4177 | 4178 | if Types[VarType].TypeKind in [ARRAYTYPE, RECORDTYPE] then 4179 | Error('Structured result is not allowed'); 4180 | 4181 | Ident[NumIdent].DataType := VarType; 4182 | end;// if IsNestedFunction 4183 | 4184 | end// if ForwardIdentIndex = 0 4185 | else 4186 | NextTok; 4187 | 4188 | EatTok(SEMICOLONTOK); 4189 | 4190 | // Check for a FORWARD directive (it is not a reserved word) 4191 | if (ForwardIdentIndex = 0) and (Tok.Kind = IDENTTOK) and (Tok.Name = 'FORWARD') then // Forward declaration 4192 | begin 4193 | Inc(NumBlocks); 4194 | Ident[NumIdent].ProcAsBlock := NumBlocks; 4195 | Ident[NumIdent].IsUnresolvedForward := TRUE; 4196 | GenerateForwardReference; 4197 | NextTok; 4198 | end 4199 | else 4200 | begin 4201 | 4202 | if ForwardIdentIndex = 0 then // New declaration 4203 | begin 4204 | Inc(NumBlocks); 4205 | Ident[NumIdent].ProcAsBlock := NumBlocks; 4206 | CompileBlock(NumIdent); 4207 | end 4208 | else // Forward declaration resolution 4209 | begin 4210 | GenerateForwardResolution(ForwardIdentIndex); 4211 | CompileBlock(ForwardIdentIndex); 4212 | Ident[ForwardIdentIndex].IsUnresolvedForward := FALSE; 4213 | end; 4214 | 4215 | end; 4216 | 4217 | EatTok(SEMICOLONTOK); 4218 | end;// if Tok.Kind in [PROCEDURETOK, FUNCTIONTOK] 4219 | 4220 | end;// while 4221 | 4222 | GenerateDeclarationEpilog; // Make jump to block entry point 4223 | 4224 | if BlockStack[BlockStackTop] <> 1 then 4225 | GenerateStackFrameProlog(LocalDataSize); 4226 | 4227 | CompileCompoundStatement; 4228 | 4229 | // If function, return Result value via the EDX register 4230 | if (BlockStack[BlockStackTop] <> 1) and (Ident[BlockIdentIndex].Kind = FUNC) then 4231 | begin 4232 | PushVarPtr(Ident[GetIdent('RESULT')].Value, LOCAL, 0); 4233 | DerefPtr(Ident[BlockIdentIndex].DataType); 4234 | SaveStackTop; 4235 | end; 4236 | 4237 | if BlockStack[BlockStackTop] = 1 then // Main program 4238 | GenerateProgramEpilog 4239 | else 4240 | begin 4241 | GenerateStackFrameEpilog; 4242 | GenerateReturn(Ident[BlockIdentIndex].NumParams * SizeOf(LongInt)); 4243 | end; 4244 | 4245 | // Delete local identifiers and types from the tables to save space 4246 | while (NumIdent > 0) and (Ident[NumIdent].Block = BlockStack[BlockStackTop]) do 4247 | begin 4248 | // If procedure or function, delete parameters first 4249 | if Ident[NumIdent].Kind in [PROC, FUNC] then 4250 | begin 4251 | if Ident[NumIdent].IsUnresolvedForward then 4252 | Error('Unresolved forward declaration of ' + Ident[NumIdent].Name); 4253 | 4254 | for ParamIndex := 1 to Ident[NumIdent].NumParams do 4255 | Dispose(Ident[NumIdent].Param[ParamIndex]); 4256 | end; 4257 | 4258 | // Delete identifier itself 4259 | Dec(NumIdent); 4260 | end; 4261 | 4262 | while (NumTypes > 0) and (Types[NumTypes].Block = BlockStack[BlockStackTop]) do 4263 | begin 4264 | // If record, delete fields first 4265 | if Types[NumTypes].TypeKind = RECORDTYPE then 4266 | for FieldIndex := 1 to Types[NumTypes].NumFields do 4267 | Dispose(Types[NumTypes].Field[FieldIndex]); 4268 | 4269 | // Delete type itself 4270 | Dec(NumTypes); 4271 | end; 4272 | 4273 | Dec(BlockStackTop); 4274 | end;// CompileBlock 4275 | 4276 | 4277 | 4278 | 4279 | procedure CompileProgram; 4280 | begin 4281 | NextTok; 4282 | EatTok(PROGRAMTOK); 4283 | AssertIdent; 4284 | NextTok; 4285 | CheckTok(SEMICOLONTOK); 4286 | 4287 | EnterIncludedFile('system.pas'); 4288 | NextTok; 4289 | 4290 | Inc(NumBlocks); 4291 | CompileBlock(0); 4292 | 4293 | CheckTok(PERIODTOK); 4294 | end;// CompileProgram 4295 | 4296 | 4297 | 4298 | 4299 | 4300 | 4301 | // ----- OPTIMIZER ----- 4302 | 4303 | 4304 | procedure MarkBlockNotDead(i: Integer); 4305 | var 4306 | j: Integer; 4307 | begin 4308 | BlockIsNotDead[i] := TRUE; 4309 | for j := 1 to NumBlocks do 4310 | if ((CallGraph[i, j div 8] and (1 shl (j mod 8))) <> 0) and not BlockIsNotDead[j] then 4311 | MarkBlockNotDead(j); 4312 | end; 4313 | 4314 | 4315 | 4316 | 4317 | 4318 | 4319 | // ----- MAIN PROGRAM ----- 4320 | 4321 | 4322 | procedure ZeroAll; 4323 | begin 4324 | NumIdent := 0; NumTypes := 0; NumBlocks := 0; BlockStackTop := 0; CodeSize := 0; CodePosStackTop := 0; 4325 | NumStaticStrChars := 0; 4326 | GlobalDataSize := 0; 4327 | end; 4328 | 4329 | 4330 | 4331 | 4332 | 4333 | procedure ChangeExt(const InStr, Ext: TString; var OutStr: TString); 4334 | var 4335 | i, DotPos: Integer; 4336 | begin 4337 | i := Length(InStr); 4338 | DotPos := 0; 4339 | 4340 | while (i > 0) and (DotPos = 0) do 4341 | begin 4342 | if InStr[i] = '.' then DotPos := i; 4343 | Dec(i); 4344 | end; 4345 | 4346 | if DotPos > 0 then 4347 | OutStr := Copy(InStr, 1, DotPos) + Ext 4348 | else 4349 | OutStr := InStr + Ext; 4350 | end; 4351 | 4352 | 4353 | 4354 | 4355 | var 4356 | BlockIndex: Integer; 4357 | OptimizationDisabled: Boolean; 4358 | 4359 | 4360 | 4361 | 4362 | begin 4363 | WriteLn; 4364 | WriteLn('XD Pascal compiler v. ', VERSION, '. Developed by Vasiliy Tereshkov, 2009-2010'); 4365 | WriteLn; 4366 | 4367 | if ParamCount < 1 then 4368 | begin 4369 | WriteLn('Usage: xdp [/n]'); 4370 | WriteLn; 4371 | WriteLn(' /n - disable optimization'); 4372 | WriteLn; 4373 | Halt(1); 4374 | end; 4375 | 4376 | if ParamCount > 1 then 4377 | OptimizationDisabled := (ParamStr(2) = '/n') or (ParamStr(2) = '/N') 4378 | else 4379 | OptimizationDisabled := FALSE; 4380 | 4381 | 4382 | ProgramName := ParamStr(1); 4383 | 4384 | ChangeExt(ProgramName, 'com', ExeName); 4385 | Assign(OutFile, ExeName); 4386 | 4387 | if not OptimizationDisabled then // Default mode 4388 | begin 4389 | for BlockIndex := 1 to MAXBLOCKS do 4390 | BlockIsNotDead[BlockIndex] := FALSE; 4391 | 4392 | // Preliminary pass: compile the program and build the call graph 4393 | VarDataOrigin := 0; 4394 | ZeroAll; 4395 | 4396 | Pass := CALLDETERMPASS; 4397 | 4398 | InitScanner; 4399 | CompileProgram; 4400 | 4401 | // Visit the call graph nodes and mark all procedures that are called as not dead 4402 | MarkBlockNotDead(1); 4403 | 4404 | VarDataOrigin := NumStaticStrChars; 4405 | end 4406 | else 4407 | begin 4408 | for BlockIndex := 1 to MAXBLOCKS do 4409 | BlockIsNotDead[BlockIndex] := TRUE; 4410 | 4411 | VarDataOrigin := MAXSTATICSTRDATASIZE; 4412 | end; 4413 | 4414 | // Final pass: compile the program and generate output (BlockIsNotDead array is preserved) 4415 | 4416 | ZeroAll; 4417 | 4418 | Pass := CODEGENERATIONPASS; 4419 | 4420 | Rewrite(OutFile); 4421 | 4422 | if IOResult <> 0 then 4423 | Error('Unable to open output file ' + ExeName); 4424 | 4425 | InitScanner; 4426 | CompileProgram; 4427 | 4428 | Close(OutFile); 4429 | 4430 | WriteLn('Compilation complete. Code size: ', CodeSize, ' bytes. Data size: ', VarDataOrigin + GlobalDataSize, ' bytes.'); 4431 | WriteLn; 4432 | end. 4433 | 4434 | --------------------------------------------------------------------------------