1 (*
2 * The contents of this file are subject to the Mozilla Public License
3 * Version 1.1 (the "License"); you may not use this file except in
4 * compliance with the License. You may obtain a copy of the License at
5 * http://www.mozilla.org/MPL/
6 *
7 * Software distributed under the License is distributed on an "AS IS"
8 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
9 * License for the specific language governing rights and limitations
10 * under the License.
11 *
12 * The Initial Developer of this code is John Hansen.
13 * Portions created by John Hansen are Copyright (C) 2009 John Hansen.
14 * All Rights Reserved.
15 *
16 *)
17 unit uNXCComp;
18
19 interface
20
21 uses
22 Classes, uNBCCommon, uGenLexer, uNXTClasses, uPreprocess, Contnrs;
23
24 type
25 TNXCComp = class
26 private
27 fStackDepth : integer;
28 fStatementType : TStatementType;
29 fInlineFunctionStack : TObjectStack;
30 fLastErrLine : integer;
31 fLastErrMsg : string;
32 endofallsource : boolean;
33 fEnhancedFirmware: boolean;
34 fIgnoreSystemFile: boolean;
35 fParenDepth : integer;
36 fSafeCalls: boolean;
37 fMaxErrors: word;
38 fFirmwareVersion: word;
39 fStackVarNames : TStringList;
40 fOnCompilerStatusChange: TCompilerStatusChangeEvent;
41 fMaxPreProcDepth: word;
FunctionParameterTypeNamenull42 function FunctionParameterTypeName(const name: string; idx: integer): string;
LocalDataTypenull43 function LocalDataType(const n: string): char;
LocalTypeNamenull44 function LocalTypeName(const n: string): string;
LocalConstantValuenull45 function LocalConstantValue(const n: string): string;
GlobalDataTypenull46 function GlobalDataType(const n: string): char;
GlobalTypeNamenull47 function GlobalTypeName(const n: string): string;
ParamDataTypenull48 function ParamDataType(const n: string): char;
ParamTypeNamenull49 function ParamTypeName(const n: string): string;
FuncParamDataTypenull50 function FuncParamDataType(const n: string): char;
51 procedure CheckSemicolon;
52 procedure OpenParen;
53 procedure CloseParen;
54 procedure InitializeGraphicOutVars;
55 procedure LocalEmitLn(SL: TStrings; const line: string);
56 procedure LocalEmitLnNoTab(SL: TStrings; const line: string);
57 procedure pop;
58 procedure push;
59 procedure SetStatementType(const Value: TStatementType);
60 procedure DoCompilerStatusChange(const Status: string; const bDone : boolean = False);
61 procedure DoCommonFuncProcDecl(var bProtoExists: boolean;
62 var Name: string; const tname: string; const tok, dt: char; bInline,
63 bSafeCall: boolean);
64 procedure HandlePreprocStatusChange(Sender : TObject; const StatusMsg : string);
65 procedure SetCurFile(const Value: string);
IsCharLiteralnull66 function IsCharLiteral(const aName: string): boolean;
IsStringLiteralnull67 function IsStringLiteral(const aName: string): boolean;
68 protected
69 fDD: TDataDefs;
70 fCurrentStruct : TDataspaceEntry;
71 fNamedTypes : TMapList;
72 fEmittedLocals : TStringList;
73 fLocals : TVariableList;
74 fParams : TVariableList;
75 fGlobals : TVariableList;
76 fFuncParams : TFunctionParameters;
77 fCurrentInlineFunction : TInlineFunction;
78 fInlineFunctions : TInlineFunctions;
79 fArrayHelpers : TArrayHelperVars;
80 fNBCSrc : TStrings;
81 fMessages : TStrings;
82 fMS : TMemoryStream;
83 fTempChar : Char;
84 fCCSet : boolean;
85 fIncludeDirs: TStrings;
86 fCurFile: string;
87 fOnCompMSg: TOnCompilerMessage;
88 fDirLine : string;
89 fCurrentLine : string;
90 fExpStr : string;
91 fExpStrHasVars : boolean;
92 fAPIFunctions : TStringList;
93 fAPIStrFunctions : TStringList;
94 fThreadNames : TStringList;
95 fCurrentThreadName : string;
96 fBytesRead : integer;
97 fSwitchFixups : TStringList;
98 fSwitchRegNames : TStringList;
99 fSwitchDepth : integer;
100 fCalc : TNBCExpParser;
101 fOptimizeLevel: integer;
102 fInlineDepth : integer;
103 fInlineStack : TObjectList; // list of TStrings
104 fSafeCalling : boolean;
105 fNestingLevel : integer;
106 fLHSDataType : char;
107 fLHSName : string;
108 fWarningsOff: boolean;
109 fFunctionNameCallStack : TStringList;
110 fSemiColonRequired : boolean;
111 fExpressionIsSigned : boolean;
112 fConstStringMap : TStringList;
113 fArrayIndexStack : TStringList;
114 fStructDecls : TStringList;
115 fUDTOnStack : string;
116 fLastExpressionOptimizedToConst : boolean;
117 fLastLoadedConst : string;
118 fProcessingMathAssignment : boolean;
119 fProcessingAsmBlock : boolean;
120 fNoCommaOperator : boolean;
AmInliningnull121 function AmInlining : boolean;
122 procedure IncrementInlineDepth;
123 procedure DecrementInlineDepth;
124 procedure HandleSpecialNames;
125 procedure EmitNXCRequiredStructs;
126 procedure ResetStatementType;
127 procedure DecrementNestingLevel;
128 procedure GetCharX;
129 procedure GetChar;
130 procedure Init;
131 procedure Prog; virtual;
132 procedure SkipCommentBlock;
133 procedure SkipLine;
134 procedure SkipDirectiveLine;
135 procedure SkipWhite;
136 procedure GetDirective;
137 procedure GetName;
138 procedure GetNum;
139 procedure GetHexNum;
140 procedure GetCharLit;
141 procedure GetOp;
142 procedure Next(bProcessDirectives : boolean = True);
143 procedure MatchString(x: string);
144 procedure Semi;
145 procedure NotNumericFactor;
146 procedure NumericFactor;
147 procedure Modulo;
148 procedure Divide;
149 procedure Multiply;
150 procedure Term;
151 procedure Add;
152 procedure EqualString;
153 procedure LessString;
154 procedure EqualArrayOrUDT(const lhs : string);
155 procedure LessArrayOrUDT(const lhs : string);
156 procedure Expression;
157 procedure DoPreIncOrDec(bPutOnStack : boolean);
IncrementOrDecrementnull158 function IncrementOrDecrement : boolean;
OptimizeExpressionnull159 function OptimizeExpression(const idx : integer) : string;
160 procedure Subtract;
161 procedure CommaExpression;
162 procedure BoolExpression;
163 procedure Relation;
164 procedure StoreZeroFlag;
ValueIsStringTypenull165 function ValueIsStringType(var dt : char) : boolean;
ValueIsArrayTypenull166 function ValueIsArrayType : boolean;
ValueIsUserDefinedTypenull167 function ValueIsUserDefinedType : boolean;
168 procedure BoolTerm;
169 procedure BitOr;
170 procedure BitXor;
171 procedure BitAnd;
TypesAreCompatiblenull172 function TypesAreCompatible(lhs, rhs : char) : boolean;
GetParamNamenull173 function GetParamName(procname : string; idx : integer) : string;
174 procedure DoCall(procname: string);
GetValueOfnull175 function GetValueOf(const name : string) : string;
176 procedure DoCallAPIFunc(procname: string);
APIFuncNameToIDnull177 function APIFuncNameToID(procname : string) : integer;
IsAPIFuncnull178 function IsAPIFunc(procname : string) : boolean;
179 procedure DoAssignValue(const aName : string; dt : char; bNoChecks : boolean = False);
180 procedure DoLocalArrayInit(const aName, ival : string; dt : char);
181 procedure DoArrayAssignValue(const aName, idx : string; dt : char);
DoNewArrayIndexnull182 function DoNewArrayIndex(theArrayDT : Char; theArray, aLHSName : string) : boolean;
183 procedure Assignment;
184 procedure CheckNotConstant(const aName : string);
CheckConstantnull185 function CheckConstant(const aName : string) : string;
Blocknull186 function Block(const lend : string = ''; const lstart : string = '') : boolean;
187 procedure BlockStatements(const lend : string = ''; const lstart : string = '');
188 procedure CheckBytesRead(const oldBytesRead : integer);
189 procedure DoFor;
190 procedure DoIf(const lend, lstart : string);
191 procedure DoWhile;
192 procedure DoDoWhile;
193 procedure DoRepeat;
194 procedure DoAsm(var dt : char);
DecorateVariablesnull195 function DecorateVariables(const asmStr : string) : string;
196 procedure DoSwitch(const lstart : string);
197 procedure DoSwitchCase;
GetCaseConstantnull198 function GetCaseConstant : string;
199 procedure DoSwitchDefault;
SwitchFixupIndexnull200 function SwitchFixupIndex : integer;
SwitchIsStringnull201 function SwitchIsString : Boolean;
SwitchRegisterNamenull202 function SwitchRegisterName : string;
203 procedure ClearSwitchFixups;
204 procedure FixupSwitch(idx : integer; lbl : string);
205 procedure DoLabel;
206 procedure DoStart;
207 procedure DoStopTask;
208 procedure DoSetPriority;
209 procedure CommaStatement(const lend, lstart : string);
210 procedure Statement(const lend, lstart : string);
211 procedure ProcessDirectives(bScan : boolean = True);
212 procedure HandlePoundLine;
ArrayOfTypenull213 function ArrayOfType(dt : char; dimensions : integer) : char;
GetVariableTypenull214 function GetVariableType(vt: char; bUnsigned: boolean): char;
215 procedure CheckForValidDataType(dt : char);
RemoveArrayDimensionnull216 function RemoveArrayDimension(dt : char) : char;
AddArrayDimensionnull217 function AddArrayDimension(dt : char) : char;
218 procedure IncLineNumber;
AddLocalnull219 function AddLocal(name: string; dt: char; const tname : string;
220 bConst : boolean; const lenexp : string) : integer;
221 procedure AllocGlobal(const tname : string; dt: char; bInline, bSafeCall, bConst : boolean);
222 procedure AllocLocal(const sub, tname: string; dt: char; bConst : boolean);
GetInitialValuenull223 function GetInitialValue(dt : char) : string;
224 procedure DoLocals(const sub: string);
225 procedure AddFunctionParameter(pname, varname, tname : string; idx : integer;
226 ptype : char; bIsConst, bIsRef, bIsArray : boolean; aDim : integer;
227 bHasDefault : boolean; defValue : string);
FormalListnull228 function FormalList(protoexists: boolean; var procname: string): integer;
229 procedure ProcedureBlock;
230 procedure InitializeGlobalArrays;
231 procedure EmitGlobalDataInitSubroutine;
232 procedure FunctionBlock(Name, tname : string; dt : char; bInline, bSafeCall : boolean);
233 procedure AbortMsg(s: string);
234 procedure Expected(s: string);
235 procedure Undefined(n: string);
236 procedure CheckIdent;
237 procedure CheckEnhancedFirmware;
238 procedure CheckDataType(dt : char);
239 procedure CheckTypeCompatibility(fp : TFunctionParameter; dt : char; const name : string);
240 procedure Duplicate(n: string);
SizeOfTypenull241 // function SizeOfType(dt: char): integer;
242 function AddEntry(N: string; dt: char; const tname, lenexp : string; bConst : boolean = False; bSafeCall : boolean = False) : integer;
243 procedure CheckDup(N: string);
244 procedure CheckTable(const N: string);
245 procedure CheckGlobal(const N: string);
246 procedure AddParam(N: string; dt: char; const tname : string;
247 bConst : boolean; bHasDefault : boolean; const defValue : string);
DataTypenull248 function DataType(const n: string): char;
DataTypeNamenull249 function DataTypeName(const n: string): string;
250 procedure LoadVar(const Name: string);
251 procedure CheckNotProc(const Name : string);
252 procedure Store(const Name: string; bNoChecks : boolean = False);
253 procedure Allocate(const Name, aVal, Val, tname: string; dt: char);
254 procedure InitializeArray(const Name, aVal, Val, tname: string; dt : char;
255 lenexpr : string);
InlineDecorationnull256 // function InlineDecoration : string;
257 procedure Epilog(bIsSub: boolean);
258 procedure Prolog(const name: string; bIsSub: boolean);
259 procedure EmitRegisters;
260 procedure EmitStackVariables;
261 procedure EmitMutexDeclaration(const name : string);
262 procedure EmitInlineParametersAndLocals(func : TInlineFunction);
263 procedure EmitLn(s: string);
264 procedure EmitLnNoTab(s: string);
265 procedure PostLabel(L: string);
266 procedure LoadConst(n: string);
267 procedure Negate;
268 procedure NotIt;
269 procedure Complement;
270 procedure PopAdd;
271 procedure PopAnd;
272 procedure PopCmpEqual;
273 procedure PopCmpGreater;
274 procedure PopCmpGreaterOrEqual;
275 procedure PopCmpLess;
276 procedure PopCmpLessOrEqual;
277 procedure PopCmpNEqual;
278 procedure PopMod;
279 procedure PopDiv;
280 procedure PopLeftShift;
281 procedure PopMul;
282 procedure PopOr;
283 procedure PopRightShift;
284 procedure PopSub;
285 procedure PopXor;
286 procedure PushPrim;
287 procedure SetZeroCC;
288 procedure Branch(L: string);
289 procedure BranchFalse(L: string);
290 procedure BranchTrue(L: string);
291 procedure ClearReg;
292 procedure ArrayAssignment(const name : string; dt : char; bIndexed : boolean);
293 procedure UDTAssignment(const name : string);
294 procedure GetAndStoreUDT(const name : string);
295 procedure MathAssignment(const name : string);
296 procedure StoreAdd(const name: string);
297 procedure StoreDiv(const name: string);
298 procedure StoreMod(const name: string);
299 procedure StoreAnd(const name: string);
300 procedure StoreOr(const name: string);
301 procedure StoreXor(const name: string);
302 procedure StoreAbs(const name: string);
303 procedure StoreSign(const name: string);
304 procedure StoreShift(bRight : boolean; const name: string);
305 procedure StoreMul(const name: string);
306 procedure StoreSub(const name: string);
307 procedure StoreInc(const name: string; const val: integer = 1);
308 procedure StoreDec(const name: string; const val: integer = 1);
309 procedure DoAPICommands(const lend, lstart : string);
310 procedure DoResetScreen;
311 procedure DoReadButton(idx : integer);
312 procedure DoBreakContinue(idx : integer; const lbl : string);
313 procedure DoOnFwdRev;
314 procedure DoOnFwdRevReg;
315 procedure DoOnFwdRevSync;
316 procedure DoOnFwdRevEx;
317 procedure DoOnFwdRevRegEx;
318 procedure DoOnFwdRevSyncEx;
319 procedure DoOnFwdRevRegPID;
320 procedure DoOnFwdRevSyncPID;
321 procedure DoOnFwdRevRegExPID;
322 procedure DoOnFwdRevSyncExPID;
323 procedure DoResetCounters;
324 procedure DoRotateMotors(idx : integer);
325 procedure DoTextNumOut(idx : integer);
326 procedure DoFontTextNumOut(idx : integer);
327 procedure DoDrawPoint;
328 procedure DoDrawPoly;
329 procedure DoDrawEllipse;
330 procedure DoDrawLineRect(idx : integer);
331 procedure DoDrawCircle;
332 procedure DoDrawGraphic(idx : integer);
333 procedure DoPlayToneEx;
334 procedure DoPlayFileEx;
335 procedure DoAcquireRelease;
336 procedure DoExitTo;
337 procedure DoSetInputOutput(const idx : integer);
338 procedure DoStop;
339 procedure DoGoto;
340 procedure DoPrecedesFollows;
341 procedure DoReturn;
342 procedure DoStopMotors;
343 procedure DoStopMotorsEx;
344 procedure DoStrCat;
StrCatHelpernull345 function StrCatHelper(const oldasmstr : string; recurseToken : Char) : string;
346 procedure DoSubString;
347 procedure DoStrReplace;
348 procedure DoStrToNum;
349 procedure MoveToCorrectRegister(dt : char);
350 procedure ReportProblem(const lineNo: integer; const fName, msg: string; const err: boolean);
351 procedure Scan;
IsWhitenull352 function IsWhite(c: char): boolean;
IsRelopnull353 function IsRelop(c: char): boolean;
IsOropnull354 function IsOrop(c: char): boolean;
IsDigitnull355 function IsDigit(c: char): boolean;
IsHexnull356 function IsHex(c: char): boolean;
IsAlNumnull357 function IsAlNum(c: char): boolean;
IsAddopnull358 function IsAddop(c: char): boolean;
IsMulopnull359 function IsMulop(c: char): boolean;
360 procedure GetString;
361 procedure CheckNumeric;
ValueIsNumericnull362 function ValueIsNumeric : boolean;
363 procedure CheckString;
364 procedure LoadAPIFunctions;
365 procedure AddAPIFunction(const name : string; id : integer);
WhatIsnull366 function WhatIs(const n: string): TSymbolType;
StringExpressionnull367 function StringExpression(const Name : string; bAdd : boolean = False) : boolean;
368 procedure StringConcatAssignment(const Name : string);
369 procedure StringFunction(const Name : string);
TempSignedByteNamenull370 function TempSignedByteName: string;
TempSignedWordNamenull371 function TempSignedWordName: string;
TempSignedLongNamenull372 function TempSignedLongName : string;
TempUnsignedLongNamenull373 function TempUnsignedLongName : string;
TempFloatNamenull374 function TempFloatName : string;
RegisterNameByStatementTypenull375 function RegisterNameByStatementType(st : TStatementType; name : string = '') : string;
RegisterNamenull376 function RegisterName(name : string = '') : string;
SignedRegisterNamenull377 function SignedRegisterName(name : string = '') : string;
UnsignedRegisterNamenull378 function UnsignedRegisterName(name : string = '') : string;
FloatRegisterNamenull379 function FloatRegisterName(name : string = '') : string;
ZeroFlagnull380 function ZeroFlag : string;
tosnull381 function tos: string;
StrTmpBufNamenull382 function StrTmpBufName(name : string = '') : string;
StrBufNamenull383 function StrBufName(name : string = '') : string;
StrRetValNamenull384 function StrRetValName(name : string = '') : string;
385 procedure StoreString(const Name: string; bNoChecks : boolean = False);
386 procedure AddAPIStringFunction(const name: string; id: integer);
APIStrFuncNameToIDnull387 function APIStrFuncNameToID(procname: string): integer;
IsAPIStrFuncnull388 function IsAPIStrFunc(procname: string): boolean;
389 procedure DoStrLen;
390 // procedure DoSizeOf;
391 procedure DoStrIndex;
392 procedure DoFormatNum;
ReplaceTokensnull393 function ReplaceTokens(const line: string): string;
394 procedure EmitAsmLines(s: string);
395 procedure EmitPoundLine;
IsLocalnull396 function IsLocal(n: string): boolean;
LocalIdxnull397 function LocalIdx(n: string): integer;
IsOldParamnull398 function IsOldParam(n: string): boolean;
IsFuncParamnull399 function IsFuncParam(n: string; bStripInline : boolean = false): boolean;
IsParamnull400 function IsParam(n: string): boolean;
ParamIdxnull401 function ParamIdx(n: string): integer;
402 procedure AllocateHelper(const Name, aVal, Val, tname: string; dt: char);
AlreadyDecoratednull403 function AlreadyDecorated(n : string) : boolean;
GetDecoratedValuenull404 function GetDecoratedValue: string;
GetDecoratedIdentnull405 function GetDecoratedIdent(const val: string): string;
406 procedure PopCmpHelper(const cc: string);
407 procedure GreaterString;
408 procedure NEqualString;
409 procedure CmpHelper(const cc, lhs, rhs : string);
410 procedure GreaterArrayOrUDT(const lhs : string);
411 procedure NEqualArrayOrUDT(const lhs : string);
412 procedure BoolSubExpression;
NewLabelnull413 function NewLabel: string;
414 procedure StoreArray(const name, idx, val: string);
415 procedure CheckTask(const Name: string);
416 procedure StringRelation;
417 procedure ArrayOrUDTRelation;
418 procedure NumericRelation;
419 procedure NumericRelationLTGT;
420 procedure NumericShiftLeftRight;
GetNBCSrcnull421 function GetNBCSrc: TStrings;
FunctionReturnTypenull422 function FunctionReturnType(const name: string): char;
FunctionParameterCountnull423 function FunctionParameterCount(const name: string): integer;
FunctionRequiredParameterCountnull424 function FunctionRequiredParameterCount(const name: string): integer;
FunctionParameterTypenull425 function FunctionParameterType(const name : string; idx : integer) : char;
426 procedure ClearLocals;
427 procedure ClearParams;
428 procedure ClearGlobals;
IsGlobalnull429 function IsGlobal(n: string): boolean;
GlobalIdxnull430 function GlobalIdx(n: string): integer;
431 procedure SetDefines(const Value: TStrings);
GetFunctionParamnull432 function GetFunctionParam(const procname: string;
433 idx: integer): TFunctionParameter;
434 procedure CheckStringConst;
AdvanceToNextParamnull435 function AdvanceToNextParam : string;
FunctionParameterIsConstantnull436 function FunctionParameterIsConstant(const name: string;
437 idx: integer): boolean;
FunctionParameterDefaultValuenull438 function FunctionParameterDefaultValue(const name: string;
439 idx: integer): string;
FunctionParameterHasDefaultnull440 function FunctionParameterHasDefault(const name: string;
441 idx: integer): boolean;
IsParamConstnull442 function IsParamConst(n: string): boolean;
IsLocalConstnull443 function IsLocalConst(n: string): boolean;
IsGlobalConstnull444 function IsGlobalConst(n: string): boolean;
GlobalUsesSafeCallnull445 function GlobalUsesSafeCall(const n: string): boolean;
GetUDTTypenull446 function GetUDTType(n : string) : string;
447 procedure AddTypeNameAlias(const lbl, args : string);
TranslateTypeNamenull448 function TranslateTypeName(const name : string) : string;
449 procedure ProcessEnum(bGlobal : boolean);
450 procedure ProcessTypedef;
451 procedure ProcessStruct(bTypeDef : boolean = False);
452 procedure CheckForTypedef(var bUnsigned, bConst, bInline, bSafeCall : boolean);
IsUserDefinedTypenull453 function IsUserDefinedType(const name : string) : boolean;
RootOfnull454 function RootOf(const name : string) : string;
DataTypeOfDataspaceEntrynull455 function DataTypeOfDataspaceEntry(DE : TDataspaceEntry) : char;
456 procedure LoadSystemFile(S : TStream);
457 procedure CheckForMain;
ProcessArrayDimensionsnull458 function ProcessArrayDimensions(var lenexpr : string) : string;
459 protected
460 fTmpAsmLines : TStrings;
461 fBadProgram : boolean;
462 fProgErrorCount : integer;
463 fDefines : TStrings;
464 procedure InternalParseStream;
465 procedure Clear;
466 property SwitchFixups : TStringList read fSwitchFixups;
467 property SwitchRegisterNames : TStringList read fSwitchRegNames;
468 protected
469 procedure TopDecls; virtual;
470 procedure Header; virtual;
471 procedure Trailer; virtual;
472 procedure PreProcess; virtual;
GetPreProcLexerClassnull473 function GetPreProcLexerClass : TGenLexerClass; virtual;
474 // dataspace definitions property
475 property DataDefinitions : TDataDefs read fDD;
476 property StatementType : TStatementType read fStatementType write SetStatementType;
477 public
478 constructor Create;
479 destructor Destroy; override;
480 procedure Parse(const aFilename : string); overload;
481 procedure Parse(aStream : TStream); overload;
482 procedure Parse(aStrings : TStrings); overload;
483 property Defines : TStrings read fDefines write SetDefines;
484 property NBCSource : TStrings read GetNBCSrc;
485 property CompilerMessages : TStrings read fMessages;
486 property IncludeDirs : TStrings read fIncludeDirs;
487 property CurrentFile : string read fCurFile write SetCurFile;
488 property OptimizeLevel : integer read fOptimizeLevel write fOptimizeLevel;
489 property WarningsOff : boolean read fWarningsOff write fWarningsOff;
490 property EnhancedFirmware : boolean read fEnhancedFirmware write fEnhancedFirmware;
491 property FirmwareVersion : word read fFirmwareVersion write fFirmwareVersion;
492 property IgnoreSystemFile : boolean read fIgnoreSystemFile write fIgnoreSystemFile;
493 property SafeCalls : boolean read fSafeCalls write fSafeCalls;
494 property MaxErrors : word read fMaxErrors write fMaxErrors;
495 property MaxPreprocessorDepth : word read fMaxPreProcDepth write fMaxPreProcDepth;
496 property OnCompilerMessage : TOnCompilerMessage read fOnCompMSg write fOnCompMsg;
497 property ErrorCount : integer read fProgErrorCount;
498 property OnCompilerStatusChange : TCompilerStatusChangeEvent read fOnCompilerStatusChange write fOnCompilerStatusChange;
499 end;
500
501 implementation
502
503 uses
504 SysUtils, Math, uNXCLexer, uNBCLexer, mwGenericLex, uLocalizedStrings,
505 NBCCommonData, NXCDefsData, uNXTConstants, Parser10;
506
507 {--------------------------------------------------------------}
508 { Constant Declarations }
509
510 const
511 TAB = ^I;
512 CR = ^M;
513 LF = ^J;
514
515 var
516 LCount : integer = 0;
517
518 const
519 MAXGLOBALS = 10000;
520 MAXPARAMS = 32;
521
522 {--------------------------------------------------------------}
523 { Type Declarations }
524
525 type
526 SymTab = array[1..MAXGLOBALS] of string;
527 TabPtr = ^SymTab;
528
529 {--------------------------------------------------------------}
530 { Variable Declarations }
531
532 var
533 Look: char = LF; { Lookahead Character }
534 // PrevLook : char;
535 Token: char; { Encoded Token }
536 Value: string; { Unencoded Token }
537
538 var
539 slevel : integer = 1;
540 linenumber : integer; // current source line number
541 totallines : integer = 0;
542
543 var
544 GS_Name : SymTab;
545 GS_Type : array[1..MAXGLOBALS] of char;
546 GS_Size : array[1..MAXGLOBALS] of integer; // size (in 'data type' units)
547 GS_ReturnType : array[1..MAXGLOBALS] of char; // only for procedures
548 NumGlobals : integer = 0;
549
550 {--------------------------------------------------------------}
551 { Definition of Keywords and Token Types }
552
553 const
554 NKW = 32; //18;
555 NKW1 = 33; //19;
556
557 const
558 KWlist: array[1..NKW] of string =
559 ('if', 'else', 'while',
560 'for', 'sub', 'void', 'task',
561 'do', 'repeat', 'switch', 'asm', 'const',
562 'default', 'case', 'typedef', 'inline', 'long', 'enum',
563 'short', 'int', 'unsigned',
564 'char', 'bool', 'byte', 'mutex', 'float', 'string',
565 'struct', 'safecall',
566 'start', 'stop', 'priority'
567 );
568
569 const // 'xileweRWve'
570 KWcode: array[1..NKW1+1] of Char =
571 (TOK_IDENTIFIER, TOK_IF, TOK_ELSE, TOK_WHILE,
572 TOK_FOR, TOK_PROCEDURE, TOK_PROCEDURE, TOK_TASK,
573 TOK_DO, TOK_REPEAT, TOK_SWITCH, TOK_ASM, TOK_CONST,
574 TOK_DEFAULT, TOK_CASE, TOK_TYPEDEF, TOK_INLINE, TOK_LONGDEF, TOK_ENUM,
575 TOK_SHORTDEF, TOK_SHORTDEF, TOK_UNSIGNED,
576 TOK_CHARDEF, TOK_BYTEDEF, TOK_BYTEDEF, TOK_MUTEXDEF, TOK_FLOATDEF, TOK_STRINGDEF,
577 TOK_STRUCT, TOK_SAFECALL,
578 TOK_START, TOK_STOP, TOK_PRIORITY,
579 #0);
580
581 const
582 API_BREAK = 0;
583 API_CONTINUE = 1;
584 API_RETURN = 2;
585 API_GOTO = 3;
586 API_ONFWD = 4;
587 API_ONREV = 5;
588 API_ONFWDREG = 6;
589 API_ONREVREG = 7;
590 API_ONFWDSYNC = 8;
591 API_ONREVSYNC = 9;
592 API_COAST = 10;
593 API_OFF = 11;
594 API_ROTATEMOTOR = 12;
595 API_ROTATEMOTOREX = 13;
596 API_ACQUIRE = 14;
597 API_RELEASE = 15;
598 API_PRECEDES = 16;
599 API_FOLLOWS = 17;
600 API_EXITTO = 18;
601 API_SETINPUT = 19;
602 API_SETOUTPUT = 20;
603 API_STOP = 21;
604 API_FLOAT = 22;
605 API_ONFWDEX = 23;
606 API_ONREVEX = 24;
607 API_ONFWDREGEX = 25;
608 API_ONREVREGEX = 26;
609 API_ONFWDSYNCEX = 27;
610 API_ONREVSYNCEX = 28;
611 API_COASTEX = 29;
612 API_OFFEX = 30;
613 API_ROTATEMOTORPID = 31;
614 API_ROTATEMOTOREXPID = 32;
615 API_RESETTACHOCOUNT = 33;
616 API_RESETBLOCKTACHOCOUNT = 34;
617 API_RESETROTATIONCOUNT = 35;
618 API_RESETALLTACHOCOUNTS = 36;
619 API_ONFWDREGPID = 37;
620 API_ONREVREGPID = 38;
621 API_ONFWDSYNCPID = 39;
622 API_ONREVSYNCPID = 40;
623 API_ONFWDREGEXPID = 41;
624 API_ONREVREGEXPID = 42;
625 API_ONFWDSYNCEXPID = 43;
626 API_ONREVSYNCEXPID = 44;
627
628 APICount = 4+41;
629 APIList : array[0..APICount-1] of string = (
630 'break', 'continue', 'return', 'goto',
631 'OnFwd', 'OnRev', 'OnFwdReg', 'OnRevReg',
632 'OnFwdSync', 'OnRevSync', 'Coast', 'Off',
633 'RotateMotor', 'RotateMotorEx',
634 'Acquire', 'Release', 'Precedes', 'Follows',
635 'ExitTo', 'SetInput', 'SetOutput', 'Stop', 'Float',
636 'OnFwdEx', 'OnRevEx', 'OnFwdRegEx', 'OnRevRegEx',
637 'OnFwdSyncEx', 'OnRevSyncEx', 'CoastEx', 'OffEx',
638 'RotateMotorPID', 'RotateMotorExPID',
639 'ResetTachoCount', 'ResetBlockTachoCount',
640 'ResetRotationCount', 'ResetAllTachoCounts',
641 'OnFwdRegPID', 'OnRevRegPID', 'OnFwdSyncPID', 'OnRevSyncPID',
642 'OnFwdRegExPID', 'OnRevRegExPID', 'OnFwdSyncExPID', 'OnRevSyncExPID'
643 );
644
645 const
646 NonAggregateTypes = [TOK_CHARDEF, TOK_SHORTDEF, TOK_LONGDEF,
647 TOK_BYTEDEF, TOK_USHORTDEF, TOK_ULONGDEF, TOK_FLOATDEF];
648 IntegerTypes = [TOK_CHARDEF, TOK_SHORTDEF, TOK_LONGDEF,
649 TOK_BYTEDEF, TOK_USHORTDEF, TOK_ULONGDEF];
650 const
651 UnsignedIntegerTypes = [TOK_BYTEDEF, TOK_USHORTDEF, TOK_ULONGDEF];
652 SignedIntegerTypes = [TOK_CHARDEF, TOK_SHORTDEF, TOK_LONGDEF];
653 SignedTypes = SignedIntegerTypes + [TOK_FLOATDEF];
654
GetArrayDimensionnull655 function GetArrayDimension(dt : char) : integer;
656 begin
657 case dt of
658 TOK_ARRAYFLOAT..TOK_ARRAYFLOAT4 : Result := Ord(dt) - Ord(TOK_ARRAYFLOAT) + 1;
659 TOK_ARRAYSTRING..TOK_ARRAYSTRING4 : Result := Ord(dt) - Ord(TOK_ARRAYSTRING) + 1;
660 TOK_ARRAYUDT..TOK_ARRAYUDT4 : Result := Ord(dt) - Ord(TOK_ARRAYUDT) + 1;
661 TOK_ARRAYCHARDEF..TOK_ARRAYCHARDEF4 : Result := Ord(dt) - Ord(TOK_ARRAYCHARDEF) + 1;
662 TOK_ARRAYSHORTDEF..TOK_ARRAYSHORTDEF4 : Result := Ord(dt) - Ord(TOK_ARRAYSHORTDEF) + 1;
663 TOK_ARRAYLONGDEF..TOK_ARRAYLONGDEF4 : Result := Ord(dt) - Ord(TOK_ARRAYLONGDEF) + 1;
664 TOK_ARRAYBYTEDEF..TOK_ARRAYBYTEDEF4 : Result := Ord(dt) - Ord(TOK_ARRAYBYTEDEF) + 1;
665 TOK_ARRAYUSHORTDEF..TOK_ARRAYUSHORTDEF4 : Result := Ord(dt) - Ord(TOK_ARRAYUSHORTDEF) + 1;
666 TOK_ARRAYULONGDEF..TOK_ARRAYULONGDEF4 : Result := Ord(dt) - Ord(TOK_ARRAYULONGDEF) + 1;
667 TOK_STRINGDEF : Result := 1; // a string is an array of byte
668 else
669 Result := 0;
670 end;
671 end;
672
IsArrayTypenull673 function IsArrayType(dt: char; bAllowStrings : boolean = False): boolean;
674 begin
675 Result := (dt >= TOK_ARRAYFLOAT) and (dt <= TOK_ARRAYULONGDEF4);
676 if not Result and bAllowStrings then
677 Result := dt = TOK_STRINGDEF;
678 end;
679
IsUDTnull680 function IsUDT(dt: char): boolean;
681 begin
682 Result := dt = TOK_USERDEFINEDTYPE;
683 end;
684
ArrayBaseTypenull685 function ArrayBaseType(dt: char): char;
686 begin
687 case dt of
688 TOK_ARRAYFLOAT..TOK_ARRAYFLOAT4 : Result := TOK_FLOATDEF;
689 TOK_ARRAYSTRING..TOK_ARRAYSTRING4 : Result := TOK_STRINGDEF;
690 TOK_ARRAYUDT..TOK_ARRAYUDT4 : Result := TOK_USERDEFINEDTYPE;
691 TOK_ARRAYCHARDEF..TOK_ARRAYCHARDEF4 : Result := TOK_CHARDEF;
692 TOK_ARRAYSHORTDEF..TOK_ARRAYSHORTDEF4 : Result := TOK_SHORTDEF;
693 TOK_ARRAYLONGDEF..TOK_ARRAYLONGDEF4 : Result := TOK_LONGDEF;
694 TOK_ARRAYBYTEDEF..TOK_ARRAYBYTEDEF4 : Result := TOK_BYTEDEF;
695 TOK_ARRAYUSHORTDEF..TOK_ARRAYUSHORTDEF4 : Result := TOK_USHORTDEF;
696 TOK_ARRAYULONGDEF..TOK_ARRAYULONGDEF4 : Result := TOK_ULONGDEF;
697 TOK_STRINGDEF : Result := TOK_BYTEDEF; // a string is an array of byte
698 else
699 Result := dt;
700 end;
701 end;
702
DataTypeToArrayDimensionsnull703 function DataTypeToArrayDimensions(dt : char) : string;
704 var
705 d, i : integer;
706 begin
707 Result := '';
708 d := GetArrayDimension(dt);
709 for i := 0 to d - 1 do
710 Result := Result + '[]';
711 end;
712
NXCStrToTypenull713 function NXCStrToType(const stype : string; bUseCase : Boolean = false) : TDSType;
714 var
715 tmptype : string;
716 begin
717 tmptype := stype;
718 if not bUseCase then
719 tmptype := LowerCase(tmptype);
720 if (tmptype = 'unsigned char') or (tmptype = 'byte') or (tmptype = 'bool') then
721 Result := dsUByte
722 else if tmptype = 'char' then
723 Result := dsSByte
724 else if (tmptype = 'unsigned int') or (tmptype = 'unsigned short') then
725 Result := dsUWord
726 else if (tmptype = 'int') or (tmptype = 'short') then
727 Result := dsSWord
728 else if tmptype = 'unsigned long' then
729 Result := dsULong
730 else if tmptype = 'long' then
731 Result := dsSLong
732 else if tmptype = 'mutex' then
733 Result := dsMutex
734 else if tmptype = 'float' then
735 Result := dsFloat
736 else if tmptype = 'void' then
737 Result := dsVoid
738 else
739 Result := dsCluster;
740 end;
741
742 procedure TNXCComp.pop;
743 begin
744 dec(fStackDepth);
745 fStackVarNames.Delete(fStackVarNames.Count - 1);
746 end;
747
748 procedure TNXCComp.push;
749 var
750 tosName : string;
751 begin
752 inc(fStackDepth);
753 MaxStackDepth := Max(MaxStackDepth, fStackDepth);
754 if fStatementType = stFloat then
755 tosName := Format('__float_stack_%3.3d%s', [fStackDepth, fCurrentThreadName])
756 else if fStatementType = stUnsigned then
757 tosName := Format('__unsigned_stack_%3.3d%s', [fStackDepth, fCurrentThreadName])
758 else
759 tosName := Format('__signed_stack_%3.3d%s', [fStackDepth, fCurrentThreadName]);
760 fStackVarNames.Add(tosName);
761 end;
762
763 procedure TNXCComp.GetCharX;
764 var
765 bytesread : integer;
766 begin
767 bytesread := fMS.Read(Look, 1);
768 inc(fBytesRead, bytesread);
769 fCurrentLine := fCurrentLine + Look;
770 if Look = LF then
771 begin
772 IncLineNumber;
773 fCurrentLine := '';
774 end;
775 if bytesread < 1 then
776 endofallsource := True;
777 if endofallsource and (slevel > 1) then begin
778 // close file pointer
779 linenumber := 0;
780 dec(slevel);
781 Look := LF;
782 endofallsource := False;
783 end;
784 end;
785
786 {--------------------------------------------------------------}
787 { Read New Character From Input Stream }
788
789 procedure TNXCComp.GetChar;
790 begin
791 if fTempChar <> ' ' then begin
792 Look := fTempChar;
793 fCurrentLine := fCurrentLine + Look;
794 fTempChar := ' ';
795 end
796 else begin
797 GetCharX;
798 if Look = '/' then begin
799 fMS.Read(fTempChar, 1);
800 if fTempChar = '*' then begin
801 Look := TOK_BLOCK_COMMENT;
802 fTempChar := ' ';
803 end
804 else if fTempChar = '/' then begin
805 Look := TOK_LINE_COMMENT;
806 fTempChar := ' ';
807 end
808 else begin
809 // we need to put that character we just read back into the buffer
810 fMS.Seek(-1, soFromCurrent);
811 fTempChar := ' ';
812 end;
813 end;
814 end;
815 end;
816
817
818 {--------------------------------------------------------------}
819 { Report Error and Halt }
820
821 procedure TNXCComp.ReportProblem(const lineNo: integer; const fName,
822 msg: string; const err : boolean);
823 var
824 tmp, tmp1, tmp2, tmp3, tmp4 : string;
825 stop : boolean;
826 begin
827 // exit without doing anything if this is not an error and warnings are off
828 if WarningsOff and not err then
829 Exit;
830 if (lineNo <> fLastErrLine) or (msg <> fLastErrMsg) then
831 begin
832 fLastErrLine := lineNo;
833 fLastErrMsg := msg;
834 if lineNo = -1 then
835 begin
836 tmp := msg;
837 fMessages.Add(tmp);
838 end
839 else
840 begin
841 if err then
842 tmp1 := Format('# Error: %s', [msg])
843 else
844 tmp1 := Format('# Warning: %s', [msg]);
845 fMessages.Add(tmp1);
846 tmp2 := Format('File "%s" ; line %d', [fName, lineNo]);
847 fMessages.Add(tmp2);
848 tmp3 := Format('# %s', [fCurrentLine]);
849 fMessages.Add(tmp3);
850 tmp4 := '#----------------------------------------------------------';
851 fMessages.Add(tmp4);
852 tmp := tmp1+#13#10+tmp2+#13#10+tmp3+#13#10+tmp4;
853 end;
854 fBadProgram := err;
855 if err then
856 inc(fProgErrorCount);
857 stop := (MaxErrors > 0) and (fProgErrorCount >= MaxErrors);
858 if assigned(fOnCompMsg) then
859 fOnCompMsg(tmp, stop);
860 if stop then
861 Abort;
862 end;
863 end;
864
865 procedure TNXCComp.AbortMsg(s: string);
866 begin
867 ReportProblem(linenumber, CurrentFile, s, True);
868 end;
869
870 (*
871 {--------------------------------------------------------------}
872 {Return the size in base units of a standard datatype }
873
SizeOfTypenull874 function TNXCComp.SizeOfType(dt : char) : integer;
875 begin
876 case dt of
877 TOK_CHARDEF, TOK_BYTEDEF : Result := 1;
878 TOK_SHORTDEF, TOK_USHORTDEF : Result := 2;
879 TOK_LONGDEF, TOK_ULONGDEF : Result := 4;
880 TOK_MUTEXDEF : Result := 4;
881 TOK_FLOATDEF : Result := 4; // ???
882 else
883 Result := 0;
884 AbortMsg('SizeOfType() - Unknown Data Type');
885 end;
886 end;
887 *)
888
889 {--------------------------------------------------------------}
890 { Report What Was Expected }
891
892 procedure TNXCComp.Expected(s: string);
893 begin
894 AbortMsg(Format(sExpectedString, [s]));
895 end;
896
897 {--------------------------------------------------------------}
898 { Report an Undefined Identifier }
899
900 procedure TNXCComp.Undefined(n: string);
901 begin
902 AbortMsg(Format(sUndefinedIdentifier, [n]));
903 end;
904
905
906 {--------------------------------------------------------------}
907 { Report a Duplicate Identifier }
908
909 procedure TNXCComp.Duplicate(n: string);
910 begin
911 AbortMsg(Format(sDuplicateIdentifier, [StripDecoration(n)]));
912 end;
913
914
915 {--------------------------------------------------------------}
916 { Check to Make Sure the Current Token is an Identifier }
917
918 procedure TNXCComp.CheckIdent;
919 begin
920 if Token <> TOK_IDENTIFIER then Expected(sIdentifier);
921 end;
922
923 {--------------------------------------------------------------}
924 { Check to Make Sure the Current Token is a Number }
925
TNXCComp.ValueIsNumericnull926 function TNXCComp.ValueIsNumeric: boolean;
927 var
928 vName : string;
929 idx : integer;
930 V : TVariable;
931 begin
932 Result := True;
933 if not (Token in [TOK_NUM, TOK_HEX]) then
934 begin
935 // what about a constant numeric variable?
936 if Token = TOK_IDENTIFIER then
937 begin
938 // it is an identifier
939 vName := GetDecoratedValue;
940 // if it is a global constant then it can be evaluated using our
941 // expression evaluator
942 fCalc.SilentExpression := vName;
943 if fCalc.ParserError then
944 begin
945 // what about a constant local?
946 idx := LocalIdx(vName);
947 if idx <> -1 then
948 begin
949 V := fLocals[idx];
950 if V.IsConstant and (V.Value <> '') then
951 Value := V.Value
952 else
953 Result := False;
954 end
955 else
956 Result := False;
957 end
958 else
959 Value := NBCFloatToStr(fCalc.Value);
960 end
961 else
962 Result := False;
963 end;
964 end;
965
966 procedure TNXCComp.CheckNumeric;
967 begin
968 if not ValueIsNumeric then
969 Expected(sNumber);
970 end;
971
972 procedure TNXCComp.CheckString;
973 begin
974 if (Token <> TOK_STRINGLIT) and
975 not (DataType(Value) in [TOK_STRINGDEF, TOK_ARRAYBYTEDEF, TOK_ARRAYCHARDEF]) then
976 Expected(sStringType);
977 end;
978
979 procedure TNXCComp.CheckStringConst;
980 begin
981 if (Token <> TOK_STRINGLIT) then
982 Expected(sStringLiteral);
983 end;
984
985
986
987 {--------------------------------------------------------------}
988 { Recognize a Decimal Digit }
989
IsDigitnull990 function TNXCComp.IsDigit(c: char): boolean;
991 begin
992 Result := c in ['0'..'9'];
993 end;
994
995 {--------------------------------------------------------------}
996 { Recognize a Hex Digit }
997
TNXCComp.IsHexnull998 function TNXCComp.IsHex(c: char): boolean;
999 begin
1000 Result := IsDigit(c) or (c in ['a'..'f', 'A'..'F']);
1001 end;
1002
1003 {--------------------------------------------------------------}
1004 { Recognize an Alphanumeric }
1005
TNXCComp.IsAlNumnull1006 function TNXCComp.IsAlNum(c: char): boolean;
1007 begin
1008 Result := IsAlpha(c) or IsDigit(c) or (c = '.');
1009 end;
1010
1011 {--------------------------------------------------------------}
1012 { Recognize an Addop }
1013
TNXCComp.IsAddopnull1014 function TNXCComp.IsAddop(c: char) : boolean;
1015 begin
1016 Result := c in ['+', '-'];
1017 end;
1018
1019 {--------------------------------------------------------------}
1020 { Recognize a Mulop }
1021
IsMulopnull1022 function TNXCComp.IsMulop(c: char): boolean;
1023 begin
1024 Result := c in ['*', '/', '%'];
1025 end;
1026
1027 {--------------------------------------------------------------}
1028 { Recognize a Boolean Orop }
1029
IsOropnull1030 function TNXCComp.IsOrop(c: char): boolean;
1031 begin
1032 Result := c in ['|', '^'];
1033 end;
1034
1035 {--------------------------------------------------------------}
1036 { Recognize a Relop }
1037
IsRelopnull1038 function TNXCComp.IsRelop(c: char): boolean;
1039 begin
1040 Result := c in ['=', '!', '<', '>'];
1041 end;
1042
1043 {--------------------------------------------------------------}
1044 { Recognize White Space }
1045
IsWhitenull1046 function TNXCComp.IsWhite(c: char): boolean;
1047 begin
1048 Result := c in [' ', TAB, CR, LF, TOK_BLOCK_COMMENT, TOK_LINE_COMMENT];
1049 end;
1050
1051 {--------------------------------------------------------------}
1052 { Skip A Comment Field }
1053
1054 procedure TNXCComp.SkipCommentBlock;
1055 begin
1056 repeat
1057 repeat
1058 GetCharX;
1059 until (Look = '*') or endofallsource;
1060 GetCharX;
1061 until (Look = '/') or endofallsource;
1062 GetChar;
1063 end;
1064
1065
1066 {--------------------------------------------------------------}
1067 { Skip A Comment To End Of Line field }
1068
1069 procedure TNXCComp.SkipLine;
1070 begin
1071 repeat
1072 GetCharX;
1073 until (Look = LF) or endofallsource;
1074 GetChar;
1075 end;
1076
1077 procedure TNXCComp.SkipDirectiveLine;
1078 begin
1079 fDirLine := Value + ' ';
1080 SkipWhite;
1081 repeat
1082 fDirLine := fDirLine + Look;
1083 GetCharX;
1084 until (Look = LF) or endofallsource;
1085 fDirLine := fDirLine + Look;
1086 GetChar;
1087 end;
1088
1089 {--------------------------------------------------------------}
1090 { Skip Over Leading White Space }
1091
1092 procedure TNXCComp.SkipWhite;
1093 begin
1094 while IsWhite(Look) and not endofallsource do begin
1095 case Look of
1096 TOK_LINE_COMMENT : SkipLine;
1097 TOK_BLOCK_COMMENT : SkipCommentBlock;
1098 else
1099 GetChar;
1100 end;
1101 end;
1102 end;
1103
1104
1105 {--------------------------------------------------------------}
1106 { Table Lookup }
1107
Lookupnull1108 function Lookup(T: TabPtr; s: string; n: integer): integer;
1109 var
1110 i: integer;
1111 found: Boolean;
1112 begin
1113 found := false;
1114 i := n;
1115 while (i > 0) and not found do
1116 if s = T^[i] then
1117 found := true
1118 else
1119 dec(i);
1120 Result := i;
1121 end;
1122
1123
1124 {--------------------------------------------------------------}
1125 { Locate a Symbol in Table }
1126 { Returns the index of the entry. Zero if not present. }
1127
TNXCComp.GlobalIdxnull1128 function TNXCComp.GlobalIdx(n: string): integer;
1129 begin
1130 Result := Lookup(@GS_Name, RootOf(n), NumGlobals);
1131 end;
1132
TNXCComp.IsGlobalnull1133 function TNXCComp.IsGlobal(n: string): boolean;
1134 begin
1135 Result := GlobalIdx(RootOf(n)) <> 0;
1136 end;
1137
TNXCComp.IsGlobalConstnull1138 function TNXCComp.IsGlobalConst(n: string): boolean;
1139 var
1140 i : integer;
1141 begin
1142 Result := False;
1143 i := fGlobals.IndexOfName(RootOf(n));
1144 if i <> -1 then
1145 Result := fGlobals[i].IsConstant;
1146 end;
1147
TNXCComp.GlobalDataTypenull1148 function TNXCComp.GlobalDataType(const n: string): char;
1149 var
1150 i : integer;
1151 begin
1152 Result := #0;
1153 i := fGlobals.IndexOfName(RootOf(n));
1154 if i <> -1 then
1155 Result := fGlobals[i].DataType;
1156 end;
1157
TNXCComp.GlobalTypeNamenull1158 function TNXCComp.GlobalTypeName(const n: string): string;
1159 var
1160 i : integer;
1161 begin
1162 Result := '';
1163 i := fGlobals.IndexOfName(RootOf(n));
1164 if i <> -1 then
1165 Result := fGlobals[i].TypeName;
1166 end;
1167
GlobalUsesSafeCallnull1168 function TNXCComp.GlobalUsesSafeCall(const n: string): boolean;
1169 var
1170 i : integer;
1171 begin
1172 Result := False;
1173 i := fGlobals.IndexOfName(RootOf(n));
1174 if i <> -1 then
1175 Result := fGlobals[i].UseSafeCall;
1176 end;
1177
TNXCComp.AlreadyDecoratednull1178 function TNXCComp.AlreadyDecorated(n: string): boolean;
1179 var
1180 i : integer;
1181 tmp : string;
1182 begin
1183 // a variable is considered to be already decorated if it
1184 // starts with "__" followed by a task name followed by DECOR_SEP
1185 // OR it starts with "__signed_stack_"
1186 // OR it starts with "__unsigned_stack_"
1187 // OR it starts with "__float_stack_"
1188 // OR it starts with %%CALLER%%_
1189 Result := False;
1190 i := Pos('__', n);
1191 if i = 1 then
1192 begin
1193 System.Delete(n, 1, 2); // remove the '__' at the beginning
1194 Result := Pos('%%CALLER%%_', n) = 1;
1195 if Result then Exit;
1196 i := Pos(DECOR_SEP, n);
1197 if i > 1 then
1198 begin
1199 tmp := Copy(n, 1, i-1);
1200 i := fThreadNames.IndexOf(tmp);
1201 Result := (i <> -1) or (tmp = 'signed_stack') or
1202 (tmp = 'unsigned_stack') or (tmp = 'float_stack');
1203 end;
1204 end;
1205 end;
1206
1207 {--------------------------------------------------------------}
1208 { Look for Symbol in Parameter Table }
1209
IsOldParamnull1210 function TNXCComp.IsOldParam(n: string): boolean;
1211 begin
1212 Result := ParamIdx(RootOf(n)) <> -1{0};
1213 end;
1214
TNXCComp.IsFuncParamnull1215 function TNXCComp.IsFuncParam(n: string; bStripInline : boolean): boolean;
1216 var
1217 i : integer;
1218 fp : TFunctionParameter;
1219 decvar : string;
1220 begin
1221 Result := False;
1222 // check in the fFuncParams
1223 for i := 0 to fFuncParams.Count - 1 do
1224 begin
1225 fp := fFuncParams[i];
1226 decvar := ApplyDecoration(fp.ProcName, fp.Name, 0);
1227 if bStripInline and fp.FuncIsInline then
1228 begin
1229 if decvar = StripInline(RootOf(n)) then
1230 begin
1231 Result := True;
1232 Break;
1233 end;
1234 end
1235 else
1236 begin
1237 if decvar = RootOf(n) then
1238 begin
1239 Result := True;
1240 Break;
1241 end;
1242 end;
1243 end;
1244 end;
1245
FuncParamDataTypenull1246 function TNXCComp.FuncParamDataType(const n: string): char;
1247 var
1248 i : integer;
1249 fp : TFunctionParameter;
1250 decvar : string;
1251 begin
1252 Result := #0;
1253 // check in the fFuncParams
1254 for i := 0 to fFuncParams.Count - 1 do
1255 begin
1256 fp := fFuncParams[i];
1257 decvar := ApplyDecoration(fp.ProcName, fp.Name, 0);
1258 if decvar = StripInline(RootOf(n)) then
1259 begin
1260 Result := fp.ParameterDataType;
1261 Break;
1262 end;
1263 end;
1264 end;
1265
TNXCComp.IsParamnull1266 function TNXCComp.IsParam(n: string): boolean;
1267 begin
1268 Result := IsOldParam(n);
1269 if not Result then
1270 Result := IsFuncParam(n);
1271 end;
1272
TNXCComp.ParamIdxnull1273 function TNXCComp.ParamIdx(n: string): integer;
1274 begin
1275 n := RootOf(n);
1276 if AlreadyDecorated(n) then
1277 Result := fParams.IndexOfName(n)
1278 else
1279 Result := fParams.IndexOfName(ApplyDecoration(fCurrentThreadName, n, 0));
1280 end;
1281
TNXCComp.IsParamConstnull1282 function TNXCComp.IsParamConst(n: string): boolean;
1283 var
1284 i : integer;
1285 begin
1286 Result := False;
1287 i := ParamIdx(RootOf(n));
1288 if i <> -1 then
1289 Result := fParams[i].IsConstant;
1290 end;
1291
1292 {
ParamConstantValuenull1293 function TNXCComp.ParamConstantValue(const n: string): string;
1294 var
1295 i : integer;
1296 begin
1297 Result := n;
1298 i := ParamIdx(RootOf(n));
1299 if i <> -1 then
1300 begin
1301 if fParams[i].IsConstant then
1302 Result := fParams[i].Value;
1303 end;
1304 end;
1305 }
1306
1307 function TNXCComp.ParamDataType(const n: string): char;
1308 var
1309 i : integer;
1310 begin
1311 i := ParamIdx(RootOf(n));
1312 if i <> -1 then
1313 Result := fParams[i].DataType
1314 else
1315 begin
parameternull1316 // maybe a function parameter?
1317 Result := FuncParamDataType(RootOf(n));
1318 end;
1319 end;
1320
ParamTypeNamenull1321 function TNXCComp.ParamTypeName(const n: string): string;
1322 var
1323 i : integer;
1324 begin
1325 Result := '';
1326 i := ParamIdx(RootOf(n));
1327 if i <> -1 then
1328 Result := fParams[i].TypeName;
1329 end;
1330
1331 {--------------------------------------------------------------}
1332 { Look for Symbol in Local Table }
1333
IsLocalnull1334 function TNXCComp.IsLocal(n: string): boolean;
1335 begin
1336 Result := LocalIdx(RootOf(n)) <> -1{0};
1337 if not Result then
1338 begin
1339 // is this a special internal variable name?
1340 end;
1341 end;
1342
LocalIdxnull1343 function TNXCComp.LocalIdx(n: string): integer;
1344 var
1345 i : integer;
1346 begin
1347 n := RootOf(n);
1348 if AlreadyDecorated(n) then
1349 Result := fLocals.IndexOfName(n)
1350 else
1351 begin
1352 Result := -1;
1353 for i := fNestingLevel downto 0 do
1354 begin
1355 Result := fLocals.IndexOfName(ApplyDecoration(fCurrentThreadName, n, i));
1356 if Result > -1 then
1357 break;
1358 end;
1359 end;
1360 end;
1361
IsLocalConstnull1362 function TNXCComp.IsLocalConst(n: string): boolean;
1363 var
1364 i : integer;
1365 begin
1366 Result := False;
1367 i := LocalIdx(RootOf(n));
1368 if i <> -1 then
1369 Result := fLocals[i].IsConstant;
1370 end;
1371
LocalConstantValuenull1372 function TNXCComp.LocalConstantValue(const n: string): string;
1373 var
1374 i : integer;
1375 begin
1376 Result := n;
1377 i := LocalIdx(RootOf(n));
1378 if i <> -1 then
1379 begin
1380 if fLocals[i].IsConstant then
1381 Result := fLocals[i].Value;
1382 end;
1383 end;
1384
LocalDataTypenull1385 function TNXCComp.LocalDataType(const n: string): char;
1386 var
1387 i : integer;
1388 begin
1389 Result := #0;
1390 i := LocalIdx(RootOf(n));
1391 if i <> -1 then
1392 Result := fLocals[i].DataType;
1393 end;
1394
TNXCComp.LocalTypeNamenull1395 function TNXCComp.LocalTypeName(const n: string): string;
1396 var
1397 i : integer;
1398 begin
1399 Result := '';
1400 i := LocalIdx(RootOf(n));
1401 if i <> -1 then
1402 Result := fLocals[i].TypeName;
1403 end;
1404
1405 {--------------------------------------------------------------}
1406 { Check to See if an Identifier is in the Symbol Table }
1407 { Report an error if it's not. }
1408
1409 procedure TNXCComp.CheckTable(const N: string);
1410 begin
1411 if not IsParam(N) and
1412 not IsLocal(N) and
1413 not IsGlobal(N) then
1414 Undefined(N);
1415 end;
1416
1417 procedure TNXCComp.CheckGlobal(const N: string);
1418 begin
1419 if not IsGlobal(N) then
1420 Undefined(N);
1421 end;
1422
1423 {--------------------------------------------------------------}
1424 { Check the Symbol Table for a Duplicate Identifier }
1425 { Report an error if identifier is already in table. }
1426
1427
1428 procedure TNXCComp.CheckDup(N: string);
1429 begin
1430 if IsGlobal(N) then
1431 Duplicate(N);
1432 end;
1433
1434
1435 {--------------------------------------------------------------}
1436 { Add a New Entry to Symbol Table }
1437
AddEntrynull1438 function TNXCComp.AddEntry(N: string; dt: char; const tname, lenexp : string;
1439 bConst, bSafeCall : boolean) : integer;
1440 var
1441 V : TVariable;
1442 begin
1443 CheckForValidDataType(dt);
1444 CheckDup(N);
1445 if NumGlobals = MAXGLOBALS then AbortMsg(sSymbolTableFull);
1446 Inc(NumGlobals);
1447 GS_Name[NumGlobals] := N;
1448 GS_Type[NumGlobals] := dt;
1449
1450 V := fGlobals.Add;
1451 with V do
1452 begin
1453 Name := N;
1454 DataType := dt;
1455 IsConstant := bConst;
1456 UseSafeCall := bSafeCall;
1457 TypeName := tname;
1458 LenExpr := lenexp;
1459 end;
1460 Result := V.Index;
1461 end;
1462
1463
1464 {--------------------------------------------------------------}
1465 { Get an preprocessor directive }
1466
1467 procedure TNXCComp.GetDirective;
1468 begin
1469 SkipWhite;
1470 if Look <> '#' then Expected(sDirective);
1471 Token := TOK_DIRECTIVE;
1472 Value := '';
1473 repeat
1474 Value := Value + Look;
1475 GetChar;
1476 until not IsAlpha(Look);
1477 end;
1478
1479 {--------------------------------------------------------------}
1480 { Get an Identifier }
1481
1482 procedure TNXCComp.GetName;
1483 begin
1484 SkipWhite;
1485 if not IsAlpha(Look) then Expected(sIdentifier);
1486 Token := TOK_IDENTIFIER;
1487 Value := '';
1488 repeat
1489 Value := Value + Look;
1490 GetChar;
1491 until not IsAlNum(Look);
1492 fExpStrHasVars := True;
1493 HandleSpecialNames;
1494 end;
1495
1496
1497 {--------------------------------------------------------------}
1498 { Get a Number }
1499
1500 procedure TNXCComp.GetNum;
1501 var
1502 savedLook : char;
1503 begin
1504 SkipWhite;
1505 if not IsDigit(Look) then Expected(sNumber);
1506 savedLook := Look;
1507 GetChar;
1508 if Look in ['x', 'X'] then
1509 begin
1510 GetHexNum;
1511 end
1512 else
1513 begin
1514 Token := TOK_NUM;
1515 Value := savedLook;
1516 if not (IsDigit(Look) or (Look = '.')) then Exit;
1517 repeat
1518 Value := Value + Look;
1519 GetChar;
1520 until not (IsDigit(Look) or (Look = '.'));
1521 end;
1522 end;
1523
1524
1525 {--------------------------------------------------------------}
1526 { Get a Hex Number }
1527
1528 procedure TNXCComp.GetHexNum;
1529 begin
1530 SkipWhite;
1531 GetChar(); // skip the $ (or 'x')
1532 if not IsHex(Look) then Expected(sHexNumber);
1533 Token := TOK_HEX;
1534 Value := '0x';
1535 repeat
1536 Value := Value + Look;
1537 GetChar;
1538 until not IsHex(Look);
1539 end;
1540
1541
1542 {--------------------------------------------------------------}
1543 { Get a Character Literal }
1544
1545 procedure TNXCComp.GetCharLit;
1546 var
1547 i : integer;
1548 begin
1549 GetCharX; // skip the '
1550 Token := TOK_NUM;
1551 if Look = '\' then
1552 begin
1553 GetCharX; // skip the '\'
1554 i := Pos(Look, 'abfnrtv''"\?');
1555 case i of
1556 1 : Value := '7'; // bell
1557 2 : Value := '8'; // backspace
1558 3 : Value := '12'; // formfeed
1559 4 : Value := '10'; // new line
1560 5 : Value := '13'; // carriage return
1561 6 : Value := '9'; // tab
1562 7 : Value := '11'; // vertical tab
1563 8 : Value := '39'; // single quote
1564 9 : Value := '34'; // double quote
1565 10 : Value := '92'; // backslash
1566 11 : Value := '63'; // question mark
1567 else
1568 Value := IntToStr(Ord(Look));
1569 end;
1570 end
1571 else
1572 begin
1573 Value := IntToStr(Ord(Look));
1574 end;
1575 GetCharX;
1576 if Look <> '''' then Expected(sCharLiteral);
1577 GetChar;
1578 end;
1579
1580 {--------------------------------------------------------------}
1581 { Get a string Literal }
1582
1583 procedure TNXCComp.GetString;
1584 var
1585 bEscapeNext : boolean;
1586 begin
1587 GetCharX; // skip the "
1588 Token := TOK_STRINGLIT;
1589 if Look = '"' then
1590 begin
1591 // empty string
1592 Value := '''''';
1593 end
1594 else
1595 begin
1596 bEscapeNext := False;
1597 Value := '''';
1598 if (Look = '''') then
1599 Value := Value + '\'''
1600 else
1601 Value := Value + Look;
1602 repeat
1603 if not bEscapeNext then
1604 bEscapeNext := Look = '\'
1605 else
1606 bEscapeNext := False;
1607 GetCharX;
1608 if not ((Look = LF) or ((Look = '"') and not bEscapeNext)) then
1609 begin
1610 if (Look = '''') and not bEscapeNext then
1611 Value := Value + '\'''
1612 else
1613 Value := Value + Look;
1614 end;
1615 until ((Look = '"') and not bEscapeNext) or (Look = LF) or endofallsource;
1616 Value := Value + '''';
1617 if Look <> '"' then Expected(sStringLiteral);
1618 end;
1619 GetChar;
1620 end;
1621
1622
1623 {--------------------------------------------------------------}
1624 { Get an Operator }
1625
1626 procedure TNXCComp.GetOp;
1627 begin
1628 SkipWhite;
1629 Token := Look;
1630 Value := Look;
1631 GetChar;
1632 end;
1633
1634
1635 {--------------------------------------------------------------}
1636 { Get the Next Input Token }
1637
1638 procedure TNXCComp.Next(bProcessDirectives : boolean);
1639 begin
1640 SkipWhite;
1641 if Look = '''' then GetCharLit
1642 else if Look = '"' then GetString
1643 else if Look = '#' then GetDirective
1644 else if IsAlpha(Look) then GetName
1645 else if IsDigit(Look) then GetNum
1646 else if Look = '$' then GetHexNum
1647 else GetOp;
1648 if bProcessDirectives then
1649 begin
1650 ProcessDirectives(False);
1651 fExpStr := fExpStr + Value;
1652 end;
1653 if not fProcessingAsmBlock and
1654 not (Token in ['<', '>', '|', '^', '&', '%', '/', '*', '-', '+', '=']) then
1655 SkipWhite; // also skip any whitespace after this token
1656 end;
1657
1658 function IsAPICommand(const name : string) : boolean;
1659 var
1660 i : integer;
1661 begin
1662 Result := False;
1663 for i := Low(APIList) to High(APIList) do
1664 begin
1665 if APIList[i] = name then
1666 begin
1667 Result := True;
1668 Break;
1669 end;
1670 end;
1671 end;
1672
1673 {--------------------------------------------------------------}
1674 { Scan the Current Identifier for Keywords }
1675
1676 procedure TNXCComp.Scan;
1677 var
1678 idx : integer;
1679 begin
1680 if Token = TOK_IDENTIFIER then
1681 begin
1682 idx := Lookup(Addr(KWlist), Value, NKW);
1683 if idx <> 0 then
1684 Token := KWcode[idx + 1]
1685 else
1686 begin
1687 // is it an API command?
1688 if IsAPICommand(Value) then
1689 Token := TOK_API
1690 else if IsUserDefinedType(Value) then
1691 Token := TOK_USERDEFINEDTYPE;
1692 end;
1693 end;
1694 end;
1695
1696
1697 {--------------------------------------------------------------}
1698 { Match a Specific Input String }
1699
1700 procedure TNXCComp.MatchString(x: string);
1701 begin
1702 if Value <> x then Expected('''' + x + '''');
1703 Next;
1704 end;
1705
1706
1707 {--------------------------------------------------------------}
1708 { Match a Semicolon }
1709
1710 procedure TNXCComp.Semi;
1711 begin
1712 MatchString(TOK_SEMICOLON);
1713 // if Token = TOK_SEMICOLON then
1714 // Next;
1715 end;
1716
1717 {
1718 procedure TNXCComp.OptionalSemi;
1719 begin
1720 if Token = TOK_SEMICOLON then
1721 Next;
1722 end;
1723 }
1724
1725 {--------------------------------------------------------------}
1726 { Output a String with Tab and CRLF }
1727
1728 procedure TNXCComp.EmitLn(s: string);
1729 begin
1730 EmitPoundLine;
1731 NBCSource.Add(#9+s);
1732 end;
1733
1734 procedure TNXCComp.EmitPoundLine;
1735 begin
1736 NBCSource.Add('#line ' + IntToStr(linenumber-1) + ' "' + CurrentFile + '"');
1737 end;
1738
1739
1740 {--------------------------------------------------------------}
1741 { Output a String without Tab with CRLF }
1742
1743 procedure TNXCComp.EmitLnNoTab(s: string);
1744 begin
1745 NBCSource.Add(s);
1746 end;
1747
1748 procedure TNXCComp.EmitAsmLines(s: string);
1749 begin
1750 if Pos(#10, s) > 0 then
1751 begin
1752 fTmpAsmLines.Text := s;
1753 NBCSource.Add(Format('#pragma macro %d', [fTmpAsmLines.Count]));
1754 NBCSource.AddStrings(fTmpAsmLines);
1755 EmitPoundLine;
1756 end
1757 else
1758 NBCSource.Add(s);
1759 end;
1760
1761
1762 {--------------------------------------------------------------}
1763 { Generate a Unique Label }
1764
NewLabelnull1765 function TNXCComp.NewLabel: string;
1766 var
1767 S: string;
1768 begin
1769 S := '';
1770 Str(LCount, S);
1771 NewLabel := LABEL_PREFIX + S;
1772 Inc(LCount);
1773 end;
1774
1775
1776 {--------------------------------------------------------------}
1777 { Post a Label To Output }
1778
1779 procedure TNXCComp.PostLabel(L: string);
1780 begin
1781 EmitLnNoTab(L+':');
1782 end;
1783
1784
1785 {---------------------------------------------------------------}
1786 { Initialize Parameter Table to Null }
1787 procedure TNXCComp.ClearParams;
1788 begin
1789 fParams.Clear;
1790 end;
1791
1792 {---------------------------------------------------------------}
1793 { Initialize Locals Table to Null }
1794 procedure TNXCComp.ClearLocals;
1795 begin
1796 fLocals.Clear;
1797 fEmittedLocals.Clear;
1798 end;
1799
1800 procedure TNXCComp.ClearGlobals;
1801 var
1802 i : integer;
1803 begin
1804 for i := 1 to MAXGLOBALS do
1805 begin
1806 GS_Name[i] := '';
1807 GS_Type[i] := #0;
1808 GS_Size[i] := 0;
1809 GS_ReturnType[i] := #0;
1810 end;
1811 NumGlobals := 0;
1812 fGlobals.Clear;
1813 end;
1814
1815
1816
1817 {--------------------------------------------------------------}
1818 { Add a Parameter to Table }
1819
1820 procedure TNXCComp.AddParam(N: string; dt: char; const tname : string;
1821 bConst : boolean; bHasDefault : boolean; const defValue : string);
1822 begin
1823 CheckForValidDataType(dt);
1824 if IsOldParam(N) then Duplicate(N);
1825 with fParams.Add do
1826 begin
1827 Name := N;
1828 DataType := dt;
1829 IsConstant := bConst;
1830 TypeName := tname;
1831 end;
1832 end;
1833
WhatIsnull1834 function TNXCComp.WhatIs(const n : string) : TSymbolType;
1835 begin
1836 // calling IsOldParam and IsFuncParam separately in order to
1837 // tell IsFuncParam to strip inline decoration in this case.
1838 if IsOldParam(n) then Result := stParam
1839 else if IsFuncParam(n, True) then Result := stParam
1840 else if IsLocal(n) then Result := stLocal
1841 else if IsGlobal(n) then Result := stGlobal
1842 else if IsAPIFunc(n) then Result := stAPIFunc
1843 else if IsAPIStrFunc(n) then Result := stAPIStrFunc
1844 else Result := stUnknown;
1845 end;
1846
DataTypenull1847 function TNXCComp.DataType(const n : string) : char;
1848 var
1849 p : integer;
1850 tname : string;
1851 DE : TDataspaceEntry;
1852 begin
1853 if (n = '') then
1854 Result := TOK_LONGDEF
1855 else if (n = 'true') or (n = 'false') or (n = '1') or (n = '0') then
1856 Result := TOK_BYTEDEF
1857 else
1858 begin
1859 case WhatIs(n) of
1860 stParam : begin
1861 Result := ParamDataType(n);
1862 p := Pos('.', n);
1863 if (Result = TOK_USERDEFINEDTYPE) and (p > 0) then
1864 begin
1865 tname := ParamTypeName(n);
1866 DE := DataDefinitions.FindEntryByFullName(tname + Copy(n, p, MaxInt));
1867 Result := DataTypeOfDataspaceEntry(DE);
1868 end;
1869 end;
1870 stLocal : begin
1871 Result := LocalDataType(n);
1872 p := Pos('.', n);
1873 if (Result = TOK_USERDEFINEDTYPE) and (p > 0) then
1874 begin
1875 tname := LocalTypeName(n);
1876 DE := DataDefinitions.FindEntryByFullName(tname + Copy(n, p, MaxInt));
1877 Result := DataTypeOfDataspaceEntry(DE);
1878 end;
1879 end;
1880 stGlobal : begin
1881 Result := GlobalDataType(n);
1882 p := Pos('.', n);
1883 if (Result = TOK_USERDEFINEDTYPE) and (p > 0) then
1884 begin
1885 tname := GlobalTypeName(n);
1886 DE := DataDefinitions.FindEntryByFullName(tname + Copy(n, p, MaxInt));
1887 Result := DataTypeOfDataspaceEntry(DE);
1888 end;
1889 end;
1890 stAPIFunc : Result := TOK_APIFUNC;
1891 stAPIStrFunc : Result := TOK_APISTRFUNC;
1892 else
1893 // handle some special cases (register variables)
1894 if (Pos('__strretval', n) = 1) or (Pos('__strtmpbuf', n) = 1) or (Pos('__strbuf', n) = 1) then
1895 Result := TOK_STRINGDEF
1896 else if (Pos('__D0', n) = 1) or (Pos('__signed_stack_', n) = 1) or (Pos('__tmpslong', n) = 1) then
1897 Result := TOK_LONGDEF
1898 else if (Pos('__DU0', n) = 1) or (Pos('__unsigned_stack_', n) = 1) or (Pos('__tmplong', n) = 1) then
1899 Result := TOK_ULONGDEF
1900 else if (Pos('__DF0', n) = 1) or (Pos('__float_stack_', n) = 1) or (Pos('__tmpfloat', n) = 1) then
1901 Result := TOK_FLOATDEF
1902 else if (Pos('__zf', n) = 1) then
1903 Result := TOK_BYTEDEF
1904 else if (Pos('__tmpsbyte', n) = 1) then
1905 Result := TOK_CHARDEF
1906 else if (Pos('__tmpsword', n) = 1) then
1907 Result := TOK_SHORTDEF
1908 else
1909 begin
1910 Result := #0;
1911 Undefined(StripDecoration(n));
1912 end;
1913 end;
1914 end;
1915 end;
1916
DataTypeNamenull1917 function TNXCComp.DataTypeName(const n : string) : string;
1918 begin
1919 Result := '';
1920 case WhatIs(n) of
1921 stParam : begin
1922 Result := ParamTypeName(n);
1923 end;
1924 stLocal : begin
1925 Result := LocalTypeName(n);
1926 end;
1927 stGlobal : begin
1928 Result := GlobalTypeName(n);
1929 end;
1930 end;
1931 end;
1932
ArrayOfTypenull1933 function TNXCComp.ArrayOfType(dt: char; dimensions : integer): char;
1934 begin
1935 Result := dt;
1936 if (dimensions > 4) or (dimensions < 1) then begin
1937 AbortMsg(sInvalidArrayDim);
1938 Exit;
1939 end
1940 else begin
1941 dec(dimensions); // convert 1-4 range into 0-3 range
1942 case dt of
1943 TOK_CHARDEF : begin
1944 Result := Char(Ord(TOK_ARRAYCHARDEF)+dimensions);
1945 end;
1946 TOK_SHORTDEF : begin
1947 Result := Char(Ord(TOK_ARRAYSHORTDEF)+dimensions);
1948 end;
1949 TOK_LONGDEF : begin
1950 Result := Char(Ord(TOK_ARRAYLONGDEF)+dimensions);
1951 end;
1952 TOK_BYTEDEF : begin
1953 Result := Char(Ord(TOK_ARRAYBYTEDEF)+dimensions);
1954 end;
1955 TOK_USHORTDEF : begin
1956 Result := Char(Ord(TOK_ARRAYUSHORTDEF)+dimensions);
1957 end;
1958 TOK_ULONGDEF : begin
1959 Result := Char(Ord(TOK_ARRAYULONGDEF)+dimensions);
1960 end;
1961 TOK_USERDEFINEDTYPE : begin
1962 Result := Char(Ord(TOK_ARRAYUDT)+dimensions);
1963 end;
1964 TOK_STRINGDEF : begin
1965 Result := Char(Ord(TOK_ARRAYSTRING)+dimensions);
1966 end;
1967 TOK_FLOATDEF : begin
1968 Result := Char(Ord(TOK_ARRAYFLOAT)+dimensions);
1969 end;
1970 else
1971 Result := dt;
1972 end;
1973 end;
1974 end;
1975
1976 {---------------------------------------------------------------}
1977 { Add Primary or var }
1978
1979 procedure TNXCComp.StoreAdd(const name : string);
1980 begin
1981 EmitLn(Format('add %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
1982 end;
1983
1984 {---------------------------------------------------------------}
1985 { Subtract Primary from var }
1986
1987 procedure TNXCComp.StoreSub(const name : string);
1988 begin
1989 EmitLn(Format('sub %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
1990 end;
1991
1992 {---------------------------------------------------------------}
1993 { Multiply Primary with var }
1994
1995 procedure TNXCComp.StoreMul(const name : string);
1996 begin
1997 EmitLn(Format('mul %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
1998 end;
1999
2000 {---------------------------------------------------------------}
2001 { Divide Primary with var }
2002
2003 procedure TNXCComp.StoreDiv(const name : string);
2004 begin
2005 // check for unsafe division (signed by unsigned)
2006 if (DataType(name) in SignedTypes) and (StatementType = stUnsigned) then
2007 begin
2008 // cast the unsigned type to a signed type
2009 EmitLn(Format('mov %s, %s', [SignedRegisterName, UnsignedRegisterName]));
2010 StatementType := stSigned;
2011 end;
2012 EmitLn(Format('div %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
2013 end;
2014
2015 {---------------------------------------------------------------}
2016 { Mod Primary with var }
2017
2018 procedure TNXCComp.StoreMod(const name : string);
2019 begin
2020 EmitLn(Format('mod %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
2021 end;
2022
2023 procedure TNXCComp.StoreAbs(const name: string);
2024 begin
2025 EmitLn(Format('abs %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
2026 end;
2027
2028 procedure TNXCComp.StoreAnd(const name: string);
2029 begin
2030 EmitLn(Format('and %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
2031 end;
2032
2033 procedure TNXCComp.StoreOr(const name: string);
2034 begin
2035 EmitLn(Format('or %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
2036 end;
2037
2038 procedure TNXCComp.StoreShift(bRight: boolean; const name: string);
2039 begin
2040 if bRight then
2041 EmitLn(Format('shr %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]))
2042 else
2043 EmitLn(Format('shl %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
2044 end;
2045
2046 procedure TNXCComp.StoreSign(const name: string);
2047 begin
2048 EmitLn(Format('sign %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
2049 end;
2050
2051 procedure TNXCComp.StoreXor(const name: string);
2052 begin
2053 EmitLn(Format('xor %0:s, %0:s, %s', [GetDecoratedIdent(name), RegisterName]));
2054 end;
2055
2056 {---------------------------------------------------------------}
2057 { increment var }
2058
2059 procedure TNXCComp.StoreInc(const name : string; const val : integer);
2060 begin
2061 EmitLn(Format('add %0:s, %0:s, %d', [GetDecoratedIdent(name), val]));
2062 end;
2063
2064 {---------------------------------------------------------------}
2065 { decrement var }
2066
2067 procedure TNXCComp.StoreDec(const name : string; const val : integer);
2068 begin
2069 EmitLn(Format('sub %0:s, %0:s, %d', [GetDecoratedIdent(name), val]));
2070 end;
2071
2072 {---------------------------------------------------------------}
2073 { Clear the Primary Register }
2074
2075 procedure TNXCComp.ClearReg;
2076 var
2077 fmtStr : string;
2078 begin
2079 fCCSet := False;
2080 // 2009-03-18 JCH: It is never safe to use "set" with a float variable
2081 if StatementType = stFloat then
2082 fmtStr := 'mov %s, 0'
2083 else
2084 fmtStr := 'set %s, 0';
2085 EmitLn(Format(fmtStr, [RegisterName]));
2086 end;
2087
2088 {---------------------------------------------------------------}
2089 { Bitwise Negate the Primary Register }
2090
2091 procedure TNXCComp.Complement;
2092 begin
2093 CheckEnhancedFirmware;
2094 fCCSet := False;
2095 EmitLn(Format('cmnt %0:s, %0:s', [RegisterName]));
2096 end;
2097
2098 {---------------------------------------------------------------}
2099 { Negate the Primary Register }
2100
2101 procedure TNXCComp.Negate;
2102 begin
2103 fCCSet := False;
2104 EmitLn(Format('neg %0:s, %0:s', [RegisterName]));
2105 end;
2106
2107 {---------------------------------------------------------------}
2108 { Complement the Primary Register }
2109
2110 procedure TNXCComp.NotIt;
2111 begin
2112 fCCSet := False;
2113 EmitLn(Format('not %0:s, %0:s', [RegisterName]));
2114 end;
2115
2116
2117 {---------------------------------------------------------------}
2118 { Load a Constant Value to Primary Register }
2119
2120 procedure TNXCComp.LoadConst(n: string);
2121 var
2122 cval : int64;
2123 tmpSrc : string;
2124 begin
2125 fLastLoadedConst := n;
2126 if (Pos('.', n) > 0) or (StatementType = stFloat) then
2127 begin
2128 tmpSrc := 'mov %s, %s';
2129 StatementType := stFloat;
2130 end
2131 else
2132 begin
2133 cval := StrToInt64Def(n, 0);
2134 if cval <= MaxInt then
2135 StatementType := stSigned
2136 else
2137 StatementType := stUnsigned;
2138 if (cval > High(smallint)) or
2139 ((cval < 0) and (not EnhancedFirmware or (cval < Low(smallint)))) then
2140 tmpSrc := 'mov %s, %s'
2141 else
2142 tmpSrc := 'set %s, %s';
2143 end;
2144 fCCSet := False;
2145 EmitLn(Format(tmpSrc, [RegisterName, n]));
2146 end;
2147
2148 procedure TNXCComp.CheckNotProc(const Name : string);
2149 begin
2150 if DataType(Name) in [TOK_PROCEDURE, TOK_TASK] then
2151 AbortMsg(sAssignTaskError);
2152 end;
2153
2154 procedure TNXCComp.CheckTask(const Name : string);
2155 begin
2156 if DataType(Name) <> TOK_TASK then
2157 AbortMsg(sArgMustBeTask);
2158 end;
2159
2160 {---------------------------------------------------------------}
2161 { Load a Variable to Primary Register }
2162
2163 procedure TNXCComp.LoadVar(const Name: string);
2164 var
2165 dt : Char;
2166 begin
2167 CheckNotProc(Name);
2168 dt := DataType(Name);
2169 if dt = TOK_FLOATDEF then
2170 StatementType := stFloat
2171 else if not (dt in UnsignedIntegerTypes) then
2172 StatementType := stSigned
2173 else
2174 StatementType := stUnsigned;
2175 fCCSet := False;
2176 EmitLn(Format('mov %s, %s', [RegisterName, GetDecoratedIdent(Name)]));
2177 end;
2178
2179 {---------------------------------------------------------------}
2180 { Push Primary onto Stack }
2181
2182 procedure TNXCComp.PushPrim;
2183 begin
2184 push;
2185 EmitLn(Format('mov %1:s, %0:s', [RegisterName, tos]));
2186 end;
2187
2188 {---------------------------------------------------------------}
2189 { Add Top of Stack to Primary }
2190
2191 procedure TNXCComp.PopAdd;
2192 begin
2193 fCCSet := False;
2194 EmitLn(Format('add %2:s, %1:s, %0:s', [RegisterName, tos, RegisterName]));
2195 pop;
2196 end;
2197
2198 {---------------------------------------------------------------}
2199 { Subtract Primary from Top of Stack }
2200
2201 procedure TNXCComp.PopSub;
2202 begin
2203 fCCSet := False;
2204 EmitLn(Format('sub %2:s, %1:s, %0:s', [RegisterName, tos, RegisterName]));
2205 pop;
2206 end;
2207
2208 {---------------------------------------------------------------}
2209 { Multiply Top of Stack by Primary }
2210
2211 procedure TNXCComp.PopMul;
2212 begin
2213 fCCSet := False;
2214 EmitLn(Format('mul %2:s, %1:s, %0:s', [RegisterName, tos, RegisterName]));
2215 pop;
2216 end;
2217
2218 {---------------------------------------------------------------}
2219 { Divide Top of Stack by Primary }
2220
2221 procedure TNXCComp.PopDiv;
2222 var
2223 p0, p1, p2 : string;
2224 begin
2225 p0 := RegisterName;
2226 p1 := tos;
2227 p2 := RegisterName;
2228 if (DataType(p1) in SignedTypes) and (DataType(p0) in UnsignedIntegerTypes) then
2229 begin
2230 // cast the unsigned type to a signed type
2231 EmitLn(Format('mov %s, %s', [SignedRegisterName, UnsignedRegisterName]));
2232 p0 := SignedRegisterName;
2233 end;
2234 fCCSet := False;
2235 EmitLn(Format('div %2:s, %1:s, %0:s', [p0, p1, p2]));
2236 pop;
2237 end;
2238
2239 {---------------------------------------------------------------}
2240 { Modulo Top of Stack by Primary }
2241
2242 procedure TNXCComp.PopMod;
2243 begin
2244 fCCSet := False;
2245 EmitLn(Format('mod %2:s, %1:s, %0:s', [RegisterName, tos, RegisterName]));
2246 pop;
2247 end;
2248
2249 {---------------------------------------------------------------}
2250 { AND Top of Stack with Primary }
2251
2252 procedure TNXCComp.PopAnd;
2253 begin
2254 fCCSet := False;
2255 EmitLn(Format('and %2:s, %1:s, %0:s', [RegisterName, tos, RegisterName]));
2256 pop;
2257 end;
2258
2259 {---------------------------------------------------------------}
2260 { OR Top of Stack with Primary }
2261
2262 procedure TNXCComp.PopOr;
2263 begin
2264 fCCSet := False;
2265 EmitLn(Format('or %2:s, %1:s, %0:s', [RegisterName, tos, RegisterName]));
2266 pop;
2267 end;
2268
2269 {---------------------------------------------------------------}
2270 { XOR Top of Stack with Primary }
2271
2272 procedure TNXCComp.PopXor;
2273 begin
2274 fCCSet := False;
2275 EmitLn(Format('xor %2:s, %1:s, %0:s', [RegisterName, tos, RegisterName]));
2276 pop;
2277 end;
2278
2279
2280 {---------------------------------------------------------------}
2281 { Left Shift Top of Stack to Primary }
2282
2283 procedure TNXCComp.PopLeftShift;
2284 begin
2285 fCCSet := False;
2286 EmitLn(Format('shl %2:s, %1:s, %0:s', [RegisterName, tos, RegisterName]));
2287 pop;
2288 end;
2289
2290 {---------------------------------------------------------------}
2291 { Right Shift Top of Stack to Primary }
2292
2293 procedure TNXCComp.PopRightShift;
2294 begin
2295 fCCSet := False;
2296 EmitLn(Format('shr %2:s, %1:s, %0:s', [RegisterName, tos, RegisterName]));
2297 pop;
2298 end;
2299
2300 {---------------------------------------------------------------}
2301 { Set zero flag based on __D0 value }
2302
2303 procedure TNXCComp.SetZeroCC;
2304 begin
2305 fCCSet := True;
2306 EmitLn(Format('tst NEQ, %s, %s',[ZeroFlag, RegisterName]));
2307 end;
2308
FunctionReturnTypenull2309 function TNXCComp.FunctionReturnType(const name : string) : char;
2310 var
2311 i : integer;
2312 begin
2313 Result := #0;
2314 i := GlobalIdx(name);
2315 if (i > 0) and (GS_Type[i] = TOK_PROCEDURE) then
2316 Result := GS_ReturnType[i];
2317 end;
2318
ValueIsStringTypenull2319 function TNXCComp.ValueIsStringType(var dt : char): boolean;
2320 begin
2321 if Token = TOK_IDENTIFIER then
2322 dt := DataType(Value)
2323 else
2324 dt := #0;
2325 Result := IsAPIStrFunc(Value);
2326 if not Result then
2327 begin
2328 Result := (Token = TOK_STRINGLIT) or
2329 ((Token = TOK_IDENTIFIER) and
2330 (dt in [TOK_STRINGDEF{, TOK_ARRAYBYTEDEF, TOK_ARRAYCHARDEF}]));
2331 if not Result then begin
2332 Result := FunctionReturnType(Value) in [TOK_STRINGDEF{, TOK_ARRAYBYTEDEF, TOK_ARRAYCHARDEF}];
2333 if not Result then begin
2334 // what about a string array?
2335 Result := (Token = TOK_IDENTIFIER) and
2336 (dt in [TOK_ARRAYSTRING..TOK_ARRAYSTRING4]) and
2337 (Look = '[');
2338 end;
2339 end
2340 else
2341 begin
2342 // if we are indexing into the string then it is not really a string type
2343 if Look = '[' then
2344 Result := False;
2345 end;
2346 end;
2347 end;
2348
ValueIsArrayTypenull2349 function TNXCComp.ValueIsArrayType: boolean;
2350 begin
2351 Result := IsArrayType(DataType(Value));
2352 end;
2353
ValueIsUserDefinedTypenull2354 function TNXCComp.ValueIsUserDefinedType: boolean;
2355 begin
2356 Result := DataType(Value) = TOK_USERDEFINEDTYPE;
2357 end;
2358
2359 procedure TNXCComp.CmpHelper(const cc, lhs, rhs: string);
2360 begin
2361 fCCSet := True;
2362 EmitLn(Format('cmp %s, %s, %s, %s',[cc, ZeroFlag, lhs, rhs]));
2363 end;
2364
2365 procedure TNXCComp.PopCmpHelper(const cc : string);
2366 begin
2367 CmpHelper(cc, tos, RegisterName);
2368 pop;
2369 end;
2370
2371 {---------------------------------------------------------------}
2372 { Set __zf If Compare was = }
2373
2374 procedure TNXCComp.PopCmpEqual;
2375 begin
2376 PopCmpHelper('EQ');
2377 end;
2378
2379 {---------------------------------------------------------------}
2380 { Set __D0 If Compare was != }
2381
2382 procedure TNXCComp.PopCmpNEqual;
2383 begin
2384 PopCmpHelper('NEQ');
2385 end;
2386
2387 {---------------------------------------------------------------}
2388 { Set __D0 If Compare was > }
2389
2390 procedure TNXCComp.PopCmpGreater;
2391 begin
2392 PopCmpHelper('GT');
2393 end;
2394
2395 {---------------------------------------------------------------}
2396 { Set __D0 If Compare was < }
2397
2398 procedure TNXCComp.PopCmpLess;
2399 begin
2400 PopCmpHelper('LT');
2401 end;
2402
2403 {---------------------------------------------------------------}
2404 { Set __D0 If Compare was <= }
2405
2406 procedure TNXCComp.PopCmpLessOrEqual;
2407 begin
2408 PopCmpHelper('LTEQ');
2409 end;
2410
2411 {---------------------------------------------------------------}
2412 { Set __D0 If Compare was >= }
2413
2414 procedure TNXCComp.PopCmpGreaterOrEqual;
2415 begin
2416 PopCmpHelper('GTEQ');
2417 end;
2418
2419 {---------------------------------------------------------------}
2420 { Store Primary to Variable }
2421
2422 procedure TNXCComp.Store(const Name: string; bNoChecks : boolean);
2423 begin
2424 if not bNoChecks then
2425 CheckNotProc(Name);
2426 EmitLn(Format('mov %s, %s',[GetDecoratedIdent(Name), RegisterName]));
2427 end;
2428
2429 procedure TNXCComp.StoreString(const Name : string; bNoChecks : boolean);
2430 begin
2431 if not bNoChecks then
2432 CheckNotProc(Name);
2433 EmitLn(Format('mov %s, %s', [GetDecoratedIdent(Name), StrBufName]));
2434 end;
2435
2436 {---------------------------------------------------------------}
2437 { Branch Unconditional }
2438
2439 procedure TNXCComp.Branch(L: string);
2440 begin
2441 EmitLn('jmp ' + L);
2442 end;
2443
2444 {---------------------------------------------------------------}
2445 { Branch False }
2446
2447 procedure TNXCComp.BranchFalse(L: string);
2448 begin
2449 // if the condition code has not been set then set it manually
2450 if not fCCSet then
2451 SetZeroCC;
2452 EmitLn(Format('brtst EQ, %s, %s', [L, ZeroFlag]));
2453 end;
2454
2455 {---------------------------------------------------------------}
2456 { Branch True }
2457
2458 procedure TNXCComp.BranchTrue(L: string);
2459 begin
2460 // if the condition code has not been set then set it manually
2461 if not fCCSet then
2462 SetZeroCC;
2463 EmitLn(Format('brtst NEQ, %s, %s', [L, ZeroFlag]));
2464 end;
2465
2466 {--------------------------------------------------------------}
2467 { Write Header Info }
2468
2469 procedure TNXCComp.Header;
2470 begin
2471 // do nothing
2472 end;
2473
2474 {--------------------------------------------------------------}
2475 { Write Trailer Info }
2476
2477 procedure TNXCComp.Trailer;
2478 var
2479 tmp : TStrings;
2480 begin
2481 DoCompilerStatusChange(sNXCGenerateTrailer);
2482 CheckForMain;
2483 // handle stack variables
2484 tmp := TStringList.Create;
2485 try
2486 tmp.AddStrings(NBCSource);
2487 NBCSource.Clear;
2488 // emit struct decls
2489 NBCSource.AddStrings(fStructDecls);
2490 EmitLnNoTab('dseg segment');
2491 // structures
2492 EmitNXCRequiredStructs;
2493 EmitLn('__SSMArgs TNXCSetScreenMode');
2494 EmitLn('__SPTArgs TNXCSoundPlayTone');
2495 EmitLn('__SPFArgs TNXCSoundPlayFile');
2496 // mutexes
2497 EmitLn('__SSMArgsMutex mutex');
2498 EmitLn('__SPTArgsMutex mutex');
2499 EmitLn('__SPFArgsMutex mutex');
2500
2501 EmitRegisters;
2502 EmitStackVariables;
2503
2504 EmitLnNoTab('dseg ends');
2505 NBCSource.AddStrings(tmp);
2506 // output the array initialization subroutine last
2507 EmitGlobalDataInitSubroutine;
2508 finally
2509 tmp.Free;
2510 end;
2511 end;
2512
2513 {--------------------------------------------------------------}
2514 { Write the Prolog }
2515
2516 procedure TNXCComp.Prolog(const name : string; bIsSub : boolean);
2517 begin
2518 if bIsSub then
2519 begin
2520 if AmInlining then
2521 begin
2522 fCurrentInlineFunction := fInlineFunctions.Add;
2523 fCurrentInlineFunction.Name := name;
2524 end
2525 else
2526 EmitLnNoTab('subroutine ' + name);
2527 end
2528 else
2529 EmitLnNoTab('thread ' + name);
2530 end;
2531
2532 {--------------------------------------------------------------}
2533 { Write the Epilog }
2534
2535 procedure TNXCComp.Epilog(bIsSub : boolean);
2536 begin
2537 if bIsSub then
2538 begin
2539 if AmInlining then
2540 begin
2541 DecrementInlineDepth;
2542 // dec(fInlineDepth);
2543 // fInlining := False;
2544 end
2545 else
2546 begin
2547 EmitLn('return');
2548 EmitLnNoTab('ends');
2549 end;
2550 end
2551 else
2552 EmitLnNoTab('endt');
2553 EmitLnNoTab('');
2554 end;
2555
2556 {--------------------------------------------------------------}
2557 { Allocate Storage for a Static variable }
2558
2559 procedure TNXCComp.AllocateHelper(const Name, aVal, Val, tname: string; dt : char);
2560 begin
2561 case dt of
2562 TOK_CHARDEF,
2563 TOK_ARRAYCHARDEF..TOK_ARRAYCHARDEF4 :
2564 EmitLn(Format('%s sbyte%s %s', [Name, aVal, Val]));
2565 TOK_SHORTDEF,
2566 TOK_ARRAYSHORTDEF..TOK_ARRAYSHORTDEF4 :
2567 EmitLn(Format('%s sword%s %s', [Name, aVal, Val]));
2568 TOK_LONGDEF,
2569 TOK_ARRAYLONGDEF..TOK_ARRAYLONGDEF4 :
2570 EmitLn(Format('%s sdword%s %s', [Name, aVal, Val]));
2571 TOK_BYTEDEF,
2572 TOK_ARRAYBYTEDEF..TOK_ARRAYBYTEDEF4 :
2573 EmitLn(Format('%s byte%s %s', [Name, aVal, Val]));
2574 TOK_USHORTDEF,
2575 TOK_ARRAYUSHORTDEF..TOK_ARRAYUSHORTDEF4 :
2576 EmitLn(Format('%s word%s %s', [Name, aVal, Val]));
2577 TOK_ULONGDEF,
2578 TOK_ARRAYULONGDEF..TOK_ARRAYULONGDEF4 :
2579 EmitLn(Format('%s dword%s %s', [Name, aVal, Val]));
2580 TOK_MUTEXDEF : EmitLn(Format('%s mutex', [Name]));
2581 TOK_FLOATDEF,
2582 TOK_ARRAYFLOAT..TOK_ARRAYFLOAT4 :
2583 EmitLn(Format('%s float%s %s', [Name, aVal, Val]));
2584 TOK_STRINGDEF : EmitLn(Format('%s byte[] %s', [Name, Val]));
2585 TOK_ARRAYSTRING..TOK_ARRAYSTRING4 :
2586 EmitLn(Format('%s byte[]%s %s', [Name, aVal, Val]));
2587 TOK_USERDEFINEDTYPE,
2588 TOK_ARRAYUDT..TOK_ARRAYUDT4 :
2589 EmitLn(Format('%s %s%s %s', [Name, tname, aVal, Val]));
2590 else
2591 AbortMsg(sUnknownDatatype);
2592 end;
2593 end;
2594
2595 procedure TNXCComp.Allocate(const Name, aVal, Val, tname: string; dt : char);
2596 //var
2597 // oldInlining : boolean;
2598 begin
2599 if (dt in [TOK_FLOATDEF, TOK_ARRAYFLOAT..TOK_ARRAYFLOAT4]) and
2600 (FirmwareVersion < MIN_FW_VER2X) then
2601 AbortMsg(sFloatNotSupported);
2602 // 2007-07-05 JCH:
2603 // changed this function to perform no code generation of variable
2604 // declarations whatsoever if the current function is marked
2605 // as inline.
2606 // Instead all the local variable and parameter information is gathered
2607 // in data structures to be output at the point of the first call of
2608 // the inline function on a per CALLER basis (i.e., once per caller)
2609 // the variables will be decorated at that point with the CALLER name
2610 // and an indication that these are inline variables.
2611 // For each local variable and function parameter stored in the
2612 // data structures for a particular inline function the body of the
2613 // inline function code will be processed and any matching tokens
2614 // (i.e., the names of these variables) will be replaced with the
2615 // decorated version of the local variable or function parameter name
2616 if AmInlining then Exit;
2617 // variables are not output within inline functions
2618 // oldInlining := fInlining;
2619 try
2620 // fInlining := False;
2621 EmitLnNoTab('dseg segment');
2622 AllocateHelper(Name, aVal, Val, tname, dt);
2623 EmitLnNoTab('dseg ends');
2624 finally
2625 // fInlining := oldInlining;
2626 end;
2627 end;
2628
2629 {---------------------------------------------------------------}
2630 { Parse and Translate a Math Factor with Leading NOT }
2631
2632 procedure TNXCComp.NotNumericFactor;
2633 begin
2634 if Token = '~' then begin // handle unary complement
2635 Next;
2636 NumericFactor;
2637 Complement;
2638 end
2639 else if Token = '!' then // handle unary logical not
2640 begin
2641 Next;
2642 NumericFactor;
2643 NotIt;
2644 end
2645 else
2646 NumericFactor;
2647 end;
2648
2649 {---------------------------------------------------------------}
2650 { Parse and Translate a Math Factor }
2651
2652 procedure TNXCComp.NumericFactor;
2653 var
2654 savedtoken, rdt : char;
2655 savedvalue : string;
2656 oldNoCommas : boolean;
2657 begin
2658 if Token = TOK_OPENPAREN then begin
2659 OpenParen;
2660 // Next;
2661 oldNoCommas := fNoCommaOperator;
2662 try
2663 fNoCommaOperator := False;
2664 CommaExpression;
2665 finally
2666 fNoCommaOperator := oldNoCommas;
2667 end;
2668 CloseParen;
2669 end
2670 else begin
2671 // scan here so that Token is changed from IDENTIFIER to the
2672 // appropriate keyword token
2673 Scan;
2674 savedtoken := Token;
2675 savedvalue := Value;
2676 // JCH fix bug where function call with whitespace between function name
2677 // and open paren was causing a compiler error. (2007-12-10)
2678 if (savedtoken = TOK_IDENTIFIER) and (DataType(savedvalue) = TOK_PROCEDURE) then
2679 begin
2680 rdt := FunctionReturnType(savedvalue);
2681 if (rdt <> #0) and (rdt <> TOK_STRINGDEF) then
2682 DoCall(savedvalue)
2683 else
2684 AbortMsg(sInvalidReturnType);
2685 end
2686 else
2687 begin
2688 Next;
2689 case savedtoken of
2690 TOK_IDENTIFIER : begin
2691 if Token = '[' then
2692 begin
2693 fArrayIndexStack.Clear;
2694 // DoArrayIndex(DataType(fLHSName), fLHSName, savedvalue);
2695 // DoArrayIndex(ArrayBaseType(DataType(savedvalue)), fLHSName, savedvalue);
2696 DoNewArrayIndex(DataType(savedvalue), savedvalue, fLHSName);
2697 end
2698 else if ((Token = '+') and (Look = '+')) or
2699 ((Token = '-') and (Look = '-')) then
2700 begin
2701 // increment/decrement
2702 LoadVar(savedvalue);
2703 if Token = '+' then
2704 StoreInc(savedvalue, 1)
2705 else
2706 StoreDec(savedvalue, 1);
2707 Next;
2708 Next;
2709 end
2710 // The next two blocks are not exactly C with respect to operator precedence
2711 // A better way to allow for assignment/math assignment within an expression
2712 // should be found. 2010-06-07 JCH
2713 else if (Token in ['+', '-', '/', '*', '%', '&', '|', '^']) and (Look = '=') then
2714 begin
2715 MathAssignment(savedvalue);
2716 LoadVar(savedvalue);
2717 end
2718 else if (Token = '=') and (Look <> '=') then
2719 begin
2720 // var = expression rather than var == expression
2721 // i.e., an assignment statement
2722 Next;
2723 DoAssignValue(savedvalue, DataType(savedvalue));
2724 LoadVar(savedvalue);
2725 end
2726 //
2727 // end of not exactly C handling of assignment/math assignment
2728 //
2729 else if savedvalue = 'true' then
2730 LoadConst('1')
2731 else if savedvalue = 'false' then
2732 LoadConst('0')
2733 else if IsAPIFunc(savedvalue) then
2734 begin
2735 DoCallAPIFunc(savedvalue);
2736 end
2737 else if IsArrayType(fLHSDataType) and not fProcessingMathAssignment then
2738 begin
2739 rdt := DataType(savedvalue);
2740 if not TypesAreCompatible(fLHSDataType, rdt) then
2741 AbortMsg(sDatatypesNotCompatible)
2742 else
2743 EmitLn(Format('mov %s, %s', [GetDecoratedIdent(fLHSName), GetDecoratedIdent(savedvalue)]));
2744 end
2745 else if (fLHSDataType = TOK_USERDEFINEDTYPE) and not fProcessingMathAssignment then
2746 begin
2747 if GetUDTType(fLHSName) <> GetUDTType(savedvalue) then
2748 AbortMsg(sUDTNotEqual)
2749 else
2750 EmitLn(Format('mov %s, %s', [GetDecoratedIdent(fLHSName), GetDecoratedIdent(savedvalue)]));
2751 end
2752 else
2753 LoadVar(savedvalue);
2754 end;
2755 TOK_ASM : begin
2756 DoAsm(fLHSDataType);
2757 end;
2758 TOK_NUM, TOK_HEX : begin
2759 LoadConst(savedvalue);
2760 end;
2761 '-' : begin
2762 if Token = TOK_NUM then
2763 begin
2764 LoadConst(savedvalue+value);
2765 Next;
2766 end
2767 else
2768 Expected(sMathFactor);
2769 end;
2770 else
2771 Expected(sMathFactor);
2772 end;
2773 end;
2774 end;
2775 end;
2776
2777 {--------------------------------------------------------------}
2778 { Recognize and Translate a Multiply }
2779
2780 procedure TNXCComp.Multiply;
2781 begin
2782 Next;
2783 NotNumericFactor;
2784 PopMul;
2785 end;
2786
2787 {-------------------------------------------------------------}
2788 { Recognize and Translate a Divide }
2789
2790 procedure TNXCComp.Divide;
2791 begin
2792 Next;
2793 NotNumericFactor;
2794 PopDiv;
2795 end;
2796
2797 {-------------------------------------------------------------}
2798 { Recognize and Translate a Module }
2799
2800 procedure TNXCComp.Modulo;
2801 begin
2802 Next;
2803 NotNumericFactor;
2804 PopMod;
2805 end;
2806
2807 {---------------------------------------------------------------}
2808 { Parse and Translate a Math Term }
2809
2810 procedure TNXCComp.Term;
2811 begin
2812 NotNumericFactor;
2813 while IsMulop(Token) do begin
2814 PushPrim;
2815 case Token of
2816 '*': Multiply;
2817 '/': Divide;
2818 '%': Modulo;
2819 end;
2820 end;
2821 end;
2822
2823 {--------------------------------------------------------------}
2824 { Recognize and Translate an Add }
2825
2826 procedure TNXCComp.Add;
2827 begin
2828 Next;
2829 Term;
2830 PopAdd;
2831 end;
2832
2833 {-------------------------------------------------------------}
2834 { Recognize and Translate a Subtract }
2835
2836 procedure TNXCComp.Subtract;
2837 begin
2838 Next;
2839 Term;
2840 PopSub;
2841 end;
2842
2843 {---------------------------------------------------------------}
2844 { Parse and Translate an Expression }
2845
2846 procedure TNXCComp.Expression;
2847 var
2848 prev, lenVal : integer;
2849 oldExpStr, optExp : string;
2850 begin
2851 fExpStrHasVars := False;
2852 // 2009-04-09 JCH:
2853 // Store the old expression string and restore it at the end of this routine
2854 // so that recursive optimizations do not destroy the previous level of
2855 // the expression. This fixes the bug caused by commenting out
2856 // "and not (fExpStr[1] in ['+', '-'])" in the OptimizeExpression function
2857 // below. Without this, an expression like x = MyFunc(233)+10; was being
2858 // optimized to x = 10;
2859 oldExpStr := fExpStr;
2860 try
2861 // set the old expression to be everything except for the first token in
2862 // the new expression (aka "Value").
2863 lenVal := Length(Value);
2864 Delete(oldExpStr, Length(oldExpStr)-lenVal+1, lenVal);
2865 // now start our new expression with the current token
2866 fExpStr := Value;
2867 prev := NBCSource.Count;
2868 if IncrementOrDecrement then
2869 begin
2870 // handle pre-increment or pre-decrement unary operators
2871 DoPreIncOrDec(true);
2872 end
2873 else
2874 begin
2875 if IsAddOp(Token) then
2876 ClearReg // handle + and - unary operators
2877 else
2878 Term;
2879 while IsAddop(Token) do begin
2880 PushPrim;
2881 case Token of
2882 '+': Add;
2883 '-': Subtract;
2884 end;
2885 end;
2886 optExp := OptimizeExpression(prev);
2887 end;
2888 finally
2889 fExpStr := oldExpStr + optExp + Value;
2890 end;
2891 end;
2892
OptimizeExpressionnull2893 function TNXCComp.OptimizeExpression(const idx: integer) : string;
2894 begin
2895 fLastExpressionOptimizedToConst := False;
2896 System.Delete(fExpStr, Length(fExpStr), 1);
2897 Result := fExpStr;
2898 if (OptimizeLevel >= 1) and (NBCSource.Count > (idx+1)) and
2899 not fExpStrHasVars then
2900 begin
2901 // 2009-03-18 JCH: I do not recall why I added the check for
2902 // + and - as the first character of an expression
2903 // I haven't been able to detect any harm in removing this check but
2904 // it could be something very obscure that will come up again
2905
above.null2906 // 2009-04-09 JCH: See my comment in the Expression function above.
2907 // The commented-out code was preventing a bug that had far too many
2908 // lines of code being removed if an expression ended in +nnn or -nnn.
2909
2910 if (fExpStr <> '') {and not (fExpStr[1] in ['+', '-'])} then
2911 begin
2912 fCalc.SilentExpression := fExpStr;
2913 if not fCalc.ParserError then
2914 begin
2915 if StatementType = stFloat then
2916 fExpStr := NBCFloatToStr(fCalc.Value)
2917 else
2918 fExpStr := IntToStr(Trunc(fCalc.Value));
2919 Result := fExpStr;
2920 // in theory, we can replace all the lines between idx and
2921 // NBCSource.Count with one line
2922 while NBCSource.Count > idx do
2923 NBCSource.Delete(NBCSource.Count-1);
2924 LoadConst(fExpStr);
2925 fExpStr := '';
2926 fLastExpressionOptimizedToConst := True;
2927 end;
2928 end;
2929 end;
2930 end;
2931
2932 {---------------------------------------------------------------}
2933 { Parse and Translate a String Expression }
2934
2935 procedure TNXCComp.StringConcatAssignment(const Name: string);
2936 begin
2937 if Look = '=' then
2938 begin
2939 Next; // move to '='
2940 Next; // move to next token
2941 StringExpression(Name, True);
2942 StoreString(Name);
2943 end
2944 else
2945 AbortMsg(sInvalidStringAssign);
2946 end;
2947
TNXCComp.GetDecoratedIdentnull2948 function TNXCComp.GetDecoratedIdent(const val : string) : string;
2949 var
2950 i : integer;
2951 begin
2952 Result := val;
2953 if not AlreadyDecorated(val) then
2954 begin
2955 case WhatIs(val) of
2956 stParam :
2957 Result := ApplyDecoration(fCurrentThreadName, val, 0);
2958 stLocal : begin
2959 // apply decoration at greatest nesting level and iterate
2960 // until we find the right value.
2961 for i := fNestingLevel downto 0 do
2962 begin
2963 Result := ApplyDecoration(fCurrentThreadName, val, i);
2964 if IsLocal(Result) then
2965 break;
2966 end;
2967 end;
2968 else
2969 Result := val;
2970 end;
2971 end;
2972 end;
2973
TNXCComp.GetDecoratedValuenull2974 function TNXCComp.GetDecoratedValue : string;
2975 begin
2976 Result := GetDecoratedIdent(Value);
2977 end;
2978
TNXCComp.StringExpressionnull2979 function TNXCComp.StringExpression(const Name : string; bAdd : boolean) : boolean;
2980 var
2981 asmStr, val, aval, tmpStr : string;
2982 dt : char;
2983 AHV : TArrayHelperVar;
2984 begin
2985 Result := False;
2986 SkipWhite;
2987 fCCSet := False;
2988 asmStr := '';
2989 if Look = TOK_OPENPAREN then
2990 begin
callnull2991 // a function call that returns a string
2992 val := Value;
2993 if DataType(val) = TOK_PROCEDURE then
2994 begin
2995 if FunctionReturnType(val) = TOK_STRINGDEF then
2996 DoCall(val)
2997 else
2998 Expected(sStringReturnValue);
2999 end
3000 else
3001 begin
3002 Next; // move to TOK_OPENPAREN
alnull3003 StringFunction(val);
3004 end;
3005 tmpStr := StrRetValName;
3006 if bAdd then
3007 asmStr := Format('strcat %s, %s, ', [StrBufName, GetDecoratedIdent(Name)])
3008 else
3009 asmStr := Format('strcat %s, ', [StrBufName]);
3010 end
3011 else if Look = '[' then
3012 begin
3013 val := Value;
3014 Next;
3015 fArrayIndexStack.Clear;
3016 Result := DoNewArrayIndex(DataType(val), val, StrRetValName);
3017 tmpStr := StrRetValName;
3018 if bAdd then
3019 asmStr := Format('strcat %s, %s, ', [StrBufName, GetDecoratedIdent(Name)])
3020 else
3021 asmStr := Format('strcat %s, ', [StrBufName]);
3022 end
3023 else if Value = 'asm' then
3024 begin
3025 // asm
3026 Next;
3027 dt := #0;
3028 DoAsm(dt);
3029 fSemiColonRequired := True;
3030 if dt <> TOK_STRINGDEF then
3031 Expected(sStringReturnValue)
3032 else
3033 begin
3034 tmpStr := StrRetValName;
3035 if bAdd then
3036 asmStr := Format('strcat %s, %s, ', [StrBufName, GetDecoratedIdent(Name)])
3037 else
3038 asmStr := Format('strcat %s, ', [StrBufName]);
3039 end;
3040 end
3041 else
3042 begin
3043 CheckString;
3044 tmpStr := GetDecoratedValue;
3045 if bAdd then
3046 asmStr := Format('strcat %s, %s, ', [StrBufName, GetDecoratedIdent(Name)])
3047 else
3048 asmStr := Format('strcat %s, ', [StrBufName]);
3049 Next;
3050 end;
3051 // in all cases we may want to recurse
3052 if Token = '+' then
3053 begin
3054 // we are overloading the + for string concatenation
3055 // we need to store the value from this string expression into
3056 // a temporary variable so that it is not overwritten by
3057 // recursing into subsequent string expressions
3058 AHV := fArrayHelpers.GetHelper(fCurrentThreadName, '', TOK_ARRAYBYTEDEF);
3059 try
3060 aval := AHV.Name;
3061 if fGlobals.IndexOfName(aval) = -1 then
3062 AddEntry(aval, TOK_ARRAYBYTEDEF, '', '');
3063 // move result of string expression to newly allocated temporary variable
3064 EmitLn(Format('mov %s, %s', [aval, tmpStr]));
3065 Next; // skip past the +
3066 asmStr := asmStr + StrCatHelper(aval + ', ', '+');
3067 {
3068 while Token = '+' do begin
3069 Next; // skip past +
3070 CheckString;
3071 asmStr := asmStr + ', ' + GetDecoratedValue;
3072 Next;
3073 end;
3074 }
3075 finally
3076 fArrayHelpers.ReleaseHelper(AHV);
3077 end;
3078 end
3079 else
3080 begin
3081 // no string concatenation
3082 asmStr := asmStr + tmpStr; // add in the variable from this string expression
3083 end;
3084 if asmStr <> '' then
3085 EmitLn(asmStr);
3086 end;
3087
3088 procedure TNXCComp.EqualArrayOrUDT(const lhs : string);
3089 var
3090 rhs : string;
3091 begin
3092 Next; // two equal signs of equality comparison
3093 MatchString('=');
3094 CheckIdent;
3095 rhs := Value;
3096 Next;
3097 CmpHelper('EQ', lhs, GetDecoratedIdent(rhs));
3098 StoreZeroFlag;
3099 end;
3100
3101 procedure TNXCComp.LessArrayOrUDT(const lhs : string);
3102 var
3103 rhs : string;
3104 begin
3105 Next;
3106 case Token of
3107 '=' : begin
3108 Next;
3109 CheckIdent;
3110 rhs := Value;
3111 Next;
3112 CmpHelper('LTEQ', lhs, GetDecoratedIdent(rhs));
3113 end;
3114 '>' : begin
3115 Next;
3116 CheckIdent;
3117 rhs := Value;
3118 Next;
3119 CmpHelper('NEQ', lhs, GetDecoratedIdent(rhs));
3120 end;
3121 else
3122 CheckIdent;
3123 rhs := Value;
3124 Next;
3125 CmpHelper('LT', lhs, GetDecoratedIdent(rhs));
3126 end;
3127 StoreZeroFlag;
3128 end;
3129
3130 procedure TNXCComp.GreaterArrayOrUDT(const lhs: string);
3131 var
3132 rhs : string;
3133 begin
3134 Next;
3135 case Token of
3136 '=' : begin
3137 Next;
3138 CheckIdent;
3139 rhs := Value;
3140 Next;
3141 CmpHelper('GTEQ', lhs, GetDecoratedIdent(rhs));
3142 end;
3143 else
3144 CheckIdent;
3145 rhs := Value;
3146 Next;
3147 CmpHelper('GT', lhs, GetDecoratedIdent(rhs));
3148 end;
3149 StoreZeroFlag;
3150 end;
3151
3152 procedure TNXCComp.NEqualArrayOrUDT(const lhs: string);
3153 var
3154 rhs : string;
3155 begin
3156 Next;
3157 if Token = '=' then
3158 begin
3159 Next;
3160 CheckIdent;
3161 rhs := Value;
3162 Next;
3163 CmpHelper('NEQ', lhs, GetDecoratedIdent(rhs));
3164 StoreZeroFlag;
3165 end
3166 else
3167 Expected('"!="');
3168 end;
3169
3170 procedure TNXCComp.EqualString;
3171 begin
3172 Next; // two equal signs of equality comparison
3173 MatchString('=');
3174 StringExpression('');
3175 CmpHelper('EQ', StrTmpBufName, StrBufName);
3176 StoreZeroFlag;
3177 end;
3178
3179 procedure TNXCComp.LessString;
3180 begin
3181 Next;
3182 case Token of
3183 '=' : begin
3184 Next;
3185 StringExpression('');
3186 CmpHelper('LTEQ', StrTmpBufName, StrBufName);
3187 end;
3188 '>' : begin
3189 Next;
3190 StringExpression('');
3191 CmpHelper('NEQ', StrTmpBufName, StrBufName);
3192 end;
3193 else
3194 StringExpression('');
3195 CmpHelper('LT', StrTmpBufName, StrBufName);
3196 end;
3197 StoreZeroFlag;
3198 end;
3199
3200 procedure TNXCComp.GreaterString;
3201 begin
3202 Next;
3203 case Token of
3204 '=' : begin
3205 Next;
3206 StringExpression('');
3207 CmpHelper('GTEQ', StrTmpBufName, StrBufName);
3208 end;
3209 else
3210 StringExpression('');
3211 CmpHelper('GT', StrTmpBufName, StrBufName);
3212 end;
3213 StoreZeroFlag;
3214 end;
3215
3216 procedure TNXCComp.NEqualString;
3217 begin
3218 Next;
3219 if Token = '=' then
3220 begin
3221 Next;
3222 StringExpression('');
3223 CmpHelper('NEQ', StrTmpBufName, StrBufName);
3224 StoreZeroFlag;
3225 end
3226 else
3227 Expected('"!="');
3228 end;
3229
3230 procedure TNXCComp.StringRelation;
3231 var
3232 valLeftOnStack : boolean;
3233 begin
3234 (*
3235 The Expression function handles ++, --, +, -, ~, and ! unary operators
3236 for numeric expressions. Do I need to handle these operators for
3237 string expressions (on both lhs and rhs)?
3238 *)
3239 valLeftOnStack := StringExpression('');
3240 if IsRelop(Token) then begin
3241 // copy to temp string buffer
3242 EmitLn(Format('mov %s, %s', [StrTmpBufName, StrBufName]));
3243 case Token of
3244 '=': EqualString;
3245 '<': LessString;
3246 '>': GreaterString;
3247 '!': NEqualString;
3248 end;
3249 end
3250 else
3251 begin
3252 if not valLeftOnStack then
3253 LoadConst('1'); // a string expression is "true"
3254 end;
3255 end;
3256
3257 procedure TNXCComp.ArrayOrUDTRelation;
3258 var
3259 lhs : string;
3260 begin
3261 (*
3262 The Expression function handles ++, --, +, -, ~, and ! unary operators
3263 for numeric expressions. Do I need to handle these operators for
3264 array/UDT expressions (on both lhs and rhs)?
3265 *)
3266 // only variables are allowed here - no expressions
3267 CheckIdent;
3268 lhs := GetDecoratedIdent(Value);
3269 Next;
3270 if IsRelop(Token) then begin
3271 case Token of
3272 '=': EqualArrayOrUDT(lhs);
3273 '<': LessArrayOrUDT(lhs);
3274 '>': GreaterArrayOrUDT(lhs);
3275 '!': NEqualArrayOrUDT(lhs);
3276 end;
3277 end
3278 else
3279 begin
3280 // is the left hand side an array, udt or a scalar?
3281 if IsArrayType(fLHSDataType) or IsUDT(fLHSDataType) then
3282 begin
3283 // do something clever
3284 fUDTOnStack := lhs;
3285 end
3286 else
3287 LoadConst('1'); // an array or UDT expression is "true"
3288 end;
3289 end;
3290
3291 procedure TNXCComp.NumericRelation;
3292 var
3293 savedToken, savedLook : Char;
3294 begin
3295 NumericRelationLTGT;
3296 while ((Token = '=') and (Look = '=')) or // C/C++ equal
3297 ((Token = '!') and (Look = '=')) or // C/C++ not equal
3298 ((Token = '<') and (Look = '>')) do // pascal not equal
3299 begin
3300 savedToken := Token;
3301 savedLook := Look;
3302 PushPrim;
3303 Next;
3304 Next;
3305 NumericRelationLTGT;
3306 if (savedToken = '=') and (savedLook = '=') then
3307 PopCmpEqual
3308 else
3309 PopCmpNEqual;
3310 StoreZeroFlag;
3311 end;
3312 end;
3313
3314 procedure TNXCComp.NumericRelationLTGT;
3315 var
3316 savedToken, savedLook : Char;
3317 begin
3318 NumericShiftLeftRight;
3319 while (not ((Token = '<') and (Look = '>'))) and // not <> (pascal not equal)
3320 (((Token = '<') and (Look = '=')) or // <=
3321 ((Token = '<') and (Look <> '<')) or // < (not left shift)
3322 ((Token = '>') and (Look = '=')) or // >=
3323 ((Token = '>') and (Look <> '>'))) do // > (not right shift)
3324 begin
3325 savedToken := Token;
3326 savedLook := Look;
3327 PushPrim;
3328 if (Look = '=') then // handle <= and >= case
3329 Next;
3330 Next;
3331 NumericShiftLeftRight;
3332 if (savedToken = '<') and (savedLook = '=') then // <=
3333 PopCmpLessOrEqual
3334 else if (savedToken = '<') and (savedLook <> '<') then // <
3335 PopCmpLess
3336 else if (savedToken = '>') and (savedLook = '=') then // >=
3337 PopCmpGreaterOrEqual
3338 else // >
3339 PopCmpGreater;
3340 StoreZeroFlag;
3341 end;
3342 end;
3343
3344 procedure TNXCComp.NumericShiftLeftRight;
3345 var
3346 savedToken, savedLook : Char;
3347 begin
3348 Expression;
3349 while ((Token = '<') and (Look = '<')) or // <<
3350 ((Token = '>') and (Look = '>')) do // >>
3351 begin
3352 savedToken := Token;
3353 savedLook := Look;
3354 PushPrim;
3355 Next;
3356 Next;
3357 Expression;
3358 if (savedToken = '<') and (savedLook = '<') then
3359 PopLeftShift
3360 else
3361 PopRightShift;
3362 end;
3363 end;
3364
3365 {---------------------------------------------------------------}
3366 { Parse and Translate a Relation }
3367
3368 procedure TNXCComp.Relation;
3369 var
3370 dt : char;
3371 begin
3372 // would it be better to check for unary operators before branching by
3373 // relation type???
3374 if ValueIsStringType(dt) then
3375 begin
3376 if (Look <> '[') or (dt in [TOK_ARRAYSTRING..TOK_ARRAYSTRING4]) then
3377 begin
3378 StringRelation;
3379 end
3380 else
3381 NumericRelation;
3382 end
3383 else if (Token = TOK_IDENTIFIER) and
3384 (ValueIsArrayType or ValueIsUserDefinedType) then
3385 begin
3386 if Look = '[' then
3387 begin
3388 {
3389 dt := RemoveArrayDimension(DataType(Value));
3390 if IsArrayType(dt) then
3391 AbortMsg(sInvalidArrayExpr)
3392 else
3393 }
3394 NumericRelation;
3395 end
3396 else
3397 begin
3398 ArrayOrUDTRelation;
3399 end;
3400 end
3401 else
3402 begin
3403 NumericRelation;
3404 end;
3405 end;
3406
3407 procedure TNXCComp.StoreZeroFlag;
3408 begin
3409 // 2009-10-13 JCH
3410 // we can't afford to store the zero flag sometimes to the signed register
3411 // and other times to the unsigned register or, worse, to the float register
3412 // so we always reset the statement type before we store the flag.
3413 ResetStatementType;
3414 EmitLn(Format('mov %s, %s', [RegisterName, ZeroFlag]));
3415 end;
3416
3417 {---------------------------------------------------------------}
3418 { Parse and Translate a Boolean Term }
3419
3420 procedure TNXCComp.BoolTerm;
3421 var
3422 L : string;
3423 begin
3424 L := NewLabel;
3425 // 2010-05-27 JCH new code for BoolTerm
3426 BitOr;
3427 while (Token = '&') and (Look = '&') do
3428 begin
3429 // move to the second '&'
3430 Next;
3431 // move past the second '&'
3432 Next;
3433 // convert D0 to boolean value if necessary
3434 if not fCCSet then
3435 begin
3436 SetZeroCC;
3437 StoreZeroFlag;
3438 end;
3439 BranchFalse(L);
3440 PushPrim;
3441 BitOr;
3442 if not fCCSet then
3443 begin
3444 // convert D0 to boolean value if necessary
3445 SetZeroCC;
3446 StoreZeroFlag;
3447 end;
3448 PopAnd;
3449 end;
3450 PostLabel(L);
3451 end;
3452
3453 procedure TNXCComp.BitOr;
3454 begin
3455 BitXor;
3456 while (Token = '|') and (Look <> '|') do
3457 begin
3458 Next;
3459 PushPrim;
3460 BitXor;
3461 PopOr;
3462 end;
3463 end;
3464
3465 procedure TNXCComp.BitXor;
3466 begin
3467 BitAnd;
3468 while (Token = '^') do
3469 begin
3470 Next;
3471 PushPrim;
3472 BitAnd;
3473 PopXor;
3474 end;
3475 end;
3476
3477 procedure TNXCComp.BitAnd;
3478 begin
3479 Relation;
3480 while (Token = '&') and (Look <> '&') do
3481 begin
3482 Next;
3483 PushPrim;
3484 Relation;
3485 PopAnd;
3486 end;
3487 end;
3488
3489 procedure TNXCComp.CommaExpression;
3490 begin
3491 BoolExpression;
3492 if fNoCommaOperator then Exit;
3493 // handle comma?
3494 if Token = TOK_COMMA then
3495 begin
3496 Next; // skip past the comma
3497 CommaExpression;
3498 end;
3499 end;
3500
3501 {---------------------------------------------------------------}
3502 { Parse and Translate a Boolean Expression }
3503
3504 procedure TNXCComp.BoolExpression;
3505 var
3506 L1, L2 : string;
3507 begin
3508 fCCSet := False;
3509 BoolSubExpression;
3510 while Token = '?' do begin
3511 // we are parsing a ?: expression
3512 Next;
3513 L1 := NewLabel;
3514 L2 := NewLabel;
3515 BranchFalse(L1);
3516 CommaExpression;
3517 Branch(L2);
3518 MatchString(':');
3519 PostLabel(L1);
3520 CommaExpression;
3521 PostLabel(L2);
3522 end;
3523 // ResetStatementType;
3524 end;
3525
3526 // BoolTerm || BoolTerm
3527 procedure TNXCComp.BoolSubExpression;
3528 var
3529 L : string;
3530 // bLogicalOr : boolean;
3531 begin
3532 L := NewLabel;
3533 BoolTerm;
3534 while (Token = '|') and (Look = '|') do begin
3535 // advance to second '|'
3536 Next;
3537 // advance past the second '|'
3538 Next;
3539 // convert D0 to boolean value if necessary
3540 if not fCCSet then
3541 begin
3542 SetZeroCC;
3543 StoreZeroFlag;
3544 end;
3545 BranchTrue(L);
3546 PushPrim;
3547 BoolTerm;
3548 if not fCCSet then
3549 begin
3550 // convert D0 to boolean value if necessary
3551 SetZeroCC;
3552 StoreZeroFlag;
3553 end;
3554 PopOr;
3555 end;
3556 PostLabel(L);
3557 end;
3558
GetParamNamenull3559 function TNXCComp.GetParamName(procname: string; idx: integer): string;
3560 var
3561 i : integer;
3562 begin
3563 Result := '';
3564 i := fFuncParams.IndexOf(procname, idx);
3565 if i <> -1 then
3566 Result := ApplyDecoration(procname, fFuncParams[i].Name, 0);
3567 end;
3568
3569 function DataTypeToParamType(ptype : char) : TFuncParamType;
3570 begin
3571 case ptype of
3572 TOK_ARRAYCHARDEF..TOK_ARRAYCHARDEF4, TOK_CHARDEF : Result := fptSBYTE;
3573 TOK_ARRAYSHORTDEF..TOK_ARRAYSHORTDEF4, TOK_SHORTDEF : Result := fptSWORD;
3574 TOK_ARRAYLONGDEF..TOK_ARRAYLONGDEF4, TOK_LONGDEF : Result := fptSLONG;
3575 TOK_ARRAYBYTEDEF..TOK_ARRAYBYTEDEF4, TOK_BYTEDEF : Result := fptUBYTE;
3576 TOK_ARRAYUSHORTDEF..TOK_ARRAYUSHORTDEF4, TOK_USHORTDEF : Result := fptUWORD;
3577 TOK_ARRAYULONGDEF..TOK_ARRAYULONGDEF4, TOK_ULONGDEF : Result := fptULONG;
3578 TOK_ARRAYUDT..TOK_ARRAYUDT4, TOK_USERDEFINEDTYPE : Result := fptUDT;
3579 TOK_ARRAYSTRING..TOK_ARRAYSTRING4, TOK_STRINGDEF : Result := fptString;
3580 TOK_ARRAYFLOAT..TOK_ARRAYFLOAT4, TOK_FLOATDEF : Result := fptFloat;
3581 TOK_MUTEXDEF : Result := fptMutex;
3582 else
3583 Result := fptUBYTE;
3584 end;
3585 end;
3586
3587 procedure TNXCComp.AddFunctionParameter(pname, varname, tname: string; idx: integer;
3588 ptype : char; bIsConst, bIsRef, bIsArray : boolean; aDim : integer;
3589 bHasDefault : boolean; defValue : string);
3590 begin
3591 // if this function is not an inline function then we will automagically
3592 // convert any Const not Ref parameter into a Const Ref parameter
3593 if bIsConst and not bIsRef and not AmInlining then
3594 bIsRef := True; // convert to const ref type
3595 (*
3596 // add a check here for a parameter that is const but not reference
3597 // when we are not inlining
3598 if bIsConst and not bIsRef and not AmInlining and (ptype in NonAggregateTypes) then
3599 ReportProblem(linenumber, CurrentFile, sConstNotInline, false);
3600 // AbortMsg(sConstNotInline);
3601 *)
3602 with fFuncParams.Add do
3603 begin
3604 ProcName := pname;
3605 Name := varname;
3606 ParamType := DataTypeToParamType(ptype);
3607 ParamTypeName := tname;
3608 ParamIndex := idx;
3609 IsArray := bIsArray;
3610 IsConstant := bIsConst;
3611 IsReference := bIsRef;
3612 ArrayDimension := aDim;
3613 FuncIsInline := AmInlining;
3614 HasDefault := bHasDefault;
3615 DefaultValue := defValue;
3616 end;
3617 end;
3618
FunctionParameterCountnull3619 function TNXCComp.FunctionParameterCount(const name : string) : integer;
3620 begin
3621 Result := fFuncParams.ParamCount(name);
3622 end;
3623
FunctionRequiredParameterCountnull3624 function TNXCComp.FunctionRequiredParameterCount(const name : string) : integer;
3625 begin
3626 Result := fFuncParams.RequiredParamCount(name);
3627 end;
3628
FunctionParameterTypenull3629 function TNXCComp.FunctionParameterType(const name: string;
3630 idx: integer): char;
3631 var
3632 i : integer;
3633 begin
3634 Result := #0;
3635 i := fFuncParams.IndexOf(name, idx);
3636 if i <> -1 then
3637 Result := fFuncParams[i].ParameterDataType;
3638 end;
3639
FunctionParameterTypeNamenull3640 function TNXCComp.FunctionParameterTypeName(const name: string;
3641 idx: integer): string;
3642 var
3643 i : integer;
3644 begin
3645 Result := '';
3646 i := fFuncParams.IndexOf(name, idx);
3647 if i <> -1 then
3648 Result := fFuncParams[i].ParamTypeName;
3649 end;
3650
FunctionParameterIsConstantnull3651 function TNXCComp.FunctionParameterIsConstant(const name: string;
3652 idx: integer): boolean;
3653 var
3654 i : integer;
3655 begin
3656 Result := False;
3657 i := fFuncParams.IndexOf(name, idx);
3658 if i <> -1 then
3659 Result := fFuncParams[i].IsConstant;
3660 end;
3661
FunctionParameterHasDefaultnull3662 function TNXCComp.FunctionParameterHasDefault(const name: string;
3663 idx: integer): boolean;
3664 var
3665 i : integer;
3666 begin
3667 Result := False;
3668 i := fFuncParams.IndexOf(name, idx);
3669 if i <> -1 then
3670 Result := fFuncParams[i].HasDefault;
3671 end;
3672
FunctionParameterDefaultValuenull3673 function TNXCComp.FunctionParameterDefaultValue(const name: string;
3674 idx: integer): string;
3675 var
3676 i : integer;
3677 begin
3678 Result := '';
3679 i := fFuncParams.IndexOf(name, idx);
3680 if i <> -1 then
3681 Result := fFuncParams[i].DefaultValue;
3682 end;
3683
GetFunctionParamnull3684 function TNXCComp.GetFunctionParam(const procname : string; idx : integer) : TFunctionParameter;
3685 var
3686 i : integer;
3687 begin
3688 Result := nil;
3689 i := fFuncParams.IndexOf(procname, idx);
3690 if i <> -1 then
3691 Result := fFuncParams[i];
3692 end;
3693
AdvanceToNextParamnull3694 function TNXCComp.AdvanceToNextParam : string;
3695 begin
3696 Result := '';
3697 Next;
3698 while not ((Token in [TOK_CLOSEPAREN, TOK_COMMA]) or endofallsource) do
3699 begin
3700 Result := Result + Value;
3701 Next;
3702 end;
3703 Result := Trim(Result);
3704 end;
3705
3706 procedure TNXCComp.DoCall(procname : string);
3707 var
3708 protocount, protoreqcount, acount, idx, i : integer;
3709 dt, rdt, pdt, oldLHSDT : char;
3710 parname, parvalue, junk, oldLHSName : string;
3711 bError : boolean;
3712 fp : TFunctionParameter;
3713 fInputs : TStrings;
3714 bFunctionIsInline, bSafeCall : boolean;
3715 inlineFunc : TInlineFunction;
3716 begin
3717 fNoCommaOperator := True;
3718 try
3719 fUDTOnStack := ''; // by default there is no UDT/Array on the return stack
3720 if fFunctionNameCallStack.IndexOf(procname) = -1 then
3721 begin
3722 fFunctionNameCallStack.Add(procname);
3723 try
3724 // is procname the same as the current thread name
3725 // (i.e., is this a recursive function call)?
3726 if procname = fCurrentThreadName then
3727 AbortMsg(sRecursiveNotAllowed);
3728 // is procname an inline function?
3729 idx := fInlineFunctions.IndexOfName(procname);
3730 bFunctionIsInline := idx <> -1;
3731 if bFunctionIsInline then
3732 begin
3733 inlineFunc := fInlineFunctions[idx];
3734 if inlineFunc.Parameters.Count = 0 then
3735 inlineFunc.Parameters := fFuncParams;
3736 inlineFunc.CurrentCaller := fCurrentThreadName;
3737 end
3738 else
3739 inlineFunc := nil;
3740 fInputs := TStringList.Create;
3741 try
3742 acount := 0;
3743 protocount := FunctionParameterCount(procname);
3744 protoreqcount := FunctionRequiredParameterCount(procname);
3745 Next;
3746 bError := Value <> TOK_OPENPAREN;
3747 if not bError then
3748 OpenParen
3749 else
3750 Expected('"("');
3751 if bFunctionIsInline and
3752 (inlineFunc.Callers.IndexOf(fCurrentThreadName) = -1) then
3753 begin
3754 inlineFunc.Callers.Add(fCurrentThreadName);
3755 // first call in this thread to this inline function
3756 // output all parameters and local variables with decoration
3757 EmitInlineParametersAndLocals(inlineFunc);
3758 // make sure the very first call to this inline function
3759 // by this thread doesn't get optimized out
3760 fExpStr := '__DO_NOT_OPTIMIZE!@#$%_';
3761 end;
3762 bSafeCall := GlobalUsesSafeCall(procname);
3763 // acquire the mutex
3764 if not bFunctionIsInline and (SafeCalls or bSafeCall) then
3765 begin
3766 EmitLnNoTab('#pragma safecalling');
3767 EmitLn(Format('acquire __%s_mutex', [procname]));
3768 end;
3769 while not bError and (Token <> TOK_CLOSEPAREN) do begin
3770 if acount >= protocount then
3771 begin
3772 AbortMsg(sTooManyArgs);
3773 bError := True;
3774 end;
3775 fp := GetFunctionParam(procname, acount);
3776 if Assigned(fp) then
3777 begin
3778 dt := FunctionParameterType(procname, acount);
3779 parname := GetParamName(procname, acount);
3780 if bFunctionIsInline then
3781 parname := InlineName(fCurrentThreadName, parname);
3782 // now process the current parameter
3783 oldLHSDT := fLHSDataType;
3784 oldLHSName := fLHSName;
3785 fLHSDataType := dt;
3786 fLHSName := parname;
3787 try
3788 // reference types cannot take expressions
3789 if fp.IsVarReference then
3790 begin
3791 CheckIdent;
3792 parvalue := GetDecoratedValue;
3793 pdt := DataType(parvalue);
3794 if fp.IsArray then
3795 begin
3796 if not IsArrayType(pdt, True) then
3797 Expected(sArrayDatatype);
3798 end;
3799 fInputs.AddObject(parvalue, fp);
3800 EmitLn(Format('mov %s, %s', [parname, parvalue]));
3801 junk := AdvanceToNextParam;
3802 if junk <> '' then
3803 AbortMsg(sExpNotSupported)
3804 else
3805 CheckTypeCompatibility(fp, pdt, parvalue);
3806 end
3807 // beginning of addition for handling expressions for UDT and array parameters
3808 else if fp.IsArray or (fp.ParamType = fptUDT) then
3809 begin
3810 fInputs.AddObject('', fp);
3811 if IsArrayType(dt) then
3812 begin
3813 DoArrayAssignValue(parname, '', dt);
3814 end
3815 else if dt = TOK_USERDEFINEDTYPE then
3816 begin
3817 GetAndStoreUDT(parname);
3818 end;
3819 end
3820 // end of addition for handling expressions for UDT and array parameters
3821 // beginning of previously commented out block
3822 else if fp.IsConstant and not fp.IsReference then
3823 begin
3824 // must be a number (or constant expression) or a string literal
3825 if dt = TOK_STRINGDEF then
3826 begin
3827 parvalue := Value;
3828 CheckStringConst;
3829 fp.ConstantValue := parvalue;
3830 fInputs.AddObject(parvalue, fp);
3831 if bFunctionIsInline then
3832 begin
3833 i := inlineFunc.Parameters.IndexOf(inlineFunc.Name, acount);
3834 if i <> -1 then
3835 begin
3836 inlineFunc.Parameters[i].Assign(fp);
3837 end;
3838 end;
3839 EmitLn(Format('mov %s, %s', [parname, parvalue]));
3840 Next;
3841 end
3842 else if dt <> #0 then
3843 begin
3844 // collect tokens to TOK_CLOSEPAREN or TOK_COMMA
3845 parvalue := Value;
3846 SkipWhite; // skip any whitespace just in case
3847 while not (Look in [TOK_CLOSEPAREN, TOK_COMMA]) or endofallsource do begin
3848 Next;
3849 parvalue := parvalue + Value;
3850 end;
3851 Next;
3852 fCalc.SilentExpression := GetValueOf(parvalue);
3853 if not fCalc.ParserError then
3854 begin
3855 parvalue := NBCFloatToStr(fCalc.Value);
3856 fCalc.SetVariable(parname, fCalc.Value);
3857 fp.ConstantValue := parvalue;
3858 fInputs.AddObject(parvalue, fp);
3859 if bFunctionIsInline then
3860 begin
3861 i := inlineFunc.Parameters.IndexOf(inlineFunc.Name, acount);
3862 if i <> -1 then
3863 begin
3864 inlineFunc.Parameters[i].Assign(fp);
3865 end;
3866 end;
3867 EmitLn(Format('mov %s, %s', [parname, parvalue]));
3868 end
3869 else
3870 begin
3871 if IsParamConst(parvalue) then
3872 begin
3873 fp.ConstantValue := ApplyDecoration(fCurrentThreadName, parvalue, 0);
3874 // fp.ConstantValue := parvalue;
3875 fInputs.AddObject(parvalue, fp);
3876 if bFunctionIsInline then
3877 begin
3878 i := inlineFunc.Parameters.IndexOf(inlineFunc.Name, acount);
3879 if i <> -1 then
3880 begin
3881 inlineFunc.Parameters[i].Assign(fp);
3882 end;
3883 end;
3884 end
3885 else
3886 begin
3887 fInputs.AddObject('', fp);
3888 Expected(sConstOrConstExpr);
3889 end;
3890 end;
3891 end;
3892 end
3893 // end of previously commented out block
3894 else
3895 begin
3896 fInputs.AddObject('', fp);
3897 // pass in True to make it so that no checks are performed
3898 // in Store and StoreString
3899 DoAssignValue(parname, dt, False);
3900 end;
3901 finally
3902 fLHSDataType := oldLHSDT;
3903 fLHSName := oldLHSName;
3904 end;
3905 end;
3906 inc(acount);
3907 Scan;
3908 if acount < protoreqcount then
3909 begin
3910 MatchString(TOK_COMMA);
3911 Scan;
3912 end
3913 else begin
3914 // we are now supposed to either have a comma or a close paren
3915 // depending on the value of acount compared to protocount
3916 if (acount < protocount) and not (Token in [TOK_COMMA, TOK_CLOSEPAREN]) then
3917 begin
3918 MatchString(TOK_COMMA);
3919 Scan;
3920 end
3921 else
3922 begin
3923 if Token = TOK_COMMA then begin
3924 Next;
3925 Scan;
3926 end;
3927 end;
3928 end;
3929 end;
3930 if Value = TOK_CLOSEPAREN then
3931 begin
3932 CloseParen;
3933
namenull3934 // look up the decorated function name given the procname
3935 // and the types of all the parameters passed into the function
3936 // if we find a function with the right name and parameters
3937 // then keep going. Otherwise report an error
3938 // if the number of parameters provided is less than the function's
3939 // defined number of parameters
3940
3941 if protoreqcount > acount then
3942 AbortMsg(sTooFewParams);
3943 while acount < protocount do
3944 begin
3945 // use default values for all the arguments not provided
3946 fp := GetFunctionParam(procname, acount);
3947 if Assigned(fp) then
3948 begin
3949 parname := GetParamName(procname, acount);
3950 if bFunctionIsInline then
3951 parname := InlineName(fCurrentThreadName, parname);
3952 parvalue := FunctionParameterDefaultValue(procname, acount);
3953 EmitLn(Format('mov %s, %s', [parname, parvalue]));
3954 end;
3955 inc(acount);
3956 end;
3957
3958 if bFunctionIsInline then
3959 inlineFunc.Emit(NBCSource)
3960 else
3961 EmitLn('call '+procname);
3962 fCCSet := False;
3963 for i := 0 to fInputs.Count - 1 do begin
3964 fp := TFunctionParameter(fInputs.Objects[i]);
3965 if fp.IsVarReference then begin
3966 // must copy out the non-const references
3967 parname := GetParamName(procname, i);
3968 if bFunctionIsInline then
3969 parname := InlineName(fCurrentThreadName, parname);
3970 EmitLn(Format('mov %s, %s', [fInputs[i], parname]));
3971 end;
3972 end;
3973 rdt := FunctionReturnType(procname);
3974 if rdt = TOK_STRINGDEF then
3975 begin
3976 // copy value from subroutine to register
3977 if bFunctionIsInline then
3978 EmitLn(Format('mov %s, %s', [StrRetValName, StrBufName(InlineName(fCurrentThreadName, procname))]))
3979 else
3980 EmitLn(Format('mov %s, %s', [StrRetValName, StrBufName(procname)]));
3981 end
3982 else if IsUDT(rdt) or IsArrayType(rdt) then
3983 begin
3984 // tell the compiler that a UDT/Array is on stack
3985 if bFunctionIsInline then
3986 fUDTOnStack := Format('__result_%s', [InlineName(fCurrentThreadName, procname)])
3987 else
3988 fUDTOnStack := Format('__result_%s', [procname]);
3989 end
3990 else if rdt in NonAggregateTypes then
3991 begin
3992 // copy value from subroutine to register
3993 if rdt = TOK_FLOATDEF then
3994 StatementType := stFloat
3995 else if not (rdt in UnsignedIntegerTypes) then
3996 StatementType := stSigned
3997 else
3998 StatementType := stUnsigned;
3999 if bFunctionIsInline then
4000 EmitLn(Format('mov %s, %s', [RegisterName, RegisterName(InlineName(fCurrentThreadName, procname))]))
4001 else
4002 EmitLn(Format('mov %s, %s', [RegisterName, RegisterName(procname)]));
4003 end;
4004 // release the mutex
4005 if not bFunctionIsInline and (SafeCalls or bSafeCall) then
4006 EmitLn(Format('release __%s_mutex', [procname]));
4007 end
4008 else
4009 Expected('")"');
4010 finally
4011 fInputs.Free;
4012 end;
4013 finally
4014 fFunctionNameCallStack.Delete(fFunctionNameCallStack.Count - 1);
4015 end;
4016 end
4017 else
4018 begin
4019 AbortMsg(sNestedCallsError);
4020 end;
4021 finally
4022 fNoCommaOperator := False;
4023 end;
4024 end;
4025
4026 procedure TNXCComp.StoreArray(const name, idx, val : string);
4027 begin
4028 // move RHS to array[idx] or set array = to RHS
4029 if idx = '' then
4030 EmitLn(Format('arrbuild %0:s, %s', [GetDecoratedIdent(name), val]))
4031 else
4032 EmitLn(Format('replace %0:s, %0:s, %s, %s', [GetDecoratedIdent(name), idx, val]));
4033 end;
4034
RemoveArrayDimensionnull4035 function TNXCComp.RemoveArrayDimension(dt: char): char;
4036 begin
4037 Result := dt;
4038 if IsArrayType(dt) then
4039 begin
4040 case dt of
4041 TOK_ARRAYFLOAT : Result := TOK_FLOATDEF;
4042 TOK_ARRAYSTRING : Result := TOK_STRINGDEF;
4043 TOK_ARRAYUDT : Result := TOK_USERDEFINEDTYPE;
4044 TOK_ARRAYCHARDEF : Result := TOK_CHARDEF;
4045 TOK_ARRAYSHORTDEF : Result := TOK_SHORTDEF;
4046 TOK_ARRAYLONGDEF : Result := TOK_LONGDEF;
4047 TOK_ARRAYBYTEDEF : Result := TOK_BYTEDEF;
4048 TOK_ARRAYUSHORTDEF : Result := TOK_USHORTDEF;
4049 TOK_ARRAYULONGDEF : Result := TOK_ULONGDEF;
4050 else
4051 Result := Char(Ord(dt)-1);
4052 end;
4053 end
4054 else if dt = TOK_STRINGDEF then
4055 Result := TOK_BYTEDEF;
4056 end;
4057
AddArrayDimensionnull4058 function TNXCComp.AddArrayDimension(dt: char): char;
4059 begin
4060 case dt of
4061 TOK_FLOATDEF : Result := TOK_ARRAYFLOAT;
4062 TOK_STRINGDEF : Result := TOK_ARRAYSTRING;
4063 TOK_USERDEFINEDTYPE : Result := TOK_ARRAYUDT;
4064 TOK_CHARDEF : Result := TOK_ARRAYCHARDEF;
4065 TOK_SHORTDEF : Result := TOK_ARRAYSHORTDEF;
4066 TOK_LONGDEF : Result := TOK_ARRAYLONGDEF;
4067 TOK_BYTEDEF : Result := TOK_ARRAYBYTEDEF;
4068 TOK_USHORTDEF : Result := TOK_ARRAYUSHORTDEF;
4069 TOK_ULONGDEF : Result := TOK_ARRAYULONGDEF;
4070 else
4071 if IsArrayType(dt) then
4072 begin
4073 Result := Char(Ord(dt)+1);
4074 // if ArrayBaseType(Result) <> ArrayBaseType(dt) then
4075 // AbortMsg(sInvalidArrayDim);
4076 end
4077 else
4078 Result := dt;
4079 end;
4080 end;
4081
4082 procedure TNXCComp.ArrayAssignment(const name : string; dt : char; bIndexed : boolean);
4083 var
4084 tmp, aval, udType, tmpUDTName : string;
4085 oldType : char;
4086 AHV : TArrayHelperVar;
4087 begin
4088 tmp := '';
4089 if bIndexed then
4090 begin
4091 Next;
4092 oldType := fLHSDataType;
4093 try
4094 fLHSDataType := TOK_LONGDEF;
4095 CommaExpression;
4096 finally
4097 fLHSDataType := oldType;
4098 end;
4099 MatchString(']');
4100 push;
4101 tmp := tos;
4102 EmitLn(Format('mov %s, %s', [tmp, RegisterName]));
4103 dt := RemoveArrayDimension(dt);
4104 fLHSDataType := RemoveArrayDimension(fLHSDataType);
4105 end;
4106 // check for additional levels of indexing
4107 if (Token = '[') and (IsArrayType(dt) or (dt = TOK_STRINGDEF)) then
4108 begin
4109 udType := '';
4110 if IsUDT(ArrayBaseType(dt)) then
4111 udType := GetUDTType(name);
4112 // get a temporary thread-safe variable of the right type
4113 AHV := fArrayHelpers.GetHelper(fCurrentThreadName, udType, dt);
4114 try
4115 aval := AHV.Name;
4116 if fGlobals.IndexOfName(aval) = -1 then
4117 AddEntry(aval, dt, udType, '');
4118 // set the variable to the specified element from previous array
4119 EmitLn(Format('index %s, %s, %s',[aval, GetDecoratedIdent(name), tmp]));
4120 // pass its name into the call to ArrayAssignment
4121 ArrayAssignment(aval, dt, True);
4122 // store temporary thread-safe variable back into previous array
4123 StoreArray(name, tmp, aval);
4124 finally
4125 fArrayHelpers.ReleaseHelper(AHV);
4126 end;
4127 end
4128 else if (Token = '.') and IsUDT(dt) then // check for struct member notation
4129 begin
4130 // set the variable to the specified element from previous array
4131 udType := '';
4132 if IsUDT(ArrayBaseType(dt)) then
4133 udType := GetUDTType(name);
4134 // get a temporary thread-safe variable of the right type
4135 AHV := fArrayHelpers.GetHelper(fCurrentThreadName, udType, dt);
4136 try
4137 aval := AHV.Name;
4138 if fGlobals.IndexOfName(aval) = -1 then
4139 AddEntry(aval, dt, udType, '');
4140 // set the variable to the specified element from previous array
4141 EmitLn(Format('index %s, %s, %s',[aval, GetDecoratedIdent(name), tmp]));
4142 // process dots
4143 tmpUDTName := aval;
4144 tmpUDTName := tmpUDTName + Value; // add the dot
4145 Next;
4146 tmpUDTName := tmpUDTName + Value; // add everything else
4147 // set value to full udt name
4148 Value := tmpUDTName;
4149 // recurse to the Assignment procedure
4150 Assignment;
4151 // store temporary thread-safe variable back into previous array
4152 StoreArray(name, tmp, aval);
4153 finally
4154 fArrayHelpers.ReleaseHelper(AHV);
4155 end;
4156 end
4157 else if Token in ['+', '-', '/', '*', '%', '&', '|', '^', '>', '<'] then
4158 begin
4159 if (dt in NonAggregateTypes) and bIndexed then
4160 begin
4161 // get the indexed value
4162 if dt = TOK_FLOATDEF then
4163 StatementType := stFloat
4164 else if not (dt in UnsignedIntegerTypes) then
4165 StatementType := stSigned
4166 else
4167 StatementType := stUnsigned;
4168 push;
4169 aval := tos;
4170 EmitLn(Format('index %s, %s, %s',[aval, GetDecoratedIdent(name), tmp]));
4171 MathAssignment(aval);
4172 StoreArray(name, tmp, aval);
4173 pop;
4174 end
4175 // 2011-02-11 - Added code to handle math assignment for arrays of UDTs
4176 else if IsUDT(dt) and bIndexed then
4177 begin
4178 // dt is not non-aggregated
4179 // set the variable to the specified element from previous array
4180 udType := '';
4181 if IsUDT(ArrayBaseType(dt)) then
4182 udType := GetUDTType(name);
4183 // get a temporary thread-safe variable of the right type
4184 AHV := fArrayHelpers.GetHelper(fCurrentThreadName, udType, dt);
4185 try
4186 aval := AHV.Name;
4187 if fGlobals.IndexOfName(aval) = -1 then
4188 AddEntry(aval, dt, udType, '');
4189 // set the variable to the specified element from previous array
4190 EmitLn(Format('index %s, %s, %s',[aval, GetDecoratedIdent(name), tmp]));
4191 MathAssignment(aval);
4192 // store temporary thread-safe variable back into previous array
4193 StoreArray(name, tmp, aval);
4194 finally
4195 fArrayHelpers.ReleaseHelper(AHV);
4196 end;
4197 end
4198 // 2011-02-11 - End of new code for arrays of UDTs
4199 else
4200 begin
4201 MathAssignment(name);
4202 end;
4203 end
4204 else
4205 begin
4206 MatchString('=');
4207 DoArrayAssignValue(name, tmp, dt);
4208 end;
4209 if bIndexed then
4210 pop;
4211 end;
4212
4213 procedure TNXCComp.CheckDataType(dt: char);
4214 var
4215 rhsDT : char;
4216 begin
4217 rhsDT := DataType(Value);
4218 if Look = '[' then
4219 rhsDT := RemoveArrayDimension(rhsDT);
4220 if (IsArrayType(rhsDT) <> IsArrayType(dt)) or
4221 (GetArrayDimension(rhsDT) <> GetArrayDimension(dt)) then
4222 AbortMsg(sDatatypesNotCompatible);
4223 end;
4224
4225 procedure TNXCComp.DoArrayAssignValue(const aName, idx: string; dt: char);
4226 var
4227 oldType : Char;
4228 oldName, udType : string;
4229 AHV : TArrayHelperVar;
4230 begin
4231 if dt = TOK_STRINGDEF then
4232 begin
4233 // name of array variable is of type string
4234 StringExpression(aName);
4235 StoreArray(aName, idx, StrBufName);
4236 end
4237 else if (Token = TOK_IDENTIFIER) and IsUDT(DataType(Value)) {dt = TOK_USERDEFINEDTYPE} then
4238 begin
4239 CheckIdent;
4240 CheckDataType(dt);
4241 StoreArray(aName, idx, GetDecoratedValue);
4242 Next;
4243 end
4244 else if IsArrayType(dt) then
4245 begin
4246 // lhs is an array. That means we can only have a factor on the rhs.
4247 if idx = '' then
4248 begin
4249 if Token = '!' then begin
4250 Next;
4251 NumericFactor;
4252 if fUDTOnStack <> '' then
4253 begin
4254 Store(aName);
4255 fUDTOnStack := '';
4256 end;
4257 EmitLn(Format('not %0:s, %0:s', [GetDecoratedIdent(aName)]));
4258 end
4259 else begin
4260 NumericFactor;
4261 if fUDTOnStack <> '' then
4262 begin
4263 Store(aName);
4264 fUDTOnStack := '';
4265 end;
4266 end;
4267 end
4268 else
4269 begin
4270 if Look = '[' then
4271 begin
4272 oldType := fLHSDataType;
4273 oldName := fLHSName;
4274 try
4275 udType := '';
4276 if IsUDT(ArrayBaseType(dt)) then
4277 udType := GetUDTType(aName);
4278 AHV := fArrayHelpers.GetHelper(fCurrentThreadName, udType, dt);
4279 try
4280 fLHSDataType := dt;
4281 fLHSName := AHV.Name;
4282 if fGlobals.IndexOfName(fLHSName) = -1 then
4283 AddEntry(fLHSName, dt, udType, '');
4284 NumericFactor;
4285 if fUDTOnStack <> '' then
4286 begin
4287 Store(fLHSName);
4288 fUDTOnStack := '';
4289 end;
4290 StoreArray(aName, idx, fLHSName);
4291 finally
4292 fArrayHelpers.ReleaseHelper(AHV);
4293 end;
4294 finally
4295 fLHSDataType := oldType;
4296 fLHSName := oldName;
4297 end;
4298 end
4299 else
4300 begin
4301 CheckIdent;
4302 CheckDataType(dt);
4303 StoreArray(aName, idx, GetDecoratedValue);
4304 Next;
4305 end;
4306 end;
4307 end
4308 else
4309 begin
4310 // since this is an assignment statement we do not allow comma operators
4311 // due to the = operator having a higher precedence than the , operator.
4312 BoolExpression;
4313 StoreArray(aName, idx, RegisterName);
4314 end;
4315 end;
4316
4317 procedure TNXCComp.MathAssignment(const name : string);
4318 var
4319 savedtoken : char;
4320 // oldType : char;
4321 begin
4322 fProcessingMathAssignment := True;
4323 try
4324 // Look has to be '=', '+', or '-' or it's all messed up
4325 if Look = '=' then
4326 begin
4327 savedtoken := Token;
4328 Next; // move to '='
4329 Next; // move to next token
4330 (*
4331 // 2009-06-24 JCH - to make such things as += work with scalars on the RHS
4332 // and arrays or UDTs on the left I wrapped the boolexpression in
4333 // try/finally which sets/resets the LHS data type
4334 // !!! THIS MIGHT BREAK SOMETHING !!!
4335 oldType := fLHSDataType;
4336 try
4337 fLHSDataType := TOK_LONGDEF;
4338 BoolExpression;
4339 finally
4340 fLHSDataType := oldType;
4341 end;
4342 *)
4343 // 2010-05-05 JCH - to make += work with non-scalars on the RHS I undid the
4344 // above change. Testing seems to prove that scalars on the RHS still
4345 // work correctly.
4346 BoolExpression;
4347 // end of 2010-05-05 changes
4348 case savedtoken of
4349 '+' : StoreAdd(name);
4350 '-' : StoreSub(name);
4351 '*' : StoreMul(name);
4352 '/' : StoreDiv(name);
4353 '%' : StoreMod(name);
4354 '&' : StoreAnd(name);
4355 '|' : StoreOr(name);
4356 '^' : StoreXor(name);
4357 end;
4358 end
4359 else if (Token = '+') and (Look = '+') then
4360 begin
4361 Next; // move to second +
4362 Next;
4363 // Semi;
4364 StoreInc(name, 1);
4365 end
4366 else if (Token = '-') and (Look = '-') then
4367 begin
4368 Next; // move to second -
4369 Next;
4370 // Semi;
4371 StoreDec(name, 1);
4372 end
4373 else if (Token = '+') and (Look = '-') then
4374 begin
4375 Next; // move to -
4376 if Look = '=' then
4377 begin
4378 Next; // move to '='
4379 Next; // move to next token
4380 BoolExpression;
4381 StoreSign(name);
4382 end
4383 else
4384 AbortMsg(sInvalidAssignment);
4385 end
4386 else if (Token = '|') and (Look = '|') then
4387 begin
4388 Next; // move to second |
4389 if Look = '=' then
4390 begin
4391 Next; // move to '='
4392 Next; // move to next token
4393 BoolExpression;
4394 StoreAbs(name);
4395 end
4396 else
4397 AbortMsg(sInvalidAssignment);
4398 end
4399 else if ((Token = '>') and (Look = '>')) or ((Token = '<') and (Look = '<')) then
4400 begin
4401 savedtoken := Token;
4402 Next; // move to second > or <
4403 if Look = '=' then
4404 begin
4405 Next; // move to '='
4406 Next; // move to next token
4407 BoolExpression;
4408 StoreShift(savedtoken='>', name);
4409 end
4410 else
4411 AbortMsg(sInvalidAssignment);
4412 end
4413 else
4414 AbortMsg(sInvalidAssignment);
4415 finally
4416 fProcessingMathAssignment := False;
4417 end;
4418 end;
4419
4420 procedure TNXCComp.DoLabel;
4421 var
4422 lbl : string;
4423 begin
4424 lbl := Value;
4425 Next; // the colon
4426 if not IsGlobal(lbl) then
4427 begin
4428 AddEntry(lbl, TOK_LABEL, '', '');
4429 PostLabel(lbl);
4430 end
4431 else
4432 Duplicate(lbl);
4433 fSemiColonRequired := False;
4434 Next;
4435 end;
4436
4437 procedure TNXCComp.DoStart;
4438 var
4439 taskname : string;
4440 begin
4441 Next;
4442 taskname := Value;
4443 CheckTask(taskname);
4444 Next;
4445 EmitLn(Format('start %s', [taskname]));
4446 end;
4447
4448 procedure TNXCComp.DoStopTask;
4449 var
4450 taskname : string;
4451 begin
4452 Next;
4453 taskname := Value;
4454 CheckTask(taskname);
4455 Next;
4456 EmitLn(Format('stopthread %s', [taskname]));
4457 end;
4458
4459 procedure TNXCComp.DoSetPriority;
4460 var
4461 taskname : string;
4462 begin
4463 // priority task, value
4464 Next;
4465 taskname := Value;
4466 CheckTask(taskname);
4467 Next;
4468 MatchString(TOK_COMMA);
4469 CheckNumeric;
4470 EmitLn(Format('priority %s, %s', [taskname, Value]));
4471 Next;
4472 end;
4473
4474 {--------------------------------------------------------------}
4475 { Parse and Translate an Assignment Statement }
4476
4477 procedure TNXCComp.Assignment;
4478 var
4479 Name: string;
4480 dt : char;
4481 begin
4482 if IncrementOrDecrement then
4483 begin
4484 DoPreIncOrDec(false);
4485 end
4486 else
4487 begin
4488 if not IsParam(Value) and
4489 not IsLocal(Value) and
4490 not IsGlobal(Value) and
4491 not IsAPIFunc(Value) and
4492 not IsAPIStrFunc(Value) then
4493 Undefined(Value);
4494 Name := Value;
4495 dt := DataType(Name);
4496 if dt = TOK_PROCEDURE then begin
4497 DoCall(Name);
4498 end
4499 else if dt = TOK_TASK then begin
4500 AbortMsg(sInvalidUseOfTaskName);
4501 SkipLine;
4502 Next;
4503 end
4504 else if dt = TOK_APIFUNC then begin
4505 Next;
4506 DoCallAPIFunc(Name); // functions should set register
4507 end
4508 else if dt = TOK_APISTRFUNC then begin
4509 Next;
amenull4510 StringFunction(Name); // functions should set register
4511 end
4512 else begin
4513 Next;
4514 fLHSDataType := dt;
4515 fLHSName := Name;
4516 try
4517 CheckNotConstant(Name);
4518 if (Token = '[') or IsArrayType(dt) then
4519 begin
4520 ArrayAssignment(Name, dt, Token = '[');
4521 end
4522 else if dt = TOK_USERDEFINEDTYPE then
4523 begin
4524 UDTAssignment(Name);
4525 end
4526 else if Token in ['+', '-', '/', '*', '%', '&', '|', '^', '>', '<'] then
4527 begin
4528 if (Token = '+') and (Look = '=')and (dt = TOK_STRINGDEF) then
4529 StringConcatAssignment(Name)
4530 else
4531 MathAssignment(Name);
4532 end
4533 else if Token = '=' then
4534 begin
4535 MatchString('=');
4536 DoAssignValue(Name, dt);
4537 end
4538 else
4539 begin
4540 // just an identifier but not assignment operator
4541 // put it on the stack
4542 LoadVar(Name);
4543 end;
4544 finally
4545 fLHSDataType := TOK_LONGDEF;
4546 fLHSName := '';
4547 end;
4548 end;
4549 end;
4550 end;
4551
4552 procedure TNXCComp.DoAssignValue(const aName: string; dt: char; bNoChecks : boolean);
4553 begin
4554 if dt = TOK_STRINGDEF then
4555 begin
4556 StringExpression(aName);
4557 StoreString(aName, bNoChecks);
4558 end
4559 else
4560 begin
4561 // no comma expression here since the assignment operator has a
4562 // higher precedence than the comma operator
4563 BoolExpression;
4564 Store(aName, bNoChecks);
4565 end;
4566 end;
4567
4568 {---------------------------------------------------------------}
4569 { Recognize and Translate an IF Construct }
4570
4571 procedure TNXCComp.DoIf(const lend, lstart : string);
4572 var
4573 L1, L2: string;
4574 begin
4575 Next;
4576 OpenParen;
4577 CommaExpression;
4578 CloseParen;
4579 L1 := NewLabel;
4580 L2 := L1;
4581 BranchFalse(L1);
4582 Block(lend, lstart);
4583 CheckSemicolon;
4584 fSemiColonRequired := Token = TOK_ELSE;
4585 if Token = TOK_ELSE then
4586 begin
4587 Next;
4588 L2 := NewLabel;
4589 Branch(L2);
4590 PostLabel(L1);
4591 Block(lend, lstart);
4592 end;
4593 PostLabel(L2);
4594 end;
4595
4596
4597 {--------------------------------------------------------------}
4598 { Parse and Translate a WHILE Statement }
4599
4600 procedure TNXCComp.DoWhile;
4601 var
4602 L1, L2: string;
4603 begin
4604 Next;
4605 OpenParen;
4606 L1 := NewLabel;
4607 L2 := NewLabel;
4608 PostLabel(L1);
4609 CommaExpression;
4610 CloseParen;
4611 BranchFalse(L2);
4612 Block(L2, L1);
4613 Branch(L1);
4614 PostLabel(L2);
4615 end;
4616
4617 procedure TNXCComp.DoDoWhile;
4618 var
4619 L1, L2: string;
4620 begin
4621 Next;
4622 L1 := NewLabel;
4623 L2 := NewLabel;
4624 PostLabel(L1);
4625 Block(L2, L1);
4626 MatchString('while');
4627 OpenParen;
4628 CommaExpression;
4629 CloseParen;
4630 BranchFalse(L2);
4631 Branch(L1);
4632 PostLabel(L2);
4633 end;
4634
4635 procedure TNXCComp.DoRepeat;
4636 var
4637 L1, L2: string;
4638 svar : string;
4639 begin
4640 Next;
4641 OpenParen;
4642 L1 := NewLabel;
4643 L2 := NewLabel;
4644 CommaExpression;
4645 CloseParen;
4646 push;
4647 svar := tos;
4648 EmitLn(Format('mov %s, %s',[svar, RegisterName]));
4649 PostLabel(L1);
4650 StoreDec(svar);
4651 EmitLn('brtst LT,' + L2 + ', ' + svar);
4652 Block(L2, L1);
4653 Branch(L1);
4654 PostLabel(L2);
4655 pop;
4656 end;
4657
StringToBoolnull4658 function StringToBool(const aValue : string) : boolean;
4659 begin
4660 Result := aValue = 'TRUE';
4661 end;
4662
4663 procedure TNXCComp.DoSwitch(const lstart : string);
4664 var
4665 L2 : string;
4666 idx : integer;
4667 bSwitchIsString : boolean;
4668 dt : char;
4669 begin
4670 Next;
4671 OpenParen;
4672 bSwitchIsString := ValueIsStringType(dt);
4673 if bSwitchIsString then
4674 StringExpression('')
4675 else
4676 CommaExpression;
4677 CloseParen;
4678 L2 := NewLabel;
4679 idx := SwitchFixupIndex;
4680 inc(fSwitchDepth);
4681 try
4682 ClearSwitchFixups;
4683 SwitchFixups.Add(Format('%d_Type=%s', [fSwitchDepth, IntToStr(Ord(bSwitchIsString))]));
4684 SwitchRegisterNames.Add(Format('%d=%s', [fSwitchDepth, RegisterName]));
4685 Block(L2, lstart);
4686 PostLabel(L2);
4687 FixupSwitch(idx, L2);
4688 finally
4689 dec(fSwitchDepth);
4690 end;
4691 end;
4692
GetCaseConstantnull4693 function TNXCComp.GetCaseConstant: string;
4694 begin
4695 Result := '';
4696 // collect tokens up to ':' (this allows for constant expressions)
4697 while (Token <> ':') and not endofallsource do
4698 begin
4699 Result := Result + Value;
4700 Next;
4701 end;
4702 // convert true|false to TRUE|FALSE
4703 if (Result = 'true') or (Result = 'false') then
4704 Result := UpperCase(Result);
4705 if IsLocal(Result) then
4706 Result := GetDecoratedIdent(Result);
4707 Result := CheckConstant(Result);
4708 end;
4709
4710 procedure TNXCComp.DoSwitchCase;
4711 var
4712 L1 : string;
4713 caseval, stackval, tmp : string;
4714 begin
4715 caseval := '';
4716 if fSwitchDepth > 0 then
4717 begin
4718 Next; // move past 'case'
4719 caseval := GetCaseConstant;
4720 MatchString(':'); // token should be ':' at this point
4721 L1 := NewLabel;
4722 PostLabel(L1);
4723 if SwitchIsString then
4724 stackval := StrBufName
4725 else
4726 stackval := SwitchRegisterName;
4727 tmp := Format('%d_Cases=%s', [fSwitchDepth, caseval]);
4728 if SwitchFixups.IndexOf(tmp) <> -1 then
4729 AbortMsg(sCaseDuplicateNotAllowed)
4730 else
4731 begin
4732 SwitchFixups.Add(tmp);
4733 SwitchFixups.Add(Format('%d=brcmp EQ, %s, %s, %s', [fSwitchDepth, L1, caseval, stackval]));
4734 end;
4735 fSemiColonRequired := False;
4736 end
4737 else
4738 AbortMsg(sCaseInvalid);
4739 end;
4740
4741 procedure TNXCComp.DoSwitchDefault;
4742 var
4743 L1 : string;
4744 begin
4745 if fSwitchDepth > 0 then
4746 begin
4747 Next; // move past 'default'
4748 MatchString(':');
4749 L1 := NewLabel;
4750 PostLabel(L1);
4751 SwitchFixups.Add(Format('%d=jmp %s', [fSwitchDepth, L1]));
4752 fSemiColonRequired := False;
4753 end
4754 else
4755 AbortMsg(sDefaultInvalid);
4756 end;
4757
4758 procedure TNXCComp.ClearSwitchFixups;
4759 var
4760 i : integer;
4761 tmpType, tmpCases, tmpDepth, name : string;
4762 begin
4763 // remove all fixups with depth == fSwitchDepth
4764 tmpDepth := IntTostr(fSwitchDepth);
4765 tmpType := Format('%d_Type', [fSwitchDepth]);
4766 tmpCases := Format('%d_Cases', [fSwitchDepth]);
4767 for i := SwitchFixups.Count - 1 downto 0 do
4768 begin
4769 name := SwitchFixups.Names[i];
4770 if (name = tmpDepth) or (name = tmpType) or (name = tmpCases) then
4771 SwitchFixups.Delete(i);
4772 end;
4773 for i := SwitchRegisterNames.Count - 1 downto 0 do
4774 begin
4775 if SwitchRegisterNames.Names[i] = tmpDepth then
4776 SwitchRegisterNames.Delete(i);
4777 end;
4778 end;
4779
SwitchIsStringnull4780 function TNXCComp.SwitchIsString: Boolean;
4781 var
4782 i : integer;
4783 tmpType : string;
4784 begin
4785 Result := False;
4786 tmpType := Format('%d_Type', [fSwitchDepth]);
4787 for i := 0 to SwitchFixups.Count - 1 do
4788 begin
4789 if SwitchFixups.Names[i] = tmpType then
4790 begin
4791 Result := Boolean(StrToIntDef(SwitchFixups.ValueFromIndex[i], 0));
4792 Break;
4793 end;
4794 end;
4795 end;
4796
SwitchRegisterNamenull4797 function TNXCComp.SwitchRegisterName: string;
4798 var
4799 i : integer;
4800 begin
4801 Result := RegisterName;
4802 for i := 0 to SwitchRegisterNames.Count - 1 do
4803 begin
4804 if SwitchRegisterNames.Names[i] = IntToStr(fSwitchDepth) then
4805 begin
4806 Result := SwitchRegisterNames.ValueFromIndex[i];
4807 break;
4808 end;
4809 end;
4810 end;
4811
4812 procedure TNXCComp.FixupSwitch(idx : integer; lbl : string);
4813 var
4814 i : integer;
4815 cnt : integer;
4816 tmpDepth : string;
4817 begin
4818 // always add a jump to the end of the switch in case
4819 // there aren't any default labels in the switch
4820 tmpDepth := IntToStr(fSwitchDepth);
4821 SwitchFixups.Add(Format('%d=jmp %s', [fSwitchDepth, lbl]));
4822 cnt := 0;
4823 for i := 0 to SwitchFixups.Count - 1 do
4824 begin
4825 if SwitchFixups.Names[i] = tmpDepth then
4826 begin
4827 NBCSource.Insert(idx+cnt, SwitchFixups.ValueFromIndex[i]);
4828 inc(cnt);
4829 end;
4830 end;
4831 end;
4832
SwitchFixupIndexnull4833 function TNXCComp.SwitchFixupIndex: integer;
4834 begin
4835 Result := NBCSource.Count;
4836 end;
4837
ReplaceTokensnull4838 function TNXCComp.ReplaceTokens(const line: string) : string;
4839 begin
4840 Result := line; // line is already trimmed
4841 if Length(Result) = 0 then Exit;
4842 Result := Replace(Result, '__RETURN__', Format(#13#10'mov %s,', [SignedRegisterName]));
4843 Result := Replace(Result, '__RETURNS__', Format(#13#10'mov %s,', [SignedRegisterName]));
4844 if Pos('__RETURNU__', Result) > 0 then
4845 begin
4846 Result := Replace(Result, '__RETURNU__', Format(#13#10'mov %s,', [UnsignedRegisterName]));
4847 if StatementType <> stUnsigned then
4848 StatementType := stUnsigned;
4849 end;
4850 if Pos('__RETURNF__', Result) > 0 then
4851 begin
4852 Result := Replace(Result, '__RETURNF__', Format(#13#10'mov %s,', [FloatRegisterName]));
4853 if StatementType <> stFloat then
4854 StatementType := stFloat;
4855 end;
4856 Result := Replace(Result, '__TMPBYTE__', TempSignedByteName);
4857 Result := Replace(Result, '__TMPWORD__', TempSignedWordName);
4858 Result := Replace(Result, '__TMPLONG__', TempSignedLongName);
4859 Result := Replace(Result, '__TMPULONG__', TempUnsignedLongName);
4860 Result := Replace(Result, '__TMPFLOAT__', TempFloatName);
4861 Result := Replace(Result, '__RETVAL__', SignedRegisterName);
4862 if Pos('__FLTRETVAL__', Result) > 0 then
4863 begin
4864 Result := Replace(Result, '__FLTRETVAL__', FloatRegisterName);
4865 if StatementType <> stFloat then
4866 StatementType := stFloat;
4867 end;
4868 if Pos('__URETVAL__', Result) > 0 then
4869 begin
4870 Result := Replace(Result, '__URETVAL__', UnsignedRegisterName);
4871 if StatementType <> stUnsigned then
4872 StatementType := stUnsigned;
4873 end;
4874 Result := Replace(Result, '__STRRETVAL__', StrRetValName);
4875 Result := Replace(Result, '__STRBUFFER__', StrBufName);
4876 Result := Replace(Result, '__STRTMPBUFFER__', StrTmpBufName);
4877 Result := Replace(Result, '__GENRETVAL__', RegisterName);
4878 Result := Replace(Result, 'true', 'TRUE');
4879 Result := Replace(Result, 'false', 'FALSE');
4880 Result := Replace(Result, 'asminclude', '#include');
4881 end;
4882
DecorateVariablesnull4883 function TNXCComp.DecorateVariables(const asmStr: string): string;
4884 var
4885 Lex : TGenLexer;
4886 len : integer;
4887 bPartOfStruct, bPastFirstKeyword : boolean;
4888
4889 procedure AddToResult;
4890 begin
4891 if (Lex.Id = piIdent) or (bPastFirstKeyword and (Lex.Id = piKeyWord)) then
4892 begin
4893 // is this a local variable or a parameter?
4894 if bPartOfStruct then
4895 Result := Result + Lex.Token
4896 else
4897 Result := Result + GetDecoratedIdent(Lex.Token);
4898 end
4899 else
4900 Result := Result + Lex.Token;
4901 if not bPartOfStruct then
4902 bPartOfStruct := Lex.Token = '.'
4903 else
4904 bPartOfStruct := (Lex.Token = '.') or (Lex.Id in [piIdent]);
4905 end;
4906 begin
4907 Result := '';
4908 len := Length(asmStr);
4909 if len > 0 then
4910 begin
4911 Lex := TNBCLexer.CreateLexer;
4912 try
4913 bPartOfStruct := False;
4914 bPastFirstKeyword := False;
4915 Lex.SetStartData(@asmStr[1], len);
4916 while not Lex.AtEnd do
4917 begin
4918 AddToResult;
4919 if not bPastFirstKeyword and (Lex.Id = piKeyWord) then
4920 bPastFirstKeyword := True;
4921 Lex.Next;
4922 end;
4923 if Lex.Id <> piUnknown then
4924 AddToResult;
4925 finally
4926 Lex.Free;
4927 end;
4928 end;
4929 end;
4930
4931 procedure TNXCComp.DoAsm(var dt : char);
4932 var
4933 asmStr : string;
4934 nestLevel : integer;
4935 begin
4936 // gather everything within asm block and output it
4937 fProcessingAsmBlock := True;
4938 try
4939 EmitPoundLine;
4940 MatchString(TOK_BEGIN);
4941 if Value <> TOK_END then
4942 begin
4943 asmStr := Value + ' ' + Look;
4944 repeat
4945 nestLevel := 0;
4946 repeat
4947 GetCharX;
4948 if Look = TOK_BEGIN then
4949 inc(nestLevel);
4950 if (Look <> TOK_END) or (nestLevel > 0) then
4951 asmStr := asmStr + Look;
4952 if Look = TOK_END then
4953 dec(nestLevel);
4954 until ((nestLevel < 0) and (Look = TOK_END)) or (Look = LF) or endofallsource;
4955 if Pos('__STRRETVAL__', asmStr) > 0 then
4956 dt := TOK_STRINGDEF
4957 else if Pos('__FLTRETVAL__', asmStr) > 0 then
4958 dt := TOK_FLOATDEF
4959 else
4960 dt := TOK_LONGDEF;
4961 asmStr := ReplaceTokens(Trim(asmStr));
4962 asmStr := DecorateVariables(asmStr);
4963 if (asmStr <> '') or (Look <> TOK_END) then
4964 EmitAsmLines(asmStr);
4965 asmStr := '';
4966 until (Look = TOK_END) or endofallsource;
4967 GetChar; // get the end token
4968 fSemiColonRequired := False;
4969 end;
4970 Next;
4971 finally
4972 fProcessingAsmBlock := False;
4973 end;
4974 end;
4975
4976 {--------------------------------------------------------------}
4977 { Parse and Translate a FOR Statement }
4978
4979 procedure TNXCComp.DoFor;
4980 var
4981 L1, L2, L3, L4: string;
4982 begin
4983 Next;
4984 OpenParen;
4985 Scan;
4986 L1 := NewLabel;
4987 L2 := NewLabel;
4988 L3 := NewLabel;
4989 L4 := NewLabel;
4990 inc(fNestingLevel);
4991 try
4992 if Token in [TOK_UNSIGNED, TOK_LONGDEF, TOK_SHORTDEF, TOK_CHARDEF,
4993 TOK_BYTEDEF, TOK_STRINGDEF, TOK_FLOATDEF] then
4994 begin
4995 DoLocals(fCurrentThreadName);
4996 end
4997 else
4998 begin
4999 if Token <> TOK_SEMICOLON then
5000 begin
5001 fNoCommaOperator := True;
5002 try
5003 Assignment;
5004 while Token = TOK_COMMA do
5005 begin
5006 Next;
5007 Assignment;
5008 end;
5009 finally
5010 fNoCommaOperator := False;
5011 end;
5012 end;
5013 Semi;
5014 end;
5015 PostLabel(L1);
5016 if Token <> TOK_SEMICOLON then
5017 CommaExpression
5018 else
5019 LoadConst('1');
5020 Semi;
5021 BranchFalse(L2);
5022 Branch(L3);
5023 PostLabel(L4);
5024 if Token <> TOK_CLOSEPAREN then
5025 begin
5026 fNoCommaOperator := True;
5027 try
5028 Assignment;
5029 while Token = TOK_COMMA do
5030 begin
5031 Next;
5032 Assignment;
5033 end;
5034 finally
5035 fNoCommaOperator := False;
5036 end;
5037 end;
5038 CloseParen;
5039 Branch(L1);
5040 PostLabel(L3);
5041 Block(L2, L4);
5042 Branch(L4);
5043 PostLabel(L2);
5044 finally
5045 DecrementNestingLevel;
5046 end;
5047 end;
5048
5049 function IndexOfAPICommand(const name : string) : integer;
5050 begin
5051 for Result := Low(APIList) to High(APIList) do
5052 begin
5053 if APIList[Result] = name then
5054 Exit;
5055 end;
5056 Result := -1;
5057 end;
5058
5059 procedure TNXCComp.DoAPICommands(const lend, lstart : string);
5060 var
5061 idx : integer;
5062 begin
5063 idx := IndexOfAPICommand(Value);
5064 case idx of
5065 API_BREAK : DoBreakContinue(idx, lend);
5066 API_CONTINUE : DoBreakContinue(idx, lstart);
5067 API_RETURN : DoReturn;
5068 API_ONFWD,
5069 API_ONREV : DoOnFwdRev;
5070 API_ONFWDEX,
5071 API_ONREVEX : DoOnFwdRevEx;
5072 API_ONFWDREG,
5073 API_ONREVREG : DoOnFwdRevReg;
5074 API_ONFWDREGEX,
5075 API_ONREVREGEX : DoOnFwdRevRegEx;
5076 API_ONFWDREGPID,
5077 API_ONREVREGPID : DoOnFwdRevRegPID;
5078 API_ONFWDREGEXPID,
5079 API_ONREVREGEXPID : DoOnFwdRevRegExPID;
5080 API_OFF,
5081 API_COAST,
5082 API_FLOAT : DoStopMotors;
5083 API_OFFEX,
5084 API_COASTEX : DoStopMotorsEx;
5085 API_ONFWDSYNC,
5086 API_ONREVSYNC : DoOnFwdRevSync;
5087 API_ONFWDSYNCEX,
5088 API_ONREVSYNCEX : DoOnFwdRevSyncEx;
5089 API_ONFWDSYNCPID,
5090 API_ONREVSYNCPID : DoOnFwdRevSyncPID;
5091 API_ONFWDSYNCEXPID,
5092 API_ONREVSYNCEXPID : DoOnFwdRevSyncExPID;
5093 API_RESETTACHOCOUNT,
5094 API_RESETBLOCKTACHOCOUNT,
5095 API_RESETROTATIONCOUNT,
5096 API_RESETALLTACHOCOUNTS : DoResetCounters;
5097 API_ROTATEMOTOR,
5098 API_ROTATEMOTOREX,
5099 API_ROTATEMOTORPID,
5100 API_ROTATEMOTOREXPID : DoRotateMotors(idx);
5101 {
5102 API_SETSENSORTYPE,
5103 API_SETSENSORMODE : DoSetSensorTypeMode(idx);
5104 API_CLEARSENSOR,
5105 API_SETSENSORTOUCH,
5106 API_SETSENSORLIGHT,
5107 API_SETSENSORSOUND,
5108 API_SETSENSORLOWSPEED,
5109 API_RESETSENSOR : DoClearSetResetSensor;
5110 }
5111 API_PRECEDES,
5112 API_FOLLOWS : DoPrecedesFollows;
5113 API_ACQUIRE,
5114 API_RELEASE : DoAcquireRelease;
5115 API_EXITTO : DoExitTo;
5116 API_SETINPUT,
5117 API_SETOUTPUT : DoSetInputOutput(idx);
5118 API_STOP : DoStop;
5119 API_GOTO : DoGoto;
5120 else
5121 AbortMsg(sUnknownAPICommand);
5122 end;
5123 end;
5124
5125 {--------------------------------------------------------------}
5126 { Parse and Translate a Single Statement }
5127
5128 procedure TNXCComp.Statement(const lend, lstart : string);
5129 var
5130 dt : Char;
5131 begin
5132 fUDTOnStack := ''; // a UDT can't remain on the stack across a statement boundary
5133 ResetStatementType;
5134 fSemiColonRequired := True;
5135 if Token = TOK_BEGIN then
5136 Block(lend, lstart)
5137 else
5138 begin
5139 ProcessDirectives;
5140 case Token of
5141 TOK_IF: DoIf(lend, lstart);
5142 TOK_WHILE: DoWhile;
5143 TOK_FOR: DoFor;
5144 TOK_DO: DoDoWhile;
5145 TOK_REPEAT: DoRepeat;
5146 TOK_SWITCH: DoSwitch(lstart);
5147 TOK_CASE: DoSwitchCase;
5148 TOK_DEFAULT: DoSwitchDefault;
5149 TOK_START: DoStart;
5150 TOK_STOP: DoStopTask;
5151 TOK_PRIORITY: DoSetPriority;
5152 TOK_ASM: begin
5153 Next;
5154 dt := #0;
5155 DoAsm(dt);
5156 end;
5157 TOK_API: DoAPICommands(lend, lstart);
5158 TOK_IDENTIFIER: begin
5159 if Look = ':' then
5160 DoLabel
5161 else
5162 Assignment;
5163 end;
5164 TOK_HEX, TOK_NUM, '+', '-': begin
5165 CommaExpression;
5166 end;
5167 TOK_CLOSEPAREN : CloseParen;
5168 TOK_SEMICOLON : ;// do nothing
5169 TOK_END : fSemiColonRequired := False;
5170 end;
5171 EmitPoundLine;
5172 end;
5173 end;
5174
5175
5176 {--------------------------------------------------------------}
5177 { Parse and Translate a Block of Statements }
5178
TNXCComp.Blocknull5179 function TNXCComp.Block(const lend, lstart : string) : boolean;
5180 begin
5181 Result := Value = TOK_BEGIN;
5182 if Result then
5183 begin
5184 Next;
5185 inc(fNestingLevel);
5186 try
5187 BlockStatements(lend, lstart);
5188 finally
5189 DecrementNestingLevel;
5190 end;
5191 MatchString(TOK_END);
5192 fSemiColonRequired := False;
5193 Scan;
5194 end
5195 else
5196 begin
5197 Scan;
5198 CommaStatement(lend, lstart);
5199 end;
5200 end;
5201
5202 procedure TNXCComp.CheckBytesRead(const oldBytesRead: integer);
5203 begin
5204 if fBytesRead = oldBytesRead then
5205 begin
5206 AbortMsg(sParserError);
5207 SkipLine;
5208 Next;
5209 end;
5210 end;
5211
5212 procedure TNXCComp.BlockStatements(const lend, lstart: string);
5213 var
5214 oldBytesRead : integer;
5215 begin
5216 Scan;
5217 while not (Token in [TOK_END, TOK_ELSE]) and not endofallsource do
5218 begin
5219 oldBytesRead := fBytesRead;
5220 DoLocals(fCurrentThreadName);
5221 CommaStatement(lend, lstart);
5222 CheckSemicolon;
5223 CheckBytesRead(oldBytesRead);
5224 end;
5225 end;
5226
5227 {--------------------------------------------------------------}
5228 { Allocate Storage for a Variable }
5229
5230 procedure TNXCComp.AllocLocal(const sub, tname : string; dt : char; bConst : boolean);
5231 var
5232 savedval : string;
5233 ival, aval, lenexpr, varName : string;
5234 bIsArray, bDone, bOpen : boolean;
5235 idx, dimensions : integer;
5236 V : TVariable;
5237 begin
5238 Next;
5239 Scan;
5240 // it is possible that the user has declared a variable using the "long int" or "short int" syntax.
5241 // we want to support that syntax.
5242 if Token = TOK_SHORTDEF then begin
5243 if dt in [TOK_LONGDEF, TOK_ULONGDEF, TOK_SHORTDEF, TOK_USHORTDEF] then
5244 Next;
5245 end;
5246 if Token <> TOK_IDENTIFIER then
5247 Expected(sVariableName);
5248 savedval := Value;
5249 ival := '';
5250 Next;
5251 aval := '';
5252 lenexpr := '';
5253 bIsArray := False;
5254 if (Token = '[') {and (Look = ']') }then begin
5255 // declaring an array
5256 bDone := False;
5257 bOpen := False;
5258 while not bDone {Token in ['[', ']']} do
5259 begin
5260 lenexpr := lenexpr + Value;
5261 if Token in ['[', ']'] then
5262 aval := aval + Token;
5263 if bOpen and (Token = ']') then
5264 bOpen := False
5265 else if not bOpen and (Token = '[') then
5266 bOpen := True
5267 else if (bOpen and (Token = '[')) or
5268 (not bOpen and (Token = ']')) then
5269 AbortMsg(sInvalidArrayDeclaration);
5270 Next;
5271 if not bOpen and (Token <> '[') then
5272 bDone := True;
5273 end;
5274 dimensions := Length(aval) div 2; // number of array dimensions
5275 dt := ArrayOfType(dt, dimensions);
5276 bIsArray := True;
5277 end;
5278 if bIsArray and bConst then
5279 AbortMsg(sConstLocArrNotSupported);
5280 varName := ApplyDecoration(sub, savedval, fNestingLevel);
5281 idx := AddLocal(varName, dt, tname, bConst, lenexpr);
5282 if (Token = TOK_COMMA) or (Token = TOK_SEMICOLON) then
5283 begin
5284 if bConst then
5285 Expected(sConstInitialization);
5286 // no need to allocate if we've already emitted this name&type
5287 if fEmittedLocals.IndexOf(varName+tname) = -1 then
5288 Allocate(varName, aval, ival, tname, dt);
5289 if bIsArray and (lenexpr <> '') then
5290 InitializeArray(varName, aval, ival, tname, dt, lenexpr);
5291 end
5292 else if Token = '=' then
5293 begin
5294 // move past the '=' sign
5295 fLHSDataType := dt;
5296 fLHSName := savedval;
5297 try
5298 Next;
5299 ival := '';
5300 if fEmittedLocals.IndexOf(varName+tname) = -1 then
5301 Allocate(varName, aval, ival, tname, dt);
5302 if bIsArray then begin
5303 ival := GetInitialValue(dt);
5304 DoLocalArrayInit(varName, ival, dt);
5305 // if not bIsArray then
5306 // DoArrayAssignValue(savedval, '', dt)
5307 end
5308 else if dt = TOK_USERDEFINEDTYPE then
5309 begin
5310 GetAndStoreUDT(savedval);
5311 end
5312 else
5313 begin
5314 DoAssignValue(savedval, dt);
5315 if fLastExpressionOptimizedToConst and (idx <> -1) then
5316 begin
5317 V := fLocals[idx];
5318 if V.IsConstant then
5319 V.Value := fLastLoadedConst;
5320 end;
5321 end;
5322 finally
5323 fLHSDataType := TOK_LONGDEF;
5324 fLHSName := '';
5325 end;
5326 end
5327 else
5328 Next;
5329 fEmittedLocals.Add(varName+tname);
5330 end;
5331
GetInitialValuenull5332 function TNXCComp.GetInitialValue(dt : char): string;
5333 var
5334 nestLevel, i : integer;
5335 tmpExpr : string;
5336 procedure UpdateResultWithValueForArrayTypes;
5337 begin
5338 if tmpExpr <> '' then
5339 begin
5340 if ArrayBaseType(dt) = TOK_STRINGDEF then
5341 begin
5342 Result := Result + tmpExpr + Value;
5343 tmpExpr := '';
5344 end
5345 else
5346 begin
5347 fCalc.SilentExpression := tmpExpr;
5348 if not fCalc.ParserError then
5349 begin
5350 if ArrayBaseType(dt) = TOK_FLOATDEF then
5351 begin
5352 tmpExpr := NBCFloatToStr(fCalc.Value);
5353 end
5354 else
5355 tmpExpr := IntToStr(Trunc(fCalc.Value))
5356 end
5357 else
5358 AbortMsg(sInvalidConstExpr);
5359 Result := Result + tmpExpr + Value;
5360 tmpExpr := '';
5361 end;
5362 end
5363 else
5364 Result := Result + Value;
5365 end;
5366 begin
5367 Result := '';
5368 // handle string variables differently
5369 if dt = TOK_STRINGDEF then
5370 begin
5371 if Token = TOK_IDENTIFIER then
5372 begin
5373 // try to resolve this as a constant string into a string literal
5374 i := fConstStringMap.IndexOfName(Value);
5375 if i <> -1 then
5376 begin
5377 Token := TOK_STRINGLIT;
5378 Value := fConstStringMap.ValueFromIndex[i];
5379 end;
5380 end;
5381 Result := Value;
5382 if Token <> TOK_STRINGLIT then
5383 AbortMsg(sInvalidStringInit);
5384 Next;
5385 end
5386 else if IsArrayType(dt) or IsUDT(dt) then
5387 begin
5388 // array and struct initialization could involve nested {} pairs
5389 if Token <> TOK_BEGIN then
5390 AbortMsg(sInvalidArrayInit);
5391 nestLevel := 1;
5392 while ((Token <> TOK_END) or (nestLevel > 0)) and not endofallsource do
5393 begin
5394 if Token = TOK_BEGIN then
5395 begin
5396 tmpExpr := '';
5397 UpdateResultWithValueForArrayTypes;
5398 end
5399 else if Token in [TOK_END, TOK_COMMA] then
5400 begin
5401 UpdateResultWithValueForArrayTypes;
5402 end
5403 else
5404 begin
5405 tmpExpr := tmpExpr + Value;
5406 end;
5407 Next;
5408 if Token = TOK_BEGIN then
5409 inc(nestLevel)
5410 else if Token = TOK_END then
5411 dec(nestLevel);
5412 end;
5413 if Token = TOK_END then
5414 begin
5415 UpdateResultWithValueForArrayTypes;
5416 Next;
5417 end
5418 else
5419 AbortMsg(sInvalidArrayInit);
5420 end
5421 else
5422 begin
5423 if dt = TOK_MUTEXDEF then
5424 AbortMsg(sInitNotAllowed);
5425 // not a string, not an array, not a mutex. Must be a scalar type or user-defined type
5426 while not (Token in [TOK_COMMA, TOK_SEMICOLON]) and not endofallsource do
5427 begin
5428 Result := Result + Value;
5429 Next;
5430 end;
5431 Result := Trim(Result);
5432 if dt in NonAggregateTypes then
5433 begin
5434 // evaluate so that constants and expressions are handled properly
5435 if Result = 'false' then
5436 Result := '0'
5437 else if Result = 'true' then
5438 Result := '1'
5439 else
5440 begin
5441 fCalc.SilentExpression := Result;
5442 if not fCalc.ParserError then
5443 begin
5444 if dt = TOK_FLOATDEF then
5445 Result := NBCFloatToStr(fCalc.Value)
5446 else
5447 Result := IntToStr(Trunc(fCalc.Value));
5448 end
5449 else
5450 AbortMsg(sInvalidConstExpr);
5451 end;
5452 end;
5453 end;
5454 end;
5455
5456 procedure TNXCComp.AllocGlobal(const tname : string; dt : char; bInline, bSafeCall, bConst : boolean);
5457 var
5458 savedval, ival, aval, lenexpr : string;
5459 dimensions, idx : integer;
5460 bArray : boolean;
5461 begin
5462 Next;
5463 Scan;
5464 // it is possible that the user has declared a variable using the "long int" or "short int" syntax.
5465 // we want to support that syntax.
5466 if Token = TOK_SHORTDEF then begin
5467 if dt in [TOK_LONGDEF, TOK_ULONGDEF, TOK_SHORTDEF, TOK_USHORTDEF] then
5468 begin
5469 Next;
5470 Scan;
5471 end;
5472 end;
5473 if Token <> TOK_IDENTIFIER then Expected(sVariableName);
5474 // optional initial value
5475 savedval := Value;
5476 ival := '';
5477 Next;
5478 // it is possible that we are looking at a function declaration
5479 // rather than a variable declaration.
5480 if Token = TOK_OPENPAREN then
5481 begin
5482 FunctionBlock(savedval, tname, dt, bInline, bSafeCall);
5483 fSemiColonRequired := False;
5484 end
5485 else
5486 begin
5487 fSemiColonRequired := True;
5488 CheckDup(savedval);
5489 if bInline then
5490 AbortMsg(sInlineInvalid);
5491 if bSafeCall then
5492 AbortMsg(sSafeCallInvalid);
5493 aval := '';
5494 lenexpr := '';
5495 bArray := False;
5496 dimensions := 0;
5497 if Token = '[' then begin
5498 aval := ProcessArrayDimensions(lenexpr);
5499 dimensions := Length(aval) div 2; // number of array dimensions
5500 dt := ArrayOfType(dt, dimensions);
5501 bArray := True;
5502 end;
5503 AddEntry(savedval, dt, tname, lenexpr, bConst);
5504 if (Token = TOK_COMMA) or (Token = TOK_SEMICOLON) then
5505 begin
5506 if bConst then
5507 Expected(sConstInitialization);
5508 Allocate(savedval, aval, ival, tname, dt);
5509 end
5510 else if Token = '=' then
5511 begin
5512 if bArray and (ArrayBaseType(dt) = TOK_STRINGDEF) then
5513 inc(dimensions);
5514 // move past the '=' sign
5515 Next;
5516 ival := GetInitialValue(dt);
5517 // lookup global and set its value
5518 idx := fGlobals.IndexOfName(savedval);
5519 if idx <> -1 then
5520 begin
5521 // do not set the value for 1 dimensional arrays since the initial
5522 // values can be set statically
5523 if dimensions <> 1 then
5524 fGlobals[idx].Value := ival;
5525 end;
5526 // the value must be a numeric constant expression if the type
5527 // is an integer type
5528 if bConst then
5529 begin
5530 if dt in NonAggregateTypes then
5531 begin
5532 if dt = TOK_FLOATDEF then
5533 fCalc.SetVariable(savedval, NBCStrToFloatDef(ival, 0))
5534 else
5535 fCalc.SetVariable(savedval, StrToInt64Def(ival, 0));
5536 end
5537 else if dt = TOK_STRINGDEF then
5538 begin
5539 // string constants - use a variable name to value map (string list)
5540 fConstStringMap.Add(savedval+'='+ival);
5541 end;
5542 // it is now okay to have const struct types since you can initialize them
5543 // else if not bArray then
5544 // AbortMsg(sInvalidConstExpr);
5545 end;
5546 // arrays with > 1 dimension cannot be initialized statically
5547 if dimensions > 1 then
5548 ival := '';
5549 Allocate(savedval, aval, ival, tname, dt);
5550 end
5551 else
5552 Next;
5553 end;
5554 end;
5555
GetVariableTypenull5556 function TNXCComp.GetVariableType(vt : char; bUnsigned : boolean) : char;
5557 begin
5558 if not bUnsigned then
5559 Result := vt
5560 else
5561 case vt of
5562 TOK_LONGDEF : Result := TOK_ULONGDEF;
5563 TOK_SHORTDEF : Result := TOK_USHORTDEF;
5564 TOK_CHARDEF : Result := TOK_BYTEDEF;
5565 else
5566 if vt = TOK_FLOATDEF then
5567 AbortMsg(sNoUnsignedFloat);
5568 Result := vt;
5569 end;
5570 end;
5571
5572 {--------------------------------------------------------------}
5573 { Parse and Translate Global Declarations }
5574
5575 procedure TNXCComp.TopDecls;
5576 var
5577 vt : char;
5578 bUnsigned, bInline, bSafeCall, bConst : boolean;
5579 oldBytesRead : Integer;
5580 dt : char;
5581 tname : string;
5582 begin
5583 DoCompilerStatusChange(sNXCProcessGlobals);
5584 bUnsigned := False;
5585 bInline := False;
5586 bSafeCall := False;
5587 bConst := False;
5588 Scan;
5589 if Token = TOK_IDENTIFIER then
5590 CheckForTypedef(bUnsigned, bConst, bInline, bSafeCall);
5591 while not (Token in [TOK_TASK, TOK_PROCEDURE]) and not endofallsource do
5592 begin
5593 oldBytesRead := fBytesRead;
5594 case Token of
5595 TOK_ASM: begin
5596 Next;
5597 dt := #0;
5598 DoAsm(dt);
5599 Scan;
5600 end;
5601 TOK_DIRECTIVE : begin
5602 ProcessDirectives;
5603 Scan;
5604 end;
5605 TOK_CONST : begin
5606 Next;
5607 Scan;
5608 bConst := True;
5609 end;
5610 TOK_UNSIGNED : begin
5611 Next;
5612 Scan;
5613 bUnsigned := True;
5614 end;
5615 TOK_INLINE : begin
5616 Next;
5617 Scan;
5618 bInline := True;
5619 end;
5620 TOK_SAFECALL : begin
5621 Next;
5622 Scan;
5623 bSafeCall := True;
5624 end;
5625 TOK_TYPEDEF : begin
5626 ProcessTypedef;
5627 end;
5628 TOK_ENUM: begin
5629 ProcessEnum(true);
5630 end;
5631 TOK_STRUCT : begin
5632 ProcessStruct(False);
5633 end;
5634 TOK_USERDEFINEDTYPE,
5635 TOK_LONGDEF, TOK_SHORTDEF,
5636 TOK_CHARDEF, TOK_BYTEDEF,
5637 TOK_MUTEXDEF, TOK_FLOATDEF,
5638 TOK_STRINGDEF : begin
5639 tname := Value;
5640 vt := Token;
5641 AllocGlobal(tname, GetVariableType(vt, bUnsigned), bInline, bSafeCall, bConst);
5642 while Token = TOK_COMMA do
5643 AllocGlobal(tname, GetVariableType(vt, bUnsigned), bInline, bSafeCall, bConst);
5644 CheckSemicolon;
5645 bUnsigned := False;
5646 bInline := False;
5647 bSafeCall := False;
5648 bConst := False;
5649 end;
5650 else
5651 // nothing here right now
5652 Semi;
5653 Scan;
5654 end;
5655 if Token = TOK_IDENTIFIER then
5656 CheckForTypedef(bUnsigned, bConst, bInline, bSafeCall);
5657 CheckBytesRead(oldBytesRead);
5658 end;
5659 if bInLine then
5660 IncrementInlineDepth;
5661 // fInlining := bInLine;
5662 fSafeCalling := bSafeCall;
5663 end;
5664
AddLocalnull5665 function TNXCComp.AddLocal(name : string; dt : char; const tname : string;
5666 bConst : boolean; const lenexp : string) : integer;
5667 var
5668 l, IL : TVariable;
5669 bAmInlining : boolean;
5670 // bIsParam, bIsLocal : boolean;
5671 begin
5672 CheckForValidDataType(dt);
5673 Result := -1;
5674 bAmInlining := AmInlining;
5675 // bIsLocal := IsLocal(name);
5676 // bIsParam := IsParam(name);
5677 // // if we are inlining then only check IsLocal
5678 // if (bAmInlining and bIsLocal) or
5679 // ((not bAmInlining) and (bIsLocal or bIsParam)) then
5680 if IsParam(name) or IsLocal(name) then
5681 Duplicate(name)
5682 else
5683 begin
5684 l := fLocals.Add;
5685 l.Name := name;
5686 l.DataType := dt;
5687 l.IsConstant := bConst;
5688 l.TypeName := tname;
5689 l.LenExpr := lenexp;
5690 l.Level := fNestingLevel;
5691 if bAmInlining and Assigned(fCurrentInlineFunction) then
5692 begin
5693 IL := fCurrentInlineFunction.LocalVariables.Add;
5694 IL.Assign(l);
5695 end;
5696 Result := l.Index;
5697 end;
5698 end;
5699
5700 procedure TNXCComp.DoLocals(const sub : string);
5701 var
5702 bIsUnsigned, bIsConst, bDummy : boolean;
5703 dt : char;
5704 tname : string;
5705 begin
5706 fNoCommaOperator := True;
5707 try
5708 bIsUnsigned := False;
5709 bIsConst := False;
5710 bDummy := False;
5711 Scan;
5712 if Token = TOK_IDENTIFIER then
5713 CheckForTypedef(bIsUnsigned, bIsConst, bDummy, bDummy);
5714 while (Token in [TOK_DIRECTIVE, TOK_UNSIGNED, TOK_CONST,
5715 TOK_TYPEDEF, TOK_STRUCT, TOK_ENUM,
5716 TOK_USERDEFINEDTYPE,
5717 TOK_LONGDEF, TOK_SHORTDEF, TOK_CHARDEF,
5718 TOK_BYTEDEF, TOK_MUTEXDEF, TOK_FLOATDEF, TOK_STRINGDEF]) and not endofallsource do
5719 begin
5720 case Token of
5721 TOK_DIRECTIVE : begin
5722 ProcessDirectives;
5723 Scan;
5724 end;
5725 TOK_CONST : begin
5726 Next;
5727 Scan;
5728 bIsConst := True;
5729 end;
5730 TOK_UNSIGNED : begin
5731 Next;
5732 Scan;
5733 bIsUnsigned := True;
5734 end;
5735 TOK_TYPEDEF : begin
5736 ProcessTypedef;
5737 end;
5738 TOK_ENUM : begin
5739 ProcessEnum(False);
5740 end;
5741 TOK_STRUCT : begin
5742 ProcessStruct(False);
5743 end;
5744 TOK_USERDEFINEDTYPE,
5745 TOK_LONGDEF, TOK_SHORTDEF,
5746 TOK_CHARDEF, TOK_BYTEDEF,
5747 TOK_MUTEXDEF, TOK_FLOATDEF, TOK_STRINGDEF : begin
5748 tname := Value;
5749 dt := Token;
5750 AllocLocal(sub, tname, GetVariableType(dt, bIsUnsigned), bIsConst);
5751 while Token = TOK_COMMA do
5752 AllocLocal(sub, tname, GetVariableType(dt, bIsUnsigned), bIsConst);
5753 Semi;
5754 Scan;
5755 bIsUnsigned := False;
5756 bIsConst := False;
5757 end;
5758 else
5759 Expected(sValidProgBlock);
5760 end;
5761 if Token = TOK_IDENTIFIER then
5762 CheckForTypedef(bIsUnsigned, bIsConst, bDummy, bDummy);
5763 end;
5764 finally
5765 fNoCommaOperator := False;
5766 end;
5767 end;
5768
5769 const
5770 HASPROTO = 2;
5771 HASNOPROTO = 3;
5772
FormalListnull5773 function TNXCComp.FormalList(protoexists : boolean; var procname : string) : integer;
5774 var
5775 protocount : integer;
5776 pltype : integer;
5777 pcount : integer;
5778 ptype : char;
5779 varnam : string;
5780 bIsUnsigned, bIsArray, bIsConst, bIsRef, bError : boolean;
5781 bHasDefault, bRequireDefaults : boolean;
5782 aval, tname, defValue : string;
5783 dimensions : integer;
5784 oldBytesRead : integer;
5785
5786 procedure CheckParam1;
5787 begin
5788 AbortMsg(sBadPrototype);
5789 bError := True;
5790 if protocount >= MAXPARAMS then
5791 AbortMsg(sMaxParamCountExceeded);
5792 inc(protocount);
5793 end;
5794
5795 procedure CheckParamHasProto;
5796 begin
5797 if not protoexists then
5798 begin
5799 Expected(sDataType);
5800 bError := True;
5801 end;
5802 if pcount >= MAXPARAMS then
5803 begin
5804 AbortMsg(sMaxParamCountExceeded);
5805 bError := True;
5806 end;
5807 if not bError then
5808 begin
5809 AddParam(ApplyDecoration(procname, varnam, 0),
5810 FunctionParameterType(procname, pcount),
5811 FunctionParameterTypeName(procname, pcount),
5812 FunctionParameterIsConstant(procname, pcount),
5813 FunctionParameterHasDefault(procname, pcount),
5814 FunctionParameterDefaultValue(procname, pcount));
5815 inc(pcount);
5816 if pcount > protocount then
5817 begin
5818 AbortMsg(sTooManyArgs);
5819 bError := True;
5820 end;
5821 end;
5822 end;
5823
5824 procedure CheckParamHasNoProto;
5825 var
5826 fpDT : char;
5827 fpType : string;
5828 fpIsConst : boolean;
5829 begin
5830 if pcount >= MAXPARAMS then
5831 begin
5832 AbortMsg(sMaxParamCountExceeded);
5833 bError := True;
5834 end;
5835 if protoexists and not bError and (pcount >= protocount) then
5836 begin
5837 AbortMsg(sTooManyArgs);
5838 bError := True;
5839 end;
5840 if protoexists and not bError then
5841 begin
5842 // compare known type to specified type
5843 fpDT := FunctionParameterType(procname, pcount);
5844 fpType := FunctionParameterTypeName(procname, pcount);
5845 fpIsConst := FunctionParameterIsConstant(procname, pcount);
5846 if (fpDT <> ptype) or (fpType <> tname) or (fpIsConst <> bIsConst) then
5847 begin
5848 AbortMsg(sFuncParamDeclMismatch);
5849 bError := True;
5850 end;
5851 end;
5852 if not bError then
5853 begin
5854 AddParam(ApplyDecoration(procname, varnam, 0), ptype, tname, bIsConst, bHasDefault, defValue);
5855 if not protoexists then
5856 begin
5857 Allocate(ApplyDecoration(procname, varnam, 0), aval, '', tname, ptype);
5858 AddFunctionParameter(procname, varnam, tname, pcount, ptype, bIsConst,
5859 bIsRef, bIsArray, dimensions, bHasDefault, defValue);
5860 inc(protocount);
5861 end;
5862 inc(pcount);
5863 end;
5864 end;
5865
5866 procedure CheckPLType;
5867 begin
5868 case pltype of
5869 1 : CheckParam1;
5870 HASPROTO : CheckParamHasProto;
5871 HASNOPROTO : CheckParamHasNoProto;
5872 end;
5873 end;
5874
5875 procedure ProcessTypes(const bFirstParam : boolean);
5876 var
5877 bInline, bSafeCall : boolean;
5878 begin
5879 bIsUnsigned := False;
5880 bIsArray := False;
5881 bIsConst := False;
5882 bIsRef := False;
5883 ptype := #0;
5884 if Token = TOK_CONST then begin
5885 bIsConst := True;
5886 Next;
5887 Scan;
5888 if bFirstParam then pltype := 1;
5889 end;
5890 // new code starts here
5891 tname := Value;
5892 if Token = TOK_UNSIGNED then
5893 begin
5894 bIsUnsigned := True;
5895 Next;
5896 Scan;
5897 if bFirstParam then pltype := 1;
5898 tname := tname + ' ' + Value;
5899 end;
5900 Value := tname;
5901 CheckForTypedef(bIsUnsigned, bIsConst, bInline, bSafeCall);
5902 // re-assign type name variable in case CheckForTypedef changed it.
5903 tname := Value;
5904 ptype := Token;
5905 if bFirstParam then pltype := 1;
5906 Next;
5907 Scan;
5908 if (Token <> '[') and (Token <> TOK_COMMA) and
5909 (Token <> TOK_CLOSEPAREN) and (Token <> '&') and
5910 (Token <> TOK_IDENTIFIER) then
5911 begin
5912 AbortMsg(sUnexpectedChar);
5913 bError := True;
5914 end;
5915 (*
5916 if Token = TOK_UNSIGNED then begin
5917 bIsUnsigned := True;
5918 Next;
5919 Scan;
5920 if bFirstParam then pltype := 1;
5921 end;
5922 if Token in [TOK_CHARDEF, TOK_BYTEDEF, TOK_SHORTDEF, TOK_LONGDEF,
5923 TOK_MUTEXDEF, TOK_FLOATDEF, TOK_STRINGDEF, TOK_USERDEFINEDTYPE, TOK_STRINGLIT] then
5924 begin
5925 ptype := Token;
5926 tname := Value;
5927 if bFirstParam then pltype := 1;
5928 Next;
5929 Scan;
5930 if (Token <> '[') and (Token <> TOK_COMMA) and
5931 (Token <> TOK_CLOSEPAREN) and (Token <> '&') and
5932 (Token <> TOK_IDENTIFIER) then
5933 begin
5934 AbortMsg(sUnexpectedChar);
5935 bError := True;
5936 end;
5937 end
5938 else if bIsUnsigned then
5939 begin
5940 AbortMsg(sMissingDataType);
5941 bError := True;
5942 end;
5943 *)
5944 if Token = '&' then
5945 begin
5946 bIsRef := True;
5947 Next;
5948 Scan;
5949 end;
5950 end;
5951
5952 procedure CheckParamTypeAndArrays;
5953 begin
5954 if pltype = HASNOPROTO then
5955 begin
5956 ptype := GetVariableType(ptype, bIsUnsigned);
5957 if ptype = #0 then
5958 bError := True;
5959 CheckForValidDataType(ptype);
5960 if not bError then
5961 begin
5962 aval := '';
5963 dimensions := 0;
5964 if (Token = '[') and (Look = ']') then begin
5965 // declaring an array
5966 while Token in ['[', ']'] do begin
5967 aval := aval + Token;
5968 Next;
5969 end;
5970 bIsArray := True;
5971 dimensions := Length(aval) div 2; // number of array dimensions
5972 ptype := ArrayOfType(ptype, dimensions);
5973 end;
5974 end;
5975 end;
5976 end;
5977
5978 procedure CheckForDefaultArgumentValue;
5979 begin
5980 bHasDefault := False;
5981 defValue := '';
5982 // check for optional equal sign
5983 if Token = '=' then
5984 begin
5985 bHasDefault := True;
5986 Next;
5987 defValue := Value;
5988 if defValue = '-' then
5989 begin
5990 Next;
5991 defValue := defValue + Value;
5992 end;
5993 Next;
5994 end;
5995 if bRequireDefaults and not bHasDefault then
5996 begin
5997 AbortMsg(sDefaultParamError);
5998 bError := True;
5999 end;
6000 if bHasDefault then
6001 bRequireDefaults := True;
6002 end;
6003 begin
6004 bRequireDefaults := False;
6005 dimensions := 0;
6006 protocount := 0;
6007 pcount := 0;
6008 pltype := 0;
6009 if protoexists then
6010 protocount := FunctionParameterCount(procname);
6011 bError := False;
6012 while (Token <> TOK_CLOSEPAREN) and not endofallsource do
6013 begin
6014 oldBytesRead := fBytesRead;
6015 if bError then
6016 Break;
6017 Scan;
6018 // handle void all by itself
6019 if Token = TOK_PROCEDURE then begin
6020 Next;
6021 Scan;
6022 Continue;
6023 end;
6024 ProcessTypes(true);
6025 if Token = TOK_IDENTIFIER then
6026 begin
6027 varnam := Value;
6028 Next;
6029 Scan;
6030 if pltype = 1 then
6031 pltype := HASNOPROTO
6032 else
6033 pltype := HASPROTO;
6034 end;
6035 CheckParamTypeAndArrays;
6036 // check for optional = and default value
6037 CheckForDefaultArgumentValue;
6038 if bError then
6039 Continue;
6040 CheckPLType;
6041
6042 // process remaining parameters
6043 while (Token = TOK_COMMA) and not endofallsource do begin
6044 if bError then
6045 Break;
6046 Next;
6047 Scan;
6048 if (pltype = 1) or (pltype = HASNOPROTO) then
6049 ProcessTypes(false);
6050 if (pltype = HASPROTO) or (pltype = HASNOPROTO) then
6051 begin
6052 if Token = TOK_IDENTIFIER then begin
6053 varnam := Value;
6054 Next;
6055 Scan;
6056 end
6057 else
6058 begin
6059 Expected(sVariableName);
6060 bError := True;
6061 end;
6062 end;
6063 CheckParamTypeAndArrays;
6064 // check for optional = and default value
6065 CheckForDefaultArgumentValue;
6066 if bError then
6067 Continue;
6068 CheckPLType;
6069 end; // while Token = TOK_COMMA
6070 CheckBytesRead(oldBytesRead);
6071 end; // while Token <> TOK_CLOSEPAREN
6072 if protoexists and (pcount < protocount) then
6073 AbortMsg(sTooFewArgs);
6074 if bError then
6075 while (Token <> TOK_CLOSEPAREN) and not endofallsource do
6076 Next; // eat tokens up to TOK_CLOSEPAREN
6077 Result := pltype;
6078 end;
6079
6080 procedure TNXCComp.ProcedureBlock;
6081 var
6082 Name : string;
6083 protoexists, bIsSub : boolean;
6084 savedToken : char;
6085 begin
6086 while Token in [TOK_INLINE, TOK_SAFECALL, TOK_PROCEDURE, TOK_TASK] do
6087 begin
6088 if Token = TOK_INLINE then
6089 begin
6090 Next;
6091 IncrementInlineDepth;
6092 end;
6093 if Token = TOK_SAFECALL then
6094 begin
6095 Next;
6096 fSafeCalling := True;
6097 end;
6098 bIsSub := Token = TOK_PROCEDURE;
6099 if AmInlining and not bIsSub then
6100 AbortMsg(sInlineInvalid);
6101 if fSafeCalling and not bIsSub then
6102 AbortMsg(sSafeCallInvalid);
6103 savedToken := Token;
6104 Next;
6105 Scan;
6106 CheckIdent;
6107 Name := Value;
6108 DoCompilerStatusChange(Format(sNXCProcedure, [Name]));
6109 if bIsSub and (Name = 'main') then
6110 AbortMsg(sMainMustBeTask);
6111 protoexists := False;
6112 Next;
6113
6114 DoCommonFuncProcDecl(protoexists, Name, '', savedToken, #0, AmInlining, fSafeCalling);
6115
6116 if Token = TOK_BEGIN then
6117 begin
6118 Prolog(Name, bIsSub);
6119 MatchString(TOK_BEGIN);
6120 if Name = 'main' then
6121 begin
6122 InitializeGlobalArrays;
6123 InitializeGraphicOutVars;
6124 end;
6125 ClearLocals;
6126 fNestingLevel := 0;
6127 DoLocals(Name);
6128 BlockStatements();
6129 Epilog(bIsSub);
6130 // MatchString(TOK_END) must be after the epilog or process directives
6131 // can be called while still inlining
6132 MatchString(TOK_END);
6133 Scan;
6134 end
6135 else
6136 begin
6137 if protoexists then
6138 Expected(sProtoAlreadyDefined);
6139 Scan;
6140 end;
6141 ClearParams;
6142 // DecrementInlineDepth;
6143 // fInlining := False;
6144 fSafeCalling := False;
6145 TopDecls;
6146 end;
6147 end;
6148
6149 procedure TNXCComp.DoCommonFuncProcDecl(var bProtoExists : boolean;
6150 var Name : string; const tname : string;
6151 const tok, dt: char; bInline, bSafeCall : boolean);
6152 var
6153 procexists : integer;
6154 pltype : integer;
6155 bIsSub : boolean;
6156 begin
6157 bIsSub := tok = TOK_PROCEDURE;
6158
6159 // TODO: move this code after the processing of the formal list of parameters
6160 // so that we can decorate the function name before checking for duplicates
6161
6162 procexists := GlobalIdx(Name);
6163 if procexists <> 0 then begin
6164 if not (GS_Type[procexists] in [TOK_PROCEDURE, TOK_TASK]) then
6165 Duplicate(Name);
6166 if GS_Size[procexists] = 0 then
6167 bProtoExists := True
6168 else
6169 Duplicate(Name);
6170 end
6171 else begin
6172 // define a mutex for this function if safecall
6173 if bIsSub and (SafeCalls or bSafeCall) then
6174 EmitMutexDeclaration(Name);
6175 AddEntry(Name, tok, tname, '', False, bSafeCall);
6176 GS_ReturnType[NumGlobals] := dt;
6177 if (dt <> #0) and (IsArrayType(dt) or IsUDT(dt)) then
6178 AddEntry(Format('__result_%s', [Name]), dt, tname, '');
6179 end;
6180
6181 OpenParen;
6182 if bIsSub then
6183 pltype := FormalList(bProtoExists, Name)
6184 else begin
6185 pltype := 0;
6186 // allow for the possibility that tasks have (void) args
6187 if Value = 'void' then
6188 Next;
6189 end;
6190 CloseParen;
6191
6192 fCurrentThreadName := Name;
6193 fThreadNames.Add(Name);
6194
6195 // allow for "stuff" after the close parenthesis and before either ; or {
6196 Scan;
6197 ProcessDirectives; // just in case there are any in between the ) and the {
6198 // now it has to either be a ; or a {
6199 if not (Token in [TOK_SEMICOLON, TOK_BEGIN]) then
6200 AbortMsg(sInvalidFuncDecl);
6201 if Token = TOK_SEMICOLON then
6202 begin
6203 // this is a function declaration (a prototype) - not a function definition
6204 pltype := 1;
6205 Next;
6206 end;
6207 if Token = TOK_BEGIN then
6208 begin
6209 if pltype = 1 then
6210 AbortMsg(sNotValidForPrototype);
6211 if bProtoExists then
6212 GS_Size[procexists] := 1
6213 else
6214 GS_Size[NumGlobals] := 1;
6215 end;
6216 end;
6217
6218 procedure TNXCComp.FunctionBlock(Name, tname : string; dt: char;
6219 bInline, bSafeCall : boolean);
6220 var
6221 protoexists : boolean;
6222 begin
6223 DoCompilerStatusChange(Format(sNXCFunction, [Name]));
6224 if bInline then
6225 IncrementInlineDepth;
6226 if Name = 'main' then
6227 AbortMsg(sMainMustBeTask);
6228 protoexists := False;
6229 DoCommonFuncProcDecl(protoexists, Name, tname, TOK_PROCEDURE, dt, bInline, bSafeCall);
6230 if Token = TOK_BEGIN then
6231 begin
6232 Prolog(Name, True);
6233 MatchString(TOK_BEGIN);
6234 ClearLocals;
6235 fNestingLevel := 0;
6236 DoLocals(Name);
6237 BlockStatements();
6238 Epilog(True);
6239 // MatchString(TOK_END) must be after the epilog or process directives
6240 // can be called while still inlining
6241 MatchString(TOK_END);
6242 Scan;
6243 end
6244 else
6245 begin
6246 if protoexists then
6247 Expected(sProtoAlreadyDefined);
6248 Scan;
6249 end;
6250 ClearParams;
6251 end;
6252
6253 {--------------------------------------------------------------}
6254 { Initialize }
6255
6256 procedure TNXCComp.Init;
6257 begin
6258 fNoCommaOperator := False;
6259 fProcessingMathAssignment := False;
6260 fInlineDepth := 0;
6261 fLastExpressionOptimizedToConst := False;
6262 fLastLoadedConst := '';
6263 fCurrentLine := '';
6264 totallines := 1;
6265 linenumber := 1;
6266 ClearParams;
6267 fStackDepth := 0;
6268 MaxStackDepth := 0;
6269 GetChar;
6270 Next;
6271 end;
6272
6273 {--------------------------------------------------------------}
6274 { Parse and Translate a Program }
6275
6276 procedure TNXCComp.Prog;
6277 begin
6278 Header;
6279 TopDecls;
6280 if Token in [TOK_INLINE, TOK_SAFECALL, TOK_PROCEDURE, TOK_TASK] then
6281 ProcedureBlock;
6282 Trailer;
6283 end;
6284
6285 { TNXCComp }
6286
6287 constructor TNXCComp.Create;
6288 begin
6289 inherited Create;
6290 fMaxPreprocDepth := 10;
6291 fMaxErrors := 0;
6292 NumGlobals := 0;
6293 endofallsource := False;
6294 fEnhancedFirmware := False;
6295 fFirmwareVersion := 128; // 1.28 NXT 2.0 firmware
6296 fIgnoreSystemFile := False;
6297 fWarningsOff := False;
6298 fDD := TDataDefs.Create;
6299 fNamedTypes := TMapList.Create;
6300 fNamedTypes.CaseSensitive := True;
6301 fNamedTypes.Duplicates := dupError;
6302 fDefines := TStringList.Create;
6303 fEmittedLocals := TStringList.Create;
6304 fEmittedLocals.CaseSensitive := True;
6305 fEmittedLocals.Sorted := True;
6306 fLocals := TVariableList.Create;
6307 fParams := TVariableList.Create;
6308 fGlobals := TVariableList.Create;
6309 fFuncParams := TFunctionParameters.Create;
6310 fInlineFunctionStack := TObjectStack.Create;
6311 fInlineFunctions := TInlineFunctions.Create;
6312 fArrayHelpers := TArrayHelperVars.Create;
6313 fTmpAsmLines := TStringList.Create;
6314 fStackVarNames := TStringList.Create;
6315 fNBCSrc := TStringList.Create;
6316 fMS := TMemoryStream.Create;
6317 fMessages := TStringList.Create;
6318 fIncludeDirs := TStringList.Create;
6319 fAPIFunctions := TStringList.Create;
6320 fAPIFunctions.CaseSensitive := True;
6321 fAPIFunctions.Sorted := True;
6322 fAPIStrFunctions := TStringList.Create;
6323 fAPIStrFunctions.CaseSensitive := True;
6324 fAPIStrFunctions.Sorted := True;
6325 fThreadNames := TStringList.Create;
6326 fThreadNames.CaseSensitive := True;
6327 fThreadNames.Sorted := True;
6328 fThreadNames.Duplicates := dupIgnore;
6329 fSwitchFixups := TStringList.Create;
6330 fSwitchRegNames := TStringList.Create;
6331 fSwitchDepth := 0;
6332 fFunctionNameCallStack := TStringList.Create;
6333 fFunctionNameCallStack.CaseSensitive := True;
6334 fConstStringMap := TStringList.Create;
6335 fConstStringMap.CaseSensitive := True;
6336 fConstStringMap.Sorted := True;
6337 fArrayIndexStack := TStringList.Create;
6338 fStructDecls := TStringList.Create;
6339 fInlineStack := TObjectList.Create(false);
6340 fCalc := TNBCExpParser.Create(nil);
6341 fCalc.PascalNumberformat := False;
6342 fCalc.CaseSensitive := True;
6343 fCalc.StandardDefines := True;
6344 fCalc.ExtraDefines := True;
6345 LoadAPIFunctions;
6346 fOptimizeLevel := 0;
6347 Clear;
6348 end;
6349
6350 destructor TNXCComp.Destroy;
6351 begin
6352 FreeAndNil(fDD);
6353 FreeAndNil(fNamedTypes);
6354 FreeAndNil(fDefines);
6355 FreeAndNil(fEmittedLocals);
6356 FreeAndNil(fLocals);
6357 FreeAndNil(fParams);
6358 FreeAndNil(fGlobals);
6359 FreeAndNil(fFuncParams);
6360 FreeAndNil(fInlineFunctionStack);
6361 FreeAndNil(fInlineFunctions);
6362 FreeAndNil(fArrayHelpers);
6363 FreeAndNil(fTmpAsmLines);
6364 FreeAndNil(fStackVarNames);
6365 FreeAndNil(fNBCSrc);
6366 FreeAndNil(fMS);
6367 FreeAndNil(fMessages);
6368 FreeAndNil(fIncludeDirs);
6369 FreeAndNil(fAPIFunctions);
6370 FreeAndNil(fAPIStrFunctions);
6371 FreeAndNil(fFunctionNameCallStack);
6372 FreeAndNil(fConstStringMap);
6373 FreeAndNil(fArrayIndexStack);
6374 FreeAndNil(fStructDecls);
6375 FreeAndNil(fThreadNames);
6376 // FreeAndNil(fParamNames);
6377 FreeAndNil(fSwitchFixups);
6378 FreeAndNil(fSwitchRegNames);
6379 FreeAndNil(fInlineStack);
6380 FreeAndNil(fCalc);
6381 inherited;
6382 end;
6383
6384 procedure TNXCComp.InternalParseStream;
6385 begin
6386 try
6387 DoCompilerStatusChange(sNXCCompBegin);
6388 DoCompilerStatusChange(Format(sCompileTargets, [FirmwareVersion, BoolToString(EnhancedFirmware)]));
6389 fFuncParams.Clear;
6390 fThreadNames.Clear;
6391 fConstStringMap.Clear;
6392 fGlobals.Clear;
6393 fBadProgram := False;
6394 fBytesRead := 0;
6395 fProgErrorCount := 0;
6396 fLastErrLine := -99;
6397 fLastErrMsg := '';
6398 fLHSDataType := #0;
6399 fLHSName := '';
6400 DoCompilerStatusChange(sNXCPreprocess);
6401 PreProcess;
6402 fMS.Position := 0;
6403 fParenDepth := 0;
6404 DoCompilerStatusChange(sNXCInitProgram);
6405 Init;
6406 DoCompilerStatusChange(sNXCParseProg);
6407 Prog;
6408 DoCompilerStatusChange(sNXCCodeGenComplete);
6409 except
6410 on E : EAbort do
6411 begin
6412 fBadProgram := True;
6413 // end processing file due to Abort in ReportProblem
6414 end;
6415 on E : EPreprocessorException do
6416 begin
6417 fBadProgram := True;
6418 ReportProblem(E.LineNo, CurrentFile, E.Message, true);
6419 end;
6420 on E : Exception do
6421 begin
6422 fBadProgram := True;
6423 ReportProblem(linenumber, CurrentFile, E.Message, true);
6424 end;
6425 end;
6426 end;
6427
6428 procedure TNXCComp.Parse(aStrings: TStrings);
6429 begin
6430 Clear;
6431 if not IgnoreSystemFile then
6432 LoadSystemFile(fMS);
6433 aStrings.SaveToStream(fMS);
6434 InternalParseStream;
6435 end;
6436
6437 procedure TNXCComp.Parse(aStream: TStream);
6438 begin
6439 Clear;
6440 if not IgnoreSystemFile then
6441 LoadSystemFile(fMS);
6442 fMS.CopyFrom(aStream, 0);
6443 InternalParseStream;
6444 end;
6445
6446 procedure TNXCComp.Parse(const aFilename: string);
6447 var
6448 Stream : TFileStream;
6449 begin
6450 Clear;
6451 if not IgnoreSystemFile then
6452 LoadSystemFile(fMS);
6453 Stream := TFileStream.Create(aFilename, fmOpenRead or fmShareDenyWrite);
6454 try
6455 fMS.CopyFrom(Stream, 0);
6456 finally
6457 Stream.Free;
6458 end;
6459 InternalParseStream;
6460 end;
6461
6462 procedure TNXCComp.Clear;
6463 begin
6464 fMS.Clear;
6465 NBCSource.Clear;
6466 fInlineFunctions.Clear;
6467 fArrayHelpers.Clear;
6468 fStructDecls.Clear;
6469 fMessages.Clear;
6470 fTempChar := ' ';
6471 fLHSDataType := #0;
6472 fLHSName := '';
6473 LCount := 0;
6474 ClearLocals;
6475 ClearParams;
6476 ClearGlobals;
6477 end;
6478
6479 {--------------------------------------------------------------}
6480 { Recognize and Translate a break/continue }
6481
6482 procedure TNXCComp.DoBreakContinue(idx : integer; const lbl: string);
6483 var
6484 val : string;
6485 begin
6486 val := APIList[idx];
6487 MatchString(val);
6488 // Semi;
6489 if lbl <> '' then
6490 Branch(lbl)
6491 else
6492 AbortMsg(Format(sInvalidBreakContinue, [val]));
6493 end;
6494
6495 procedure TNXCComp.DoOnFwdRev;
6496 var
6497 op, arg1 : string;
6498 begin
6499 //OnFwd(ports, pwr)
6500 //OnRev(ports, pwr)
6501 op := Value;
6502 Next;
6503 OpenParen;
6504 // ports
6505 arg1 := GetDecoratedValue;
6506 Next;
6507 MatchString(TOK_COMMA);
6508 // pwr
6509 BoolExpression;
6510 CloseParen;
6511 EmitLn(Format('%s(%s, %s)',[op, arg1, RegisterName]));
6512 end;
6513
6514 procedure TNXCComp.DoOnFwdRevEx;
6515 var
6516 op, arg1, arg3 : string;
6517 begin
6518 //OnFwdEx(ports, pwr, reset)
6519 //OnRevEx(ports, pwr, reset)
6520 op := Value;
6521 Next;
6522 OpenParen;
6523 // ports
6524 arg1 := GetDecoratedValue;
6525 Next;
6526 MatchString(TOK_COMMA);
6527 // pwr
6528 BoolExpression;
6529 MatchString(TOK_COMMA);
6530 // reset
6531 CheckNumeric;
6532 arg3 := Value;
6533 Next;
6534 CloseParen;
6535 EmitLn(Format('%s(%s, %s, %s)',[op, arg1, RegisterName, arg3]));
6536 end;
6537
6538 procedure TNXCComp.DoOnFwdRevReg;
6539 var
6540 op, arg1, svar : string;
6541 begin
6542 //OnFwdReg(ports, pwr, regmode)
6543 //OnRevReg(ports, pwr, regmode)
6544 op := Value;
6545 Next;
6546 OpenParen;
6547 // ports
6548 arg1 := GetDecoratedValue;
6549 Next;
6550 MatchString(TOK_COMMA);
6551 // pwr
6552 BoolExpression;
6553 push;
6554 svar := tos;
6555 EmitLn(Format('mov %s, %s',[svar, RegisterName]));
6556 MatchString(TOK_COMMA);
6557 // regmode
6558 BoolExpression;
6559 CloseParen;
6560 EmitLn(Format('%s(%s, %s, %s)',[op, arg1, svar, RegisterName]));
6561 pop;
6562 end;
6563
6564 procedure TNXCComp.DoOnFwdRevRegEx;
6565 var
6566 op, arg1, svar, arg4 : string;
6567 begin
6568 //OnFwdRegEx(ports, pwr, regmode, reset)
6569 //OnRevRegEx(ports, pwr, regmode, reset)
6570 op := Value;
6571 Next;
6572 OpenParen;
6573 // ports
6574 arg1 := GetDecoratedValue;
6575 Next;
6576 MatchString(TOK_COMMA);
6577 // pwr
6578 BoolExpression;
6579 push;
6580 svar := tos;
6581 EmitLn(Format('mov %s, %s',[svar, RegisterName]));
6582 MatchString(TOK_COMMA);
6583 // regmode
6584 BoolExpression;
6585 MatchString(TOK_COMMA);
6586 // reset
6587 CheckNumeric;
6588 arg4 := Value;
6589 Next;
6590 CloseParen;
6591 EmitLn(Format('%s(%s, %s, %s, %s)',[op, arg1, svar, RegisterName, arg4]));
6592 pop;
6593 end;
6594
6595 procedure TNXCComp.DoOnFwdRevSync;
6596 var
6597 op, ports, pwr : string;
6598 begin
6599 //OnFwdSync(ports, pwr, turnpct)
6600 //OnRevSync(ports, pwr, turnpct)
6601 op := Value;
6602 Next;
6603 OpenParen;
6604 // ports
6605 ports := GetDecoratedValue;
6606 Next;
6607 MatchString(TOK_COMMA);
6608 // pwr
6609 BoolExpression;
6610 push;
6611 pwr := tos;
6612 EmitLn(Format('mov %s, %s',[pwr, RegisterName]));
6613 MatchString(TOK_COMMA);
6614 // turnpct
6615 BoolExpression;
6616 CloseParen;
6617 EmitLn(Format('%s(%s, %s, %s)',[op, ports, pwr, RegisterName]));
6618 pop;
6619 end;
6620
6621 procedure TNXCComp.DoOnFwdRevSyncEx;
6622 var
6623 op, ports, pwr, arg4 : string;
6624 begin
6625 //OnFwdSyncEx(ports, pwr, turnpct, reset)
6626 //OnRevSyncEx(ports, pwr, turnpct, reset)
6627 op := Value;
6628 Next;
6629 OpenParen;
6630 // ports
6631 ports := GetDecoratedValue;
6632 Next;
6633 MatchString(TOK_COMMA);
6634 // pwr
6635 BoolExpression;
6636 push;
6637 pwr := tos;
6638 EmitLn(Format('mov %s, %s',[pwr, RegisterName]));
6639 MatchString(TOK_COMMA);
6640 // turnpct
6641 BoolExpression;
6642 MatchString(TOK_COMMA);
6643 // reset
6644 CheckNumeric;
6645 arg4 := Value;
6646 Next;
6647 CloseParen;
6648 EmitLn(Format('%s(%s, %s, %s, %s)',[op, ports, pwr, RegisterName, arg4]));
6649 pop;
6650 end;
6651
6652 procedure TNXCComp.DoOnFwdRevRegPID;
6653 var
6654 op, arg1, svar, regvar, pvar, ivar : string;
6655 begin
6656 //OnFwdRegPID(ports, pwr, regmode, p, i, d)
6657 //OnRevRegPID(ports, pwr, regmode, p, i, d)
6658 op := Value;
6659 Next;
6660 OpenParen;
6661 // ports
6662 arg1 := GetDecoratedValue;
6663 Next;
6664 MatchString(TOK_COMMA);
6665 // pwr
6666 BoolExpression;
6667 push;
6668 svar := tos;
6669 EmitLn(Format('mov %s, %s',[svar, RegisterName]));
6670 MatchString(TOK_COMMA);
6671 // regmode
6672 BoolExpression;
6673 push;
6674 regvar := tos;
6675 EmitLn(Format('mov %s, %s',[regvar, RegisterName]));
6676 MatchString(TOK_COMMA);
6677 // p
6678 BoolExpression;
6679 push;
6680 pvar := tos;
6681 EmitLn(Format('mov %s, %s',[pvar, RegisterName]));
6682 MatchString(TOK_COMMA);
6683 // i
6684 BoolExpression;
6685 push;
6686 ivar := tos;
6687 EmitLn(Format('mov %s, %s',[ivar, RegisterName]));
6688 MatchString(TOK_COMMA);
6689 // d
6690 BoolExpression;
6691 CloseParen;
6692 EmitLn(Format('%s(%s, %s, %s, %s, %s, %s)',[op, arg1, svar, regvar, pvar, ivar, RegisterName]));
6693 pop;
6694 pop;
6695 pop;
6696 pop;
6697 end;
6698
6699 procedure TNXCComp.DoOnFwdRevRegExPID;
6700 var
6701 op, arg1, svar, arg4, regvar, pvar, ivar : string;
6702 begin
6703 //OnFwdRegExPID(ports, pwr, regmode, reset, p, i, d)
6704 //OnRevRegExPID(ports, pwr, regmode, reset, p, i, d)
6705 op := Value;
6706 Next;
6707 OpenParen;
6708 // ports
6709 arg1 := GetDecoratedValue;
6710 Next;
6711 MatchString(TOK_COMMA);
6712 // pwr
6713 BoolExpression;
6714 push;
6715 svar := tos;
6716 EmitLn(Format('mov %s, %s',[svar, RegisterName]));
6717 MatchString(TOK_COMMA);
6718 // regmode
6719 BoolExpression;
6720 push;
6721 regvar := tos;
6722 EmitLn(Format('mov %s, %s',[regvar, RegisterName]));
6723 MatchString(TOK_COMMA);
6724 // reset
6725 CheckNumeric;
6726 arg4 := Value;
6727 MatchString(TOK_COMMA);
6728 // p
6729 BoolExpression;
6730 push;
6731 pvar := tos;
6732 EmitLn(Format('mov %s, %s',[pvar, RegisterName]));
6733 MatchString(TOK_COMMA);
6734 // i
6735 BoolExpression;
6736 push;
6737 ivar := tos;
6738 EmitLn(Format('mov %s, %s',[ivar, RegisterName]));
6739 MatchString(TOK_COMMA);
6740 // d
6741 BoolExpression;
6742 CloseParen;
6743 EmitLn(Format('%s(%s, %s, %s, %s, %s, %s, %s)',[op, arg1, svar, regvar, arg4, pvar, ivar, RegisterName]));
6744 pop;
6745 pop;
6746 pop;
6747 pop;
6748 end;
6749
6750 procedure TNXCComp.DoOnFwdRevSyncPID;
6751 var
6752 op, ports, pwr, turnvar, pvar, ivar : string;
6753 begin
6754 //OnFwdSyncPID(ports, pwr, turnpct, p, i, d)
6755 //OnRevSyncPID(ports, pwr, turnpct, p, i, d)
6756 op := Value;
6757 Next;
6758 OpenParen;
6759 // ports
6760 ports := GetDecoratedValue;
6761 Next;
6762 MatchString(TOK_COMMA);
6763 // pwr
6764 BoolExpression;
6765 push;
6766 pwr := tos;
6767 EmitLn(Format('mov %s, %s',[pwr, RegisterName]));
6768 MatchString(TOK_COMMA);
6769 // turnpct
6770 BoolExpression;
6771 push;
6772 turnvar := tos;
6773 EmitLn(Format('mov %s, %s',[turnvar, RegisterName]));
6774 MatchString(TOK_COMMA);
6775 // p
6776 BoolExpression;
6777 push;
6778 pvar := tos;
6779 EmitLn(Format('mov %s, %s',[pvar, RegisterName]));
6780 MatchString(TOK_COMMA);
6781 // i
6782 BoolExpression;
6783 push;
6784 ivar := tos;
6785 EmitLn(Format('mov %s, %s',[ivar, RegisterName]));
6786 MatchString(TOK_COMMA);
6787 // d
6788 BoolExpression;
6789 CloseParen;
6790 EmitLn(Format('%s(%s, %s, %s, %s, %s, %s)',[op, ports, pwr, turnvar, pvar, ivar, RegisterName]));
6791 pop;
6792 pop;
6793 pop;
6794 pop;
6795 end;
6796
6797 procedure TNXCComp.DoOnFwdRevSyncExPID;
6798 var
6799 op, ports, pwr, arg4, turnvar, pvar, ivar : string;
6800 begin
6801 //OnFwdSyncExPID(ports, pwr, turnpct, reset, p, i, d)
6802 //OnRevSyncExPID(ports, pwr, turnpct, reset, p, i, d)
6803 op := Value;
6804 Next;
6805 OpenParen;
6806 // ports
6807 ports := GetDecoratedValue;
6808 Next;
6809 MatchString(TOK_COMMA);
6810 // pwr
6811 BoolExpression;
6812 push;
6813 pwr := tos;
6814 EmitLn(Format('mov %s, %s',[pwr, RegisterName]));
6815 MatchString(TOK_COMMA);
6816 // turnpct
6817 BoolExpression;
6818 push;
6819 turnvar := tos;
6820 EmitLn(Format('mov %s, %s',[turnvar, RegisterName]));
6821 MatchString(TOK_COMMA);
6822 // reset
6823 CheckNumeric;
6824 arg4 := Value;
6825 MatchString(TOK_COMMA);
6826 // p
6827 BoolExpression;
6828 push;
6829 pvar := tos;
6830 EmitLn(Format('mov %s, %s',[pvar, RegisterName]));
6831 MatchString(TOK_COMMA);
6832 // i
6833 BoolExpression;
6834 push;
6835 ivar := tos;
6836 EmitLn(Format('mov %s, %s',[ivar, RegisterName]));
6837 MatchString(TOK_COMMA);
6838 // d
6839 BoolExpression;
6840 CloseParen;
6841 EmitLn(Format('%s(%s, %s, %s, %s, %s, %s, %s)',[op, ports, pwr, turnvar, arg4, pvar, ivar, RegisterName]));
6842 pop;
6843 pop;
6844 pop;
6845 pop;
6846 end;
6847
6848 procedure TNXCComp.DoRotateMotors(idx: integer);
6849 var
6850 op, ports, pwr, angle, turnpct, bsync, bstop, p, i : string;
6851 begin
6852 //RotateMotor(ports, pwr, angle)
6853 //RotateMotorEx(ports, pwr, angle, turnpct, bSync, bStop)
6854 //RotateMotorPID(ports, pwr, angle, p, i, d)
6855 //RotateMotorExPID(ports, pwr, angle, turnpct, bSync, bStop, p, i, d)
6856 op := Value;
6857 Next;
6858 OpenParen;
6859 // ports
6860 ports := GetDecoratedValue;
6861 Next;
6862 MatchString(TOK_COMMA);
6863 // power
6864 BoolExpression;
6865 push;
6866 pwr := tos;
6867 EmitLn(Format('mov %s, %s',[pwr, RegisterName]));
6868 MatchString(TOK_COMMA);
6869 // angle
6870 BoolExpression;
6871 if idx = API_ROTATEMOTOR then
6872 begin
6873 // RotateMotor
6874 CloseParen;
6875 EmitLn(Format('%s(%s, %s, %s)', [op, ports, pwr, RegisterName]))
6876 end
6877 else if idx = API_ROTATEMOTORPID then
6878 begin
6879 // RotateMotorPID
6880 push;
6881 angle := tos;
6882 EmitLn(Format('mov %s, %s',[angle, RegisterName]));
6883 MatchString(TOK_COMMA);
6884 // P
6885 BoolExpression;
6886 push;
6887 p := tos;
6888 EmitLn(Format('mov %s, %s',[p, RegisterName]));
6889 MatchString(TOK_COMMA);
6890 // I
6891 BoolExpression;
6892 push;
6893 i := tos;
6894 EmitLn(Format('mov %s, %s',[i, RegisterName]));
6895 MatchString(TOK_COMMA);
6896 // D
6897 BoolExpression;
6898 CloseParen;
6899 EmitLn(Format('%s(%s, %s, %s, %s, %s, %s)', [op, ports, pwr, angle, p, i, RegisterName]));
6900 pop;
6901 pop;
6902 pop;
6903 end
6904 else
6905 begin
6906 // RotateMotorEx or RotateMotorExPID
6907 push;
6908 angle := tos;
6909 EmitLn(Format('mov %s, %s',[angle, RegisterName]));
6910 MatchString(TOK_COMMA);
6911 // turn pct
6912 BoolExpression;
6913 push;
6914 turnpct := tos;
6915 EmitLn(Format('mov %s, %s',[turnpct, RegisterName]));
6916 MatchString(TOK_COMMA);
6917 // bsync
6918 BoolExpression;
6919 push;
6920 bsync := tos;
6921 EmitLn(Format('mov %s, %s',[bsync, RegisterName]));
6922 MatchString(TOK_COMMA);
6923 // bStop
6924 BoolExpression;
6925 if idx = API_ROTATEMOTOREX then
6926 begin
6927 CloseParen;
6928 EmitLn(Format('%s(%s, %s, %s, %s, %s, %s)', [op, ports, pwr, angle, turnpct, bsync, RegisterName]));
6929 end
6930 else
6931 begin
6932 // RotateMotorExPID
6933 push;
6934 bstop := tos;
6935 EmitLn(Format('mov %s, %s',[bstop, RegisterName]));
6936 MatchString(TOK_COMMA);
6937 // P
6938 BoolExpression;
6939 push;
6940 p := tos;
6941 EmitLn(Format('mov %s, %s',[p, RegisterName]));
6942 MatchString(TOK_COMMA);
6943 // I
6944 BoolExpression;
6945 push;
6946 i := tos;
6947 EmitLn(Format('mov %s, %s',[i, RegisterName]));
6948 MatchString(TOK_COMMA);
6949 // D
6950 BoolExpression;
6951 CloseParen;
6952 EmitLn(Format('%s(%s, %s, %s, %s, %s, %s, %s, %s, %s)', [op, ports, pwr, angle, turnpct, bsync, bstop, p, i, RegisterName]));
6953 pop;
6954 pop;
6955 pop;
6956 end;
6957 pop;
6958 pop;
6959 pop;
6960 end;
6961 pop;
6962 end;
6963
6964 procedure TNXCComp.DoAcquireRelease;
6965 var
6966 op, val : string;
6967 begin
6968 // Acquire(mutex);
6969 // Release(mutex);
6970 op := LowerCase(Value);
6971 Next;
6972 OpenParen;
6973 // mutex
6974 val := GetDecoratedValue;
6975 CheckIdent;
6976 CheckGlobal(val); // mutex must be a global variable
6977 if DataType(val) <> TOK_MUTEXDEF then
6978 Expected(sMutexType);
6979 Next;
6980 CloseParen;
6981 EmitLn(op + ' ' + val);
6982 end;
6983
6984 procedure TNXCComp.DoPrecedesFollows;
6985 var
6986 op, val : string;
6987 begin
6988 // Precedes(x, y, z, ...);
6989 // Follows(x, y, z);
6990 op := LowerCase(Value);
6991 Next;
6992 OpenParen;
6993 val := Value;
6994 CheckIdent;
6995 CheckGlobal(val); // task names must be global
6996 if DataType(val) <> TOK_TASK then
6997 Expected(sTaskName);
6998 Next;
6999 while Value = TOK_COMMA do
7000 begin
7001 val := val + Value; // the comma
7002 Next;
7003 CheckIdent;
7004 CheckGlobal(Value);
7005 val := val + ' ' + Value; // the next value
7006 Next;
7007 end;
7008 CloseParen;
7009 EmitLn(op + ' ' + val);
7010 end;
7011
7012 procedure TNXCComp.DoExitTo;
7013 var
7014 op, val : string;
7015 begin
7016 // ExitTo(task);
7017 op := LowerCase(Value);
7018 Next;
7019 OpenParen;
7020 // task
7021 val := Value;
7022 CheckIdent;
7023 CheckGlobal(val); // must be global name
7024 if DataType(val) <> TOK_TASK then
7025 Expected(sTaskName);
7026 Next;
7027 CloseParen;
7028 EmitLn(op + ' ' + val);
7029 end;
7030
7031 procedure TNXCComp.DoStop;
7032 begin
7033 // Stop(stop?);
7034 Next;
7035 OpenParen;
7036 // stop?
7037 BoolExpression;
7038 CloseParen;
7039 EmitLn(Format('stop %s',[RegisterName]));
7040 end;
7041
7042 procedure TNXCComp.DoGoto;
7043 begin
7044 // goto labelName;
7045 Next;
7046 // labelName
7047 CheckIdent;
7048 Branch(Value);
7049 // EmitLn(Format('jmp %s',[Value]));
7050 Next;
7051 end;
7052
7053 procedure TNXCComp.DoSetInputOutput(const idx: integer);
7054 var
7055 port, pchk, field, val, asmstr : string;
7056 i, cnt, iport : integer;
7057 begin
7058 // SetInput(port, field, value)
7059 // SetOutput(ports, field, value [, field, value, ...])
7060 Next;
7061 OpenParen;
7062 // port
7063 port := GetDecoratedValue;
7064 Next;
7065 MatchString(TOK_COMMA);
7066 // field
7067 CheckNumeric;
7068 field := Value;
7069 Next;
7070 MatchString(TOK_COMMA);
7071 // value
7072 BoolExpression;
7073 if idx = API_SETINPUT then
7074 begin
7075 // SetInput
7076 CloseParen;
7077 EmitLn(Format('setin %s, %s, %s', [RegisterName, port, field]));
7078 end
7079 else
7080 begin
7081 // setout can take additional optional field/value pairs
7082 cnt := 0;
7083 pchk := port;
7084 if idx = API_SETOUTPUT then
7085 begin
7086 iport := StrToIntDef(port, 0);
7087 case iport of
7088 OUT_AB : port := '__OUT_AB';
7089 OUT_AC : port := '__OUT_AC';
7090 OUT_BC : port := '__OUT_BC';
7091 OUT_ABC : port := '__OUT_ABC';
7092 end;
7093 end;
7094 asmstr := Format('setout %s, %s', [port, field]);
7095 while (Token = TOK_COMMA) and not endofallsource do
7096 begin
7097 inc(cnt);
7098 push;
7099 val := tos;
7100 EmitLn(Format('mov %s, %s',[val, RegisterName]));
7101 Next;
7102 // field
7103 CheckNumeric;
7104 field := Value;
7105 Next;
7106 MatchString(TOK_COMMA);
7107 // value
7108 BoolExpression;
7109 asmstr := asmstr + Format(', %s, %s', [val, field]);
7110 end;
7111 CloseParen;
7112 asmstr := asmstr + Format(', %s', [RegisterName]);
7113 EmitLn(Format('compif EQ, isconst(%s), FALSE', [pchk]));
7114 EmitLn(asmstr);
7115 EmitLn('compelse');
7116 EmitLn(Format('compchk LT, %s, 0x07', [pchk]));
7117 EmitLn(Format('compchk GTEQ, %s, 0x00', [pchk]));
7118 EmitLn(asmstr);
7119 EmitLn('compend');
7120 for i := 0 to cnt - 1 do
7121 pop;
7122 end;
7123 end;
7124
7125 procedure TNXCComp.DoReturn;
7126 var
7127 rdt : char;
7128 idx : integer;
7129 bFuncStyle : boolean;
7130 begin
7131 // return
7132 idx := GlobalIdx(fCurrentThreadName);
7133 if GS_Type[idx] <> TOK_PROCEDURE then
7134 AbortMsg(sReturnInvalid);
7135 rdt := FunctionReturnType(fCurrentThreadName);
7136 Next;
7137 // leave return value on "stack"
7138 if rdt = TOK_STRINGDEF then
7139 begin
7140 bFuncStyle := Token = TOK_OPENPAREN;
7141 if bFuncStyle then
7142 Next;
7143 StringExpression('');
7144 if bFuncStyle then
7145 Next;
7146 end
7147 else if IsUDT(rdt) or IsArrayType(rdt) then
7148 begin
7149 // currently this code only supports returning a variable for UDTs or Arrays
7150 // TODO : add support for an array or UDT expression
7151 bFuncStyle := Token = TOK_OPENPAREN;
7152 if bFuncStyle then
7153 Next;
7154 fLHSDataType := rdt;
7155 fLHSName := Format('__result_%s',[fCurrentThreadName]);
7156 try
7157 NumericFactor;
7158 finally
7159 fLHSDataType := TOK_LONGDEF;
7160 fLHSName := '';
7161 end;
7162 {
7163 // 2008-12-14 JCH - needed the decorated value rather than just Value
7164 EmitLn(Format('mov __result_%s, %s',[fCurrentThreadName, GetDecoratedValue]));
7165 // 2008-12-14 JCH The next line fixes a bug where parser gets out
7166 // of sync with the end of the return statement
7167 Next; // move to the ')' or ';'
7168 }
7169 if bFuncStyle then
7170 Next;
7171 end
7172 else if rdt <> #0 then
7173 begin
7174 CommaExpression;
7175 MoveToCorrectRegister(rdt);
7176 end;
7177 // Semi;
7178 EmitLn('return');
7179 end;
7180
7181 procedure TNXCComp.DoResetCounters;
7182 var
7183 op, arg1 : string;
7184 begin
7185 // ResetTachoCount(ports)
7186 // ResetBlockTachoCount(ports)
7187 // ResetRotationCount(ports)
7188 // ResetAllTachoCounts(ports)
7189 op := Value;
7190 Next;
7191 OpenParen;
7192 // ports
7193 arg1 := GetDecoratedValue;
7194 Next;
7195 CloseParen;
7196 EmitLn(op + TOK_OPENPAREN + arg1 + TOK_CLOSEPAREN);
7197 end;
7198
7199 procedure TNXCComp.DoStopMotors;
7200 var
7201 op, arg1 : string;
7202 begin
7203 // Off(ports)
7204 // Coast(ports)
7205 // Float(ports)
7206 op := Value;
7207 Next;
7208 OpenParen;
7209 // ports
7210 arg1 := GetDecoratedValue;
7211 Next;
7212 CloseParen;
7213 EmitLn(op + TOK_OPENPAREN + arg1 + TOK_CLOSEPAREN);
7214 end;
7215
7216 procedure TNXCComp.DoStopMotorsEx;
7217 var
7218 op, arg1, arg2 : string;
7219 begin
7220 // OffEx(ports, reset)
7221 // CoastEx(ports, reset)
7222 op := Value;
7223 Next;
7224 OpenParen;
7225 // ports
7226 arg1 := GetDecoratedValue;
7227 Next;
7228 MatchString(TOK_COMMA);
7229 // reset
7230 CheckNumeric;
7231 arg2 := Value;
7232 Next;
7233 CloseParen;
7234 EmitLn(Format('%s(%s, %s)', [op, arg1, arg2]));
7235 end;
7236
7237 procedure TNXCComp.PreProcess;
7238 var
7239 P : TLangPreprocessor;
7240 i, idx : integer;
7241 tmpFile, tmpMsg : string;
7242 begin
7243 P := TLangPreprocessor.Create(GetPreProcLexerClass, ExtractFilePath(ParamStr(0)), lnNXC, MaxPreprocessorDepth);
7244 try
7245 P.OnPreprocessorStatusChange := HandlePreprocStatusChange;
7246 P.AddPoundLineToMultiLineMacros := True;
7247 P.Defines.AddDefines(Defines);
7248 if EnhancedFirmware then
7249 P.Defines.Define('__ENHANCED_FIRMWARE');
7250 P.Defines.AddEntry('__FIRMWARE_VERSION', IntToStr(FirmwareVersion));
7251 P.AddIncludeDirs(IncludeDirs);
7252 if not IgnoreSystemFile then
7253 begin
7254 P.SkipIncludeFile('NBCCommon.h');
7255 P.SkipIncludeFile('NXCDefs.h');
7256 end;
7257 P.Preprocess(CurrentFile, fMS);
7258 for i := 0 to P.Warnings.Count - 1 do
7259 begin
7260 tmpMsg := P.Warnings.ValueFromIndex[i];
7261 idx := Pos('|', tmpMsg);
7262 tmpFile := Copy(tmpMsg, 1, idx-1);
7263 Delete(tmpMsg, 1, idx);
7264 ReportProblem(StrToIntDef(P.Warnings.Names[i], 0), tmpFile, tmpMsg, false);
7265 end;
7266 finally
7267 P.Free;
7268 end;
7269 end;
7270
7271 procedure TNXCComp.ProcessDirectives(bScan : boolean);
7272 begin
7273 while Token = TOK_DIRECTIVE do
7274 begin
7275 // look for #line statements
7276 if LowerCase(Value) = '#line' then
7277 begin
7278 SkipDirectiveLine;
7279 HandlePoundLine;
7280 Next(False);
7281 end
7282 else
7283 begin
7284 SkipDirectiveLine;
7285 Next(False);
7286 end;
7287 EmitPoundLine;
7288 EmitLnNoTab(Trim(fDirLine));
7289 // EmitLn(Trim(fDirLine));
7290 if bScan then
7291 Scan;
7292 end;
7293 end;
7294
7295 procedure TNXCComp.HandlePoundLine;
7296 var
7297 i : integer;
7298 tmpLine, tmpFile : string;
7299 begin
7300 i := Pos('#line ', fDirLine);
7301 if i = 1 then
7302 begin
7303 // this is a special preprocessor line
7304 tmpLine := Trim(fDirLine);
7305 Delete(tmpLine, 1, 6);
7306 i := Pos(' ', tmpLine);
7307 linenumber{[slevel]} := StrToIntDef(Copy(tmpLine, 1, i - 1), linenumber{[slevel]});
7308 IncLineNumber;
7309 Delete(tmpLine, 1, i);
7310 tmpFile := Replace(tmpLine, '"', '');
7311 CurrentFile := tmpFile;
7312 end;
7313 end;
7314
7315 procedure TNXCComp.IncLineNumber;
7316 begin
7317 linenumber := linenumber + 1;
7318 inc(totallines);
7319 end;
7320
APIFuncNameToIDnull7321 function TNXCComp.APIFuncNameToID(procname: string): integer;
7322 begin
7323 Result := StrToIntDef(fAPIFunctions.Values[procname], -1);
7324 end;
7325
APIStrFuncNameToIDnull7326 function TNXCComp.APIStrFuncNameToID(procname: string): integer;
7327 begin
7328 Result := StrToIntDef(fAPIStrFunctions.Values[procname], -1);
7329 end;
7330
IsAPIFuncnull7331 function TNXCComp.IsAPIFunc(procname: string): boolean;
7332 begin
7333 Result := fAPIFunctions.IndexOfName(procname) <> -1;
7334 end;
7335
IsAPIStrFuncnull7336 function TNXCComp.IsAPIStrFunc(procname: string): boolean;
7337 begin
7338 Result := fAPIStrFunctions.IndexOfName(procname) <> -1;
7339 end;
7340
7341 procedure TNXCComp.AddAPIFunction(const name: string; id: integer);
7342 begin
7343 fAPIFunctions.Add(name + '=' + IntToStr(id));
7344 end;
7345
7346 procedure TNXCComp.AddAPIStringFunction(const name: string; id: integer);
7347 begin
7348 fAPIStrFunctions.Add(name + '=' + IntToStr(id));
7349 end;
7350
tosnull7351 function TNXCComp.tos : string;
7352 begin
7353 Result := fStackVarNames[fStackVarNames.Count - 1];
7354 // set statement type based on type on top of stack
7355 if Pos('__float_stack_', Result) <> 0 then
7356 StatementType := stFloat
7357 else if (Pos('__signed_stack_', Result) <> 0) and (StatementType <> stFloat) then
7358 StatementType := stSigned;
7359 {
7360 if fStatementType = stFloat then
7361 Result := Format('__float_stack_%3.3d%s', [fStackDepth, fCurrentThreadName])
7362 else if fStatementType = stUnsigned then
7363 Result := Format('__unsigned_stack_%3.3d%s', [fStackDepth, fCurrentThreadName])
7364 else
7365 Result := Format('__signed_stack_%3.3d%s', [fStackDepth, fCurrentThreadName]);
7366 }
7367 end;
7368
TempSignedByteNamenull7369 function TNXCComp.TempSignedByteName: string;
7370 begin
7371 Result := Format('__tmpsbyte%s', [fCurrentThreadName]);
7372 end;
7373
TempSignedWordNamenull7374 function TNXCComp.TempSignedWordName: string;
7375 begin
7376 Result := Format('__tmpsword%s', [fCurrentThreadName]);
7377 end;
7378
TempSignedLongNamenull7379 function TNXCComp.TempSignedLongName: string;
7380 begin
7381 Result := Format('__tmpslong%s', [fCurrentThreadName]);
7382 end;
7383
TempUnsignedLongNamenull7384 function TNXCComp.TempUnsignedLongName: string;
7385 begin
7386 Result := Format('__tmplong%s', [fCurrentThreadName]);
7387 end;
7388
TempFloatNamenull7389 function TNXCComp.TempFloatName: string;
7390 begin
7391 Result := Format('__tmpfloat%s', [fCurrentThreadName]);
7392 end;
7393
RegisterNameByStatementTypenull7394 function TNXCComp.RegisterNameByStatementType(st : TStatementType; name : string = '') : string;
7395 begin
7396 if fUDTOnStack <> '' then
7397 begin
7398 Result := fUDTOnStack;
7399 fUDTOnStack := ''; // once it has been used it is removed from the stack
7400 end
7401 else
7402 begin
7403 if st = stFloat then
7404 Result := FloatRegisterName(name)
7405 else if st = stUnsigned then
7406 Result := UnsignedRegisterName(name)
7407 else
7408 Result := SignedRegisterName(name);
7409 end;
7410 end;
7411
RegisterNamenull7412 function TNXCComp.RegisterName(name : string): string;
7413 begin
7414 if fUDTOnStack <> '' then
7415 begin
7416 Result := fUDTOnStack;
7417 fUDTOnStack := ''; // once it has been used it is removed from the stack
7418 end
7419 else
7420 begin
7421 if fStatementType = stFloat then
7422 Result := FloatRegisterName(name)
7423 else if fStatementType = stUnsigned then
7424 Result := UnsignedRegisterName(name)
7425 else
7426 Result := SignedRegisterName(name);
7427 end;
7428 end;
7429
SignedRegisterNamenull7430 function TNXCComp.SignedRegisterName(name: string): string;
7431 begin
7432 if name = '' then
7433 name := fCurrentThreadName;
7434 Result := Format('__D0%s',[name]);
7435 end;
7436
UnsignedRegisterNamenull7437 function TNXCComp.UnsignedRegisterName(name: string): string;
7438 begin
7439 if name = '' then
7440 name := fCurrentThreadName;
7441 Result := Format('__DU0%s',[name]);
7442 end;
7443
FloatRegisterNamenull7444 function TNXCComp.FloatRegisterName(name: string): string;
7445 begin
7446 if name = '' then
7447 name := fCurrentThreadName;
7448 Result := Format('__DF0%s',[name]);
7449 end;
7450
ZeroFlagnull7451 function TNXCComp.ZeroFlag: string;
7452 begin
7453 Result := Format('__zf%s', [fCurrentThreadName]);
7454 end;
7455
StrTmpBufNamenull7456 function TNXCComp.StrTmpBufName(name : string): string;
7457 begin
7458 if name = '' then
7459 name := fCurrentThreadName;
7460 Result := Format('__strtmpbuf%s', [name]);
7461 end;
7462
StrBufNamenull7463 function TNXCComp.StrBufName(name : string): string;
7464 begin
7465 if name = '' then
7466 name := fCurrentThreadName;
7467 Result := Format('__strbuf%s', [name]);
7468 end;
7469
StrRetValNamenull7470 function TNXCComp.StrRetValName(name : string): string;
7471 begin
7472 if name = '' then
7473 name := fCurrentThreadName;
7474 Result := Format('__strretval%s', [name]);
7475 end;
7476
7477 procedure TNXCComp.EmitRegisters;
7478 var
7479 j, k, idx, LastRegIdx : integer;
7480 f : TInlineFunction;
7481 H : TArrayHelperVar;
7482 dt : Char;
7483 name, tname : string;
7484 function EmitFmt(const idx : integer) : string;
7485 begin
7486 Result := REGVARS_ARRAY[idx] + ' ' + REGVARTYPES_ARRAY[idx];
7487 end;
7488 begin
7489 LastRegIdx := High(REGVARS_ARRAY);
7490 if FirmwareVersion < MIN_FW_VER2X then
7491 dec(LastRegIdx, 2);
7492 for j := 0 to fArrayHelpers.Count - 1 do
7493 begin
7494 H := fArrayHelpers[j];
7495 dt := H.DataType;
7496 name := H.Name;
7497 tname := GlobalTypeName(name);
7498 AllocateHelper(name, DataTypeToArrayDimensions(dt), '', tname, dt);
7499 end;
7500 for j := 0 to fThreadNames.Count - 1 do
7501 begin
7502 name := fThreadNames[j];
7503 if fInlineFunctions.IndexOfName(name) = -1 then
7504 begin
7505 for idx := Low(REGVARS_ARRAY) to LastRegIdx do
7506 EmitLn(Format(EmitFmt(idx), [name]));
7507 dt := FunctionReturnType(name);
7508 if IsUDT(dt) or IsArrayType(dt) then
7509 begin
7510 tname := GlobalTypeName(name);
7511 AllocateHelper(Format('__result_%s', [name]), DataTypeToArrayDimensions(dt), '', tname, dt);
7512 end;
7513 end;
7514 end;
7515 for j := 0 to fInlineFunctions.Count - 1 do
7516 begin
7517 f := fInlineFunctions[j];
7518 for k := 0 to f.Callers.Count - 1 do
7519 begin
7520 name := InlineName(f.Callers[k], f.Name);
7521 for idx := Low(REGVARS_ARRAY) to LastRegIdx do
7522 EmitLn(Format(EmitFmt(idx), [name]));
7523 dt := FunctionReturnType(f.Name);
7524 if IsUDT(dt) or IsArrayType(dt) then
7525 begin
7526 tname := GlobalTypeName(f.Name);
7527 AllocateHelper(Format('__result_%s', [name]), DataTypeToArrayDimensions(dt), '', tname, dt);
7528 end;
7529 end;
7530 end;
7531 end;
7532
7533 procedure TNXCComp.EmitStackVariables;
7534 var
7535 i, j, k : integer;
7536 f : TInlineFunction;
7537 name : string;
7538 begin
7539 for j := 0 to fThreadNames.Count - 1 do
7540 begin
7541 name := fThreadNames[j];
7542 if fInlineFunctions.IndexOfName(name) = -1 then
7543 begin
7544 for i := 1 to MaxStackDepth do begin
7545 EmitLn(Format('__signed_stack_%3.3d%s slong', [i, name]));
7546 end;
7547 for i := 1 to MaxStackDepth do begin
7548 EmitLn(Format('__unsigned_stack_%3.3d%s long', [i, name]));
7549 end;
7550 if FirmwareVersion >= MIN_FW_VER2X then
7551 begin
7552 for i := 1 to MaxStackDepth do begin
7553 EmitLn(Format('__float_stack_%3.3d%s float', [i, name]));
7554 end;
7555 end;
7556 end;
7557 end;
7558 for j := 0 to fInlineFunctions.Count - 1 do
7559 begin
7560 f := fInlineFunctions[j];
7561 for k := 0 to f.Callers.Count - 1 do
7562 begin
7563 name := InlineName(f.Callers[k], f.Name);
7564 for i := 1 to MaxStackDepth do begin
7565 EmitLn(Format('__signed_stack_%3.3d%s slong', [i, name]));
7566 end;
7567 for i := 1 to MaxStackDepth do begin
7568 EmitLn(Format('__unsigned_stack_%3.3d%s long', [i, name]));
7569 end;
7570 if FirmwareVersion >= MIN_FW_VER2X then
7571 begin
7572 for i := 1 to MaxStackDepth do begin
7573 EmitLn(Format('__float_stack_%3.3d%s float', [i, name]));
7574 end;
7575 end;
7576 end;
7577 end;
7578 end;
7579
7580 const
7581 APISF_NUMTOSTR = 0;
7582 APISF_STRCAT = 1;
7583 APISF_SUBSTR = 2;
7584 APISF_FLATTEN = 3;
7585 APISF_STRREPLACE = 4;
7586 APISF_FORMATNUM = 5;
7587
7588 procedure TNXCComp.StringFunction(const Name : string);
7589 var
7590 id : integer;
7591 op : string;
7592 begin
7593 id := APIStrFuncNameToID(Name);
7594 case id of
7595 APISF_NUMTOSTR, APISF_FLATTEN : begin
7596 OpenParen;
7597 BoolExpression;
7598 CloseParen;
7599 if id = APISF_NUMTOSTR then
7600 op := 'numtostr'
7601 else
7602 op := 'flatten';
7603 EmitLn(Format('%s %s, %s', [op, StrRetValName, RegisterName]));
7604 end;
7605 APISF_STRCAT : DoStrCat;
7606 APISF_SUBSTR : DoSubString;
7607 APISF_STRREPLACE : DoStrReplace;
7608 APISF_FORMATNUM : DoFormatNum;
7609 else
7610 AbortMsg(Format(sNotAnAPIStrFunc, [Name]));
7611 end;
7612 end;
7613
7614 procedure TNXCComp.DoStrReplace;
7615 var
7616 str, strnew, idx : string;
7617 begin
7618 // StrReplace(string, idx, strnew)
7619 OpenParen;
7620 // string
7621 StringExpression('');
7622 EmitLn(Format('mov %s, %s', [StrTmpBufName, StrBufName]));
7623 str := StrTmpBufName;
7624 MatchString(TOK_COMMA);
7625 // idx
7626 BoolExpression;
7627 push;
7628 idx := tos;
7629 EmitLn(Format('mov %s, %s', [idx, RegisterName]));
7630 MatchString(TOK_COMMA);
7631 // strnew
7632 StringExpression('');
7633 EmitLn(Format('mov %s, %s', [StrRetValName, StrBufName]));
7634 strnew := StrRetValName;
7635 CloseParen;
7636 // strip the null from the replacement string so that it doesn't embed a null
7637 // in the middle of the output string
7638 EmitLn(Format('strtoarr %s, %s', [StrBufName, strnew]));
7639 EmitLn(Format('strreplace %s, %s, %s, %s', [StrRetValName, str, idx, StrBufName]));
7640 pop;
7641 end;
7642
7643 procedure TNXCComp.DoStrCat;
7644 var
7645 asmStr : string;
7646 begin
7647 // StrCat(str1, str2, ..., strN)
7648 OpenParen;
7649 asmstr := Format('strcat %s, ', [StrRetValName]) + StrCatHelper('', ',');
7650 CloseParen;
7651 EmitLn(asmStr);
7652 end;
7653
TNXCComp.StrCatHelpernull7654 function TNXCComp.StrCatHelper(const oldasmstr : string; recurseToken : Char) : string;
7655 var
7656 AHV : TArrayHelperVar;
7657 aval : string;
7658 begin
7659 StringExpression('');
7660 AHV := fArrayHelpers.GetHelper(fCurrentThreadName, '', TOK_ARRAYBYTEDEF);
7661 try
7662 aval := AHV.Name;
7663 if fGlobals.IndexOfName(aval) = -1 then
7664 AddEntry(aval, TOK_ARRAYBYTEDEF, '', '');
7665 // move result of string expression to newly allocated temporary variable
7666 EmitLn(Format('mov %s, %s', [aval, StrBufName]));
7667 if Token = recurseToken then
7668 begin
7669 Next; // skip past the recurse token (comma or + depending on the context)
7670 Result := oldasmstr + StrCatHelper(aval + ', ', ',');
7671 end
7672 else
7673 Result := oldasmstr + aval;
7674 finally
7675 fArrayHelpers.ReleaseHelper(AHV);
7676 end;
7677 end;
7678
7679 procedure TNXCComp.DoSubString;
7680 var
7681 str, idx : string;
7682 begin
7683 // SubStr(string, idx, len)
7684 OpenParen;
7685 // string
7686 StringExpression('');
7687 str := StrBufName;
7688 MatchString(TOK_COMMA);
7689 // idx
7690 BoolExpression;
7691 push;
7692 idx := tos;
7693 EmitLn(Format('mov %s, %s', [idx, RegisterName]));
7694 MatchString(TOK_COMMA);
7695 // len
7696 BoolExpression;
7697 CloseParen;
7698 EmitLn(Format('strsubset %s, %s, %s, %s', [StrRetValName, str, idx, RegisterName]));
7699 pop;
7700 end;
7701
7702 const
7703 APIF_ABS = 0;
7704 APIF_SIGN = 1;
7705 APIF_RANDOM = 2;
7706 APIF_GETINPUT = 3;
7707 APIF_GETOUTPUT = 4;
7708 APIF_RESETSCREEN = 7;
7709 APIF_TEXTOUT = 8;
7710 APIF_NUMOUT = 9;
7711 APIF_PLAYTONEEX = 12;
7712 APIF_PLAYFILEEX = 13;
7713 APIF_BUTTONPRESSED = 18;
7714 APIF_BUTTONCOUNT = 19;
7715 APIF_READBUTTONEX = 20;
7716 APIF_DRAWPOINT = 22;
7717 APIF_DRAWLINE = 23;
7718 APIF_DRAWCIRCLE = 24;
7719 APIF_DRAWRECT = 25;
7720 APIF_DRAWGRAPHIC = 26;
7721 APIF_DRAWGRAPHICEX = 27;
7722 APIF_STRTONUM = 31;
7723 APIF_STRLEN = 32;
7724 APIF_STRINDEX = 33;
7725 APIF_ASM = 34;
7726 APIF_DRAWGRAPHICAR = 35;
7727 APIF_DRAWGRAPHICAREX = 36;
7728 APIF_DRAWPOLY = 37;
7729 APIF_DRAWELLIPSE = 38;
7730 APIF_FONTTEXTOUT = 39;
7731 APIF_FONTNUMOUT = 40;
7732 // APIF_SIZEOF = 41;
7733
7734 procedure TNXCComp.DoCallAPIFunc(procname: string);
7735 var
7736 arg, parg, op, asmStr : string;
7737 id : integer;
7738 dt : char;
7739 begin
7740 fCCSet := False;
7741 ResetStatementType;
7742 id := APIFuncNameToID(procname);
7743 case id of
7744 APIF_ASM : begin
7745 dt := #0;
7746 DoAsm(dt);
7747 fSemiColonRequired := True;
7748 end;
7749 APIF_RANDOM : begin
7750 OpenParen;
7751 if Value = TOK_CLOSEPAREN then
7752 begin
7753 CloseParen;
7754 EmitLn(Format('SignedRandom(%0:s)', [RegisterName]));
7755 end
7756 else
7757 begin
7758 BoolExpression;
7759 CloseParen;
7760 EmitLn(Format('Random(%0:s, %0:s)', [RegisterName]));
7761 end;
7762 end;
7763 APIF_ABS, APIF_SIGN :
7764 begin
7765 OpenParen;
7766 BoolExpression;
7767 CloseParen;
7768 case id of
7769 APIF_ABS : asmStr := 'abs %0:s, %0:s';
7770 APIF_SIGN : asmStr := 'sign %0:s, %0:s';
7771 end;
7772 EmitLn(Format(asmStr, [RegisterName]));
7773 end;
7774 APIF_GETINPUT, APIF_GETOUTPUT :
7775 begin
7776 // GetInput(port, field)
7777 // GetOutput(port, field)
7778 OpenParen;
7779 // port
7780 parg := GetDecoratedValue;
7781 Next;
7782 MatchString(TOK_COMMA);
7783 // field
7784 CheckNumeric;
7785 arg := Value;
7786 Next;
7787 CloseParen;
7788 case id of
7789 APIF_GETINPUT : op := 'getin';
7790 APIF_GETOUTPUT : op := 'getout';
7791 end;
7792 EmitLn(Format('%s %s, %s, %s', [op, RegisterName, parg, arg]));
7793 end;
7794 APIF_RESETSCREEN : DoResetScreen;
7795 APIF_TEXTOUT, APIF_NUMOUT : DoTextNumOut(id);
7796 APIF_PLAYTONEEX : DoPlayToneEx;
7797 APIF_PLAYFILEEX : DoPlayFileEx;
7798 APIF_BUTTONPRESSED, APIF_BUTTONCOUNT, APIF_READBUTTONEX : DoReadButton(id);
7799 APIF_DRAWPOINT : DoDrawPoint;
7800 APIF_DRAWLINE, APIF_DRAWRECT : DoDrawLineRect(id);
7801 APIF_DRAWCIRCLE : DoDrawCircle;
7802 APIF_DRAWGRAPHIC,
7803 APIF_DRAWGRAPHICEX,
7804 APIF_DRAWGRAPHICAR,
7805 APIF_DRAWGRAPHICAREX : DoDrawGraphic(id);
7806 APIF_STRTONUM : DoStrToNum;
7807 APIF_STRLEN : DoStrLen;
7808 APIF_STRINDEX : DoStrIndex;
7809 APIF_DRAWPOLY : DoDrawPoly;
7810 APIF_DRAWELLIPSE : DoDrawEllipse;
7811 APIF_FONTTEXTOUT, APIF_FONTNUMOUT : DoFontTextNumOut(id);
7812 // APIF_SIZEOF : DoSizeOf;
7813 else
7814 AbortMsg(Format(sNotAnAPIFunc, [procname]));
7815 end;
7816 end;
7817
7818 (*
7819 procedure TNXCComp.DoSizeOf;
7820 var
7821 val : integer;
7822 arg, savedval : string;
7823 savedtok : Char;
7824 begin
7825 // sizeof(var or type)
7826 OpenParen;
7827 Scan;
7828 arg := '';
7829 savedtok := #0;
7830 while Token <> TOK_CLOSEPAREN do begin
7831 // unsigned and const do not change the type size so skip them
7832 if not (Token in [TOK_CONST, TOK_UNSIGNED]) then
7833 begin
7834 savedval := Value;
7835 savedtok := Token;
7836 arg := arg + Value + ' ';
7837 if Token = TOK_IDENTIFIER then
7838 Break;
7839 end;
7840 Next;
7841 Scan;
7842 end;
7843 arg := Trim(arg);
7844 if savedtok := TOK_IDENTIFIER then
7845 begin
7846 // first look up the type from the variable name
7847 end
7848 else
7849 begin
7850 // get type from type name
7851 end;
7852
7853 //?????????
7854 CloseParen;
7855 EmitLn(Format('mov %s, %s', [RegisterName, IntToStr(val)]));
7856 end;
7857 *)
7858
7859 procedure TNXCComp.DoStrIndex;
7860 var
7861 arg : string;
7862 begin
7863 // StrIndex(string, idx)
7864 OpenParen;
7865 // string
7866 StringExpression('');
7867 arg := StrBufName;
7868 MatchString(TOK_COMMA);
7869 // idx
7870 BoolExpression;
7871 CloseParen;
7872 EmitLn(Format('strindex %0:s, %s, %0:s',[RegisterName, arg]));
7873 end;
7874
7875 procedure TNXCComp.DoStrLen;
7876 var
7877 arg : string;
7878 begin
7879 // StrLen(string)
7880 OpenParen;
7881 // string
7882 StringExpression('');
7883 arg := StrBufName;
7884 CloseParen;
7885 EmitLn(Format('strlen %s, %s', [RegisterName, arg]));
7886 end;
7887
7888 procedure TNXCComp.DoStrToNum;
7889 var
7890 arg : string;
7891 begin
7892 // StrToNum(string)
7893 OpenParen;
7894 // string
7895 StringExpression('');
7896 arg := StrBufName;
7897 CloseParen;
7898 push;
7899 EmitLn(Format('strtonum %0:s, %s, %s, NA, NA', [RegisterName, tos, arg]));
7900 pop;
7901 end;
7902
7903 procedure TNXCComp.DoResetScreen;
7904 begin
7905 OpenParen;
7906 CloseParen;
7907 EmitLn('acquire __SSMArgsMutex');
7908 EmitLn('set __SSMArgs.ScreenMode, 0');
7909 EmitLn('syscall SetScreenMode, __SSMArgs');
7910 EmitLn(Format('mov %s, __SSMArgs.Result', [RegisterName]));
7911 EmitLn('release __SSMArgsMutex');
7912 end;
7913
7914 procedure TNXCComp.DoTextNumOut(idx: integer);
7915 var
7916 x, y, txt, val : string;
7917 bCls : boolean;
7918 begin
7919 //TextOut(x,y,txt,options=false)
7920 //NumOut(x,y,num,options=false)
7921 OpenParen;
7922 // arg1 = x
7923 BoolExpression;
7924 push;
7925 x := tos;
7926 EmitLn(Format('mov %s, %s', [x, RegisterName]));
7927 MatchString(TOK_COMMA);
7928 // arg2 = y
7929 BoolExpression;
7930 push;
7931 y := tos;
7932 EmitLn(Format('mov %s, %s', [y, RegisterName]));
7933 MatchString(TOK_COMMA);
7934 if idx = APIF_NUMOUT then
7935 begin
7936 BoolExpression;
7937 bCls := Token = TOK_COMMA;
7938 if bCls then
7939 begin
7940 push;
7941 val := tos;
7942 EmitLn(Format('mov %s, %s', [val, RegisterName]));
7943 MatchString(TOK_COMMA);
7944 // arg4 = cls
7945 BoolExpression;
7946 end;
7947 CloseParen;
7948 EmitLn('acquire __TextOutMutex');
7949 EmitLn('mov __TextOutArgs.Location.X, ' + x);
7950 EmitLn('mov __TextOutArgs.Location.Y, ' + y);
7951 if bCls then
7952 begin
7953 EmitLn('mov __TextOutArgs.Options, ' + RegisterName);
7954 EmitLn(Format('numtostr __TextOutArgs.Text, %s',[val]));
7955 end
7956 else
7957 begin
7958 EmitLn('set __TextOutArgs.Options, 0');
7959 EmitLn(Format('numtostr __TextOutArgs.Text, %s',[RegisterName]));
7960 end;
7961 EmitLn('syscall DrawText, __TextOutArgs');
7962 ResetStatementType;
7963 EmitLn(Format('mov %s, __TextOutArgs.Result',[RegisterName]));
7964 EmitLn('release __TextOutMutex');
7965 if bCls then
7966 pop;
7967 end
7968 else
7969 begin
7970 StringExpression('');
7971 txt := StrBufName;
7972 bCls := Token = TOK_COMMA;
7973 if bCls then
7974 begin
7975 MatchString(TOK_COMMA);
7976 // arg4 = cls
7977 BoolExpression;
7978 end;
7979 CloseParen;
7980 EmitLn('acquire __TextOutMutex');
7981 EmitLn('mov __TextOutArgs.Location.X, ' + x);
7982 EmitLn('mov __TextOutArgs.Location.Y, ' + y);
7983 if bCls then
7984 EmitLn('mov __TextOutArgs.Options, ' + RegisterName)
7985 else
7986 EmitLn('set __TextOutArgs.Options, 0');
7987 EmitLn('mov __TextOutArgs.Text, ' + txt);
7988 EmitLn('syscall DrawText, __TextOutArgs');
7989 ResetStatementType;
7990 EmitLn(Format('mov %s, __TextOutArgs.Result',[RegisterName]));
7991 EmitLn('release __TextOutMutex');
7992 end;
7993 pop;
7994 pop;
7995 end;
7996
7997 procedure TNXCComp.DoFontTextNumOut(idx: integer);
7998 var
7999 x, y, fntname, txt, val : string;
8000 bCls : boolean;
8001 begin
8002 //FontTextOut(x,y,file,txt,options=false)
8003 //FontNumOut(x,y,file,num,options=false)
8004 OpenParen;
8005 // arg1 = x
8006 BoolExpression;
8007 push;
8008 x := tos;
8009 EmitLn(Format('mov %s, %s', [x, RegisterName]));
8010 MatchString(TOK_COMMA);
8011 // arg2 = y
8012 BoolExpression;
8013 push;
8014 y := tos;
8015 EmitLn(Format('mov %s, %s', [y, RegisterName]));
8016 MatchString(TOK_COMMA);
8017 // arg3 = file
8018 StringExpression('');
8019 EmitLn(Format('mov %s, %s', [StrTmpBufName, StrBufName]));
8020 fntname := StrTmpBufName;
8021 MatchString(TOK_COMMA);
8022 if idx = APIF_FONTNUMOUT then
8023 begin
8024 BoolExpression;
8025 bCls := Token = TOK_COMMA;
8026 if bCls then
8027 begin
8028 push;
8029 val := tos;
8030 EmitLn(Format('mov %s, %s', [val, RegisterName]));
8031 MatchString(TOK_COMMA);
8032 // arg4 = cls
8033 BoolExpression;
8034 end;
8035 CloseParen;
8036 EmitLn('acquire __FontOutMutex');
8037 EmitLn('mov __FontOutArgs.Location.X, ' + x);
8038 EmitLn('mov __FontOutArgs.Location.Y, ' + y);
8039 EmitLn('mov __FontOutArgs.Filename, ' + fntname);
8040 if bCls then
8041 begin
8042 EmitLn('mov __FontOutArgs.Options, ' + RegisterName);
8043 EmitLn(Format('numtostr __FontOutArgs.Text, %s',[val]));
8044 end
8045 else
8046 begin
8047 EmitLn('set __FontOutArgs.Options, 0');
8048 EmitLn(Format('numtostr __FontOutArgs.Text, %s',[RegisterName]));
8049 end;
8050 EmitLn('syscall DrawFont, __FontOutArgs');
8051 ResetStatementType;
8052 EmitLn(Format('mov %s, __FontOutArgs.Result',[RegisterName]));
8053 EmitLn('release __FontOutMutex');
8054 if bCls then
8055 pop;
8056 end
8057 else
8058 begin
8059 StringExpression('');
8060 txt := StrBufName;
8061 bCls := Token = TOK_COMMA;
8062 if bCls then
8063 begin
8064 MatchString(TOK_COMMA);
8065 // arg4 = cls
8066 BoolExpression;
8067 end;
8068 CloseParen;
8069 EmitLn('acquire __FontOutMutex');
8070 EmitLn('mov __FontOutArgs.Location.X, ' + x);
8071 EmitLn('mov __FontOutArgs.Location.Y, ' + y);
8072 EmitLn('mov __FontOutArgs.Filename, ' + fntname);
8073 if bCls then
8074 EmitLn('mov __FontOutArgs.Options, ' + RegisterName)
8075 else
8076 EmitLn('set __FontOutArgs.Options, 0');
8077 EmitLn('mov __FontOutArgs.Text, ' + txt);
8078 EmitLn('syscall DrawFont, __FontOutArgs');
8079 ResetStatementType;
8080 EmitLn(Format('mov %s, __FontOutArgs.Result',[RegisterName]));
8081 EmitLn('release __FontOutMutex');
8082 end;
8083 pop;
8084 pop;
8085 end;
8086
8087 procedure TNXCComp.DoDrawPoint;
8088 var
8089 x, y : string;
8090 bCls : boolean;
8091 begin
8092 //PointOut(x,y,cls=false)
8093 OpenParen;
8094 // arg1 = x
8095 BoolExpression;
8096 push;
8097 x := tos;
8098 EmitLn(Format('mov %s, %s', [x, RegisterName]));
8099 MatchString(TOK_COMMA);
8100 // arg2 = y
8101 BoolExpression;
8102 bCls := Token = TOK_COMMA;
8103 if bCls then
8104 begin
8105 push;
8106 y := tos;
8107 EmitLn(Format('mov %s, %s', [y, RegisterName]));
8108 MatchString(TOK_COMMA);
8109 // arg3 = cls
8110 BoolExpression;
8111 end;
8112 CloseParen;
8113 EmitLn('acquire __PointOutMutex');
8114 EmitLn('mov __PointOutArgs.Location.X, ' + x);
8115 if bCls then begin
8116 EmitLn('mov __PointOutArgs.Location.Y, ' + y);
8117 EmitLn('mov __PointOutArgs.Options, ' + RegisterName);
8118 end
8119 else begin
8120 EmitLn('mov __PointOutArgs.Location.Y, ' + RegisterName);
8121 EmitLn('set __PointOutArgs.Options, 0');
8122 end;
8123 EmitLn('syscall DrawPoint, __PointOutArgs');
8124 ResetStatementType;
8125 EmitLn(Format('mov %s, __PointOutArgs.Result',[RegisterName]));
8126 EmitLn('release __PointOutMutex');
8127 pop;
8128 if bCls then
8129 pop;
8130 end;
8131
8132 procedure TNXCComp.DoDrawPoly;
8133 var
8134 pts : string;
8135 bCls : boolean;
8136 begin
8137 //PolyOut(points,options=false)
8138 OpenParen;
8139 // arg1 = points
8140 pts := GetDecoratedValue;
8141 Next;
8142 bCls := Token = TOK_COMMA;
8143 if bCls then
8144 begin
8145 MatchString(TOK_COMMA);
8146 // arg2 = cls
8147 BoolExpression;
8148 end;
8149 CloseParen;
8150 EmitLn('acquire __PolyOutMutex');
8151 EmitLn('mov __PolyOutArgs.Points, ' + pts);
8152 if bCls then begin
8153 EmitLn('mov __PolyOutArgs.Options, ' + RegisterName);
8154 end
8155 else begin
8156 EmitLn('set __PolyOutArgs.Options, 0');
8157 end;
8158 EmitLn('syscall DrawPolygon, __PolyOutArgs');
8159 ResetStatementType;
8160 EmitLn(Format('mov %s, __PolyOutArgs.Result',[RegisterName]));
8161 EmitLn('release __PolyOutMutex');
8162 end;
8163
8164 procedure TNXCComp.DoDrawLineRect(idx : integer);
8165 var
8166 x, y, x2, y2 : string;
8167 bCls : boolean;
8168 begin
8169 //LineOut(x1,y1,x2,y2,cls=false)
8170 //RectOut(x1,y1,width,height,cls=false)
8171 OpenParen;
8172 // arg1 = x
8173 BoolExpression;
8174 push;
8175 x := tos;
8176 EmitLn(Format('mov %s, %s', [x, RegisterName]));
8177 MatchString(TOK_COMMA);
8178 // arg2 = y
8179 BoolExpression;
8180 push;
8181 y := tos;
8182 EmitLn(Format('mov %s, %s', [y, RegisterName]));
8183 MatchString(TOK_COMMA);
8184 // arg3 = x2
8185 BoolExpression;
8186 push;
8187 x2 := tos;
8188 EmitLn(Format('mov %s, %s', [x2, RegisterName]));
8189 MatchString(TOK_COMMA);
8190 // arg4 = y2
8191 BoolExpression;
8192 bCls := Token = TOK_COMMA;
8193 if bCls then
8194 begin
8195 push;
8196 y2 := tos;
8197 EmitLn(Format('mov %s, %s', [y2, RegisterName]));
8198 MatchString(TOK_COMMA);
8199 // arg5 = cls
8200 BoolExpression;
8201 end;
8202 CloseParen;
8203 if idx = APIF_DRAWRECT then
8204 begin
8205 EmitLn('acquire __RectOutMutex');
8206 EmitLn('mov __RectOutArgs.Location.X, ' + x);
8207 EmitLn('mov __RectOutArgs.Location.Y, ' + y);
8208 EmitLn('mov __RectOutArgs.Size.Width, ' + x2);
8209 if bCls then begin
8210 EmitLn('mov __RectOutArgs.Size.Height, ' + y2);
8211 EmitLn('mov __RectOutArgs.Options, ' + RegisterName);
8212 end
8213 else begin
8214 EmitLn('mov __RectOutArgs.Size.Height, ' + RegisterName);
8215 EmitLn('set __RectOutArgs.Options, 0');
8216 end;
8217 EmitLn('syscall DrawRect, __RectOutArgs');
8218 ResetStatementType;
8219 EmitLn(Format('mov %s, __RectOutArgs.Result',[RegisterName]));
8220 EmitLn('release __RectOutMutex');
8221 end
8222 else
8223 begin
8224 EmitLn('acquire __LineOutMutex');
8225 EmitLn('mov __LineOutArgs.StartLoc.X, ' + x);
8226 EmitLn('mov __LineOutArgs.StartLoc.Y, ' + y);
8227 EmitLn('mov __LineOutArgs.EndLoc.X, ' + x2);
8228 if bCls then begin
8229 EmitLn('mov __LineOutArgs.EndLoc.Y, ' + y2);
8230 EmitLn('mov __LineOutArgs.Options, ' + RegisterName);
8231 end
8232 else begin
8233 EmitLn('mov __LineOutArgs.EndLoc.Y, ' + RegisterName);
8234 EmitLn('set __LineOutArgs.Options, 0');
8235 end;
8236 EmitLn('syscall DrawLine, __LineOutArgs');
8237 ResetStatementType;
8238 EmitLn(Format('mov %s, __LineOutArgs.Result',[RegisterName]));
8239 EmitLn('release __LineOutMutex');
8240 end;
8241 pop;
8242 pop;
8243 pop;
8244 if bCls then
8245 pop;
8246 end;
8247
8248 procedure TNXCComp.DoDrawCircle;
8249 var
8250 x, y, radius : string;
8251 bCls : boolean;
8252 begin
8253 //CircleOut(x1,y1,radius,cls=false)
8254 OpenParen;
8255 // arg1 = x
8256 BoolExpression;
8257 push;
8258 x := tos;
8259 EmitLn(Format('mov %s, %s', [x, RegisterName]));
8260 MatchString(TOK_COMMA);
8261 // arg2 = y
8262 BoolExpression;
8263 push;
8264 y := tos;
8265 EmitLn(Format('mov %s, %s', [y, RegisterName]));
8266 MatchString(TOK_COMMA);
8267 // arg3 = radius
8268 BoolExpression;
8269 bCls := Token = TOK_COMMA;
8270 if bCls then
8271 begin
8272 push;
8273 radius := tos;
8274 EmitLn(Format('mov %s, %s', [radius, RegisterName]));
8275 MatchString(TOK_COMMA);
8276 // arg4 = cls
8277 BoolExpression;
8278 end;
8279 CloseParen;
8280 EmitLn('acquire __CircleOutMutex');
8281 EmitLn('mov __CircleOutArgs.Center.X, ' + x);
8282 EmitLn('mov __CircleOutArgs.Center.Y, ' + y);
8283 if bCls then begin
8284 EmitLn('mov __CircleOutArgs.Size, ' + radius);
8285 EmitLn('mov __CircleOutArgs.Options, ' + RegisterName);
8286 end
8287 else begin
8288 EmitLn('mov __CircleOutArgs.Size, ' + RegisterName);
8289 EmitLn('set __CircleOutArgs.Options, 0');
8290 end;
8291 EmitLn('syscall DrawCircle, __CircleOutArgs');
8292 ResetStatementType;
8293 EmitLn(Format('mov %s, __CircleOutArgs.Result',[RegisterName]));
8294 EmitLn('release __CircleOutMutex');
8295 pop;
8296 pop;
8297 if bCls then
8298 pop;
8299 end;
8300
8301 procedure TNXCComp.DoDrawEllipse;
8302 var
8303 x, y, radiusX, radiusY : string;
8304 bCls : boolean;
8305 begin
8306 //EllipseOut(x,y,radiusX,radiusY,cls=false)
8307 OpenParen;
8308 // arg1 = x
8309 BoolExpression;
8310 push;
8311 x := tos;
8312 EmitLn(Format('mov %s, %s', [x, RegisterName]));
8313 MatchString(TOK_COMMA);
8314 // arg2 = y
8315 BoolExpression;
8316 push;
8317 y := tos;
8318 EmitLn(Format('mov %s, %s', [y, RegisterName]));
8319 MatchString(TOK_COMMA);
8320 // arg3 = radiusX
8321 BoolExpression;
8322 push;
8323 radiusX := tos;
8324 EmitLn(Format('mov %s, %s', [radiusX, RegisterName]));
8325 MatchString(TOK_COMMA);
8326 // arg4 = radiusY
8327 BoolExpression;
8328 bCls := Token = TOK_COMMA;
8329 if bCls then
8330 begin
8331 push;
8332 radiusY := tos;
8333 EmitLn(Format('mov %s, %s', [radiusY, RegisterName]));
8334 MatchString(TOK_COMMA);
8335 // arg5 = cls
8336 BoolExpression;
8337 end;
8338 CloseParen;
8339 EmitLn('acquire __EllipseOutMutex');
8340 EmitLn('mov __EllipseOutArgs.Center.X, ' + x);
8341 EmitLn('mov __EllipseOutArgs.Center.Y, ' + y);
8342 EmitLn('mov __EllipseOutArgs.SizeX, ' + radiusX);
8343 if bCls then begin
8344 EmitLn('mov __EllipseOutArgs.SizeY, ' + radiusY);
8345 EmitLn('mov __EllipseOutArgs.Options, ' + RegisterName);
8346 end
8347 else begin
8348 EmitLn('mov __EllipseOutArgs.SizeY, ' + RegisterName);
8349 EmitLn('set __EllipseOutArgs.Options, 0');
8350 end;
8351 EmitLn('syscall DrawEllipse, __EllipseOutArgs');
8352 ResetStatementType;
8353 EmitLn(Format('mov %s, __EllipseOutArgs.Result',[RegisterName]));
8354 EmitLn('release __EllipseOutMutex');
8355 pop;
8356 pop;
8357 pop;
8358 if bCls then
8359 pop;
8360 end;
8361
8362 procedure TNXCComp.DoDrawGraphic(idx : integer);
8363 var
8364 x, y, fname, vars : string;
8365 bCls : boolean;
8366 begin
8367 //GraphicOut(x,y,fname,options=0)
8368 //GraphicOutEx(x,y,fname,vars,options=0)
8369 //GraphicArrayOut(x,y,data,options=0)
8370 //GraphicArrayOutEx(x,y,data,vars,options=0)
8371 OpenParen;
8372 // arg1 = x
8373 BoolExpression;
8374 push;
8375 x := tos;
8376 EmitLn(Format('mov %s, %s', [x, RegisterName]));
8377 MatchString(TOK_COMMA);
8378 // arg2 = y
8379 BoolExpression;
8380 push;
8381 y := tos;
8382 EmitLn(Format('mov %s, %s', [y, RegisterName]));
8383 MatchString(TOK_COMMA);
8384 // arg3 = fname|data
8385 if idx in [APIF_DRAWGRAPHIC, APIF_DRAWGRAPHICEX] then
8386 begin
8387 StringExpression('');
8388 fname := StrBufName;
8389 end
8390 else
8391 begin
8392 fname := GetDecoratedValue;
8393 if DataType(Value) <> TOK_ARRAYBYTEDEF then
8394 Expected(sByteArrayType);
8395 Next;
8396 end;
8397 if idx in [APIF_DRAWGRAPHICEX, APIF_DRAWGRAPHICAREX] then
8398 begin
8399 MatchString(TOK_COMMA);
8400 // arg4 = vars
8401 vars := GetDecoratedValue;
8402 Next;
8403 end;
8404 bCls := Token = TOK_COMMA;
8405 if bCls then
8406 begin
8407 MatchString(TOK_COMMA);
8408 // arg4 = cls
8409 BoolExpression;
8410 end;
8411 CloseParen;
8412 EmitLn('acquire __GraphicOutMutex');
8413 if idx in [APIF_DRAWGRAPHIC, APIF_DRAWGRAPHICEX] then
8414 begin
8415 EmitLn('mov __GraphicOutArgs.Location.X, ' + x);
8416 EmitLn('mov __GraphicOutArgs.Location.Y, ' + y);
8417 if bCls then begin
8418 EmitLn('mov __GraphicOutArgs.Options, ' + RegisterName);
8419 end
8420 else begin
8421 EmitLn('mov __GraphicOutArgs.Options, 0');
8422 end;
8423 EmitLn('mov __GraphicOutArgs.Filename, ' + fname);
8424 if idx = APIF_DRAWGRAPHICEX then
8425 EmitLn('mov __GraphicOutArgs.Variables, ' + vars)
8426 else
8427 EmitLn('mov __GraphicOutArgs.Variables, __GraphicOutEmptyVars');
8428 EmitLn('syscall DrawGraphic, __GraphicOutArgs');
8429 ResetStatementType;
8430 EmitLn(Format('mov %s, __GraphicOutArgs.Result',[RegisterName]));
8431 end
8432 else
8433 begin
8434 EmitLn('mov __GraphicArrayOutArgs.Location.X, ' + x);
8435 EmitLn('mov __GraphicArrayOutArgs.Location.Y, ' + y);
8436 if bCls then begin
8437 EmitLn('mov __GraphicArrayOutArgs.Options, ' + RegisterName);
8438 end
8439 else begin
8440 EmitLn('set __GraphicArrayOutArgs.Options, 0');
8441 end;
8442 EmitLn('mov __GraphicArrayOutArgs.Data, ' + fname);
8443 if idx = APIF_DRAWGRAPHICAREX then
8444 EmitLn('mov __GraphicArrayOutArgs.Variables, ' + vars)
8445 else
8446 EmitLn('mov __GraphicArrayOutArgs.Variables, __GraphicOutEmptyVars');
8447 EmitLn('syscall DrawGraphicArray, __GraphicArrayOutArgs');
8448 ResetStatementType;
8449 EmitLn(Format('mov %s, __GraphicArrayOutArgs.Result',[RegisterName]));
8450 end;
8451 EmitLn('release __GraphicOutMutex');
8452 pop;
8453 pop;
8454 end;
8455
8456 procedure TNXCComp.DoPlayToneEx;
8457 var
8458 freq, dur, vol : string;
8459 begin
8460 //PlayToneEx(freq, dur, vol, loop)
8461 OpenParen;
8462 // arg1 == Frequency
8463 BoolExpression;
8464 push;
8465 freq := tos;
8466 EmitLn(Format('mov %s, %s', [freq, RegisterName]));
8467 MatchString(TOK_COMMA);
8468 // arg2 == Duration
8469 BoolExpression;
8470 push;
8471 dur := tos;
8472 EmitLn(Format('mov %s, %s', [dur, RegisterName]));
8473 MatchString(TOK_COMMA);
8474 // arg3 == Volume
8475 BoolExpression;
8476 push;
8477 vol := tos;
8478 EmitLn(Format('mov %s, %s', [vol, RegisterName]));
8479 MatchString(TOK_COMMA);
8480 // arg4 == loop?
8481 BoolExpression;
8482 CloseParen;
8483 EmitLn('acquire __SPTArgsMutex');
8484 EmitLn('mov __SPTArgs.Frequency, ' + freq);
8485 EmitLn('mov __SPTArgs.Duration, ' + dur);
8486 EmitLn('mov __SPTArgs.Volume, ' + vol);
8487 EmitLn(Format('mov __SPTArgs.Loop, %s',[RegisterName]));
8488 EmitLn('syscall SoundPlayTone, __SPTArgs');
8489 ResetStatementType;
8490 EmitLn(Format('mov %s, __SPTArgs.Result',[RegisterName]));
8491 EmitLn('release __SPTArgsMutex');
8492 pop;
8493 pop;
8494 pop;
8495 end;
8496
8497 procedure TNXCComp.DoPlayFileEx;
8498 var
8499 fname, vol : string;
8500 begin
8501 //PlayFileEx(file, vol, loop?)
8502 OpenParen;
8503 // arg1 == Filename
8504 StringExpression('');
8505 fname := StrBufName;
8506 MatchString(TOK_COMMA);
8507 // arg2 == Volume
8508 BoolExpression;
8509 push;
8510 vol := tos;
8511 EmitLn(Format('mov %s, %s', [vol, RegisterName]));
8512 MatchString(TOK_COMMA);
8513 // arg3 == loop?
8514 BoolExpression;
8515 CloseParen;
8516 EmitLn('acquire __SPFArgsMutex');
8517 EmitLn('mov __SPFArgs.Filename, ' + fname);
8518 EmitLn('mov __SPFArgs.Volume, ' + vol);
8519 EmitLn(Format('mov __SPFArgs.Loop, %s', [RegisterName]));
8520 EmitLn('syscall SoundPlayFile, __SPFArgs');
8521 ResetStatementType;
8522 EmitLn(Format('mov %s, __SPFArgs.Result', [RegisterName]));
8523 EmitLn('release __SPFArgsMutex');
8524 pop;
8525 end;
8526
8527 procedure TNXCComp.DoReadButton(idx: integer);
8528 var
8529 btn, pressed, count : string;
8530 begin
8531 // ButtonPressed(btn, reset)
8532 // ButtonCount(btn, reset)
8533 // ReadButtonEx(btn, reset, pressed, count)
8534 OpenParen;
8535 // arg1 = button index
8536 BoolExpression;
8537 push;
8538 btn := tos;
8539 EmitLn(Format('mov %s, %s', [btn, RegisterName]));
8540 MatchString(TOK_COMMA);
8541 // arg2 = reset?
8542 BoolExpression;
8543 if idx = APIF_READBUTTONEX then
8544 begin
8545 // two output args
8546 MatchString(TOK_COMMA);
8547 // pressed
8548 pressed := GetDecoratedValue;
8549 CheckIdent;
8550 CheckTable(Value);
8551 Next;
8552 MatchString(TOK_COMMA);
8553 // count
8554 count := GetDecoratedValue;
8555 CheckIdent;
8556 CheckTable(Value);
8557 Next;
8558 end;
8559 CloseParen;
8560 EmitLn('acquire __RBtnMutex');
8561 EmitLn('mov __RBtnArgs.Index, ' + btn);
8562 EmitLn(Format('mov __RBtnArgs.Reset, %s', [RegisterName]));
8563 EmitLn('syscall ReadButton, __RBtnArgs');
8564 ResetStatementType;
8565 if idx = APIF_BUTTONCOUNT then
8566 EmitLn(Format('mov %s, __RBtnArgs.Count',[RegisterName]))
8567 else if idx = APIF_BUTTONPRESSED then
8568 EmitLn(Format('mov %s, __RBtnArgs.Pressed',[RegisterName]))
8569 else
8570 begin
8571 EmitLn(Format('mov %s, __RBtnArgs.Pressed', [pressed]));
8572 EmitLn(Format('mov %s, __RBtnArgs.Count', [count]));
8573 EmitLn(Format('mov %s, __RBtnArgs.Result', [RegisterName]));
8574 end;
8575 EmitLn('release __RBtnMutex');
8576 pop;
8577 end;
8578
8579 procedure TNXCComp.LoadAPIFunctions;
8580 begin
APIF_ASMnull8581 AddAPIFunction('asm', APIF_ASM);
APIF_ABSnull8582 AddAPIFunction('abs', APIF_ABS);
APIF_SIGNnull8583 AddAPIFunction('sign', APIF_SIGN);
APIF_RANDOMnull8584 AddAPIFunction('Random', APIF_RANDOM);
APIF_GETINPUTnull8585 AddAPIFunction('GetInput', APIF_GETINPUT);
APIF_GETOUTPUTnull8586 AddAPIFunction('GetOutput', APIF_GETOUTPUT);
APIF_RESETSCREENnull8587 AddAPIFunction('ResetScreen', APIF_RESETSCREEN);
APIF_TEXTOUTnull8588 AddAPIFunction('TextOut', APIF_TEXTOUT);
APIF_NUMOUTnull8589 AddAPIFunction('NumOut', APIF_NUMOUT);
APIF_PLAYTONEEXnull8590 AddAPIFunction('PlayToneEx', APIF_PLAYTONEEX);
APIF_PLAYFILEEXnull8591 AddAPIFunction('PlayFileEx', APIF_PLAYFILEEX);
APIF_BUTTONPRESSEDnull8592 AddAPIFunction('ButtonPressed', APIF_BUTTONPRESSED);
APIF_BUTTONCOUNTnull8593 AddAPIFunction('ButtonCount', APIF_BUTTONCOUNT);
APIF_READBUTTONEXnull8594 AddAPIFunction('ReadButtonEx', APIF_READBUTTONEX);
APIF_DRAWPOINTnull8595 AddAPIFunction('PointOut', APIF_DRAWPOINT);
APIF_DRAWLINEnull8596 AddAPIFunction('LineOut', APIF_DRAWLINE);
APIF_DRAWCIRCLEnull8597 AddAPIFunction('CircleOut', APIF_DRAWCIRCLE);
APIF_DRAWRECTnull8598 AddAPIFunction('RectOut', APIF_DRAWRECT);
APIF_DRAWGRAPHICnull8599 AddAPIFunction('GraphicOut', APIF_DRAWGRAPHIC);
APIF_DRAWGRAPHICEXnull8600 AddAPIFunction('GraphicOutEx', APIF_DRAWGRAPHICEX);
APIF_STRTONUMnull8601 AddAPIFunction('StrToNum', APIF_STRTONUM);
APIF_STRLENnull8602 AddAPIFunction('StrLen', APIF_STRLEN);
APIF_STRINDEXnull8603 AddAPIFunction('StrIndex', APIF_STRINDEX);
APISF_NUMTOSTRnull8604 AddAPIStringFunction('NumToStr', APISF_NUMTOSTR);
APISF_STRCATnull8605 AddAPIStringFunction('StrCat', APISF_STRCAT);
APISF_SUBSTRnull8606 AddAPIStringFunction('SubStr', APISF_SUBSTR);
APISF_FLATTENnull8607 AddAPIStringFunction('Flatten', APISF_FLATTEN);
APISF_STRREPLACEnull8608 AddAPIStringFunction('StrReplace', APISF_STRREPLACE);
APISF_FORMATNUMnull8609 AddAPIStringFunction('FormatNum', APISF_FORMATNUM);
APIF_DRAWGRAPHICARnull8610 AddAPIFunction('GraphicArrayOut', APIF_DRAWGRAPHICAR);
APIF_DRAWGRAPHICAREXnull8611 AddAPIFunction('GraphicArrayOutEx', APIF_DRAWGRAPHICAREX);
APIF_DRAWPOLYnull8612 AddAPIFunction('PolyOut', APIF_DRAWPOLY);
APIF_DRAWELLIPSEnull8613 AddAPIFunction('EllipseOut', APIF_DRAWELLIPSE);
APIF_FONTTEXTOUTnull8614 AddAPIFunction('FontTextOut', APIF_FONTTEXTOUT);
APIF_FONTNUMOUTnull8615 AddAPIFunction('FontNumOut', APIF_FONTNUMOUT);
APIF_SIZEOFnull8616 // AddAPIFunction('sizeof', APIF_SIZEOF);
8617 end;
8618
TNXCComp.GetNBCSrcnull8619 function TNXCComp.GetNBCSrc: TStrings;
8620 begin
thennull8621 if AmInlining and Assigned(fCurrentInlineFunction) then
8622 Result := fCurrentInlineFunction.Code
8623 else
8624 Result := fNBCSrc;
8625 end;
8626
8627 {
8628 procedure TNXCComp.EmitInlineFunction(const idx: integer);
8629 begin
8630 if (idx >= 0) and (idx < fInlineFunctions.Count) then
8631 begin
8632 fInlineFunctions.Items[idx].Emit(NBCSource);
8633 end;
8634 end;
8635 }
8636
8637 procedure TNXCComp.SetDefines(const Value: TStrings);
8638 begin
8639 fDefines.Assign(Value);
8640 end;
8641
8642 procedure TNXCComp.CheckTypeCompatibility(fp: TFunctionParameter; dt: char; const name : string);
8643 var
8644 expectedBase, providedBase : char;
8645 begin
8646 if GetArrayDimension(fp.ParameterDataType) <> GetArrayDimension(dt) then
8647 AbortMsg(sDatatypesNotCompatible)
8648 else
8649 begin
8650 expectedBase := ArrayBaseType(fp.ParameterDataType);
8651 providedBase := ArrayBaseType(dt);
8652 if (expectedBase in NonAggregateTypes) then
8653 begin
8654 if not (providedBase in NonAggregateTypes) then
8655 Expected(sNumericType)
8656 else begin
8657 // if parameter type name is a named type then type names must match
8658 if (fNamedTypes.IndexOf(fp.ParamTypeName) <> -1) and
8659 (fp.ParamTypeName <> DataTypeName(name)) then
8660 AbortMsg(sUDTNotEqual);
8661 end;
8662 end
8663 else if (expectedBase = TOK_STRINGDEF) and (providedBase <> TOK_STRINGDEF) then
8664 Expected(sStringVarType)
8665 else if expectedBase = TOK_USERDEFINEDTYPE then
8666 begin
8667 if providedBase <> TOK_USERDEFINEDTYPE then
8668 Expected(sStructType)
8669 else begin
8670 // struct types must be the same
8671 if fp.ParamTypeName <> GetUDTType(name) then
8672 AbortMsg(sUDTNotEqual);
8673 end;
8674 end
8675 else if (expectedBase = TOK_MUTEXDEF) and (providedBase <> TOK_MUTEXDEF) then
8676 Expected(sMutexType);
8677 end;
8678 end;
8679
8680 procedure TNXCComp.CheckNotConstant(const aName: string);
8681 begin
8682 // is this thing constant?
8683 if (IsParam(aName) and IsParamConst(aName)) or
8684 (IsLocal(aName) and IsLocalConst(aName)) or
8685 (IsGlobal(aName) and IsGlobalConst(aName)) then
8686 AbortMsg(sConstNotAllowed);
8687 end;
8688
TNXCComp.IsStringLiteralnull8689 function TNXCComp.IsStringLiteral(const aName: string) : boolean;
8690 begin
8691 Result := (Pos('"', aName) = 1) and (LastDelimiter('"', aName) = Length(aName));
8692 end;
8693
TNXCComp.IsCharLiteralnull8694 function TNXCComp.IsCharLiteral(const aName: string) : boolean;
8695 begin
8696 Result := (Pos('''', aName) = 1) and (LastDelimiter('''', aName) = Length(aName));
8697 end;
8698
TNXCComp.CheckConstantnull8699 function TNXCComp.CheckConstant(const aName: string) : string;
8700 var
8701 bIsConst : boolean;
8702 idx : integer;
8703 V : TVariable;
8704 begin
8705 // is this thing constant?
8706 Result := aName;
8707 if IsParam(aName) then
8708 begin
8709 bIsConst := IsParamConst(aName);
8710 end
8711 else if IsLocal(aName) then
8712 begin
8713 idx := LocalIdx(aName);
8714 if idx <> -1 then
8715 begin
8716 V := fLocals[idx];
8717 bIsConst := V.IsConstant;
8718 if bIsConst then
8719 Result := V.Value;
8720 end
8721 else
8722 bIsConst := False;
8723 end
8724 else if IsGlobal(aName) then
8725 begin
8726 idx := fGlobals.IndexOfName(aName);
8727 if idx <> -1 then
8728 begin
8729 V := fGlobals[idx];
8730 bIsConst := V.IsConstant;
8731 if bIsConst then
8732 Result := V.Value;
8733 end
8734 else
8735 bIsConst := False;
8736 end
8737 else if IsStringLiteral(aName) or IsCharLiteral(aName) then
8738 begin
8739 bIsConst := True;
8740 end
8741 else
8742 begin
8743 // perhaps it is a constant expression that can be evaluated?
8744 fCalc.SilentExpression := aName;
8745 bIsConst := not fCalc.ParserError;
8746 if bIsConst then
8747 Result := NBCFloatToStr(fCalc.Value);
8748 end;
8749 if not bIsConst then
8750 AbortMsg(sConstRequired);
8751 end;
8752
TNXCComp.IncrementOrDecrementnull8753 function TNXCComp.IncrementOrDecrement: boolean;
8754 begin
8755 Result := ((Token = '+') and (Look = '+')) or
8756 ((Token = '-') and (Look = '-'));
8757 end;
8758
8759 procedure TNXCComp.DoPreIncOrDec(bPutOnStack : boolean);
8760 var
8761 bInc : boolean;
8762 begin
8763 bInc := Token = '+';
8764 Next;
8765 Next;
8766 CheckIdent;
8767 // identifier must be an integer type
8768 if not (DataType(Value) in NonAggregateTypes) then
8769 Expected(sNumericType);
8770 if bInc then
8771 StoreInc(Value, 1)
8772 else
8773 StoreDec(Value, 1);
8774 if bPutOnStack then
8775 LoadVar(Value);
8776 Next;
8777 end;
8778
GetPreProcLexerClassnull8779 function TNXCComp.GetPreProcLexerClass: TGenLexerClass;
8780 begin
8781 Result := TNXCLexer;
8782 end;
8783
8784 (*
InlineDecorationnull8785 function TNXCComp.InlineDecoration: string;
8786 begin
8787 // if fInlining then
8788 // Result := '%%CALLER%%_'
8789 // else
8790 Result := '';
8791 end;
8792 *)
8793
8794 procedure TNXCComp.AddTypeNameAlias(const lbl, args: string);
8795 begin
8796 // add a named type alias
8797 if fNamedTypes.IndexOf(lbl) = -1 then
8798 fNamedTypes.AddEntry(lbl, args)
8799 else
8800 Duplicate(lbl);
8801 end;
8802
TNXCComp.TranslateTypeNamenull8803 function TNXCComp.TranslateTypeName(const name: string): string;
8804 var
8805 idx : integer;
8806 tname : string;
8807 begin
8808 Result := name;
8809 idx := fNamedTypes.IndexOf(name);
8810 if idx <> -1 then
8811 begin
8812 tname := fNamedTypes.MapValue[idx];
8813 if tname <> name then
8814 Result := TranslateTypeName(tname)
8815 else
8816 Result := tname;
8817 end;
8818 end;
8819
8820 procedure TNXCComp.ProcessEnum(bGlobal : boolean);
8821 var
8822 bNewType : boolean;
8823 sTypeName, varName, eName : string;
8824 iEnumVal, idx : integer;
8825 dt : Char;
8826 V : TVariable;
8827 begin
8828 // enums in NXC are unsigned bytes by default
8829 dt := TOK_BYTEDEF;
8830 iEnumVal := 0;
8831 bNewType := False;
8832 sTypeName := '';
8833 // enum [tag] { enumerators } [declarator];
8834 // eat until semi-colon
8835 Next;
8836 Scan; // skip past the "enum" keyword
8837 // optional type name
8838 if Token = TOK_IDENTIFIER then
8839 begin
8840 bNewType := True;
8841 sTypeName := Value;
8842 Next;
8843 Scan;
8844 end;
8845 MatchString(TOK_BEGIN);
8846 Scan;
8847 // process enumerators
8848 while Token <> TOK_END do begin
8849 // name [= val] ,
8850 CheckIdent;
8851 eName := Value;
8852 Next;
8853 if Token = '=' then begin
8854 Next; // skip past the equal sign to the value
8855 CheckNumeric;
8856 iEnumVal := StrToIntDef(Value, 0);
8857 Next; // skip past the value to comma or }
8858 end;
8859 dt := ValueToDataType(iEnumVal);
8860 V := nil;
8861 if bGlobal then
8862 begin
8863 idx := AddEntry(eName, dt, sTypeName, '', True);
8864 if idx <> -1 then
8865 V := fGlobals[idx];
8866 Allocate(eName, '', IntToStr(iEnumVal), sTypeName, dt);
8867 end
8868 else
8869 begin
8870 eName := ApplyDecoration(fCurrentThreadName, eName, fNestingLevel);
8871 idx := AddLocal(eName, dt, sTypeName, True, '');
8872 if idx <> -1 then
8873 V := fLocals[idx];
8874 // no need to allocate if we've already emitted this name&type
8875 if fEmittedLocals.IndexOf(eName+sTypeName) = -1 then
8876 Allocate(eName, '', IntToStr(iEnumVal), sTypeName, dt);
8877 end;
8878 if Assigned(V) then
8879 V.Value := IntToStr(iEnumVal);
8880 inc(iEnumVal);
8881 if Token <> TOK_END then
8882 begin
8883 Next;
8884 Scan;
8885 end;
8886 end;
8887 // should be at TOK_END
8888 MatchString(TOK_END);
8889 if bNewType then
8890 AddTypeNameAlias(sTypeName, DataTypeToTypeName(dt));
8891 // optional type name
8892 if Token = TOK_IDENTIFIER then
8893 begin
8894 // declare a variable of this type (only valid if bNewType is true
8895 if not bNewType then
8896 AbortMsg(sInvalidEnumDecl);
8897 varName := Value;
8898 if bGlobal then
8899 begin
8900 AddEntry(varName, dt, sTypeName, '', False);
8901 Allocate(varName, '', '', sTypeName, dt);
8902 end
8903 else
8904 begin
8905 varName := ApplyDecoration(fCurrentThreadName, varName, fNestingLevel);
8906 AddLocal(varName, dt, sTypeName, False, '');
8907 // no need to allocate if we've already emitted this name&type
8908 if fEmittedLocals.IndexOf(varName+sTypeName) = -1 then
8909 Allocate(varName, '', '', sTypeName, dt);
8910 end;
8911 Next;
8912 Scan; // move past identifier
8913 end;
8914 Semi; // required semicolon
8915 Scan;
8916 end;
8917
8918 procedure TNXCComp.ProcessTypedef;
8919 var
8920 basetype, newtype : string;
8921 i, lb, ln : integer;
8922 begin
8923 // typedef basetype newtype;
8924 // or
8925 // typedef struct {...} newtype;
8926 // base type can be multiple tokens (e.g., unsigned int)
8927 Next;
8928 Scan;
8929 if Token = TOK_STRUCT then
8930 begin
8931 ProcessStruct(True);
8932 end
8933 else
8934 begin
8935 basetype := '';
8936 while Token <> TOK_SEMICOLON do
8937 begin
8938 newtype := Value;
8939 if Look <> TOK_SEMICOLON then
8940 basetype := basetype + ' ' + Value;
8941 Next;
8942 end;
8943 i := Pos(newtype, basetype);
8944 lb := Length(basetype);
8945 ln := Length(newtype);
8946 if i = lb - ln + 1 then
8947 System.Delete(basetype, lb - ln + 1, MaxInt);
8948 basetype := Trim(basetype);
8949 AddTypeNameAlias(newtype, basetype);
8950 Semi;
8951 Scan;
8952 end;
8953 end;
8954
8955 procedure TNXCComp.LocalEmitLnNoTab(SL : TStrings; const line : string);
8956 begin
8957 SL.Add(line);
8958 end;
8959
8960 procedure TNXCComp.LocalEmitLn(SL : TStrings; const line : string);
8961 begin
8962 SL.Add(#9+line);
8963 end;
8964
8965 procedure TNXCComp.ProcessStruct(bTypeDef : boolean);
8966 var
8967 sname, mtype, aval, mname, mtypename, tmp : string;
8968 DE : TDataspaceEntry;
8969 dt : TDSType;
8970 SL : TStringList;
8971 i : integer;
8972 procedure AddMemberToCurrentStructure;
8973 begin
8974 // add a member to the current structure definition
8975 if mtype = 'string' then
8976 begin
8977 mtype := 'byte';
8978 aval := '[]' + aval;
8979 end;
8980 dt := NXCStrToType(mtype, True);
8981 if dt = dsCluster then
8982 LocalEmitLn(SL, Format('%s %s%s', [mname, mtype, aval]))
8983 else
8984 LocalEmitLn(SL, Format('%s %s%s', [mname, TypeToStr(dt), aval]));
8985 DE := fCurrentStruct.SubEntries.Add;
8986 HandleVarDecl(DataDefinitions, fNamedTypes, True, DE, mname, mtype+aval, @NXCStrToType);
8987 aval := '';
8988 end;
8989 begin
8990 // struct name {...};
8991 // or
8992 // struct {...} name; (and bTypeDef is true)
8993 Next;
8994 SL := TStringList.Create;
8995 try
8996 // create a new structure definition
8997 fCurrentStruct := DataDefinitions.Add;
8998 fCurrentStruct.DataType := dsCluster;
8999 if not bTypeDef then
9000 begin
9001 sname := Value;
9002 AddTypeNameAlias(sname, sname);
9003 fCurrentStruct.Identifier := sname;
9004 fCurrentStruct.TypeName := sname;
9005 Next; // skip past the type name
9006 end;
9007 if Token = TOK_IDENTIFIER then begin
9008 // invalid at this location
9009 Expected(TOK_BEGIN);
9010 Next;
9011 end;
9012 MatchString(TOK_BEGIN);
9013 while (Token <> TOK_END) and not endofallsource do
9014 begin
9015 // process a member declaration
9016 // format is multi-part typename membername [];
9017 // e.g., unsigned int membername
9018 // or int membername
9019 Scan;
9020 mtypename := Value;
9021 if Token = TOK_UNSIGNED then
9022 begin
9023 Next;
9024 Scan;
9025 mtypename := mtypename + ' ' + Value;
9026 end;
9027 // make sure we translate typedefs
9028 mtype := TranslateTypeName(mtypename);
9029 Next;
9030 mname := Value;
9031 Next;
9032 aval := '';
9033 while Token <> TOK_SEMICOLON do begin
9034 if Token = '[' then begin
9035 aval := ProcessArrayDimensions(tmp);
9036 end;
9037 if Token = ',' then begin
9038 AddMemberToCurrentStructure;
9039 Next;
9040 mname := Value;
9041 Next;
9042 end;
9043 if not (Token in [TOK_SEMICOLON, '[', ',']) then
9044 begin
9045 AbortMsg(sUnexpectedChar);
9046 Next;
9047 end;
9048 end;
9049 Semi;
9050 AddMemberToCurrentStructure;
9051 end;
9052 Next; // skip past the '}' (aka TOK_END)
9053 if bTypeDef then
9054 begin
9055 sname := Value;
9056 AddTypeNameAlias(sname, sname);
9057 fCurrentStruct.Identifier := sname;
9058 fCurrentStruct.TypeName := sname;
9059 Next; // skip past the type name
9060 end;
9061 // all struct declarations will be emitted to a special stringlist
9062 // and then output at the start of the NBC code
9063 LocalEmitLnNoTab(fStructDecls, 'dseg segment');
9064 LocalEmitLn(fStructDecls, sname+' struct');
9065 for i := 0 to SL.Count - 1 do
9066 LocalEmitLnNoTab(fStructDecls, SL[i]);
9067 LocalEmitLn(fStructDecls, sname+' ends');
9068 LocalEmitLnNoTab(fStructDecls, 'dseg ends');
9069 finally
9070 SL.Free;
9071 end;
9072 Semi; // skip past the ';'
9073 Scan;
9074 end;
9075
9076 procedure TNXCComp.CheckForTypedef(var bUnsigned, bConst, bInline, bSafeCall : boolean);
9077 var
9078 i : integer;
9079 tmpName : string;
9080 begin
9081 tmpName := TranslateTypeName(Value);
9082 if Value <> tmpName then
9083 begin
9084 Token := TOK_IDENTIFIER;
9085 Value := tmpName;
9086 // only need to check if Value
9087 i := Pos('unsigned ', Value);
9088 if i > 0 then
9089 begin
9090 System.Delete(Value, i, 9);
9091 bUnsigned := True;
9092 end;
9093 i := Pos('const ', Value);
9094 if i > 0 then
9095 begin
9096 System.Delete(Value, i, 6);
9097 bConst := True;
9098 end;
9099 i := Pos('inline ', Value);
9100 if i > 0 then
9101 begin
9102 System.Delete(Value, i, 7);
9103 bInline := True;
9104 end;
9105 i := Pos('safecall ', Value);
9106 if i > 0 then
9107 begin
9108 System.Delete(Value, i, 9);
9109 bSafeCall := True;
9110 end;
9111 Value := Trim(Value);
9112 end;
9113 Scan;
9114 end;
9115
IsUserDefinedTypenull9116 function TNXCComp.IsUserDefinedType(const name: string): boolean;
9117 begin
9118 Result := DataDefinitions.IndexOfName(name) <> -1;
9119 end;
9120
TNXCComp.RootOfnull9121 function TNXCComp.RootOf(const name: string): string;
9122 var
9123 p : integer;
9124 begin
9125 p := Pos('.', name);
9126 if p > 0 then
9127 Result := Copy(name, 1, p-1)
9128 else
9129 Result := name;
9130 end;
9131
TNXCComp.DataTypeOfDataspaceEntrynull9132 function TNXCComp.DataTypeOfDataspaceEntry(DE: TDataspaceEntry): char;
9133 var
9134 dim : integer;
9135 bt : char;
9136 tmpDE : TDataspaceEntry;
9137 begin
9138 Result := #0;
9139 if not Assigned(DE) then Exit;
9140 case DE.DataType of
9141 dsUByte : Result := TOK_BYTEDEF;
9142 dsSByte : Result := TOK_CHARDEF;
9143 dsUWord : Result := TOK_USHORTDEF;
9144 dsSWord : Result := TOK_SHORTDEF;
9145 dsULong : Result := TOK_ULONGDEF;
9146 dsSLong : Result := TOK_LONGDEF;
9147 dsCluster : Result := TOK_USERDEFINEDTYPE;
9148 dsMutex : Result := TOK_MUTEXDEF;
9149 dsFloat : Result := TOK_FLOATDEF;
9150 dsArray : begin
9151 // count dimensions and find base type
9152 dim := 1;
9153 tmpDE := DE.SubEntries[0];
9154 while tmpDE.DataType = dsArray do
9155 begin
9156 inc(dim);
9157 tmpDE := tmpDE.SubEntries[0];
9158 end;
9159 bt := DataTypeOfDataspaceEntry(tmpDE);
9160 Result := ArrayOfType(bt, dim);
9161 // 2010-05-13 JCH - the code below was causing problems with byte array
9162 // types not being seen as compatible with parameters of that type
9163 // and not being allowed to use ++ or += since they were seen as a string type
9164 // temporarily treat byte[] as string
9165 if Result = TOK_ARRAYBYTEDEF then
9166 Result := TOK_STRINGDEF;
9167 end;
9168 else
9169 Result := #0;
9170 end;
9171 end;
9172
9173 procedure TNXCComp.UDTAssignment(const name: string);
9174 //var
9175 // tmp, aval : string;
9176 begin
9177 if Token in ['+', '-', '/', '*', '%', '&', '|', '^'] then
9178 begin
9179 MathAssignment(name);
9180 // StoreUDT(name, tmp, aval);
9181 end
9182 else
9183 begin
9184 MatchString('=');
9185 GetAndStoreUDT(name);
9186 end;
9187 end;
9188
9189 procedure TNXCComp.GetAndStoreUDT(const name: string);
9190 begin
9191 NotNumericFactor;
9192 if fUDTOnStack <> '' then
9193 begin
9194 Store(name);
9195 fUDTOnStack := '';
9196 end;
9197 end;
9198
GetUDTTypenull9199 function TNXCComp.GetUDTType(n: string): string;
9200 var
9201 i : integer;
9202 root_type, root_name : string;
9203 DE : TDataspaceEntry;
9204 fp : TFunctionParameter;
9205 begin
9206 Result := '';
9207 n := StripInline(n);
9208 case WhatIs(n) of
9209 stParam : begin
9210 i := ParamIdx(n);
9211 if i <> -1 then
9212 begin
9213 if ArrayBaseType(fParams[i].DataType) = TOK_USERDEFINEDTYPE then
9214 begin
9215 root_name := RootOf(n);
9216 if root_name <> n then
9217 begin
9218 root_type := fParams[i].TypeName;
9219 System.Delete(n, 1, Length(root_name)+1);
9220 n := root_type + '.' + n;
9221 DE := DataDefinitions.FindEntryByFullName(n);
9222 if Assigned(DE) then
9223 Result := DE.TypeName;
9224 end
9225 else
9226 Result := fParams[i].TypeName;
9227 end;
9228 end
9229 else
9230 begin
9231 // i = -1
9232 for i := 0 to fFuncParams.Count - 1 do
9233 begin
9234 fp := fFuncParams[i];
9235 if n = ApplyDecoration(fp.ProcName, fp.Name, 0) then
9236 begin
9237 Result := fp.ParamTypeName;
9238 Break;
9239 end;
9240 end;
9241 end;
9242 end;
9243 stLocal : begin
9244 i := LocalIdx(n);
9245 if (i <> -1) and (ArrayBaseType(fLocals[i].DataType) = TOK_USERDEFINEDTYPE) then
9246 // if i = -1 then
9247 begin
9248 // maybe this is a member of a struct which might itself be a user defined type
9249 root_name := RootOf(n);
9250 if root_name <> n then
9251 begin
9252 // i := LocalIdx(root_name);
9253 // i := fLocals.IndexOfName(root_name);
9254 // if (i <> -1) and (ArrayBaseType(fLocals[i].DataType) = TOK_USERDEFINEDTYPE) then
9255 // begin
9256 root_type := fLocals[i].TypeName;
9257 System.Delete(n, 1, Length(root_name)+1);
9258 n := root_type + '.' + n;
9259 DE := DataDefinitions.FindEntryByFullName(n);
9260 if Assigned(DE) then
9261 Result := DE.TypeName;
9262 // end;
9263 end
9264 else
9265 Result := fLocals[i].TypeName;
9266 end;
9267 // else if ArrayBaseType(fLocals[i].DataType) = TOK_USERDEFINEDTYPE then
9268 // Result := fLocals[i].TypeName;
9269 end;
9270 stGlobal : begin
9271 i := fGlobals.IndexOfName(n);
9272 if i = -1 then
9273 begin
9274 // maybe this is a member of a struct which might itself be a user defined type
9275 root_name := RootOf(n);
9276 if root_name <> n then
9277 begin
9278 i := fGlobals.IndexOfName(root_name);
9279 if (i <> -1) and (ArrayBaseType(fGlobals[i].DataType) = TOK_USERDEFINEDTYPE) then
9280 begin
9281 root_type := fGlobals[i].TypeName;
9282 System.Delete(n, 1, Length(root_name)+1);
9283 n := root_type + '.' + n;
9284 DE := DataDefinitions.FindEntryByFullName(n);
9285 if Assigned(DE) then
9286 Result := DE.TypeName;
9287 end;
9288 end;
9289 end
9290 else if ArrayBaseType(fGlobals[i].DataType) = TOK_USERDEFINEDTYPE then
9291 Result := fGlobals[i].TypeName;
9292 end;
9293 else
9294 Result := '';
9295 AbortMsg(sUnknownUDT);
9296 end;
9297 end;
9298
9299 procedure TNXCComp.InitializeArray(const Name, aVal, Val, tname: string;
9300 dt: char; lenexpr: string);
9301 var
9302 tmpVal, expr, tmpType, codeStr : string;
9303 idx, n, dim : integer;
9304 begin
9305 if (lenexpr = '') or
9306 (lenexpr = '[]') or
9307 (lenexpr = '[][]') or
9308 (lenexpr = '[][][]') then
9309 Exit;
9310 tmpType := tname;
9311 if tmpType = 'string' then
9312 tmpType := 'byte[]';
9313 // grab the first array expression from lenexpr
9314 idx := Pos('[', lenexpr);
9315 n := Pos(']', lenexpr);
9316 expr := Copy(lenexpr, idx+1, n-idx-1);
9317 System.Delete(lenexpr, idx, n-idx+1);
9318 // now check dimensions
9319 dim := GetArrayDimension(dt);
9320 if dim = 1 then
9321 begin
9322 if ArrayBaseType(dt) in NonAggregateTypes then
9323 tmpVal := '0'
9324 else
9325 begin
9326 // create a variable to be used for initializing the array
9327 dec(dim);
9328 tmpVal := Format('__%s_%d', [Name, dim]);
9329 EmitLn('dseg segment');
9330 AllocateHelper(tmpVal, '', '', tmpType, dt);
9331 EmitLn('dseg ends');
9332 end;
9333 if expr = '' then
9334 expr := '1';
9335 codeStr := Format('arrinit %s, %s, %s', [Name, tmpVal, expr]);
9336 EmitLn(codeStr);
9337 end
9338 else
9339 begin
9340 // recurse if needed
9341 dt := RemoveArrayDimension(dt);
9342 // define a variable at this new level
9343 tmpVal := Format('__%s_%d', [Name, dim]);
9344 EmitLn('dseg segment');
9345 AllocateHelper(tmpVal, DataTypeToArrayDimensions(dt), '', tmpType, dt);
9346 EmitLn('dseg ends');
9347 InitializeArray(tmpVal, aVal, Val, tname, dt, lenexpr);
9348 if expr = '' then
9349 expr := '1';
9350 codeStr := Format('arrinit %s, %s, %s', [Name, tmpVal, expr]);
9351 EmitLn(codeStr);
9352 end;
9353 end;
9354
9355 procedure TNXCComp.LoadSystemFile(S : TStream);
9356 var
9357 tmp : string;
9358 begin
9359 // load fMS with the contents of NBCCommon.h followed by NXCDefs.h
9360 tmp := '#line 0 "NXCDefs.h"'#13#10;
9361 S.Write(PChar(tmp)^, Length(tmp));
9362
9363 S.Write(nbc_common_data, High(nbc_common_data)+1);
9364 S.Write(nxc_defs_data, High(nxc_defs_data)+1);
9365 // tmp := Format('#line 0 "%s"'#13#10, [CurrentFile]);
9366 tmp := '#reset'#13#10;
9367 S.Write(PChar(tmp)^, Length(tmp));
9368 end;
9369
9370 procedure TNXCComp.CheckSemicolon;
9371 begin
9372 if fSemiColonRequired then
9373 begin
9374 Semi;
9375 Scan;
9376 end;
9377 end;
9378
9379 procedure TNXCComp.CloseParen;
9380 begin
9381 dec(fParenDepth);
9382 if fParenDepth < 0 then
9383 AbortMsg(sUnmatchedCloseParen);
9384 MatchString(TOK_CLOSEPAREN);
9385 end;
9386
9387 procedure TNXCComp.OpenParen;
9388 begin
9389 MatchString(TOK_OPENPAREN);
9390 inc(fParenDepth);
9391 end;
9392
9393 procedure TNXCComp.InitializeGraphicOutVars;
9394 begin
9395 if IgnoreSystemFile then
9396 Exit; // do not intialization if we are not including the standard headers
9397 if not EnhancedFirmware then
9398 EmitLn('arrinit __GraphicOutEmptyVars, 0, 256')
9399 else
9400 EmitLn('arrinit __GraphicOutEmptyVars, 0, 16');
9401 end;
9402
9403 procedure TNXCComp.EmitMutexDeclaration(const name: string);
9404 begin
9405 EmitLn('dseg segment');
9406 EmitLn(Format(' __%s_mutex mutex', [name]));
9407 EmitLn('dseg ends');
9408 end;
9409
9410 procedure TNXCComp.EmitInlineParametersAndLocals(func: TInlineFunction);
9411 var
9412 i : integer;
9413 p : TFunctionParameter;
9414 v : TVariable;
9415 varname, tname : string;
9416 dt : char;
9417 bConst : boolean;
9418 begin
9419 for i := 0 to FunctionParameterCount(func.Name) - 1 do
9420 begin
9421 p := GetFunctionParam(func.Name, i);
9422 if Assigned(p) then
9423 begin
9424 varname := InlineName(fCurrentThreadName, ApplyDecoration(p.ProcName, p.Name, 0));
9425 tname := p.ParamTypeName;
9426 dt := p.ParameterDataType;
9427 bConst := p.IsConstant;
9428 if AmInlining then
9429 begin
9430 // call AddLocal instead
9431 if not IsLocal(varname) then
9432 AddLocal(varname, dt, tname, bConst, '');
9433 end
9434 else
9435 begin
9436 // allocate this parameter
9437 Allocate(varname, DataTypeToArrayDimensions(dt), '', tname, dt);
9438 end;
9439 end;
9440 end;
9441 for i := 0 to func.LocalVariables.Count - 1 do
9442 begin
9443 v := func.LocalVariables[i];
9444 varname := InlineName(fCurrentThreadName, v.Name);
9445 tname := v.TypeName;
9446 dt := v.DataType;
9447 bConst := v.IsConstant;
9448 if AmInlining then
9449 begin
9450 // call AddLocal instead
9451 if not IsLocal(varname) then
9452 AddLocal(varname, dt, tname, bConst, '');
9453 end
9454 else
9455 begin
9456 // allocate this variable
9457 Allocate(varname, DataTypeToArrayDimensions(dt), '', tname, dt);
9458 end;
9459 end;
9460 end;
9461
TypesAreCompatiblenull9462 function TNXCComp.TypesAreCompatible(lhs, rhs: char): boolean;
9463 var
9464 lDim, rDim : integer;
9465 lBase, rBase : Char;
9466 begin
9467 Result := ((lhs <> TOK_MUTEXDEF) and (rhs <> TOK_MUTEXDEF)) and
9468 ((lhs = rhs) or
9469 ((lhs in [TOK_ARRAYBYTEDEF, TOK_ARRAYCHARDEF, TOK_STRINGDEF]) and
9470 (rhs in [TOK_ARRAYBYTEDEF, TOK_ARRAYCHARDEF, TOK_STRINGDEF])) or
9471 ((lhs in [Chr(Ord(TOK_ARRAYBYTEDEF)+1), TOK_ARRAYSTRING]) and
9472 (rhs in [Chr(Ord(TOK_ARRAYBYTEDEF)+1), TOK_ARRAYSTRING])) or
9473 ((lhs in [Chr(Ord(TOK_ARRAYBYTEDEF)+2), Chr(Ord(TOK_ARRAYSTRING)+1)]) and
9474 (rhs in [Chr(Ord(TOK_ARRAYBYTEDEF)+2), Chr(Ord(TOK_ARRAYSTRING)+1)])) or
9475 ((lhs in [Chr(Ord(TOK_ARRAYBYTEDEF)+3), Chr(Ord(TOK_ARRAYSTRING)+2)]) and
9476 (rhs in [Chr(Ord(TOK_ARRAYBYTEDEF)+3), Chr(Ord(TOK_ARRAYSTRING)+2)]))
9477 );
9478 if not Result then
9479 begin
9480 if IsArrayType(lhs) or IsArrayType(rhs) then
9481 begin
9482 // dimension counts have to match and base types have to be compatible
9483 lDim := GetArrayDimension(lhs);
9484 rDim := GetArrayDimension(rhs);
9485 Result := lDim = rDim;
9486 if Result then
9487 begin
9488 // also base type compatible
9489 lBase := ArrayBaseType(lhs);
9490 rBase := ArrayBaseType(rhs);
9491 Result := ((lBase in NonAggregateTypes) and (rBase in NonAggregateTypes)) or (lBase = rBase);
9492 end;
9493 end
9494 else
9495 begin
9496 // neither is an array
9497 Result := (lhs in NonAggregateTypes) and (rhs in NonAggregateTypes);
9498 end;
9499 end;
9500 end;
9501
9502 procedure TNXCComp.DoFormatNum;
9503 var
9504 str : string;
9505 begin
9506 // FormatNum(string, value)
9507 OpenParen;
9508 // string
9509 StringExpression('');
9510 str := StrBufName;
9511 MatchString(TOK_COMMA);
9512 // value
9513 BoolExpression;
9514 CloseParen;
9515 EmitLn(Format('fmtnum %s, %s, %s', [StrRetValName, str, RegisterName]));
9516 end;
9517
9518 procedure TNXCComp.DecrementNestingLevel;
9519 var
9520 i : integer;
9521 begin
9522 dec(fNestingLevel);
9523 // clear any locals defined below the current level
9524 // since they have just gone out of scope
9525 for i := fLocals.Count - 1 downto 0 do
9526 begin
9527 if fLocals[i].Level > fNestingLevel then
9528 fLocals.Delete(i);
9529 end;
9530 end;
9531
9532 procedure TNXCComp.CheckEnhancedFirmware;
9533 begin
9534 if not EnhancedFirmware then
9535 AbortMsg(sEnhancedFirmwareReqd);
9536 end;
9537
9538 procedure TNXCComp.InitializeGlobalArrays;
9539 begin
9540 // all this routine does is emit a call to the global array
9541 // initialization subroutine
9542 EmitLn('call __initialize_global_data');
9543 end;
9544
9545 procedure TNXCComp.EmitGlobalDataInitSubroutine;
9546 var
9547 i : integer;
9548 V : TVariable;
9549 aval : string;
9550 begin
9551 EmitLnNoTab('subroutine __initialize_global_data');
9552 for i := 0 to fGlobals.Count - 1 do
9553 begin
9554 V := fGlobals[i];
9555 if IsArrayType(V.DataType) then
9556 begin
9557 if (V.LenExpr <> '') and (V.Value = '') then
9558 begin
9559 // generate code to initialize this array.
9560 aval := DataTypeToArrayDimensions(V.DataType);
9561 InitializeArray(V.Name, aval, '', V.TypeName, V.DataType, V.LenExpr);
9562 end
9563 else if V.Value <> '' then
9564 begin
9565 DoLocalArrayInit(V.Name, V.Value, V.DataType);
9566 end;
9567 end
9568 // possibly also initialize struct types containing arrays...
9569 end;
9570 EmitLn('return');
9571 EmitLnNoTab('ends');
9572 end;
9573
StripBracesnull9574 function StripBraces(str : string) : string;
9575 begin
9576 Result := Copy(str, 2, Length(str)-2);
9577 end;
9578
9579 procedure TNXCComp.DoLocalArrayInit(const aName, ival: string; dt: char);
9580 var
9581 asmstr, {src, }tmp : string;
9582 // i : integer;
9583 begin
9584 // generate an arrbuild asm statement for this array given the initial values
9585 asmstr := Format('arrbuild %s', [aName]);
9586 tmp := StripBraces(ival);
9587 asmstr := asmstr + ', ' + tmp;
9588 EmitLn(asmstr);
9589 end;
9590
TNXCComp.DoNewArrayIndexnull9591 function TNXCComp.DoNewArrayIndex(theArrayDT : Char; theArray, aLHSName : string) : boolean;
9592 var
9593 AHV : TArrayHelperVar;
9594 tmp, udType, aval, tmpUDTName, oldExpStr : string;
9595 tmpDT : char;
9596 begin
9597 Result := False;
9598 // grab the index as an expression and put it on the stack
9599 Next;
9600 tmpDT := fLHSDataType;
9601 oldExpStr := fExpStr;
9602 try
9603 fLHSDataType := TOK_LONGDEF;
9604 CommaExpression;
9605 finally
9606 fLHSDataType := tmpDT;
9607 fExpStr := oldExpStr;
9608 end;
9609 if Value <> ']' then
9610 Expected(''']''');
9611 push;
9612 tmp := tos;
9613 EmitLn(Format('mov %s, %s', [tmp, RegisterName]));
9614 fArrayIndexStack.Add(tmp);
9615 theArrayDT := RemoveArrayDimension(theArrayDT);
9616
9617 // check for additional levels of indexing
9618 if (Look = '[') and (IsArrayType(theArrayDT) or (theArrayDT = TOK_STRINGDEF)) then
9619 begin
9620 Next; // move to '['
9621 udType := '';
9622 if IsUDT(ArrayBaseType(theArrayDT)) then
9623 udType := GetUDTType(theArray);
9624 // get a temporary thread-safe variable of the right type
9625 AHV := fArrayHelpers.GetHelper(fCurrentThreadName, udType, theArrayDT);
9626 try
9627 aval := AHV.Name;
9628 if fGlobals.IndexOfName(aval) = -1 then
9629 AddEntry(aval, theArrayDT, udType, '');
9630 // set the variable to the specified element from previous array
9631 EmitLn(Format('index %s, %s, %s',[aval, GetDecoratedIdent(theArray), tmp]));
9632 // pass its name into the call to DoNewArrayIndex
9633 Result := DoNewArrayIndex(theArrayDT, aval, aLHSName);
9634 finally
9635 fArrayHelpers.ReleaseHelper(AHV);
9636 end;
9637 end
9638 else
9639 begin
9640 // no more indexing
9641 udType := '';
9642 if IsUDT(ArrayBaseType(theArrayDT)) then
9643 udType := GetUDTType(theArray);
9644 // get a temporary thread-safe variable of the right type
9645 AHV := fArrayHelpers.GetHelper(fCurrentThreadName, udType, theArrayDT);
9646 try
9647 aval := AHV.Name;
9648 if fGlobals.IndexOfName(aval) = -1 then
9649 AddEntry(aval, theArrayDT, udType, '');
9650 // set the variable to the specified element from previous array
9651 EmitLn(Format('index %s, %s, %s',[aval, GetDecoratedIdent(theArray), tmp]));
9652 // check for struct member notation
9653 if (Look = '.') and IsUDT(theArrayDT) then
9654 begin
9655 Next; // move to the dot
9656 // process dots
9657 tmpUDTName := aval;
9658 tmpUDTName := tmpUDTName + Value; // add the dot
9659 Next;
9660 tmpUDTName := tmpUDTName + Value; // add everything else
9661 // set value to full udt name
9662 Value := tmpUDTName;
9663 end
9664 else
9665 begin
9666 // set value to temporary array name
9667 Value := aval;
9668 end;
9669 Token := TOK_IDENTIFIER;
9670 tmpDT := DataType(Value);
9671 if (tmpDT in NonAggregateTypes) and (aLHSName = '') then
9672 begin
9673 Result := True; // i.e., loaded a value on the stack
9674 LoadVar(Value);
9675 Next; // move to the next token
9676 end
9677 else if aLHSName <> '' then
9678 begin
9679 if tmpDT = TOK_STRINGDEF then
9680 EmitLn(Format('strcat %s, %s', [aLHSName, GetDecoratedValue]))
9681 else if tmpDT in NonAggregateTypes then
9682 begin
9683 Result := True; // loaded a value onto the stack
9684 LoadVar(Value);
9685 end
9686 else if not IsArrayType(DataType(StripInline(aLHSName))) then
9687 EmitLn(Format('mov %s, %s', [GetDecoratedIdent(aLHSName), GetDecoratedValue]))
9688 else
9689 begin
9690 Result := True; // sort of loaded a value onto the stack
9691 fUDTOnStack := Value;
9692 end;
9693 Next; // move to the next token
9694 end
9695 else
9696 begin
9697 // recurse to the NumericRelation procedure
9698 Result := True; // a numeric relation always puts a value on the stack
9699 NumericRelation;
9700 end;
9701 finally
9702 fArrayHelpers.ReleaseHelper(AHV);
9703 end;
9704 end;
9705 pop;
9706 end;
9707
9708 procedure TNXCComp.SetStatementType(const Value: TStatementType);
9709 begin
9710 fStatementType := Value;
9711 if (Value = stFloat) and (FirmwareVersion < MIN_FW_VER2X) then
9712 AbortMsg(sFloatNotSupported);
9713 end;
9714
9715 procedure TNXCComp.ResetStatementType;
9716 begin
9717 StatementType := stSigned;
9718 end;
9719
9720 procedure TNXCComp.EmitNXCRequiredStructs;
9721 var
9722 SL : TStringList;
9723 begin
9724 SL := TStringList.Create;
9725 try
9726 SL.Text :=
9727 'TNXCSoundPlayFile struct'#13#10 +
9728 ' Result sbyte'#13#10 +
9729 ' Filename byte[]'#13#10 +
9730 ' Loop byte'#13#10 +
9731 ' Volume byte'#13#10 +
9732 'TNXCSoundPlayFile ends'#13#10 +
9733 'TNXCSoundPlayTone struct'#13#10 +
9734 ' Result sbyte'#13#10 +
9735 ' Frequency word'#13#10 +
9736 ' Duration word'#13#10 +
9737 ' Loop byte'#13#10 +
9738 ' Volume byte'#13#10 +
9739 'TNXCSoundPlayTone ends'#13#10 +
9740 'TNXCSetScreenMode struct'#13#10 +
9741 ' Result sbyte'#13#10 +
9742 ' ScreenMode dword'#13#10 +
9743 'TNXCSetScreenMode ends';
9744 NBCSource.AddStrings(SL);
9745 NBCSource.Add('');
9746 finally
9747 SL.Free;
9748 end;
9749 end;
9750
9751 procedure TNXCComp.CheckForMain;
9752 var
9753 i : integer;
9754 V : TVariable;
9755 begin
9756 for i := 0 to fGlobals.Count - 1 do
9757 begin
9758 V := fGlobals[i];
9759 if (V.DataType = TOK_TASK) and (V.Name = 'main') then
9760 Exit;
9761 end;
9762 // if we get here we know that main does not exist
9763 AbortMsg(sMainTaskNotFound);
9764 end;
9765
9766 procedure TNXCComp.DoCompilerStatusChange(const Status: string; const bDone : boolean);
9767 begin
9768 if Assigned(fOnCompilerStatusChange) then
9769 fOnCompilerStatusChange(Self, Status, bDone);
9770 end;
9771
AmInliningnull9772 function TNXCComp.AmInlining: boolean;
9773 begin
9774 // Result := fInlineStack.Count > 0;
9775 Result := fInlineDepth > 0;
9776 end;
9777
9778 procedure TNXCComp.DecrementInlineDepth;
9779 begin
9780 // remove the
9781 dec(fInlineDepth);
9782 end;
9783
9784 procedure TNXCComp.IncrementInlineDepth;
9785 begin
9786 inc(fInlineDepth);
9787 // fInlineStack.Add(TStringList.Create);
9788 end;
9789
9790 procedure TNXCComp.HandleSpecialNames;
9791 begin
9792 if Value = '__TMPBYTE__' then
9793 Value := TempSignedByteName
9794 else if Value = '__TMPWORD__' then
9795 Value := TempSignedWordName
9796 else if Value = '__TMPLONG__' then
9797 Value := TempSignedLongName
9798 else if Value = '__TMPULONG__' then
9799 Value := TempUnsignedLongName
9800 else if Value = '__TMPFLOAT__' then
9801 Value := TempFloatName
9802 else if Value = '__RETVAL__' then
9803 Value := SignedRegisterName
9804 else if Value = '__FLTRETVAL__' then
9805 Value := FloatRegisterName
9806 else if Value = '__STRRETVAL__' then
9807 Value := StrRetValName
9808 else if Value = '__GENRETVAL__' then
9809 Value := RegisterName
9810 else if Value = 'false' then
9811 begin
9812 Value := '0';
9813 Token := TOK_NUM;
9814 end
9815 else if Value = 'true' then
9816 begin
9817 Value := '1';
9818 Token := TOK_NUM;
9819 end;
9820 end;
9821
TNXCComp.GetValueOfnull9822 function TNXCComp.GetValueOf(const name: string): string;
9823 begin
9824 Result := name;
9825 if IsLocalConst(name) then
9826 begin
9827 Result := LocalConstantValue(name);
9828 end
9829 {
9830 else if IsParamConst(name) then
9831 begin
9832 Result := ParamConstantValue(name);
9833 end;
9834 }
9835 end;
9836
9837 procedure TNXCComp.MoveToCorrectRegister(dt: char);
9838 var
9839 cReg : string;
9840 rst : TStatementType;
9841 begin
9842 if dt in UnsignedIntegerTypes then begin
9843 creg := UnsignedRegisterName;
9844 rst := stUnsigned;
9845 end
9846 else if dt = TOK_FLOATDEF then begin
9847 creg := FloatRegisterName;
9848 rst := stFloat;
9849 end
9850 else begin
9851 creg := SignedRegisterName;
9852 rst := stSigned;
9853 end;
9854 if rst <> StatementType then
9855 EmitLn(Format('mov %s, %s', [creg, RegisterName]));
9856 end;
9857
9858 procedure TNXCComp.CheckForValidDataType(dt: char);
9859 begin
9860 // valid data types
9861 if not (dt in [TOK_CHARDEF, TOK_SHORTDEF, TOK_LONGDEF, TOK_BYTEDEF, TOK_USHORTDEF,
9862 TOK_ULONGDEF, TOK_MUTEXDEF, TOK_FLOATDEF, TOK_STRINGDEF,
9863 TOK_USERDEFINEDTYPE..TOK_ARRAYULONGDEF4,
9864 TOK_PROCEDURE, TOK_TASK, TOK_LABEL]) then
9865 AbortMsg(sUnknownDatatype);
9866 end;
9867
9868 procedure TNXCComp.HandlePreprocStatusChange(Sender: TObject;
9869 const StatusMsg: string);
9870 begin
9871 DoCompilerStatusChange(StatusMsg);
9872 end;
9873
9874 procedure TNXCComp.SetCurFile(const Value: string);
9875 begin
9876 if CurrentFile <> Value then
9877 begin
9878 fCurFile := Value;
9879 DoCompilerStatusChange(Format(sCurrentFile, [Value]));
9880 end;
9881 end;
9882
ProcessArrayDimensionsnull9883 function TNXCComp.ProcessArrayDimensions(var lenexpr : string) : string;
9884 var
9885 bDone, bOpen : boolean;
9886 begin
9887 lenexpr := '';
9888 Result := '';
9889 // declaring an array
9890 bDone := False;
9891 bOpen := False;
9892 while not bDone do
9893 begin
9894 lenexpr := lenexpr + Value;
9895 if Token in ['[', ']'] then
9896 Result := Result + Token;
9897 if bOpen and (Token = ']') then
9898 bOpen := False
9899 else if not bOpen and (Token = '[') then
9900 bOpen := True
9901 else if (bOpen and (Token = '[')) or
9902 (not bOpen and (Token = ']')) then
9903 AbortMsg(sInvalidArrayDeclaration);
9904 Next;
9905 if not bOpen and (Token <> '[') then
9906 bDone := True;
9907 end;
9908 end;
9909
9910 procedure TNXCComp.CommaStatement(const lend, lstart: string);
9911 begin
9912 Statement(lend, lstart);
9913 if fNoCommaOperator then Exit;
9914 // handle comma?
9915 if Token = TOK_COMMA then
9916 begin
9917 Next; // skip past the comma
9918 CommaStatement(lend, lstart);
9919 end;
9920 end;
9921
9922 end.
9923
9924