Apple-2gs-SW
/
ORCA-C
mirror of https://github.com/byteworksinc/ORCA-C.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

Compare commits

base: Apple-2gs-SW:orcac-220
Branches Tags
Apple-2gs-SW:master
Apple-2gs-SW:orcac-220
Apple-2gs-SW:orcac-220b7
Apple-2gs-SW:orcac-220b6
Apple-2gs-SW:orcac-220b5
Apple-2gs-SW:orcac-220b4
Apple-2gs-SW:orcac-220b3
Apple-2gs-SW:orcac-220b2
Apple-2gs-SW:orcac-220b1
...
compare: Apple-2gs-SW:master
Branches Tags
Apple-2gs-SW:master
Apple-2gs-SW:orcac-220
Apple-2gs-SW:orcac-220b7
Apple-2gs-SW:orcac-220b6
Apple-2gs-SW:orcac-220b5
Apple-2gs-SW:orcac-220b4
Apple-2gs-SW:orcac-220b3
Apple-2gs-SW:orcac-220b2
Apple-2gs-SW:orcac-220b1

31 Commits
orcac-220 ... master

Author SHA1 Message Date
Stephen Heumann 69320cd4d8 Detect some erroneous numeric constants that were being allowed. 
These include tokens like 0x, 0b, and 1.2LL.
 2024-04-23 22:07:19 -05:00
Stephen Heumann 8278f7865a Support unconvertible preprocessing numbers. 
These are tokens that follow the syntax for a preprocessing number, but not for an integer or floating constant after preprocessing. They are now allowed within the preprocessing phases of the compiler. They are not legal after preprocessing, but they may be used as operands of the # and ## preprocessor operators to produce legal tokens.
 2024-04-23 21:39:14 -05:00
Stephen Heumann 6b7414384f Fix code generation bug for indirect load/store of 64-bit values. 
The issue was that if a 64-bit value was being loaded via one pointer and stored via another, the load and store parts could both be using y for their indexing, but they would clash with each other, potentially leading to loads coming from the wrong place.

Here are some examples that illustrate the problem:

/* example 1 */
int main(void) {
        struct {
                char c[16];
                long long x;
        } s = {.x = 0x1234567890abcdef}, *sp = &s;
        long long ll, *llp = ≪
        *llp = sp->x;
        return ll != s.x; // should return 0
}

/* example 2 */
int main(void) {
        struct {
                char c[16];
                long long x;
        } s = {.x = 0x1234567890abcdef}, *sp = &s;
        long long ll, *llp = ≪
        unsigned i = 0;
        *llp = sp[i].x;
        return ll != s.x; // should return 0
}

/* example 3 */
int main(void) {
        long long x[2] = {0, 0x1234567890abcdef}, *xp = x;
        long long ll, *llp = ≪
        unsigned i = 1;
        *llp = xp[i];
        return ll != x[1]; // should return 0
}
 2024-04-10 20:49:17 -05:00
Stephen Heumann 77e0b8fc59 Fix codegen error for some indirect accesses to 64-bit values. 
The code was not properly adding in the offset of the 64-bit value from the pointed-to location, so the wrong memory location would be accessed. This affected indirect accesses to non-initial structure members, when used as operands to certain operations.

Here is an example showing the problem:

#include <stdio.h>

long long x = 123456;

struct S {
        long long a;
        long long b;
} s = {0, 123456};

int main(void) {
        struct S *sp = &s;

        if (sp->b != x) {
                puts("error");
        }
}
 2024-04-03 21:04:47 -05:00
Stephen Heumann 50636bd28b Fix code generation for qualified struct or union function parameters. 
They were not being properly recognized as structs/unions, so they were being passed by address rather than by value as they should be.

Here is an example affected by this:

struct S {int a,b,c,d;};

int f(struct S s) {
    return s.a + s.b + s.c + s.d;
}

int main(void) {
    const struct S s = {1,2,3,4};
    return f(s);
}
 2024-04-01 20:37:51 -05:00
Stephen Heumann 83537fd3c7 Disable a peephole optimization that can produce bad code. 
The optimization applies to code sequences like:
	dec abs
	lda abs
	beq ...
where the dec and lda were supposed to refer to the same location.

There were two problems with this optimization as written:
-It considered the dec and lda to refer to the same location even if they were actually references to different elements of the same array.
-It did not work in the case where the A register value was needed in subsequent code.

The first of these was already an issue in previous ORCA/C releases, as in the following example:

#pragma optimize -1
int x[2] = {0,0};
int main(void) {
        --x[0];
        if (x[1] != 0)
                return 123;
        return 0; /* should return 0 */
}

I do not believe the second problem was triggered by any code sequences generated in previous releases of ORCA/C, but it can be triggered after commit 4c402fc88, e.g. by the following example:

#pragma optimize -1
int x = 1;
int main(void) {
        int y = 123;
        --x;
        return x == 0; /* should return 1 */
}

Since the circumstances where this peephole optimization was triggered validly are pretty obscure, just disabling it should have a minimal impact on the generated code.
 2024-03-17 21:31:18 -05:00
Stephen Heumann 81934109fc Fix issues with type names in the third expression of a for loop. 
There were a couple issues here:
*If the type name contained a semicolon (for struct/union member declarations), a spurious error would be reported.
*Tags or enumeration constants declared in the type name should be in scope within the loop, but were not.

These both stemmed from the way the parser handled the third expression, which was to save the tokens from it and re-inject them at the end of the loop. To get the scope issues right, the expression really needs to be evaluated at the point where it occurs, so we now do that. To enable that while still placing the code at the end of the loop, a mechanism to remove and re-insert sections of generated code is introduced.

Here is an example illustrating the issues:

int main(void) {
        int i, j, x;
        for (i = 0; i < 123; i += sizeof(struct {int a;}))
                for (j = 0; j < 123; j += sizeof(enum E {A,B,C}))
                        x = i + j + A;
}
 2024-03-13 22:09:25 -05:00
Stephen Heumann 72234a4f2b Generate better code for most unsigned 32-bit comparisons. 2024-03-10 21:24:33 -05:00
Stephen Heumann 36f766a662 Generate better code for comparisons against constant 1 or 2. 2024-03-06 21:57:27 -06:00
Stephen Heumann 4c402fc883 Generate better code for certain equality/inequality comparisons. 2024-03-06 21:18:50 -06:00
Stephen Heumann ca0147507b Generate slightly better code for logical negation. 2024-03-06 17:04:51 -06:00
Stephen Heumann 24c6e72a83 Simplify some conditional branches. 
This affects certain places where code like the following could be generated:

	bCC lab2
lab1	brl ...
lab2 ...

If lab1 is no longer referenced due to previous optimizations, it can be removed. This then allows the bCC+brl combination to be shortened to a single conditional branch, if the target is close enough.

This introduces a flag for tracking and potentially removing labels that are only used as the target of one branch. This could be used more widely, but currently it is only used for the specific code sequences shown above. Using it in other places could potentially open up possibilities for invalid native-code optimizations that were previously blocked due to the presence of the label.
 2024-03-05 22:20:34 -06:00
Stephen Heumann 0f18fa63b5 Optimize some additional cases of a branch to a branch. 
This covers patterns like

	bCC lab
	???
	???
lab:	bra/brl ...

These can come up in the new code for 32-bit ||, but also in cases like "if (i > 0) ...".
 2024-03-05 17:16:17 -06:00
Stephen Heumann 8f07ca5d6c Generate better code for && and || with 32-bit operands. 2024-03-05 17:09:21 -06:00
Stephen Heumann 60b472a99e Optimize generated code for some indexing ops in large memory model. 
This generates slightly better code for indexing a global/static char array with a signed 16-bit index and a positive offset, e.g. a[i+1].

Here is an example that is affected:

#pragma memorymodel 1
#pragma optimize -1
char a[] = {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15};
int main(int argc, char *argv[]) {
        return a[argc+2];
}
 2024-03-04 19:38:39 -06:00
Stephen Heumann 995885540b Correct a comment. 2024-03-04 19:03:13 -06:00
Stephen Heumann 34c5be5cab Update readme files for version 2.2.1. 2024-02-28 20:11:13 -06:00
Stephen Heumann 75a928e273 Change division-by-zero tests to cases requiring a constant expression. 2024-02-27 13:06:45 -06:00
Stephen Heumann a545685ab4 Use more correct logic for expanding macros in macro parameters. 
Specifically, this affects the case where a macro argument ends with the name of a function-like macro that takes 0 parameters. When that argument is initially expanded, the macro should not be expanded, even if there are parentheses within the macro that it is being passed to or the subsequent program code. This is the case because the C standards specify that "The argument’s preprocessing tokens are completely macro replaced before being substituted as if they formed the rest of the preprocessing file with no other preprocessing tokens being available." (The macro may still be expanded at a later stage, but that depends on other rules that determine whether the expansion is suppressed.) The logic for this was already present for the case of macros taking one or more argument; this extends it to apply to function-like macros taking zero arguments as well.

I'm not sure that this makes any practical difference while cycles of mutually-referential macros still aren't handled correctly (issue #48), but if that were fixed then there would be some cases that depend on this behavior.
 2024-02-26 22:31:46 -06:00
Stephen Heumann ce94f4e2b6 Do not pass negative sizes to strncat or strncmp in tests. 
These parameters are of type size_t, which is unsigned.
 2024-02-24 18:57:50 -06:00
Stephen Heumann 84fdb5c975 Fix handling of empty macro arguments as ## operands. 
Previously, there were a couple problems:

*If the parameter that was passed an empty argument appeared directly after the ##, the ## would permanently be removed from the macro record, affecting subsequent uses of the macro even if the argument was not empty.
*If the parameter that was passed an empty argument appeared between two ## operators, both would effectively be skipped, so the tokens to the left of the first ## and to the right of the second would not be combined.

This example illustrates both issues (not expected to compile; just check preprocessor output):

#pragma expand 1
#define x(a,b,c) a##b##c
x(1, ,3)
x(a,b,c)
 2024-02-22 21:55:46 -06:00
Stephen Heumann d1847d40be Set numString properly for numeric tokens generated by ##. 
Previously, it was not necessarily set correctly for the newly-generated token. This would result in incorrect behavior if that token was an operand to another ## operator, as in the following example:

#define x(a,b,c) a##b##c
x(1,2,3)
 2024-02-22 21:42:05 -06:00
Stephen Heumann c671bb71a5 Document recent library bug fixes. 2024-02-22 21:20:33 -06:00
Stephen Heumann a646a03b5e Avoid possible errors when using postfix ++/-- on pointer expressions. 
There was code that would attempt to use the cType field of the type record, but this is only valid for scalar types, not pointer types. In the case of a pointer type, the upper two bytes of the pointer would be interpreted as a cType value, and if they happened to have one of the values being tested for, incorrect intermediate code would be generated. The lower two bytes of the pointer would be used as a baseType value; this would most likely result in "compiler error" messages from the code generator, but might cause incorrect code generation with no errors if that value happened to correspond to a real baseType.

Code like the following might cause this error, although it only occurs if pointers have certain values and therefore depends on the memory layout at compile time:

void f(const int **p) {
    (*p)++;
}

This bug was introduced in commit f2a66a524a.
 2024-02-09 20:45:14 -06:00
Stephen Heumann 7ca30d7784 Do not give a compile error for division of any integer constant by 0. 
Division by zero produces undefined behavior if it is evaluated, but in general we cannot tell whether a given expression will actually be evaluated at run time, so we should not report this as a compile-time error.

We still report an error for division by zero in constant expressions that need to be evaluated at compile time. We also still produce a lint message about division by zero if the appropriate flag is enabled.
 2024-02-02 20:03:34 -06:00
Stephen Heumann c9dc566c10 Update release notes. 2024-02-02 18:31:48 -06:00
Stephen Heumann 2ca4aba5c4 Correct a misspelled error code in <gsos.h>. 2024-01-18 17:55:41 -06:00
ksherlock d7cc9b5909
update gsbug.h prototypes and errors based on gsbug and niftylist (#86) 
* update gsbug.h prototypes and errors based on gsbug and niftylist

* updates

* remove gsbug 1.7 development error codes
 2024-01-18 17:51:22 -06:00
Kelvin Sherlock 586229e6eb #define should always use the global pool.... 
if a #define is within a function, it could use the local memory pool for string allocation (via Malloc in NextToken, line 5785) which can lead to a dangling memory reference when the macro is expanded.

void function(void) {

#define TEXT "abc"

static struct {
	char text[sizeof(TEXT)];
} template = { TEXT };

}
 2024-01-15 22:05:32 -06:00
Stephen Heumann 0aee669746 Update version number for ORCA/C 2.2.1 development. 2024-01-15 21:47:00 -06:00
Stephen Heumann 25085f5b81 Update script for setting filetypes. 
It now covers all the files in the repository.
 2023-08-06 17:50:26 -05:00
24 changed files with 833 additions and 406 deletions
Show Stats Expand all files Collapse all files

14
C.Read.Me
View File

@ -1,18 +1,20 @@
Welcome to ORCA/C 2.2.0! This is a release containing updates from
Welcome to ORCA/C 2.2.1! This is a release containing updates from
community members (Stephen Heumann and Kelvin Sherlock).
ORCA/C 2.2.0 adds support for almost all of the new language and library
ORCA/C 2.2 adds support for almost all of the new language and library
features required by the C17 standard. It also has several other new
features, such as additional lint checks to help identify bugs and
portability problems. In addition to these new features, ORCA/C 2.2.0
portability problems. In addition to these new features, ORCA/C 2.2
includes hundreds of bug fixes in the compiler and libraries.
The ORCA/C manual has been fully updated to cover ORCA/C 2.2.0, so new
ORCA/C 2.2.1 includes additional bug fixes to ORCA/C 2.2.0.
The ORCA/C manual has been fully updated to cover ORCA/C 2.2, so new
users should simply refer to that. Users familiar with older versions
of ORCA/C can refer to the cc.notes file in the Release.Notes directory
for a description of the changes between ORCA/C 2.0 and ORCA/C 2.2.0.
for a description of the changes between ORCA/C 2.0 and ORCA/C 2.2.1.
ORCA/C 2.2.0 requires a real or emulated Apple IIGS with at least the
ORCA/C 2.2.1 requires a real or emulated Apple IIGS with at least the
following specifications:
* 2 MB of RAM (3 MB or more recommended)

22
C.Update.ReadMe
View File

@ -1,25 +1,25 @@
This is an update package that can be used to update ORCA/C 2.1.0 to
ORCA/C 2.2.0. You must have an existing copy of ORCA/C 2.1.0 in order
to use this update. If you do not already have a copy, you can get it
as part of Opus ][: The Software, a collection of Byte Works software
which is sold by Juiced.GS:
This is an update package that can be used to update ORCA/C 2.1.0 or
2.2.0 to ORCA/C 2.2.1. You must have an existing copy of ORCA/C 2.1.0
or 2.2.0 in order to use this update. If you do not already have a
copy, you can get it as part of Opus ][: The Software, a collection of
Byte Works software which is sold by Juiced.GS:
https://juiced.gs/store/opus-ii-software/
This update must be applied to an existing ORCA installation containing
ORCA/C 2.1.0 or an ORCA/C 2.2.0 beta (including the one provided on
Opus ][: The Software). To apply the update, you just need to copy
the files from this distribution into the corresponding locations in
your ORCA installation, replacing any older versions.
ORCA/C 2.1.0 or ORCA/C 2.2.0 (including the one provided on Opus ][:
The Software). To apply the update, you just need to copy the files
from this distribution into the corresponding locations in your ORCA
installation, replacing any older versions.
If you received this update as a SHK file, you can simply extract the
the files from it directly on top of your ORCA installation.
files from it directly on top of your ORCA installation.
If you received this update as a disk image, you can apply the update
by copying the files into place using the Finder, or by running the
following command within the root directory of your ORCA installation
using the text-based ORCA shell:
COPY -C :ORCAC.220:=
COPY -C :ORCAC.221:=
In addition to the ORCA shell environment, this update can also be
used under other environments that are compatible with ORCA/C, such as

8
CC.rez
View File

@ -4,12 +4,12 @@ resource rVersion(1) {
{
2, /* Major revision */
2, /* Minor revision */
0, /* Bug version */
release, /* Release stage */
0, /* Non-final release # */
1, /* Bug version */
development, /* Release stage */
1, /* Non-final release # */
},
verUS, /* Region code */
"ORCA/C", /* Short version number */
"Copyright 1997, Byte Works, Inc.\n" /* Long version number */
"Updated 2023"
"Updated 2024"
};

6
CCommon.pas
View File

@ -112,7 +112,7 @@ const
flag_t = $00001000; {treat all errors as terminal?}
flag_w = $00000200; {wait when an error is found?}
versionStr = '2.2.0'; {compiler version}
versionStr = '2.2.1 dev'; {compiler version}
type
{Misc.}
@ -202,6 +202,7 @@ type
barbarop,pluseqop,minuseqop,asteriskeqop,slasheqop,
percenteqop,ltlteqop,gtgteqop,andeqop,caroteqop,
bareqop,poundpoundop,dotdotdotsy,
ppnumber, {preprocessing number (pp-token)}
otherch, {other non-whitespace char (pp-token)}
eolsy,eofsy, {control characters}
typedef, {user types}
@ -225,7 +226,7 @@ type
tokenSet = set of tokenEnum;
tokenClass = (reservedWord,reservedSymbol,identifier,intConstant,longConstant,
longlongConstant,realConstant,stringConstant,otherCharacter,
macroParameter);
preprocessingNumber,macroParameter);
identPtr = ^identRecord; {^ to a symbol table entry}
tokenType = record {a token}
kind: tokenEnum; {kind of token}
@ -243,6 +244,7 @@ type
ispstring: boolean;
prefix: charStrPrefixEnum);
otherCharacter: (ch: char); {used for preprocessing tokens only}
preprocessingNumber: (errCode: integer); {used for pp tokens only}
macroParameter: (pnum: integer);
end;

2
CGI.Debug
View File

@ -139,7 +139,7 @@ opt[pc_ckn] := 'ckn';
end; {InitWriteCode}
procedure PrintDAG (tag: stringPtr; code: icptr);
procedure PrintDAG {tag: stringPtr; code: icptr};
{ print a DAG }
{ }

108
CGI.pas
View File

@ -48,6 +48,7 @@ const
forFlags = 256; {instruction used for effect on flags only}
subtract1 = 512; {subtract 1 from address operand}
shiftLeft8 = 1024; {shift operand left 8 bits}
labelUsedOnce = 2048; {only one branch targets this label}
m_adc_abs = $6D; {op code #s for 65816 instructions}
m_adc_dir = $65;
@ -292,6 +293,8 @@ type
ccPointer : (pval: longint; pstr: longStringPtr);
end;
codeRef = icptr; {reference to a code location}
{basic blocks}
{------------}
iclist = ^iclistRecord; {used to form lists of records}
@ -657,6 +660,21 @@ procedure GenTool (fop: pcodes; fp1, fp2: integer; dispatcher: longint);
{ dispatcher - tool entry point }
function GetCodeLocation: codeRef;
{ Get a reference to the current location in the generated }
{ code, suitable to be passed to RemoveCode. }
procedure InsertCode (theCode: codeRef);
{ Insert a section of already-generated code that was }
{ previously removed with RemoveCode. }
{ }
{ parameters: }
{ theCode - code removed (returned from RemoveCode) }
{procedure PrintBlocks (tag: stringPtr; bp: blockPtr); {debug}
{ print a series of basic blocks }
@ -666,6 +684,28 @@ procedure GenTool (fop: pcodes; fp1, fp2: integer; dispatcher: longint);
{ bp - first block to print }
{procedure PrintDAG (tag: stringPtr; code: icptr); {debug}
{ print a DAG }
{ }
{ parameters: }
{ tag - label for lines }
{ code - first node in DAG }
function RemoveCode (start: codeRef): codeRef;
{ Remove a section of already-generated code, from immediately }
{ after start up to the latest code generated. Returns the }
{ code removed, so it may be re-inserted later. }
{ }
{ parameters: }
{ start - location to start removing from }
{ }
{ Note: start must be a top-level pcode (not a subexpression). }
{ Note: The region removed must not include a dc_enp. }
function TypeSize (tp: baseTypeEnum): integer;
{ Find the size, in bytes, of a variable }
@ -1430,6 +1470,74 @@ if codeGeneration then begin
end; {GenLdcReal}
function GetCodeLocation{: codeRef};
{ Get a reference to the current location in the generated }
{ code, suitable to be passed to RemoveCode. }
begin {GetCodeLocation}
GetCodeLocation := DAGhead;
end {GetCodeLocation};
procedure InsertCode {theCode: codeRef};
{ Insert a section of already-generated code that was }
{ previously removed with RemoveCode. }
{ }
{ parameters: }
{ theCode - code removed (returned from RemoveCode) }
var
lcode: icptr;
begin {InsertCode}
if theCode <> nil then
if codeGeneration then begin
lcode := theCode;
{ PrintDAG(@'Inserting: ', lcode); {debug}
while lcode^.next <> nil do
lcode := lcode^.next;
lcode^.next := DAGhead;
DAGhead := theCode;
end; {if}
end; {InsertCode}
function RemoveCode {start: codeRef): codeRef};
{ Remove a section of already-generated code, from immediately }
{ after start up to the latest code generated. Returns the }
{ code removed, so it may be re-inserted later. }
{ }
{ parameters: }
{ start - location to start removing from }
{ }
{ Note: start must be a top-level pcode (not a subexpression). }
{ Note: The region removed must not include a dc_enp. }
var
lcode: icptr;
begin {RemoveCode}
if start = DAGhead then
RemoveCode := nil
else begin
RemoveCode := DAGhead;
if codeGeneration then begin
lcode := DAGhead;
while (lcode^.next <> start) and (lcode^.next <> nil) do
lcode := lcode^.next;
if lcode^.next = nil then
Error(cge1);
lcode^.next := nil;
{ PrintDAG(@'Removing: ', DAGhead); {debug}
DAGhead := start;
end; {if}
end; {else}
end; {RemoveCode}
function TypeSize {tp: baseTypeEnum): integer};
{ Find the size, in bytes, of a variable }

52
Expression.pas
View File

@ -1414,7 +1414,11 @@ var
op1 := op1 * op2;
slashch : begin {/}
if op2 = 0 then begin
Error(109);
if not (kind in [normalExpression,
autoInitializerExpression]) then
Error(109)
else if ((lint & lintOverflow) <> 0) then
Error(129);
op2 := 1;
end; {if}
if unsigned then
@ -1424,7 +1428,11 @@ var
end;
percentch : begin {%}
if op2 = 0 then begin
Error(109);
if not (kind in [normalExpression,
autoInitializerExpression]) then
Error(109)
else if ((lint & lintOverflow) <> 0) then
Error(129);
op2 := 1;
end; {if}
if unsigned then
@ -1570,7 +1578,11 @@ var
asteriskch : umul64(llop1, llop2); {*}
slashch : begin {/}
if (llop2.lo = 0) and (llop2.hi = 0) then begin
Error(109);
if not (kind in [normalExpression,
autoInitializerExpression]) then
Error(109)
else if ((lint & lintOverflow) <> 0) then
Error(129);
llop2 := longlong1;
end; {if}
if unsigned then
@ -1580,7 +1592,11 @@ var
end;
percentch : begin {%}
if (llop2.lo = 0) and (llop2.hi = 0) then begin
Error(109);
if not (kind in [normalExpression,
autoInitializerExpression]) then
Error(109)
else if ((lint & lintOverflow) <> 0) then
Error(129);
llop2 := longlong1;
end; {if}
if unsigned then
@ -3298,8 +3314,10 @@ var
else
Gen2t(pc_ind, ord(tqVolatile in expressionType^.qualifiers), 0, tp);
if pc_l in [pc_lli,pc_lld] then
if expressionType^.cType in [ctBool,ctFloat,ctDouble,ctLongDouble,
ctComp] then begin
if (expressionType^.kind = scalarType) and
(expressionType^.cType in
[ctBool,ctFloat,ctDouble,ctLongDouble,ctComp])
then begin
t1 := GetTemp(ord(expressionType^.size));
Gen2t(pc_cop, t1, 0, expressionType^.baseType);
end; {if}
@ -3310,8 +3328,10 @@ var
Gen0t(pc_cpi, tp);
Gen0t(pc_bno, tp);
if pc_l in [pc_lli,pc_lld] then {correct the value for postfix ops}
if expressionType^.cType in [ctBool,ctFloat,ctDouble,ctLongDouble,
ctComp] then begin
if (expressionType^.kind = scalarType) and
(expressionType^.cType in
[ctBool,ctFloat,ctDouble,ctLongDouble,ctComp])
then begin
Gen0t(pc_pop, expressionType^.baseType);
Gen2t(pc_lod, t1, 0, expressionType^.baseType);
Gen0t(pc_bno, expressionType^.baseType);
@ -3433,11 +3453,17 @@ var
while tp <> nil do begin
if tp^.middle <> nil then begin
GenerateCode(tp^.middle);
if expressionType^.kind in [structType,unionType] then begin
if expressionType^.size & $FFFF8000 <> 0 then
Error(61);
Gen1t(pc_ldc, long(expressionType^.size).lsw, cgWord);
Gen0(pc_psh);
if expressionType^.kind in [structType,unionType,definedType]
then begin
tType := expressionType;
while tType^.kind = definedType do
tType := tType^.dType;
if tType^.kind in [structType,unionType] then begin
if tType^.size & $FFFF8000 <> 0 then
Error(61);
Gen1t(pc_ldc, long(tType^.size).lsw, cgWord);
Gen0(pc_psh);
end; {if}
end; {if}
if fmt <> fmt_none then begin
new(tfp);

525
Gen.pas
View File

@ -321,6 +321,7 @@ case op^.opcode of
loc := LabelToDisp(op^.left^.r) + op^.left^.q;
if (op^.left^.opcode <> pc_lod) or (loc > 255) then
Error(cge1);
offset := offset + op^.q;
if offset = 0 then
GenNative(mop, direct, loc, nil, 0)
else begin
@ -618,7 +619,7 @@ function NeedsCondition (opcode: pcodes): boolean;
begin {NeedsCondition}
NeedsCondition := opcode in
[pc_and,pc_ior,pc_cui,pc_cup,pc_lor,pc_lnd,pc_ldl,pc_lil,pc_lld,
[pc_and,pc_ior,pc_cui,pc_cup,pc_ldl,pc_lil,pc_lld,
pc_lli,pc_gil,pc_gli,pc_gdl,pc_gld,pc_iil,pc_ili,pc_idl,pc_ild,
pc_cop,pc_cpo,pc_cpi,pc_dvi,pc_mpi,pc_adi,pc_sbi,pc_mod,pc_bno,
pc_udi,pc_uim,pc_umi,pc_cnv,pc_rbo,pc_shl,pc_shr,pc_usr,pc_lbf,
@ -1068,8 +1069,22 @@ var
end; {ReverseConditional}
function SimpleLongOp(op: icptr): boolean;
{ Is op an operation on cg(U)Long that can be done using the }
{ addressing modes of CPX? }
begin {SimpleLongOp}
SimpleLongOp :=
(op^.opcode = pc_ldc)
or (op^.opcode = pc_lao)
or ((op^.opcode = pc_lod) and (LabelToDisp(op^.r) + op^.q <= 253))
or ((op^.opcode = pc_ldo) and smallMemoryModel);
end; {SimpleLongOp}
begin {GenCmp}
{To reduct the number of possibilities that must be handled, pc_les }
{To reduce the number of possibilities that must be handled, pc_les }
{and pc_leq compares are reduced to their equivalent pc_grt and }
{pc_geq instructions. }
if op^.opcode = pc_les then begin
@ -1113,15 +1128,16 @@ if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
if NeedsCondition(op^.left^.opcode) then
GenImpliedForFlags(m_tax);
if (num >= 0) and (num < 3) then begin
if num <> 0 then begin
if num = 0 then
GenNative(m_bpl, relative, lab1, nil, 0)
else begin
lab2 := GenLabel;
GenNative(m_bmi, relative, lab2, nil, 0);
for i := 1 to num do
GenImplied(m_dea);
end; {if}
GenNative(m_bpl, relative, lab1, nil, 0);
if num <> 0 then
GenLab(lab2);
if num = 2 then
GenImplied(m_lsr_a);
GenNative(m_bne, relative, lab1, nil, 0);
GenLabUsedOnce(lab2);
end; {else}
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if (num >= 0) and (num < 3)}
@ -1134,7 +1150,7 @@ if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_bcs, relative, lab2, nil, 0);
if num > 0 then begin
GenLab(lab1);
GenLabUsedOnce(lab1);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
end {if}
@ -1147,8 +1163,17 @@ if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
end {if}
else {if optype in [cgUByte,cgUWord] then} begin
if num <> 0 then begin
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
if num in [1,2] then begin
if num = 1 then
GenImpliedForFlags(m_tax)
else
GenImplied(m_lsr_a);
GenNative(m_bne, relative, lab1, nil, 0);
end {if}
else begin
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_bcs, relative, lab1, nil, 0);
end; {else}
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end; {if}
@ -1163,9 +1188,9 @@ if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
if (num >= 0) and (num < 3) then begin
GenNative(m_bmi, relative, lab1, nil, 0);
if num > 0 then begin
for i := 1 to num do
GenImplied(m_dea);
GenNative(m_bmi, relative, lab1, nil, 0);
if num = 2 then
GenImplied(m_lsr_a);
GenNative(m_beq, relative, lab1, nil, 0);
end; {if}
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
@ -1184,7 +1209,7 @@ if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
GenLab(lab1);
end {if}
else begin
GenLab(lab1);
GenLabUsedOnce(lab1);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
end; {else}
@ -1192,8 +1217,17 @@ if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
end {if}
else {if optype in [cgUByte,cgUWord] then} begin
if num <> 0 then begin
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
if num in [1,2] then begin
if num = 1 then
GenImpliedForFlags(m_tax)
else
GenImplied(m_lsr_a);
GenNative(m_beq, relative, lab1, nil, 0);
end {if}
else begin
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(m_bcc, relative, lab1, nil, 0);
end; {else}
end; {if}
GenNative(m_brl, longrelative, lb, nil, 0);
if num <> 0 then
@ -1282,7 +1316,7 @@ else
else
GenNative(m_bcs, relative, lab2, nil, 0);
if op^.opcode = pc_grt then
GenLab(lab3);
GenLabUsedOnce(lab3);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
end {if}
@ -1330,50 +1364,134 @@ else
end; {case optype of cgByte,cgUByte,cgWord,cgUWord}
cgULong: begin
gLong.preference := onStack;
GenTree(op^.right);
gLong.preference := A_X;
GenTree(op^.left);
if gLong.where = onStack then begin
GenImplied(m_ply);
GenImplied(m_pla);
lab1 := GenLabel;
lab2 := GenLabel;
simple := false;
if SimpleLongOp(op^.right) then
simple := true
else if rOpcode in [pc_fjp,pc_tjp] then
if SimpleLongOp(op^.left) then begin
ReverseConditional;
simple := true;
end; {if}
if simple then begin
if op^.opcode = pc_grt then begin
if SimpleLongOp(op^.left) then
ReverseConditional;
if op^.opcode = pc_grt then
if op^.right^.opcode = pc_ldc then
if op^.right^.lval <> $ffffffff then begin
op^.right^.lval := op^.right^.lval + 1;
op^.opcode := pc_geq;
end; {if}
end; {if}
gLong.preference := A_X;
GenTree(op^.left);
if gLong.where = onStack then begin
GenImplied(m_pla);
GenImplied(m_plx);
end; {if}
if op^.opcode = pc_grt then
if not (rOpcode in [pc_fjp,pc_tjp]) then
GenNative(m_ldy_imm, immediate, 0, nil, 0);
with op^.right^ do
case opcode of
pc_ldc:
GenNative(m_cpx_imm, immediate, long(lval).msw, nil, 0);
pc_lao:
GenNative(m_cpx_imm, immediate, q, lab, shift16);
pc_lod:
GenNative(m_cpx_dir, direct, LabelToDisp(r)+q+2, nil, 0);
pc_ldo:
GenNative(m_cpx_abs, absolute, q+2, lab, 0);
end; {case}
GenNative(m_bne, relative, lab1, nil, 0);
with op^.right^ do
case opcode of
pc_ldc:
GenNative(m_cmp_imm, immediate, long(lval).lsw, nil, 0);
pc_lao:
GenNative(m_cmp_imm, immediate, q, lab, 0);
pc_lod:
GenNative(m_cmp_dir, direct, LabelToDisp(r)+q, nil, 0);
pc_ldo:
GenNative(m_cmp_abs, absolute, q, lab, 0);
end; {case}
GenLab(lab1);
if rOpcode = pc_fjp then begin
if op^.opcode = pc_grt then begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
end; {if}
GenNative(m_bcs, relative, lab2, nil, 0);
if op^.opcode = pc_grt then
GenLabUsedOnce(lab3);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
end {if}
else if rOpcode = pc_tjp then begin
if op^.opcode = pc_grt then
GenNative(m_beq, relative, lab2, nil, 0);
GenNative(m_bcc, relative, lab2, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab2);
end {else if}
else if op^.opcode = pc_geq then begin
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenImplied(m_rol_a);
end {else if}
else {if op^.opcode = pc_grt then} begin
GenNative(m_beq, relative, lab2, nil, 0);
GenNative(m_bcc, relative, lab2, nil, 0);
GenImplied(m_iny);
GenLab(lab2);
GenImplied(m_tya);
end; {else}
end {if}
else begin
GenImplied(m_tay);
gLong.preference := onStack;
GenTree(op^.right);
gLong.preference := A_X;
GenTree(op^.left);
if gLong.where = onStack then begin
GenImplied(m_ply);
GenImplied(m_pla);
end {if}
else begin
GenImplied(m_tay);
GenImplied(m_txa);
end; {else}
GenNative(m_ldx_imm, immediate, 1, nil, 0);
GenNative(m_cmp_s, direct, 3, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenImplied(m_tya);
GenNative(m_cmp_s, direct, 1, nil, 0);
GenLab(lab1);
if op^.opcode = pc_grt then begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
end; {if}
GenNative(m_bcs, relative, lab2, nil, 0);
if op^.opcode = pc_grt then
GenLab(lab3);
GenImplied(m_dex);
GenLab(lab2);
GenImplied(m_pla);
GenImplied(m_pla);
GenImplied(m_txa);
if rOpcode = pc_fjp then begin
lab4 := GenLabel;
GenNative(m_bne, relative, lab4, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab4);
end {if}
else if rOpcode = pc_tjp then begin
lab4 := GenLabel;
GenNative(m_beq, relative, lab4, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab4);
end; {else if}
end; {else}
lab1 := GenLabel;
GenNative(m_ldx_imm, immediate, 1, nil, 0);
GenNative(m_cmp_s, direct, 3, nil, 0);
GenNative(m_bne, relative, lab1, nil, 0);
GenImplied(m_tya);
GenNative(m_cmp_s, direct, 1, nil, 0);
GenLab(lab1);
lab2 := GenLabel;
if op^.opcode = pc_grt then begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
end; {if}
GenNative(m_bcs, relative, lab2, nil, 0);
if op^.opcode = pc_grt then
GenLab(lab3);
GenImplied(m_dex);
GenLab(lab2);
GenImplied(m_pla);
GenImplied(m_pla);
GenImplied(m_txa);
if rOpcode = pc_fjp then begin
lab4 := GenLabel;
GenNative(m_bne, relative, lab4, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab4);
end {if}
else if rOpcode = pc_tjp then begin
lab4 := GenLabel;
GenNative(m_beq, relative, lab4, nil, 0);
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab4);
end; {else if}
end;
cgReal,cgDouble,cgComp,cgExtended: begin
@ -2135,10 +2253,14 @@ if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
num := op^.right^.q;
lab1 := GenLabel;
if opcode in [pc_fjp,pc_tjp] then begin
if num <> 0 then
GenNative(m_cmp_imm, immediate, num, nil, 0)
else if NeedsCondition(leftOp) then
GenImpliedForFlags(m_tay);
if num = 0 then begin
if NeedsCondition(leftOp) then
GenImpliedForFlags(m_tay);
end {if}
else if num = 1 then
GenImplied(m_dea)
else
GenNative(m_cmp_imm, immediate, num, nil, 0);
if opcode = pc_fjp then
GenNative(beq, relative, lab1, nil, 0)
else
@ -2147,12 +2269,20 @@ if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and
GenLab(lab1);
end {if}
else begin
GenNative(m_ldx_imm, immediate, 0, nil, 0);
GenNative(m_cmp_imm, immediate, num, nil, 0);
GenNative(bne, relative, lab1, nil, 0);
GenImplied(m_inx);
GenLab(lab1);
GenImplied(m_txa);
if num <> 0 then
GenNative(m_eor_imm, immediate, num, nil, 0)
else if NeedsCondition(leftOp) then
GenImpliedForFlags(m_tax);
GenNative(m_beq, relative, lab1, nil, 0);
if op^.opcode = pc_equ then begin
GenNative(m_lda_imm, immediate, $ffff, nil, 0);
GenLab(lab1);
GenImplied(m_ina);
end {if}
else begin
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
end; {else}
end; {else}
end {if}
else if (op^.optype in [cgLong,cgULong]) and (leftOp in [pc_ldo,pc_lod])
@ -2167,24 +2297,20 @@ else if (op^.optype in [cgLong,cgULong]) and (leftOp in [pc_ldo,pc_lod])
GenNative(m_brl, longrelative, lb, nil, 0);
GenLab(lab1);
end {if}
else if op^.opcode = pc_equ then begin
lab1 := GenLabel;
lab2 := GenLabel;
DoOr(op^.left);
GenNative(bne, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenNative(m_bra, relative, lab2, nil, 0);
GenLab(lab1);
GenNative(m_lda_imm, immediate, 0, nil, 0);
GenLab(lab2);
end {else if}
else {if op^.opcode = pc_neq then} begin
else begin
lab1 := GenLabel;
DoOr(op^.left);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
end; {else if}
if op^.opcode = pc_equ then begin
GenNative(m_lda_imm, immediate, $ffff, nil, 0);
GenLab(lab1);
GenImplied(m_ina);
end {if}
else begin
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
end; {else}
end; {else}
end {else if}
else if (op^.optype in [cgLong,cgULong]) and (rightOp in [pc_ldo,pc_lod]) then begin
gLong.preference := A_X;
@ -2229,8 +2355,7 @@ else
if Complex(op^.right) or (not (opcode in [pc_fjp,pc_tjp])) then begin
GenImplied(m_pha);
GenTree(op^.right);
GenImplied(m_sec);
GenNative(m_sbc_s, direct, 1, nil, 0);
GenNative(m_eor_s, direct, 1, nil, 0);
GenImplied(m_plx);
GenImplied(m_tax);
if opcode in [pc_fjp,pc_tjp] then begin
@ -2245,10 +2370,15 @@ else
else begin
lab1 := GenLabel;
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
if op^.opcode = pc_equ then
GenNative(m_eor_imm, immediate, 1, nil, 0);
if op^.opcode = pc_equ then begin
GenNative(m_lda_imm, immediate, $ffff, nil, 0);
GenLab(lab1);
GenImplied(m_ina);
end {if}
else begin
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
end; {else}
end; {else}
end {if}
else begin
@ -2392,10 +2522,15 @@ else
else begin
lab3 := GenLabel;
GenNative(m_beq, relative, lab3, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab3);
if op^.opcode = pc_equ then
GenNative(m_eor_imm, immediate, 1, nil, 0);
if op^.opcode = pc_equ then begin
GenNative(m_lda_imm, immediate, $ffff, nil, 0);
GenLab(lab3);
GenImplied(m_ina);
end {if}
else begin
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab3);
end; {else}
end; {else}
end; {case optype of cgQuad,cgUQuad}
@ -3148,81 +3283,44 @@ case optype of
gQuad := lQuad;
gQuad.where := gQuad.preference; {unless overridden later}
if gLong.where = inPointer then begin
if q = 0 then begin
if gLong.fixedDisp then begin
GenNative(m_ldy_imm, immediate, 6, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(6);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(4);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(2);
GenNative(m_lda_indl, direct, gLong.disp, nil, 0);
StoreWordOfQuad(0);
end {if}
if gLong.fixedDisp then begin
GenNative(m_ldy_imm, immediate, q+6, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(6);
GenNative(m_ldy_imm, immediate, q+4, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(4);
GenNative(m_ldy_imm, immediate, q+2, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(2);
if q = 0 then
GenNative(m_lda_indl, direct, gLong.disp, nil, 0)
else begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, 6, nil, 0);
GenImplied(m_tay);
GenNative(m_ldy_imm, immediate, q, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(6);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(4);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(2);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(0);
end; {else}
end {if q = 0}
StoreWordOfQuad(0);
end {if}
else begin
if gLong.fixedDisp then begin
GenNative(m_ldy_imm, immediate, q+6, nil, 0);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(6);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(4);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(2);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(0);
end {if}
else begin
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, q+6, nil, 0);
GenImplied(m_tay);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(6);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(4);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(2);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
StoreWordOfQuad(0);
end; {else}
gQuad.where := onStack;
GenImplied(m_tya);
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, q+6, nil, 0);
GenImplied(m_tay);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
GenImplied(m_pha);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
GenImplied(m_pha);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
GenImplied(m_pha);
GenImplied(m_dey);
GenImplied(m_dey);
GenNative(m_lda_indly, direct, gLong.disp, nil, 0);
GenImplied(m_pha);
end; {else}
end {if glong.where = inPointer}
else if gLong.where = localAddress then begin
@ -3617,11 +3715,17 @@ else begin
else begin
if op^.left^.opcode = pc_lao then begin
GenTree(op^.right);
if signed then
GenImplied(m_tay);
GenNative(m_ldx_imm, immediate, op^.left^.q, op^.left^.lab, shift16);
if signed then begin
GenImpliedForFlags(m_tay);
lab2 := GenLabel;
GenNative(m_bpl, relative, lab2, nil, 0);
GenImplied(m_dex);
GenLab(lab2);
signed := false;
end; {if}
GenImplied(m_clc);
GenNative(m_adc_imm, immediate, op^.left^.q, op^.left^.lab, 0);
GenNative(m_ldx_imm, immediate, op^.left^.q, op^.left^.lab, shift16);
end {if}
else begin
gLong.preference := onStack;
@ -3696,7 +3800,7 @@ var
GenNative(m_inc_dirx, direct, 2, nil, 0);
GenLab(lab1);
end {if}
else {if op in [pc_gdl,pc_gld] then} begin
else {if op in [pc_ldl,pc_lld] then} begin
lab1 := GenLabel;
if p = 1 then begin
GenNative(m_lda_dirx, direct, 0, nil, 0);
@ -5493,10 +5597,11 @@ procedure GenTree {op: icptr};
lab1: integer;
operandIsBoolean: boolean;
begin {GenntNgiNot}
begin {GenBntNgiNot}
if op^.opcode = pc_not then
operandIsBoolean := op^.left^.opcode in
[pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt,pc_not];
[pc_and,pc_ior,pc_lnd,pc_lor,pc_not,pc_neq,pc_equ,pc_geq,pc_leq,
pc_les,pc_grt];
GenTree(op^.left);
case op^.opcode of
pc_bnt:
@ -5507,16 +5612,17 @@ procedure GenTree {op: icptr};
GenImplied(m_ina);
end; {case pc_ngi}
pc_not: begin
pc_not:
if not operandIsBoolean then begin
lab1 := GenLabel;
GenImpliedForFlags(m_tax);
GenNative(m_beq, relative, lab1, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenNative(m_lda_imm, immediate, $ffff, nil, 0);
GenLab(lab1);
end; {if}
GenNative(m_eor_imm, immediate, 1, nil, 0);
end; {if}
GenImplied(m_ina);
end {if}
else
GenNative(m_eor_imm, immediate, 1, nil, 0);
end; {case}
end; {GenBntNgiNot}
@ -6504,49 +6610,50 @@ procedure GenTree {op: icptr};
{ Generate code for a pc_lor or pc_lnd }
var
lab1,lab2: integer; {label}
opc: pcodes; {operation code}
procedure DoOra;
{ do some common oring operations to reduce space }
begin {DoOra}
if gLong.where = onStack then begin
GenImplied(m_pla);
GenNative(m_sta_dir, direct, dworkLoc, nil, 0);
GenImplied(m_pla);
end {if}
else
GenNative(m_stx_dir, direct, dworkLoc, nil, 0);
GenNative(m_ora_dir, direct, dworkLoc, nil, 0);
end; {DoOra}
lab1,lab2,lab3,lab4: integer; {labels}
begin {GenLorLnd}
opc := op^.opcode;
lab1 := GenLabel;
lab3 := GenLabel;
lab4 := GenLabel;
gLong.preference := A_X;
GenTree(op^.left);
DoOra;
lab2 := GenLabel;
if opc = pc_lnd then
GenNative(m_bne, relative, lab2, nil, 0)
if glong.where = A_X then
GenImpliedForFlags(m_tay)
else begin
GenNative(m_beq, relative, lab2, nil, 0);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenImplied(m_plx);
GenImplied(m_pla);
end; {else}
GenNative(m_brl, longrelative, lab1, nil, 0);
GenLab(lab2);
GenNative(m_bne, relative, lab1, nil, 0);
GenImplied(m_txa);
if op^.opcode = pc_lor then begin
lab2 := GenLabel;
GenNative(m_beq, relative, lab2, nil, 0);
GenLabUsedOnce(lab1);
GenNative(m_brl, longrelative, lab3, nil, 0);
GenLab(lab2);
end {if}
else begin
GenNative(m_bne, relative, lab1, nil, 0);
GenNative(m_brl, longrelative, lab4, nil, 0);
GenLab(lab1);
end; {if}
gLong.preference := A_X;
GenTree(op^.right);
DoOra;
GenNative(m_beq, relative, lab1, nil, 0);
if glong.where = A_X then
GenImpliedForFlags(m_tay)
else begin
GenImplied(m_plx);
GenImplied(m_pla);
end; {else}
GenNative(m_bne, relative, lab3, nil, 0);
GenImplied(m_txa);
GenNative(m_beq, relative, lab4, nil, 0);
GenLab(lab3);
GenNative(m_lda_imm, immediate, 1, nil, 0);
GenLab(lab1);
GenLab(lab4);
end; {GenLorLnd}
@ -7723,7 +7830,7 @@ var
localSize := localSize + size;
end {else if}
else if opcode in
[pc_les,pc_leq,pc_grt,pc_geq,pc_sto,pc_cpi,pc_ind,pc_lor,pc_lnd,
[pc_les,pc_leq,pc_grt,pc_geq,pc_sto,pc_cpi,pc_ind,
pc_ili,pc_iil,pc_idl,pc_ild,pc_ixa]
then begin
if dworkLoc = 0 then begin

4
Header.pas
View File

@ -18,7 +18,7 @@ uses CCommon, MM, Scanner, Symbol, CGI;
{$segment 'HEADER'}
const
symFileVersion = 41; {version number of .sym file format}
symFileVersion = 44; {version number of .sym file format}
var
inhibitHeader: boolean; {should .sym includes be blocked?}
@ -722,6 +722,7 @@ procedure EndInclude {chPtr: ptr};
WriteByte(ord(token.prefix));
end;
otherCharacter: WriteByte(ord(token.ch));
preprocessingNumber:WriteWord(token.errCode);
macroParameter: WriteWord(token.pnum);
reservedSymbol: if token.kind in [lbracech,rbracech,lbrackch,
rbrackch,poundch,poundpoundop] then
@ -1392,6 +1393,7 @@ var
token.prefix := charStrPrefixEnum(ReadByte);
end;
otherCharacter: token.ch := chr(ReadByte);
preprocessingNumber: token.errCode := ReadWord;
macroParameter: token.pnum := ReadWord;
reservedSymbol: if token.kind in [lbracech,rbracech,lbrackch,
rbrackch,poundch,poundpoundop] then

43
Native.pas
View File

@ -110,6 +110,14 @@ procedure GenLab (lnum: integer);
{ lnum - label number }
procedure GenLabUsedOnce (lnum: integer);
{ generate a label that is only targeted by one branch }
{ }
{ parameters: }
{ lnum - label number }
procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean);
{ Set up the object file }
@ -1637,7 +1645,7 @@ var
end; {if}
m_bcs,m_beq,m_bne,m_bmi,m_bpl,m_bcc:
if npeep[ns+2].opcode = d_lab then
if npeep[ns+2].opcode = d_lab then begin
if npeep[ns+2].operand = operand then
if npeep[ns+1].opcode = m_brl then begin
if Short(ns,npeep[ns+1].operand) then begin
@ -1674,8 +1682,20 @@ var
opcode := m_bmi;
end {else if m_bra}
else if npeep[ns+3].opcode in [m_bra,m_brl] then
if Short(ns,npeep[ns+3].operand) then
if Short(ns,npeep[ns+3].operand) then begin
operand := npeep[ns+3].operand;
if (npeep[ns+2].flags & labelUsedOnce) <> 0 then
Remove(ns+2);
end; {if}
end {if}
else if npeep[ns+3].opcode = d_lab then
if npeep[ns+3].operand = operand then
if npeep[ns+4].opcode in [m_bra,m_brl] then
if Short(ns,npeep[ns+4].operand) then begin
operand := npeep[ns+4].operand;
if (npeep[ns+3].flags & labelUsedOnce) <> 0 then
Remove(ns+3);
end; {if}
m_brl:
if Short(ns,operand) then begin
@ -1700,11 +1720,12 @@ var
Remove(ns+3);
end; {if}
m_dec_abs:
{disabled - can generate bad code}
{m_dec_abs:
if npeep[ns+1].opcode = m_lda_abs then
if name^ = npeep[ns+1].name^ then
if npeep[ns+2].opcode = m_beq then
Remove(ns+1);
Remove(ns+1);}
m_lda_abs:
if npeep[ns+1].opcode = m_clc then begin
@ -2301,6 +2322,18 @@ GenNative(d_lab, gnrlabel, lnum, nil, 0);
end; {GenLab}
procedure GenLabUsedOnce {lnum: integer};
{ generate a label that is only targeted by one branch }
{ }
{ parameters: }
{ lnum - label number }
begin {GenLabUsedOnce}
GenNative(d_lab, gnrlabel, lnum, nil, labelUsedOnce);
end; {GenLabUsedOnce}
procedure InitFile {keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean};
{ Set up the object file }
@ -2625,7 +2658,7 @@ yRegister.condition := regUnknown;
lastRegOpcode := 0; {BRK}
nnextspot := 1;
nleadOpcodes := [m_asl_a,m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_brl,{m_bvs,}
m_dec_abs,m_lda_abs,m_lda_dir,m_lda_imm,m_ldx_imm,m_sta_abs,m_sta_dir,
{m_dec_abs,}m_lda_abs,m_lda_dir,m_lda_imm,m_ldx_imm,m_sta_abs,m_sta_dir,
m_pha,m_plb,{m_plx,}m_tax,m_tya,m_tyx,m_phy,m_pei_dir,m_ldy_imm,m_rep,
m_ora_dir,m_ora_abs,m_and_imm,m_pea,m_tcd];
nstopOpcodes := [d_end,d_pin];

16
ORCACDefs/gsbug.h
View File

@ -14,13 +14,17 @@
#ifndef __GSBUG__
#define __GSBUG__
/* Error Codes */
#define debugUnImpErr 0xFF01
#define debugBadSelErr 0xFF02
#define dgiProgramCounter 0 /* for DebugGetInfo */
extern pascal Word DebugVersion() inline(0x04FF,dispatcher);
extern pascal Word DebugStatus() inline(0x06FF,dispatcher);
extern pascal void DebugStr() inline(0x09FF,dispatcher);
extern pascal void SetMileStone() inline(0x0AFF,dispatcher);
extern pascal void DebugSetHook() inline(0x0BFF,dispatcher);
extern pascal LongWord DebugGetInfo() inline(0x0CFF,dispatcher);
extern pascal Word DebugVersion(void) inline(0x04FF,dispatcher);
extern pascal Word DebugStatus(void) inline(0x06FF,dispatcher);
extern pascal void DebugStr(Pointer) inline(0x09FF,dispatcher);
extern pascal void SetMileStone(Pointer) inline(0x0AFF,dispatcher);
extern pascal void DebugSetHook(VoidProcPtr) inline(0x0BFF,dispatcher);
extern pascal LongWord DebugGetInfo(Word) inline(0x0CFF,dispatcher);
#endif

2
ORCACDefs/gsos.h
View File

@ -126,7 +126,7 @@
#define invalidFSTop 0x0065 /* invalid FST operation */
#define fstCaution 0x0066 /* FST handled call, but result is weird */
#define devNameErr 0x0067 /* device exists with same name as replacement name */
#define defListFull 0x0068 /* device list is full */
#define devListFull 0x0068 /* device list is full */
#define supListFull 0x0069 /* supervisor list is full */
#define fstError 0x006a /* generic FST error */
#define resExistsErr 0x0070 /* cannot expand file, resource already exists */

68
Parser.pas
View File

@ -122,13 +122,6 @@ type
val: longlong; {switch value}
end;
{token stack}
{-----------}
tokenStackPtr = ^tokenStackRecord;
tokenStackRecord = record
next: tokenStackPtr;
token: tokenType;
end;
{statement stack}
{---------------}
statementPtr = ^statementRecord;
@ -157,7 +150,7 @@ type
);
forSt: (
forLoop: integer; {branch here to loop}
e3List: tokenStackPtr; {tokens for last expression}
e3Code: codeRef; {code for last expression}
);
switchSt: (
maxVal: longint; {max switch value}
@ -690,11 +683,9 @@ var
{ handle a for statement }
var
errorFound: boolean; {did we find an error?}
e3Start: codeRef; {ref to start of code for expression 3}
forLoop, continueLab, breakLab: integer; {branch points}
parencount: integer; {number of unmatched '(' chars}
stPtr: statementPtr; {work pointer}
tl,tk: tokenStackPtr; {for forming expression list}
begin {ForStatement}
NextToken; {skip the 'for' token}
@ -733,29 +724,12 @@ var
end; {if}
Match(semicolonch,22);
tl := nil; {collect the tokens for the last expression}
parencount := 0;
errorFound := false;
while (token.kind <> eofsy)
and ((token.kind <> rparench) or (parencount <> 0))
and (token.kind <> semicolonch) do begin
new(tk); {place the token in the list}
tk^.next := tl;
tl := tk;
tk^.token := token;
if token.kind = lparench then {allow parens in the expression}
parencount := parencount+1
else if token.kind = rparench then
parencount := parencount-1;
NextToken; {next token}
end; {while}
if errorFound then {if an error was found, dump the list}
while tl <> nil do begin
tk := tl;
tl := tl^.next;
dispose(tk);
end; {while}
stPtr^.e3List := tl; {save the list}
e3Start := GetCodeLocation; {generate and save code for expression 3}
if token.kind <> rparench then begin
Expression(normalExpression, [rparench]);
Gen0t(pc_pop, UsualUnaryConversions);
end; {if}
stPtr^.e3Code := RemoveCode(e3Start);
Match(rparench,12); {get the closing for loop paren}
if c99Scope then PushTable;
@ -1128,37 +1102,13 @@ procedure EndForStatement;
{ finish off a for statement }
var
ltoken: tokenType; {for putting ; on stack}
stPtr: statementPtr; {work pointer}
tl,tk: tokenStackPtr; {for forming expression list}
lSuppressMacroExpansions: boolean; {local copy of suppressMacroExpansions}
begin {EndForStatement}
if c99Scope then PopTable;
stPtr := statementList;
Gen1(dc_lab, stPtr^.continueLab); {define the continue label}
tl := stPtr^.e3List; {place the expression back in the list}
if tl <> nil then begin
PutBackToken(token, false, false);
ltoken.kind := semicolonch;
ltoken.class := reservedSymbol;
PutBackToken(ltoken, false, false);
while tl <> nil do begin
PutBackToken(tl^.token, false, false);
tk := tl;
tl := tl^.next;
dispose(tk);
end; {while}
lSuppressMacroExpansions := suppressMacroExpansions; {inhibit token echo}
suppressMacroExpansions := true;
NextToken; {evaluate the expression}
Expression(normalExpression, [semicolonch]);
Gen0t(pc_pop, UsualUnaryConversions);
NextToken; {skip the semicolon}
suppressMacroExpansions := lSuppressMacroExpansions;
end; {if}
InsertCode(stPtr^.e3Code); {insert code for expression 3}
Gen1(pc_ujp, stPtr^.forLoop); {loop to the test}
Gen1(dc_lab, stPtr^.breakLab); {create the exit label}
statementList := stPtr^.next; {pop the statement record}

2
README.md
View File

@ -49,4 +49,4 @@ Alternatively, you can keep the LF line endings in your working copy of the Git
[udl]: http://ftp.gno.org/pub/apple2/gs.specific/gno/file.convert/udl.114.shk
In addition to converting the line endings, you will also have to set the files to the appropriate file types before building ORCA/C on a IIGS. The included `settypes` script (for use under the ORCA shell) does this for the sources to the ORCA/C compiler itself, although it does not currently cover the test cases and headers.
In addition to converting the line endings, you will also have to set the files to the appropriate file types before building ORCA/C on a IIGS. The included `settypes` script (for use under the ORCA shell) can be used to do this.

189
Scanner.pas
View File

@ -805,6 +805,7 @@ if list or (numErr <> 0) then begin
186: msg := @'lint: implicit conversion changes value of constant';
187: msg := @'expression has incomplete struct or union type';
188: msg := @'local variable used in asm statement is out of range for addressing mode';
189: msg := @'malformed numeric constant';
end; {case}
if extraStr <> nil then begin
extraStr^ := concat(msg^,extraStr^);
@ -1097,6 +1098,8 @@ case token.kind of
dotdotdotsy: write('...');
otherch: write(token.ch);
ppNumber: write(token.numString^);
macroParm: write('$', token.pnum:1);
@ -1118,16 +1121,11 @@ procedure CheckIdentifier; forward;
{ See if an identifier is a reserved word, macro or typedef }
procedure DoNumber (scanWork: boolean); forward;
procedure DoNumber; forward;
{ The current character starts a number - scan it }
{ }
{ Parameters: }
{ scanWork - get characters from workString? }
{ Scan a number from workString }
{ }
{ Globals: }
{ ch - first character in sequence; set to first char }
{ after sequence }
{ workString - string to take numbers from }
@ -1311,6 +1309,7 @@ var
class1,class2: tokenClass; {token classes}
i: integer; {loop variable}
kind1,kind2: tokenEnum; {token kinds}
lsaveNumber: boolean; {local copy of saveNumber}
lt: tokenType; {local copy of token}
str1,str2: stringPtr; {identifier strings}
@ -1373,27 +1372,37 @@ else if class1 in numericConstants then begin
str2 := @reservedWords[kind2]
else if kind2 = dotch then
str2 := @'.'
else if (kind2 = plusch)
and (tk1.numString^[length(tk1.numString^)] in ['e','E','p','P']) then
str2 := @'+'
else if (kind2 = minusch)
and (tk1.numString^[length(tk1.numString^)] in ['e','E','p','P']) then
str2 := @'-'
else begin
Error(63);
goto 1;
end; {else}
workString := concat(tk1.numString^, str2^);
lt := token;
DoNumber(true);
lsaveNumber := saveNumber;
saveNumber := true;
DoNumber;
saveNumber := lsaveNumber;
tk1 := token;
token := lt;
goto 1;
end {else if class1 in numericConstants}
else if kind1 = dotch then begin
if class2 in numericConstants then begin
workString := concat(tk1.numString^, tk2.numString^);
lt := token;
DoNumber(true);
tk1 := token;
token := lt;
goto 1;
end; {if}
if class2 in numericConstants then
if charKinds[ord(tk2.numString^[1])] = digit then begin
workString := concat('.', tk2.numString^);
lt := token;
DoNumber;
tk1 := token;
token := lt;
goto 1;
end; {if}
end {else if class1 in numericConstants}
else if kind1 = poundch then begin
@ -1878,6 +1887,8 @@ procedure Expand (macro: macroRecordPtr);
{ Globals: }
{ macroList - scanner putback buffer }
label 1;
type
parameterPtr = ^parameterRecord;
parameterRecord = record {parameter list element}
@ -2156,8 +2167,10 @@ else begin
tcPtr := pptr^.tokens;
if tcPtr = nil then begin
if tlPtr^.next <> nil then
if tlPtr^.next^.token.kind = poundpoundop then
tlPtr^.next := tlPtr^.next^.next;
if tlPtr^.next^.token.kind = poundpoundop then begin
tlPtr := tlPtr^.next;
goto 1;
end; {if}
if lastPtr <> nil then
if lastPtr^.token.kind = poundpoundop then
if tokenList <> nil then
@ -2179,7 +2192,7 @@ else begin
if not tcPtr^.expandEnabled then
inhibit := true;
if tcPtr = pptr^.tokens then
if (mPtr <> nil) and (mPtr^.parameters > 0) then
if (mPtr <> nil) and (mPtr^.parameters >= 0) then
inhibit := true;
if (mPtr <> nil) and (not inhibit) then
Expand(mPtr)
@ -2209,7 +2222,7 @@ else begin
tokenEnd := tlPtr^.tokenEnd;
PutBackToken(tlPtr^.token, expandEnabled, false);
end; {else}
lastPtr := tlPtr;
1: lastPtr := tlPtr;
tlPtr := tlPtr^.next;
end; {while}
end; {else}
@ -2786,8 +2799,12 @@ var
ple: stringListPtr; {pointer to the last element in parameterList}
pnum: integer; {for counting parameters}
tPtr,tk1,tk2: tokenListRecordPtr; {pointer to a token}
luseGlobalPool: boolean; {local copy of useGlobalPool}
begin {DoDefine}
lUseGlobalPool := useGlobalPool;
useGlobalPool := true; {use global memory for defines}
expandMacros := false; {block expansions}
saveNumber := true; {save characters in numeric tokens}
parameterList := nil; {no parameters yet}
@ -2969,6 +2986,9 @@ var
tk2^.token.sval^.str[i] then
goto 3;
end;
preprocessingNumber:
if tk1^.token.numString^ <> tk2^.token.numString^ then
goto 3;
macroParameter:
if tk1^.token.pnum <> tk2^.token.pnum then
goto 3;
@ -2999,6 +3019,7 @@ var
dispose(np);
end; {while}
saveNumber := false; {stop saving numeric strings}
useGlobalPool := lUseGlobalPool;
end; {DoDefine}
@ -3853,22 +3874,19 @@ Error(err);
end; {Error2}
procedure DoNumber {scanWork: boolean};
procedure DoNumber;
{ The current character starts a number - scan it }
{ }
{ Parameters: }
{ scanWork - get characters from workString? }
{ Scan a number from workString }
{ }
{ Globals: }
{ ch - first character in sequence; set to first char }
{ after sequence }
{ workString - string to take numbers from }
label 1,2;
var
atEnd: boolean; {at end of workString?}
c2: char; {next character to process}
err: integer; {error code}
i: integer; {loop index}
isBin: boolean; {is the value a binary number?}
isHex: boolean; {is the value a hex number?}
@ -3891,17 +3909,13 @@ var
{ Return the next character that is a part of the number }
begin {NextChar}
if scanWork then begin
if ord(workString[0]) <> numIndex then begin
numIndex := numIndex+1;
c2 := workString[numIndex];
end {if}
else
c2 := ' ';
if ord(workString[0]) <> numIndex then begin
numIndex := numIndex+1;
c2 := workString[numIndex];
end {if}
else begin
NextCh;
c2 := ch;
atEnd := true;
c2 := ' ';
end; {else}
end; {NextChar}
@ -3913,8 +3927,10 @@ var
{ code never actually get converted to numeric constants. }
begin {FlagError}
if not skipping then
Error(errCode);
if err = 0 then
err := errCode
else if err <> errCode then
err := 189;
end; {FlagError}
@ -3961,6 +3977,7 @@ var
begin {DoNumber}
atEnd := false; {not at end}
isBin := false; {assume it's not binary}
isHex := false; {assume it's not hex}
isReal := false; {assume it's an integer}
@ -3968,13 +3985,10 @@ isLong := false; {assume a short integer}
isLongLong := false;
isFloat := false;
unsigned := false; {assume signed numbers}
err := 0; {no error so far}
stringIndex := 0; {no digits so far...}
if scanWork then begin {set up the scanner}
numIndex := 0;
NextChar;
end {if}
else
c2 := ch;
numIndex := 0; {set up the scanner}
NextChar;
if c2 = '.' then begin {handle the case of no leading digits}
stringIndex := 1;
numString[1] := '0';
@ -4043,6 +4057,8 @@ while c2 in ['l','u','L','U'] do {check for long or unsigned}
if c2 = c1 then begin
NextChar;
isLongLong := true;
if isReal then
FlagError(156);
end {if}
else
isLong := true;
@ -4056,10 +4072,6 @@ while c2 in ['l','u','L','U'] do {check for long or unsigned}
unsigned := true;
end; {else}
if c2 in ['f','F'] then begin {allow F designator on reals}
if unsigned then
FlagError(91);
if isLongLong then
FlagError(156);
if not isReal then begin
FlagError(100);
isReal := true;
@ -4138,6 +4150,8 @@ else begin {hex, octal, & binary}
token.qval.hi := 0;
if isHex then begin
i := 3;
if length(numString) < 3 then
FlagError(189);
while i <= length(numString) do begin
if token.qval.hi & $F0000000 <> 0 then begin
i := maxint;
@ -4156,6 +4170,8 @@ else begin {hex, octal, & binary}
end {if}
else if isBin then begin
i := 3;
if length(numString) < 3 then
FlagError(189);
while i <= length(numString) do begin
if token.qval.hi & $80000000 <> 0 then begin
i := maxint;
@ -4171,7 +4187,7 @@ else begin {hex, octal, & binary}
end; {while}
end {if}
else begin
i := 1;
i := 2;
while i <= length(numString) do begin
if token.qval.hi & $E0000000 <> 0 then begin
i := maxint;
@ -4216,14 +4232,18 @@ else begin {hex, octal, & binary}
token.class := intConstant;
end; {else}
end; {else}
if saveNumber then begin
sp := pointer(GMalloc(length(numString)+1));
CopyString(pointer(sp), @numString);
if not atEnd then {make sure we read all characters}
FlagError(189);
if err <> 0 then begin {handle unconvertible pp-numbers}
token.class := preprocessingNumber;
token.kind := ppnumber;
token.errCode := err;
end; {if}
if saveNumber or (err <> 0) then begin
sp := pointer(GMalloc(length(workString)+1));
CopyString(pointer(sp), @workString);
token.numString := sp;
end; {if}
if scanWork then {make sure we read all characters}
if ord(workString[0]) <> numIndex then
Error(63);
end; {DoNumber}
@ -4560,7 +4580,8 @@ lintErrors :=
spaceStr := ' '; {strings used in stringization}
quoteStr := '"';
{set of classes for numeric constants}
numericConstants := [intConstant,longConstant,longlongConstant,realConstant];
numericConstants :=
[intConstant,longConstant,longlongConstant,realConstant,preprocessingNumber];
new(mp); {__LINE__}
mp^.name := @'__LINE__';
@ -4791,7 +4812,7 @@ repeat
else if lch in ['.','0'..'9'] then begin
token.name := GetWord;
saveNumber := true;
DoNumber(true);
DoNumber;
saveNumber := false;
end {else if}
else if lch = '"' then
@ -5315,6 +5336,44 @@ var
end; {ConcatenateTokenString}
procedure Number;
{ Scan a preprocessing number token. It is converted to an }
{ integer or floating constant if it matches the syntax for }
{ one of those, or left as a preprocessing number if not. }
var
numLen: 1..maxint;
lastCh: char;
begin {Number}
numLen := 0;
lastCh := chr(0);
while (charKinds[ord(ch)] in [digit,letter,ch_dot])
or ((lastCh in ['e','E','p','P'])
and (charKinds[ord(ch)] in [ch_plus,ch_dash])) do
begin
if numLen < 255 then begin
numLen := numLen + 1;
workString[numLen] := ch;
end {if}
else
numLen := 256;
lastCh := ch;
NextCh;
end; {while}
if numLen = 256 then begin
if not skipping then
Error(131);
numLen := 1;
workString[1] := '0';
end; {if}
workString[0] := chr(numLen);
DoNumber;
end; {Number}
begin {NextToken}
if ifList = nil then {do pending EndInclude calls}
while includeCount <> 0 do begin
@ -5648,7 +5707,7 @@ case charKinds[ord(ch)] of
ch_dot : begin {tokens that start with '.'}
if charKinds[ord(PeekCh)] = digit then
DoNumber(false)
Number
else begin
NextCh;
if (ch = '.') and (PeekCh = '.') then begin
@ -5861,7 +5920,7 @@ case charKinds[ord(ch)] of
end;
digit : {numeric constants}
DoNumber(false);
Number;
ch_other: begin {other non-whitespace char (pp-token)}
token.kind := otherch;
@ -5919,10 +5978,20 @@ if printMacroExpansions then
if not suppressMacroExpansions then
if not suppressPrint then
PrintToken(token); {print the token stream}
if token.kind = otherch then
if token.kind = otherch then begin
if not (skipping or preprocessing or suppressMacroExpansions)
or doingPPExpression then
Error(1);
end {if}
else if token.kind = ppNumber then
if not (skipping or preprocessing or suppressMacroExpansions)
or doingPPExpression then begin
Error(token.errCode);
token.kind := intconst;
token.class := intConstant;
token.ival := 0;
token.numString := @'0';
end; {if}
end; {NextToken}

4
Table.asm
View File

@ -309,6 +309,8 @@ charSym start single character symbols
enum (barbarop,pluseqop,minuseqop,asteriskeqop,slasheqop)
enum (percenteqop,ltlteqop,gtgteqop,andeqop,caroteqop)
enum (bareqop,poundpoundop,dotdotdotsy)
enum (ppnumber) preprocessing number
enum (otherch) other non-whitespace char
enum (eolsy,eofsy) control characters
enum (typedef) user types
! converted operations
@ -466,6 +468,7 @@ icp start in-coming priority for expression
dc i1'3' bareqop
dc i1'200' poundpoundop
dc i1'200' dotdotdotsy
dc i1'200' ppnumber
dc i1'200' otherch
dc i1'200' eolsy
dc i1'200' eofsy
@ -644,6 +647,7 @@ isp start in stack priority for expression
dc i1'2' bareqop
dc i1'0' poundpoundop
dc i1'0' dotdotdotsy
dc i1'0' ppnumber
dc i1'0' otherch
dc i1'0' eolsy
dc i1'0' eofsy

2
Tests/Conformance/C15.1.0.1.CC
View File

@ -34,7 +34,7 @@ second string argument!"))
goto Fail;
strcpy(s1, "this is the first string argument");
strcpy(s1, strncat (s1, s2, -5));
strcpy(s1, strncat (s1, s2, 0));
if (strcmp (s1, "this is the first string argument"))
goto Fail;

2
Tests/Conformance/C15.2.0.1.CC
View File

@ -29,7 +29,7 @@ int main (void)
if (i != 0)
goto Fail;
i = strncmp (s1, s2, -90L); /* should just return 0 */
i = strncmp (s1, s2, 0L); /* should just return 0 */
if (i != 0)
goto Fail;

1
Tests/Conformance/DOIT3
View File

@ -28,6 +28,7 @@
{1} c99desinit.c
{1} c99printfa.c
{1} c99strtold.c
{1} c99ppnum.c
{1} c11generic.c
{1} c11align.c
{1} c11noret.c

36
Tests/Conformance/c99ppnum.c Normal file
View File

@ -0,0 +1,36 @@
/*
* Test handling of preprocessing numbers.
*
* Most of this applies to C89, but hex float and long long are specific to
* C99 and later.
*/
#include <stdio.h>
#include <string.h>
#define COMBINE3(a,b,c) a##b##c
#define STRINGIZE(x) #x
int main(void) {
if (COMBINE3(123,.,456) != 123.456)
goto Fail;
if (COMBINE3(1.,08,999999999999999999999999999999999)
!= 1.08999999999999999999999999999999999)
goto Fail;
if (COMBINE3(0x,AB,09) != 0xAB09)
goto Fail;
if (strcmp(STRINGIZE(.1xyzp+), ".1xyzp+") != 0)
goto Fail;
if (strcmp(STRINGIZE(0xaBcD), "0xaBcD") != 0)
goto Fail;
if (strcmp(STRINGIZE(089ae-.), "089ae-.") != 0)
goto Fail;
if (sizeof(COMBINE3(123,L,L)) < sizeof(long long))
goto Fail;
printf ("Passed Conformance Test c99ppnum\n");
return 0;
Fail:
printf ("Failed Conformance Test c99ppnum\n");
}

4
Tests/Deviance/D7.6.1.2.CC
View File

@ -5,9 +5,7 @@
void main(void)
{
int i;
i = 4/0;
static int i = 4/0;
printf("Failed Deviance Test 7.6.1.2\n");
}

4
Tests/Deviance/D7.6.1.3.CC
View File

@ -5,9 +5,7 @@
void main(void)
{
int i;
i = 4%0;
static int i = 4%0;
printf("Failed Deviance Test 7.6.1.3\n");
}

52
cc.notes
View File

@ -1,11 +1,13 @@
ORCA/C 2.2.0
ORCA/C 2.2.1
Copyright 1997, Byte Works Inc.
Updated by Stephen Heumann and Kelvin Sherlock, 2017-2023
Updated by Stephen Heumann and Kelvin Sherlock, 2017-2024
These release notes document the changes between ORCA/C 2.0 and ORCA/C 2.2.0. They are intended mainly for users familiar with earlier versions of ORCA/C. New users should simply refer to the ORCA/C 2.2 manual, which has been fully updated to document the new features and other changes in ORCA/C 2.2.0.
These release notes document the changes between ORCA/C 2.0 and ORCA/C 2.2.1. They are intended mainly for users familiar with earlier versions of ORCA/C. New users should refer to the ORCA/C 2.2 manual, which has been fully updated to document the new features and other changes in ORCA/C 2.2.
-- Change List --------------------------------------------------------------
2.2.1 1. Bugs squashed. See bug notes, below.
2.2.0 1. Bugs squashed. See bug notes, below.
2. New language features added (mainly features from C99 and C11).
@ -1582,6 +1584,50 @@ Turning this optimization on means ORCA/C is no longer strictly in compliance wi
If you use #pragma debug 0x0010 to enable stack check debug code, the compiler will still flag variable argument functions that do not consume all arguments as a run-time error, even though ANSI C does allow them.
-- Bugs from C 2.2.0 that have been fixed in C 2.2.1 ------------------------
1. If there was a #define directive immediately after the opening brace of a function body, and the macro defined there was used after the end of that function or was used in the initializer for a static variable, incorrect code might be generated or spurious errors might be reported.
(Kelvin Sherlock)
2. In <gsbug.h>, the declarations of the pseudo tool calls provided by GSBug did not include prototypes. Now they do.
(Kelvin Sherlock)
3. In <gsos.h>, the error code devListFull was misspelled as defListFull.
4. Code that divides an integer constant by zero (e.g. 1/0) will no longer always produce an error. Such code will produce undefined behavior if it is executed, but since the compiler cannot always determine whether the code will be executed at run time, this is no longer treated as an error that prevents compilation. If #pragma lint bit 5 is set, a lint message about the division by zero will still be produced. An error will also still be reported for division by zero in constant expressions that need to be evaluated at compile time.
5. In some obscure circumstances, ORCA/C might behave incorrectly when the postfix ++ or -- operators were used on an expression of pointer type. This would typically result in "compiler error" messages, but could potentially also cause incorrect code to be generated without any errors being reported.
6. If the first string passed to strcat() or strncat() crossed a bank boundary, those functions would generally behave incorrectly and corrupt memory.
7. In certain situations where the third argument to strncat() was 0x8000 or greater, it could behave incorrectly.
8. If strncmp() was called with a third argument of 0x1000000 or greater, it could sometimes incorrectly return 0. (Note that such size values exceed the address space of the 65816, so under ORCA/C they effectively impose no limit on the number of characters to be compared. The behavior of strncmp() should therefore be the same as strcmp() in these cases.)
9. If an error was encountered when trying to write out buffered data in fclose(), the stream would not actually be closed, and the buffer allocated for it would not be freed. Now the stream will be closed (disassociated from the file) and the buffer will be freed even if an error is encountered.
10. If an error was encountered when trying to write out buffered data to a file when exiting the program, it could hang and never actually quit.
11. If fclose() was called on a file created by tmpfile() at a time when there was very little free memory available, it could corrupt memory and cause a crash. (This will no longer happen, but the file still may not be deleted if there is insufficient memory available when fclose() is called.)
12. If a numeric token formed using a ## preprocessor operator was an operand for another ## preprocessor operator, the resulting token would be incorrect.
13. If an empty argument was passed for a macro parameter that was used as an operand of the ## preprocessing operator, the result would likely be incorrect, and subsequent uses of the same macro also might not be expanded correctly.
14. If a struct, union, or enum type name appeared within the third expression in a for loop statement (e.g. in a cast or as the argument to sizeof), ORCA/C could behave incorrectly. It could report a spurious error if a semicolon occurred within the type name as part of a structure or union member declaration. Also, any tags or enumeration constants declared by such a type name should be in scope within the loop body, but they were not.
15. Native code peephole optimization might produce invalid code in some obscure circumstances where one element of a global or static array was decremented and then another element of the same array was accessed immediately thereafter.
16. When an expression of const- or volatile-qualified struct or union type was passed as a function parameter, incorrect code would be generated. This could lead to incorrect program behavior or crashes.
17. Incorrect code could be generated in certain circumstances where a long long or unsigned long long member of a structure or array was accessed via a pointer.
18. The ORCA/C preprocessor now allows for preprocessing number tokens that do not match the syntax of an integer or floating constant (e.g. 08Ae-.x). If any such tokens remain after preprocessing, an error will still be reported. Note that this means that code like 0x3e+1 is now treated as a single token that is invalid if it remains after preprocessing, rather than as three tokens that form a valid expression; if you want it to be interpreted as three tokens, you must include whitespace before the +.
19. When numeric tokens beginning with . were used as operands to the ## preprocessing operator, they behaved as if they started with a leading 0, which could lead to an incorrect result (e.g. 123##.456 became 1230.456).
-- Bugs from C 2.1.1 B3 that have been fixed in C 2.2.0 ---------------------
1. There were various bugs that could cause incorrect code to be generated in certain cases. Some of these were specific to certain optimization passes, alone or in combination.

73
settypes
View File

@ -1,20 +1,61 @@
filetype = src
change =.rez rez
change =.pas pascal
change =.Comments pascal
change =.Debug pascal
change =.Print pascal
change =.asm asm65816
change =.macros asm65816
change make= exec
change linkit= linker
change smake exec
change count exec
change backup exec
change settypes exec
filetype =.notes txt
filetype =.md txt
filetype -p =.rez= src; change -p =.rez= rez
filetype -p =.pas src; change -p =.pas pascal
filetype CGI.Comments src; change CGI.Comments pascal
filetype CGI.Debug src; change -p CGI.Debug pascal
filetype Scanner.debug src; change -p Scanner.debug pascal
filetype Symbol.Print src; change Symbol.Print pascal
filetype -p =.asm src; change -p =.asm asm65816
filetype -p =.macros src; change -p =.macros asm65816
filetype -p make= src; change -p make= exec
filetype -p linkit= src; change -p linkit= linker
filetype smake src; change smake exec
filetype count src; change count exec
filetype backup src; change backup exec
filetype settypes src; change settypes exec
filetype cc.notes txt
filetype -p =.md txt
filetype LICENSE txt
filetype C.Read.Me txt
filetype C.Update.ReadMe txt
filetype Tech.Support txt
filetype Manual.docx $00
filetype obj:README.txt txt
filetype -p ORCACDefs:=.h src; change -p ORCACDefs:=.h cc
filetype -p C.Samples:Benchmarks:=.cc src; change -p C.Samples:Benchmarks:=.cc cc
filetype -p C.Samples:CDA.Samples:=.cc src; change -p C.Samples:CDA.Samples:=.cc cc
filetype -p C.Samples:CDev.Samples:=.cc src; change -p C.Samples:CDev.Samples:=.cc cc
filetype -p C.Samples:CDev.Samples:=.rez src; change -p C.Samples:CDev.Samples:=.rez rez
filetype -p C.Samples:CDev.Samples:=.make src; change -p C.Samples:CDev.Samples:=.make exec
filetype -p C.Samples:Desktop.Samples:=.cc src; change -p C.Samples:Desktop.Samples:=.cc cc
filetype -p C.Samples:Graphic.Samples:=.cc src; change -p C.Samples:Graphic.Samples:=.cc cc
filetype -p C.Samples:HyperCard:=.cc src; change -p C.Samples:HyperCard:=.cc cc
filetype -p C.Samples:HyperCard:=.rez src; change -p C.Samples:HyperCard:=.rez rez
filetype -p C.Samples:HyperCard:=.make src; change -p C.Samples:HyperCard:=.make exec
filetype -p C.Samples:HyperStudio:=.cc src; change -p C.Samples:HyperStudio:=.cc cc
filetype -p C.Samples:HyperStudio:=.rez src; change -p C.Samples:HyperStudio:=.rez rez
filetype -p C.Samples:HyperStudio:=.make src; change -p C.Samples:HyperStudio:=.make exec
filetype -p C.Samples:Text.Samples:=.cc src; change -p C.Samples:Text.Samples:=.cc cc
filetype -p C.Samples:Text.Samples:=.h src; change -p C.Samples:Text.Samples:=.h cc
filetype C.Samples:Text.Samples:Key2.Funcs src; change C.Samples:Text.Samples:Key2.Funcs cc
filetype -p C.Samples:Text.Samples:=.asm src; change -p C.Samples:Text.Samples:=.asm asm65816
filetype -p C.Samples:Text.Samples:=.Build src; change -p C.Samples:Text.Samples:=.Build exec
filetype -p Tests:Conformance:=.c src; change -p Tests:Conformance:=.c cc
filetype -p Tests:Conformance:=.CC src; change -p Tests:Conformance:=.CC cc
filetype -p Tests:Conformance:DOIT= src; change -p Tests:Conformance:DOIT= exec
filetype -p Tests:Conformance:TEST= src; change -p Tests:Conformance:TEST= exec
filetype -p Tests:Deviance:=.CC src; change -p Tests:Deviance:=.CC cc
filetype Tests:Deviance:D3401.DATA src; change Tests:Deviance:D3401.DATA cc
filetype Tests:Deviance:DOIT src; change Tests:Deviance:DOIT exec
filetype Tests:Deviance:RUN.DEVIANCE src; change Tests:Deviance:RUN.DEVIANCE exec
filetype -p Tests:Deviance:TEST= src; change -p Tests:Deviance:TEST= exec
filetype -p Tests:Spec.Conform:=.CC src; change -p Tests:Spec.Conform:=.CC cc
filetype -p Tests:Spec.Conform:=.H src; change -p Tests:Spec.Conform:=.H cc
filetype -p Tests:Spec.Conform:SPC3402= src; change -p Tests:Spec.Conform:SPC3402= cc
filetype -p Tests:Spec.Conform:=FILE= src; change -p Tests:Spec.Conform:=FILE= cc
filetype -p Tests:Spec.Conform:=.EXEC src; change -p Tests:Spec.Conform:=.EXEC exec
filetype -p Tests:Spec.Deviance:=.CC src; change -p Tests:Spec.Deviance:=.CC cc
filetype Tests:Spec.Deviance:DOIT src; change Tests:Spec.Deviance:DOIT exec
filetype Tests:Spec.Deviance:TEST src; change Tests:Spec.Deviance:TEST exec
* Install udl and uncomment this to also convert to CR line endings.
* udl -g =