12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486 |
- MODULE FoxBinarySymbolFile; (** AUTHOR "fof"; PURPOSE "Symbol File - Binary Format"; *)
- IMPORT
- Basic := FoxBasic, Scanner := FoxScanner, SyntaxTree := FoxSyntaxTree, Global := FoxGlobal,
- Files,Streams, Kernel, SYSTEM, D := Debugging, Diagnostics, Options, Formats := FoxFormats, InterfaceComparison := FoxInterfaceComparison
- ,Commands, Printout := FoxPrintout, SemanticChecker := FoxSemanticChecker,
- Machine
- ;
- (** Symbol File Format
- SymbolFile = codeOptions:RawSet
- Imports
- [sfSysFlag sysFlags:RawNum]
- [sfConst {Symbol Value}]
- [sfVar {Symbol}]
- [sfXProcedure {Symbol ParameterList}]
- [sfOperator {Symbol ParameterList [sfInline Inline]}]
- [sfCProcedure {Symbol ParameterList Inline}]
- [sfAlias {Type name:RawString}]
- [sfType {Type}]
- sfEnd.
- Imports = {moduleName:RawString} 0X
- Symbol = [sfObjFlag flag:RawNum] [sfReadOnly]
- Type name:RawString
- Value = [ RawNum | RawHInt | RawReal | RawLReal | RawString ]
- Type = TypeReference
- | BasicType
- | ImportedType
- | UserType.
- TypeReference = number<0:RawNum
- BasicType = sfTypeBoolean | .. | sfLastType.
- ImportedType = ModuleNumber (structName:RawString | 0X typeIndex:RawNum)
- ModuleNumber = sfMod1 | .. | sfModOther-1 | sfModOther moduleNumber:RawNum
- UserType = [sfInvisible] [sfSysFlag sysFlag:RawNum] UserType2
- UserType2 = sfTypeOpenArray baseType:Type name:RawString
- | sfTypeStaticArray baseType:Type name:RawString length:RawNum
- | sfTypePointer baseType:Type name:RawString
- | sfTypeRecord baseType:Type name:RawString Record
- | sfTypeProcedure baseType:Type name:RawString flags:RawNum
- ParameterList
- Record = mode:RawNum priority:Char {variable:Symbol}
- [sfTProcedure {Symbol [name:RawString] ParameterList [sfInline Inline]} ]
- sfEnd.
- ParameterList = {
- [sfObjflag ( sfCParam | sfDarwinCParam | sfWinAPIParam )]
- [sfVar] [sfReadOnly] Type name:RawString
- } sfEnd.
- Inline = {len:Char {c:Char}} 0X.
- *)
- CONST
- TraceImport=0;
- TraceExport=1;
- Trace = {} ;
- (* FoxProgTools.Enum --start=1 sfTypeBoolean sfTypeChar8 sfTypeChar16 sfTypeChar32
- sfTypeShortint sfTypeInteger sfTypeLongint sfTypeHugeint sfTypeReal sfTypeLongreal sfTypeSet
- sfTypeString sfTypeNoType sfTypeNilType sfTypeByte sfTypeSptr sfMod1 ~
- FoxProgTools.Enum --start=2DH --hex sfModOther sfTypeOpenArray sfTypeStaticArray sfTypePointer sfTypeRecord sfTypeProcedure
- sfSysFlag sfInvisible sfReadOnly sfObjFlag sfConst sfVar sfLProcedure sfXProcedure sfOperator sfTProcedure sfCProcedure sfAlias sfType sfEnd ~
- *)
- sfTypeBoolean= 1;
- sfTypeChar8= 2;
- sfTypeChar16= 3;
- sfTypeChar32= 4;
- sfTypeShortint= 5;
- sfTypeInteger= 6;
- sfTypeLongint= 7;
- sfTypeHugeint = 8;
- sfTypeReal = 9;
- sfTypeLongreal = 10;
- sfTypeSet = 11;
- sfTypeString = 12;
- sfTypeNoType = 13;
- sfTypeNilType = 14;
- sfTypeByte = 15;
- sfTypeAny = 16;
- sfTypeObject = 17;
- sfTypeAddress= 18;
- sfTypeSize = 19;
- sfTypeUnsigned8=20;
- sfTypeUnsigned16=21;
- sfTypeUnsigned32=22;
- sfTypeUnsigned64=23;
- sfLastType = 23;
- sfMod1 = sfLastType+1;
- sfModOther=2DH;
- sfTypeOpenArray=2EH;
- (*
- sfTypeDynamicArray=2FH;
- *)
- sfTypeStaticArray=30H;
- sfTypePointer=31H;
- sfTypeRecord=32H;
- sfTypeProcedure=33H;
- sfSysFlag=34H;
- sfInvisible=35H;
- sfHidden = 0ACH;
- sfReadOnly=36H;
- sfObjFlag = 37H; (* fof: very (!) bad idea to have same number for two type flags *)
- sfConst=37H;
- sfVar=38H;
- sfTypeEnumeration=39H;
- (*
- sfLProcedure=39H;
- *)
- sfXProcedure=3AH;
- sfOperator=3BH;
- sfTProcedure=3CH;
- sfCProcedure = sfTProcedure;
- sfAlias=3DH;
- sfType=3EH;
- sfEnd= 3FH;
- sfTypeOpenMathArray = 40H;
- sfTypeTensor=42H;
- sfTypeStaticMathArray = 43H;
- sfTypeAll = 44H;
- sfTypeRange = 45H;
- sfTypeComplex = 46H;
- sfTypeLongcomplex = 47H;
- (* workaround: handle inlined operators *)
- sfInline = 0ABH;
- sfProtected = 0;
- sfActive=1;
- sfSafe=2;
- sfClass=16;
- sfDelegate = 5;
- sfUntraced = 4;
- sfWinAPIParam = 13; (* ejz *)
- sfCParam= 14; (* fof for linux *)
- sfDarwinCParam= 15; (* fld for darwin *)
- sfRealtime= 21;
- sfDynamic = 22;
- sfUnsafe= 23;
- sfDisposable= 24;
- sfFictive = 25;
- Undef=MIN(LONGINT);
- CONST
- FileTag = 0BBX; (* same constants are defined in Linker and AosLoader *)
- NoZeroCompress = 0ADX; (* do. *)
- FileVersion* = 0B1X; (* do. *)
- FileVersionOC*=0B2X;
- FileVersionCurrent*=0B4X;
- TYPE
- (* TypeReference provides a link between a type and a number for the purpose of late fixes while importing.
- When a type number is encountered while importing, a type reference will be used as a placeholder for the final type.
- After the import process has collected all types, the references are replaced by the referenced types (cf. Resolver Object) *)
- TypeReference = OBJECT (SyntaxTree.Type)
- VAR nr: LONGINT;
- PROCEDURE & InitTypeReference(nr: LONGINT);
- BEGIN
- InitType(Basic.invalidPosition); SELF.nr := nr;
- END InitTypeReference;
- END TypeReference;
- (* IndexToType provides a link between numbers and a type. Lists like this are typically filled while importing and provide the base
- for the type resolving, cf. Resolver below
- *)
- IndexToType= OBJECT(Basic.List)
- PROCEDURE PutType(nr: LONGINT; type: SyntaxTree.Type);
- BEGIN GrowAndSet(nr,type);
- END PutType;
- PROCEDURE GetType(nr: LONGINT): SyntaxTree.Type;
- VAR node: ANY;
- BEGIN node := Get(nr); IF node = NIL THEN RETURN NIL ELSE RETURN node(SyntaxTree.Type) END;
- END GetType;
- END IndexToType;
- LateFix= POINTER TO RECORD (* contains a late fix to be resolved in a later step: type fixes and implementations *)
- p: ANY; (*scope: SyntaxTree.Scope;*)
- next: LateFix;
- END;
- LateFixList = OBJECT (* fifo queue for items to be resolved later on - deferred fixes *)
- VAR first,last: LateFix;
- PROCEDURE & Init;
- BEGIN first := NIL; last := NIL;
- END Init;
- (* get and remove element from list *)
- PROCEDURE Get((*VAR scope: SyntaxTree.Scope*)): ANY;
- VAR p: ANY;
- BEGIN
- IF first # NIL THEN p := first.p; (*scope := first.scope;*) first := first.next ELSE p := NIL; END;
- IF first = NIL THEN last := NIL END;
- RETURN p;
- END Get;
- (* add unresolved type to list *)
- PROCEDURE Add(p: ANY (*; scope: SyntaxTree.Scope*));
- VAR next: LateFix;
- BEGIN
- (*ASSERT(scope # NIL);*)
- NEW(next); next.p := p; (* next.scope := scope;*)
- next.next := NIL;
- IF first = NIL THEN first := next; last := next;
- ELSE last.next := next; last := next
- END;
- END Add;
- END LateFixList;
- (*
- The resolver object is used to replace type references in a SyntaxTree.Module tree with the respective types from a given type list.
- To do so, the resolver traverses the module tree partially with direct procedural recursion and partially using the visitor pattern.
- *)
- Resolver=OBJECT (SyntaxTree.Visitor)
- VAR typeList: IndexToType; system: Global.System; typeFixes: LateFixList;
- checker: SemanticChecker.Checker;
- PROCEDURE & Init(system: Global.System; symbolFile: BinarySymbolFile; importCache: SyntaxTree.ModuleScope);
- VAR streamDiagnostics: Diagnostics.StreamDiagnostics;
- BEGIN
- typeList := NIL; SELF.system := system; NEW(typeFixes);
- NEW(streamDiagnostics, D.Log);
- checker := SemanticChecker.NewChecker(streamDiagnostics,FALSE,FALSE,TRUE,system,symbolFile,importCache,"");
- END Init;
- (* types that do not refer to other types *)
- PROCEDURE VisitType(x: SyntaxTree.Type);
- BEGIN END VisitType;
- PROCEDURE VisitBasicType(x: SyntaxTree.BasicType);
- BEGIN END VisitBasicType;
- PROCEDURE VisitByteType(x: SyntaxTree.ByteType);
- BEGIN END VisitByteType;
- PROCEDURE VisitBooleanType(x: SyntaxTree.BooleanType);
- BEGIN END VisitBooleanType;
- PROCEDURE VisitSetType(x: SyntaxTree.SetType);
- BEGIN END VisitSetType;
- PROCEDURE VisitAddressType(x: SyntaxTree.AddressType);
- BEGIN END VisitAddressType;
- PROCEDURE VisitSizeType(x: SyntaxTree.SizeType);
- BEGIN END VisitSizeType;
- PROCEDURE VisitAnyType(x: SyntaxTree.AnyType);
- BEGIN END VisitAnyType;
- PROCEDURE VisitObjectType(x: SyntaxTree.ObjectType);
- BEGIN END VisitObjectType;
- PROCEDURE VisitNilType(x: SyntaxTree.NilType);
- BEGIN END VisitNilType;
- PROCEDURE VisitCharacterType(x: SyntaxTree.CharacterType);
- BEGIN END VisitCharacterType;
- PROCEDURE VisitIntegerType(x: SyntaxTree.IntegerType);
- BEGIN END VisitIntegerType;
- PROCEDURE VisitFloatType(x: SyntaxTree.FloatType);
- BEGIN END VisitFloatType;
- PROCEDURE VisitComplexType(x: SyntaxTree.ComplexType);
- BEGIN END VisitComplexType;
- PROCEDURE VisitQualifiedType(x: SyntaxTree.QualifiedType);
- BEGIN
- x.SetResolved(ResolveType(x.resolved))
- END VisitQualifiedType;
- PROCEDURE VisitStringType(x: SyntaxTree.StringType);
- BEGIN END VisitStringType;
- PROCEDURE VisitRangeType(x: SyntaxTree.RangeType);
- BEGIN END VisitRangeType;
- (* types containing links to other types *)
- (**
- check enumeration scope: enter symbols and check for duplicate names
- **)
- PROCEDURE CheckEnumerationScope(x: SyntaxTree.EnumerationScope);
- VAR e: SyntaxTree.Constant; lowest, highest,value: LONGINT;
- BEGIN
- lowest := 0; highest := 0;
- e := x.firstConstant;
- WHILE (e # NIL) DO
- e.SetType(x.ownerEnumeration);
- e.SetState(SyntaxTree.Resolved);
- value := e.value(SyntaxTree.EnumerationValue).value;
- IF value < lowest THEN lowest := value END;
- IF value > highest THEN highest := value END;
- e := e.nextConstant;
- END;
- x.ownerEnumeration.SetRange(lowest,highest);
- END CheckEnumerationScope;
- (**
- resolve enumeration type: check enumeration scope
- **)
- PROCEDURE VisitEnumerationType(x: SyntaxTree.EnumerationType);
- VAR baseScope: SyntaxTree.EnumerationScope; resolved: SyntaxTree.Type; enumerationBase: SyntaxTree.EnumerationType;
- BEGIN
- x.SetEnumerationBase(ResolveType(x.enumerationBase));
- IF x.enumerationBase # NIL THEN
- resolved := x.enumerationBase.resolved;
- enumerationBase := resolved(SyntaxTree.EnumerationType);
- baseScope := enumerationBase.enumerationScope;
- END;
- CheckEnumerationScope(x.enumerationScope);
- x.SetState(SyntaxTree.Resolved);
- END VisitEnumerationType;
- PROCEDURE VisitArrayType(arrayType: SyntaxTree.ArrayType);
- BEGIN
- ASSERT(arrayType.arrayBase # NIL);
- arrayType.SetArrayBase(ResolveType(arrayType.arrayBase));
- arrayType.SetHasPointers(arrayType.arrayBase.resolved.hasPointers);
- arrayType.SetState(SyntaxTree.Resolved);
- END VisitArrayType;
- PROCEDURE VisitMathArrayType(arrayType: SyntaxTree.MathArrayType);
- BEGIN
- arrayType.SetArrayBase(ResolveType(arrayType.arrayBase));
- IF arrayType.form = SyntaxTree.Static THEN
- arrayType.SetIncrement(system.SizeOf(arrayType.arrayBase));
- arrayType.SetHasPointers(arrayType.arrayBase.resolved.hasPointers);
- ELSE
- arrayType.SetHasPointers(TRUE)
- END;
- arrayType.SetState(SyntaxTree.Resolved);
- END VisitMathArrayType;
- PROCEDURE VisitPointerType(pointerType: SyntaxTree.PointerType);
- VAR recordType: SyntaxTree.RecordType;
- BEGIN
- IF ~(SyntaxTree.Resolved IN pointerType.state) THEN
- typeFixes.Add(pointerType);
- pointerType.SetState(SyntaxTree.Resolved);
- END;
- (*
- pointerType.SetPointerBase(ResolveType(pointerType.pointerBase));
- IF pointerType.pointerBase.resolved IS SyntaxTree.RecordType THEN
- recordType := pointerType.pointerBase.resolved(SyntaxTree.RecordType);
- IF (recordType.typeDeclaration = NIL) THEN
- recordType.SetPointerType(pointerType);
- recordType.SetTypeDeclaration(pointerType.typeDeclaration)
- END;
- END;
- pointerType.SetState(SyntaxTree.Resolved);
- *)
- END VisitPointerType;
- PROCEDURE FixPointerType(pointerType: SyntaxTree.PointerType);
- VAR recordType: SyntaxTree.RecordType;
- BEGIN
- pointerType.SetPointerBase(ResolveType(pointerType.pointerBase));
- IF pointerType.pointerBase.resolved IS SyntaxTree.RecordType THEN
- recordType := pointerType.pointerBase.resolved(SyntaxTree.RecordType);
- IF (recordType.typeDeclaration = NIL) THEN
- recordType.SetPointerType(pointerType);
- recordType.SetTypeDeclaration(pointerType.typeDeclaration)
- END;
- END;
- END FixPointerType;
- PROCEDURE VisitRecordType(recordType: SyntaxTree.RecordType);
- VAR recordBase: SyntaxTree.RecordType; numberMethods: LONGINT; procedure,super,testsuper: SyntaxTree.Procedure; recordScope: SyntaxTree.RecordScope;
- pointerType: SyntaxTree.Type; typeDeclaration: SyntaxTree.TypeDeclaration; symbol: SyntaxTree.Symbol; size: HUGEINT; hasPointer: BOOLEAN;
- var: SyntaxTree.Variable;
- BEGIN
- recordType.SetBaseType(ResolveType(recordType.baseType));
- recordScope := recordType.recordScope;
- recordBase := recordType.GetBaseRecord();
- hasPointer := FALSE;
- IF recordBase = NIL THEN numberMethods := 0;
- ELSE
- recordBase.Accept(SELF); numberMethods := recordBase.recordScope.numberMethods;
- END;
- symbol := recordScope.firstSymbol; (* must use the sorted list here, important! *)
- WHILE symbol # NIL DO
- IF (symbol IS SyntaxTree.Procedure) THEN
- procedure := symbol(SyntaxTree.Procedure);
- IF procedure IS SyntaxTree.Operator THEN FixProcedureType(procedure.type(SyntaxTree.ProcedureType)) END;
- super := SemanticChecker.FindSuperProcedure(recordScope, procedure);
- procedure.SetSuper(super);
- IF super # NIL THEN
- procedure.SetAccess(procedure.access+super.access);
- END;
- IF procedure.super # NIL THEN
- procedure.SetMethodNumber(procedure.super.methodNumber)
- ELSE
- procedure.SetMethodNumber(numberMethods);
- INC(numberMethods);
- END;
- END;
- symbol := symbol.nextSymbol;
- END;
- recordScope.SetNumberMethods(numberMethods);
- IF (recordScope.firstProcedure # NIL) OR (recordBase # NIL) & (recordBase.isObject) THEN
- recordType.IsObject(TRUE)
- END;
- IF (recordBase # NIL) & recordBase.hasPointers THEN hasPointer := TRUE END;
- Scope(recordType.recordScope);
- var := recordType.recordScope.firstVariable;
- WHILE var # NIL DO
- hasPointer := hasPointer OR var.type.resolved.hasPointers & ~var.untraced;
- var := var.nextVariable;
- END;
- recordType.SetHasPointers(hasPointer);
- checker.SetCurrentScope(recordType.recordScope);
- checker.ResolveArrayStructure(recordType);
- recordType.SetState(SyntaxTree.Resolved);
- size := system.SizeOf(recordType); (* generate field offsets *)
- IF (recordType.typeDeclaration = NIL) & (recordType.pointerType # NIL) THEN
- pointerType := recordType.pointerType.resolved;
- typeDeclaration := pointerType.typeDeclaration;
- recordType.SetTypeDeclaration(typeDeclaration);
- END;
- END VisitRecordType;
- PROCEDURE VisitProcedureType(procedureType: SyntaxTree.ProcedureType);
- VAR parameter: SyntaxTree.Parameter;
- BEGIN
- IF ~(SyntaxTree.Resolved IN procedureType.state) THEN
- typeFixes.Add(procedureType);
- IF procedureType.isDelegate THEN
- procedureType.SetHasPointers(TRUE);
- END;
- procedureType.SetState(SyntaxTree.Resolved);
- END;
- END VisitProcedureType;
- PROCEDURE FixProcedureType(procedureType: SyntaxTree.ProcedureType);
- VAR parameter: SyntaxTree.Parameter; returnType: SyntaxTree.Type;
- BEGIN
- (* parameter list *)
- parameter := procedureType.firstParameter;
- WHILE(parameter # NIL) DO
- parameter.SetType(ResolveType(parameter.type));
- parameter := parameter.nextParameter;
- END;
- (* return type *)
- returnType := ResolveType(procedureType.returnType);
- procedureType.SetReturnType(ResolveType(returnType));
- IF returnType# NIL THEN
- parameter := SyntaxTree.NewParameter(Basic.invalidPosition,procedureType,Global.ReturnParameterName,SyntaxTree.VarParameter);
- parameter.SetType(returnType);
- parameter.SetState(SyntaxTree.Resolved);
- procedureType.SetReturnParameter(parameter);
- END;
- END FixProcedureType;
- (* a type reference is resolved by replacing it with the respective element of the type list, all other types remain *)
- PROCEDURE ResolveType(type: SyntaxTree.Type): SyntaxTree.Type;
- BEGIN
- IF type = NIL THEN RETURN NIL
- ELSIF (type IS TypeReference) THEN
- type := typeList.GetType(type(TypeReference).nr);
- END;
- IF ~(SyntaxTree.Resolved IN type.state) THEN
- type.Accept(SELF);
- type.SetState(SyntaxTree.Resolved);
- END;
- RETURN type;
- END ResolveType;
- (** resolve all pending types (late resolving).
- - type fixes are resolved at the end of the declaration phase
- - type fixes may imply new type fixes that are also entered at the end of the list
- **)
- PROCEDURE FixTypes;
- VAR p: ANY; prevScope: SyntaxTree.Scope;
- BEGIN
- (*prevScope := currentScope;*)
- p := typeFixes.Get((*currentScope*));
- WHILE p # NIL DO
- ASSERT(p IS SyntaxTree.Type);
- IF p IS SyntaxTree.PointerType THEN
- FixPointerType(p(SyntaxTree.PointerType))
- ELSIF p IS SyntaxTree.ProcedureType THEN
- FixProcedureType(p(SyntaxTree.ProcedureType))
- ELSE
- HALT(100);
- END;
- p := typeFixes.Get((*currentScope*));
- END;
- (*currentScope :=prevScope;*)
- END FixTypes;
- (* scope traversal *)
- PROCEDURE Scope(scope: SyntaxTree.Scope);
- VAR typeDeclaration: SyntaxTree.TypeDeclaration; variable: SyntaxTree.Variable; procedure: SyntaxTree.Procedure;
- BEGIN
- (* type declarations *)
- typeDeclaration := scope.firstTypeDeclaration;
- WHILE(typeDeclaration # NIL) DO
- typeDeclaration.SetDeclaredType(ResolveType(typeDeclaration.declaredType));
- IF ~(typeDeclaration.declaredType IS SyntaxTree.BasicType) THEN
- typeDeclaration.declaredType.SetTypeDeclaration(typeDeclaration);
- END;
- typeDeclaration := typeDeclaration.nextTypeDeclaration;
- END;
- (* variables *)
- variable := scope.firstVariable;
- WHILE(variable # NIL) DO
- variable.SetType(ResolveType(variable.type));
- ASSERT (~(variable.type IS TypeReference));
- ASSERT(~(variable.type.resolved IS TypeReference));
- variable := variable.nextVariable;
- END;
- (* procedures *)
- procedure := scope.firstProcedure;
- WHILE(procedure # NIL) DO
- Scope(procedure.procedureScope);
- procedure.SetType(ResolveType(procedure.type));
- procedure := procedure.nextProcedure;
- END;
- END Scope;
- (* replace all TypeReferences in module by referenced types in typeList *)
- PROCEDURE Resolve(module: SyntaxTree.Module; typeList: IndexToType);
- BEGIN
- SELF.typeList := typeList;
- Scope(module.moduleScope);
- FixTypes;
- module.SetState(SyntaxTree.Resolved);
- END Resolve;
- END Resolver;
- (*
- An Index is the data structure containing a number to be mapped to types via the object TypeToIndex below.
- Used for type enumeration when exporting.
- *)
- Index =POINTER TO RECORD tag: LONGINT END;
- (*
- The TypeToIndex object provides the link between a type and a module and type number. It is the inverse of the IndexToType and is used
- for exporting. It is implemented using a hash table mapping a SyntaxTree.Type to a Index object.
- *)
- TypeToIndex= OBJECT (Basic.HashTable)
- PROCEDURE GetIndex(type: SyntaxTree.Type): LONGINT;
- VAR t:ANY;
- BEGIN
- t := Get(type);
- IF t # NIL THEN RETURN t(Index).tag ELSE RETURN Undef END;
- END GetIndex;
- PROCEDURE PutIndex(type:SyntaxTree.Type; nr: LONGINT);
- VAR t: Index;
- BEGIN
- ASSERT(nr # Undef);
- NEW(t); t.tag := nr; Put(type,t);
- END PutIndex;
- END TypeToIndex;
- Attribute = OBJECT
- VAR
- numberTypes: LONGINT;
- indexToType: IndexToType;
- typeToIndex: TypeToIndex;
- PROCEDURE &Init;
- BEGIN numberTypes := 0; NEW(indexToType,16); NEW(typeToIndex,100);
- END Init;
- END Attribute;
- IndexToAttribute= OBJECT(Basic.List)
- PROCEDURE PutAttribute(nr: LONGINT; attribute: Attribute);
- BEGIN GrowAndSet(nr,attribute);
- END PutAttribute;
- PROCEDURE GetAttribute(nr: LONGINT): Attribute;
- VAR node: ANY; attribute: Attribute;
- BEGIN
- IF Length() <= nr THEN node := NIL ELSE node := Get(nr) END;
- IF node # NIL THEN attribute := node(Attribute)
- ELSE NEW(attribute); PutAttribute(nr,attribute);
- END;
- RETURN attribute
- END GetAttribute;
- END IndexToAttribute;
- BinarySymbolFile*=OBJECT (Formats.SymbolFileFormat)
- VAR file-: Files.File; extension-: Basic.FileName;
- noRedefinition, noModification, noInterfaceCheck: BOOLEAN;
- version: CHAR;
- (** Import - Symbol Table Loader Plugin *)
- PROCEDURE Import(CONST moduleName: ARRAY OF CHAR; importCache: SyntaxTree.ModuleScope): SyntaxTree.Module;
- VAR
- module: SyntaxTree.Module;
- moduleIdentifier,contextIdentifier: SyntaxTree.Identifier;
- moduleScope: SyntaxTree.ModuleScope;
- fileName: Files.FileName;
- R: Streams.Reader;
- tag, i: LONGINT;
- visibility: SET;
- type: SyntaxTree.Type;
- variable: SyntaxTree.Variable;
- constant: SyntaxTree.Constant;
- procedure: SyntaxTree.Procedure;
- procedureType: SyntaxTree.ProcedureType;
- procedureScope: SyntaxTree.ProcedureScope;
- typeDeclaration: SyntaxTree.TypeDeclaration;
- resolver: Resolver;
- allTypes: IndexToType; numberReimports, numberTypes : LONGINT;
- name: SyntaxTree.IdentifierString;
- value: SyntaxTree.Value;
- stamp: LONGINT;
- b: BOOLEAN;
- indexToAttribute: IndexToAttribute;
- predefType: ARRAY sfLastType+1 OF SyntaxTree.Type;
- PROCEDURE NewTypeReference(nr: LONGINT): SyntaxTree.Type;
- VAR typeReference: TypeReference;
- BEGIN
- NEW(typeReference,nr); RETURN typeReference;
- END NewTypeReference;
- (* Imports = {moduleName:RawString} 0X *)
- PROCEDURE Imports;
- VAR moduleName: SyntaxTree.IdentifierString; import: SyntaxTree.Import; importedModule: SyntaxTree.Module; moduleIdentifier,moduleContext: SyntaxTree.Identifier; b: BOOLEAN;
- BEGIN
- R.RawString(moduleName);
- WHILE moduleName # "" DO
- ASSERT(moduleName # "SYSTEM");
- IF TraceImport IN Trace THEN D.Str("import module: "); D.Str(moduleName); D.Ln; END;
- (* as the context is not encoded in the symbol file, we have to deduce it from the filename, this is ugly but necessary
- to keep consistency with old compiler
- *)
- Global.ContextFromName(moduleName,moduleIdentifier,moduleContext);
- import := importCache.ImportByModuleName(moduleIdentifier,moduleContext);
- IF import # NIL THEN
- IF import.module = NIL THEN (* has not yet been imported by parent module *)
- (* adjust import symbol in parent *)
- importedModule := Import(moduleName,importCache);
- import.SetModule(importedModule);
- ELSE
- (* take module from parent *)
- importedModule := import.module;
- END
- ELSE
- importedModule := Import(moduleName,importCache);
- IF importedModule # NIL THEN
- import := SyntaxTree.NewImport(Basic.invalidPosition,importedModule.name,importedModule.name,FALSE);
- import.SetContext(importedModule.context);
- import.SetModule(importedModule);
- import.SetState(SyntaxTree.Resolved);
- importCache.AddImport(import);
- END;
- END;
- (* create new import symbol for this module scope *)
- IF importedModule # NIL THEN
- import := SyntaxTree.NewImport(Basic.invalidPosition,moduleIdentifier,moduleIdentifier,TRUE);
- import.SetModule(importedModule);
- import.SetContext(moduleContext);
- import.SetState(SyntaxTree.Resolved);
- module.moduleScope.AddImport(import);
- module.moduleScope.EnterSymbol(import,b);
- END;
- R.RawString(moduleName);
- END
- END Imports;
- (* Value = [ RawNum | RawHInt | RawReal | RawLReal | RawString ] *)
- PROCEDURE Value(type: SyntaxTree.Type): SyntaxTree.Value;
- VAR i: LONGINT; huge: HUGEINT; r: REAL; lr: LONGREAL; string: SyntaxTree.String; length: LONGINT; set: SET;
- value: SyntaxTree.Value; size: LONGINT;
- BEGIN
- size := type.sizeInBits;
- IF type IS SyntaxTree.BooleanType THEN R.RawNum(i);
- IF TraceImport IN Trace THEN D.Str("InConst / Bool / "); D.Int(i,1); D.Ln; END;
- IF i = 0 THEN value := Global.NewBooleanValue(system,Basic.invalidPosition,FALSE) ELSE value := Global.NewBooleanValue(system,Basic.invalidPosition,TRUE) END
- ELSIF (type IS SyntaxTree.CharacterType) THEN
- IF (size=8) OR (size=16) OR (size=32) THEN
- R.RawNum(i);
- IF TraceImport IN Trace THEN D.Str("InConst / Char / "); D.Int(i,1); D.Ln; END;
- value := SyntaxTree.NewCharacterValue(Basic.invalidPosition,CHR(i));
- END;
- ELSIF type IS SyntaxTree.IntegerType THEN
- IF (size = 32) & ~type(SyntaxTree.IntegerType).signed THEN
- R.RawHInt(huge);
- IF TraceImport IN Trace THEN D.Str("InConst / Unsigned32 / "); D.Ln END;
- value := SyntaxTree.NewIntegerValue (Basic.invalidPosition,huge);
- ELSIF size <=32 THEN
- R.RawNum(i);
- IF TraceImport IN Trace THEN D.Str("InConst / Int"); D.Int(size,1); D.String(" "); D.Int(i,1); D.Ln END;
- value := SyntaxTree.NewIntegerValue(Basic.invalidPosition,i);
- ELSIF size=64 THEN
- R.RawHInt(huge);
- IF TraceImport IN Trace THEN D.Str("InConst / HInt / "); D.Ln END;
- value := SyntaxTree.NewIntegerValue (Basic.invalidPosition,huge);
- END;
- ELSIF type IS SyntaxTree.SetType THEN R.RawNum(SYSTEM.VAL(LONGINT, set));
- IF TraceImport IN Trace THEN D.Str("InConst / Set / "); D.Hex(SYSTEM.VAL(LONGINT, set),1); D.Ln END;
- value := SyntaxTree.NewSetValue(Basic.invalidPosition,set);
- ELSIF type IS SyntaxTree.FloatType THEN
- IF size = 32 THEN
- R.RawReal(r);
- IF TraceImport IN Trace THEN D.Str("InConst / Real / "); D.Ln END;
- value := SyntaxTree.NewRealValue(Basic.invalidPosition,r);
- ELSIF size = 64 THEN
- R.RawLReal(lr);
- IF TraceImport IN Trace THEN D.Str("InConst / LongReal / "); D.Ln END;
- value := SyntaxTree.NewRealValue(Basic.invalidPosition,lr);
- END;
- ELSIF type IS SyntaxTree.StringType THEN
- IF version <= FileVersionOC THEN NEW(string, 256)
- ELSE R.RawLInt(length); NEW(string, length)
- END;
- R.RawString(string^);
- IF TraceImport IN Trace THEN D.Str("InConst / String / "); D.Str(string^); D.Ln END;
- value := SyntaxTree.NewStringValue(Basic.invalidPosition,string);
- type(SyntaxTree.StringType).SetLength(value(SyntaxTree.StringValue).length);
- type.SetState(SyntaxTree.Resolved);
- ELSIF type IS SyntaxTree.EnumerationType THEN R.RawNum(i);
- IF TraceImport IN Trace THEN D.Str("InConst / LInt / "); D.Int(i,1); D.Ln END;
- value := SyntaxTree.NewEnumerationValue(Basic.invalidPosition,i);
- ELSIF type IS SyntaxTree.NilType THEN
- IF TraceImport IN Trace THEN D.Str("InConst / Nil"); D.Ln END;
- value := SyntaxTree.NewNilValue(Basic.invalidPosition);
- END;
- value.SetType(type);
- value.SetState(SyntaxTree.Resolved);
- RETURN value
- END Value;
- (* EnumerationList = {name:RawString} sfEnd *)
- PROCEDURE EnumerationList(enumerationScope: SyntaxTree.EnumerationScope);
- VAR enumerator: SyntaxTree.Constant; visibility,flags: SET; b: BOOLEAN;
- type: SyntaxTree.Type; name: SyntaxTree.IdentifierString; identifier: SyntaxTree.Identifier;
- BEGIN
- R.RawString(name);
- WHILE name # "" DO
- identifier := SyntaxTree.NewIdentifier(name);
- enumerator := SyntaxTree.NewConstant(Basic.invalidPosition,identifier);
- enumerationScope.AddConstant(enumerator);
- enumerationScope.EnterSymbol(enumerator,b);
- IF name # "@" THEN enumerationScope.lastConstant.SetAccess(SyntaxTree.Public+SyntaxTree.Internal+SyntaxTree.Protected)
- ELSE enumerationScope.lastConstant.SetAccess(SyntaxTree.Internal)
- END;
- value := Value(enumerationScope.ownerEnumeration);
- enumerator.SetValue(value);
- enumerator.SetType(enumerationScope.ownerEnumeration);
- R.RawString(name);
- END;
- END EnumerationList;
- (* ParameterList = { [sfObjflag ( sfCParam | sfDarwinCParam | sfWinAPIParam )] [sfVar] [sfReadOnly] Type name:RawString } sfEnd *)
- PROCEDURE ParameterList(VAR callingConvention: LONGINT; parentScope: SyntaxTree.Scope; procedureType: SyntaxTree.ProcedureType);
- VAR name: SyntaxTree.IdentifierString; type: SyntaxTree.Type; f: LONGINT;
- kind: LONGINT;
- parameter: SyntaxTree.Parameter;
- BEGIN
- IF TraceImport IN Trace THEN
- D.Str("ParameterList "); D.Ln
- END;
- callingConvention := SyntaxTree.OberonCallingConvention;
- R.RawNum(tag);
- WHILE tag#sfEnd DO
- IF tag = sfObjFlag THEN (*! the calling convention should not be expressed via the parameters (compatiblity with old compiler) *)
- R.RawNum(f);
- IF f = sfCParam THEN (* fof for Linux *)
- callingConvention := SyntaxTree.CCallingConvention
- ELSIF f = sfDarwinCParam THEN (* fld for darwin *)
- callingConvention := SyntaxTree.DarwinCCallingConvention
- ELSIF f=sfWinAPIParam THEN
- callingConvention := SyntaxTree.WinAPICallingConvention
- ELSE HALT(100)
- END;
- R.RawNum(tag);
- END;
- IF tag=sfVar THEN
- R.RawNum(tag);
- kind := SyntaxTree.VarParameter;
- ELSE
- kind := SyntaxTree.ValueParameter;
- END;
- IF tag = sfReadOnly THEN (* var const *)
- R.RawNum(tag);
- kind := SyntaxTree.ConstParameter;
- END;
- type := Type();
- R.RawString(name);
- parameter := SyntaxTree.NewParameter(Basic.invalidPosition,procedureType,SyntaxTree.NewIdentifier(name),kind);
- parameter.SetType(type);
- parameter.SetState(SyntaxTree.Resolved);
- (*! remove this after a rebuild of the release - for compatibility only *)
- IF (parameter.name=Global.SelfParameterName)
- OR (parameter.name=Global.ReturnParameterName)
- OR (parameter.name=Global.PointerReturnName)
- OR (parameter.name=Global.ResultName) THEN (* ignore *)
- ELSE
- procedureType.AddParameter(parameter);
- END;
- R.RawNum(tag)
- END;
- IF callingConvention # SyntaxTree.OberonCallingConvention THEN
- procedureType.RevertParameters;
- END;
- END ParameterList;
- (* returns the index of module importedModule in the list of module module *)
- PROCEDURE ModuleByIndex(module: SyntaxTree.Module; index: LONGINT): SyntaxTree.Module;
- VAR import: SyntaxTree.Import;
- BEGIN import := module.moduleScope.firstImport;
- WHILE (import # NIL) & (index > 0) DO
- IF (* (import.direct) & *) ~Global.IsSystemModule(import.module) THEN DEC(index) END;
- import := import.nextImport;
- END;
- ASSERT(import # NIL);
- (* ASSERT(import.direct); *)
- RETURN import.module;
- END ModuleByIndex;
- (*
- Record =
- mode:RawNum priority:Char {variable:Symbol}
- [sfTProcedure {Symbol [name:RawString] ParameterList [sfInline Inline]} ]
- sfEnd
- *)
- PROCEDURE Record(recordType: SyntaxTree.RecordType; baseType: SyntaxTree.Type);
- VAR
- mode: SET;
- priority: LONGINT;
- visibility: SET;
- active, safe, isOperator, isDynamic, isFictive: BOOLEAN;
- untraced, realtime, constructor: BOOLEAN;
- fOffset: LONGINT;
- variable: SyntaxTree.Variable;
- procedure: SyntaxTree.Procedure;
- operator: SyntaxTree.Operator;
- procedureType: SyntaxTree.ProcedureType;
- recordScope: SyntaxTree.RecordScope;
- recordBody: SyntaxTree.Body;
- name: SyntaxTree.IdentifierString;
- ch: CHAR;
- callingConvention: LONGINT;
- BEGIN
- recordScope := recordType.recordScope;
- R.RawNum(SYSTEM.VAL(LONGINT, mode));
- IF sfActive IN mode THEN active := TRUE ELSE active := FALSE END;
- IF sfProtected IN mode THEN recordType.SetProtected(TRUE) END;
- IF sfSafe IN mode THEN safe := TRUE ELSE safe := FALSE END;
- R.Char(ch);
- priority := ORD(ch); (* body priority, if active object *)
- IF TraceImport IN Trace THEN
- D.Str("Rec / Mode / "); D.Hex(SYSTEM.VAL(LONGINT, mode),1); D.Ln;
- D.Str("Rec / Prio / "); D.Int(priority,1); D.Ln
- END;
- R.RawNum(tag);
- WHILE (tag < sfTProcedure) OR (tag > sfEnd) DO (*read fields*)
- isOperator := FALSE;
- Symbol(recordScope,type,name,visibility,untraced, realtime, constructor, isOperator, isDynamic, isFictive, fOffset);
- ASSERT(type # NIL);
- IF name = "" THEN visibility := SyntaxTree.Internal END;
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- variable.SetType(type);
- variable.SetUntraced(untraced);
- variable.SetAccess(visibility);
- IF isFictive THEN
- TRACE(fOffset);
- variable.SetFictive(fOffset);
- variable.SetUntraced(TRUE);
- END;
- variable.SetState(SyntaxTree.Resolved);
- recordScope.AddVariable(variable);
- recordScope.EnterSymbol(variable,b);
- R.RawNum(tag);
- END;
- IF tag=sfTProcedure THEN
- R.RawNum(tag);
- WHILE tag#sfEnd DO
- isOperator := FALSE;
- Symbol(recordScope,type,name, visibility,untraced, realtime, constructor, isOperator, isDynamic, isFictive, fOffset);
- IF name = "" THEN R.RawString(name) END;
- procedureScope := SyntaxTree.NewProcedureScope(recordScope);
- IF isOperator THEN
- operator := SyntaxTree.NewOperator(Basic.invalidPosition,SyntaxTree.NewIdentifier(name),procedureScope);
- procedure := operator
- ELSE
- procedure := SyntaxTree.NewProcedure(Basic.invalidPosition,SyntaxTree.NewIdentifier(name),procedureScope);
- END;
- procedureType := SyntaxTree.NewProcedureType(Basic.invalidPosition,recordScope);
- procedureType.SetReturnType(type);
- procedureType.SetRealtime(realtime);
- procedure.SetConstructor(constructor);
- procedureType.SetDelegate(TRUE);
- procedure.SetType(procedureType);
- procedure.SetAccess(visibility);
- procedure.SetState(SyntaxTree.Resolved);
- IF constructor THEN
- recordScope.SetConstructor(procedure); (*! redundant *)
- END;
- ParameterList(callingConvention,procedureScope,procedureType);
- recordScope.AddProcedure(procedure);
- IF isOperator THEN
- recordScope.AddOperator(operator);
- END;
- recordScope.EnterSymbol(procedure,b);
- (* This identifies a inlined Indexer *)
- R.RawNum(tag);
- IF tag = sfInline THEN
- Inline(procedureScope);
- (*
- INCL(flag, SyntaxTree.Inline);
- INCL(flag, SyntaxTree.Indexer);
- INCL(flag, SyntaxTree.Operator);
- mscope.code := Inline();
- *)
- R.RawNum(tag)
- END;
- IF (procedure.name=Global.RecordBodyName) THEN
- recordScope.SetBodyProcedure(procedure);
- recordBody := SyntaxTree.NewBody(Basic.invalidPosition,procedureScope);
- recordBody.SetSafe(safe);
- recordBody.SetActive(active);
- procedureScope.SetBody(recordBody);
- END;
- END
- ELSE ASSERT(tag = sfEnd);
- END;
- (*
- ASSERT((bodyFlags = {}) OR (recordScope.bodyProcedure # NIL));
- *)
- recordType.SetBaseType(baseType);
- END Record;
- (*
- Type =
- TypeReference
- |BasicType
- |ImportedType
- |UserType.
- TypeReference = number:RawNum(<0)
- BasicType = sfTypeBoolean | .. | sfLastType.
- ImportedType = ModuleNumber (structName:RawString | 0X typeIndex:RawNum)
- ModuleNumber = sfMod1 | .. | sfModOther-1 | sfModOther moduleNumber:RawNum
- UserType = [sfInvisible] [sfSysFlag sysFlag:RawNum] UserType2
- UserType2=
- sfTypeOpenArray baseType:Type name:RawString flags:RawNum
- |sfTypeStaticArray baseType:Type name:RawString flags:RawNum length:RawNum
- |sfOpenMathArray baseType:Type name:RawString
- |sfStaticMathArray baseType:Type name:RawString length:RawNum
- |sfTypeTensor baseType:Type name:RawString
- |sfTypePointer baseType:Type name:RawString flags:RawNum
- |sfTypeRecord baseType:Type name:RawString flags:RawNum Record
- |sfTypeProcedure baseType:Type name:RawString flags:RawNum ParameterList
- |sfTypeEnumeration enumerationBase:Type name:RawString
- *)
- PROCEDURE Type(): SyntaxTree.Type;
- VAR
- typtag,len: LONGINT;
- name: SyntaxTree.IdentifierString;
- type, baseType: SyntaxTree.Type;
- typeDeclaration: SyntaxTree.TypeDeclaration;
- arrayType: SyntaxTree.ArrayType;
- mathArrayType: SyntaxTree.MathArrayType;
- pointerType: SyntaxTree.PointerType;
- procedureType: SyntaxTree.ProcedureType;
- recordType: SyntaxTree.RecordType;
- recordScope: SyntaxTree.RecordScope;
- qualifiedType: SyntaxTree.QualifiedType;
- enumerationScope: SyntaxTree.EnumerationScope;
- enumerationType: SyntaxTree.EnumerationType;
- (*import: SyntaxTree.Import;*)
- importedModule: SyntaxTree.Module;
- identifier: SyntaxTree.Identifier;
- thisIndex : LONGINT;
- typeAdr: LONGINT;
- size: SyntaxTree.Value;
- visibility: SET;
- typeName: SyntaxTree.IdentifierString;
- sysflag: LONGINT; flags: SET;
- attribute: Attribute;
- callingConvention: LONGINT;
- BEGIN
- visibility := SyntaxTree.Public + SyntaxTree.Protected + SyntaxTree.Internal; flags := {};
- IF tag <= 0 THEN (* TypeReference = number:RawNum(<0) *)
- type := NewTypeReference(-tag);
- IF TraceImport IN Trace THEN
- D.Str("Type / OldStr "); D.Int(-tag,1); D.Ln
- END
- ELSIF tag = sfTypeString THEN
- type := SyntaxTree.NewStringType(Basic.invalidPosition,system.characterType,0);
- IF TraceImport IN Trace THEN
- D.Str("Type / String "); D.Int(tag,1); D.Ln
- END
- ELSIF tag <= sfLastType THEN (* BasicType = sfTypeBoolean | .. | sfLastType. *)
- type := predefType[tag];
- ASSERT((tag = sfTypeNoType) OR (type # NIL));
- IF TraceImport IN Trace THEN
- D.Str("Type / Basic "); D.Int(tag,1); D.Ln
- END
- ELSIF tag = sfTypeRange THEN
- type := system.rangeType;
- ELSIF tag = sfTypeComplex THEN
- type := system.complexType;
- ELSIF tag = sfTypeLongcomplex THEN
- type := system.longcomplexType;
- ELSIF tag <= sfModOther THEN
- (* ImportedType = ModuleNumber (structName:RawString | 0X typeIndex:RawNum) *)
- (* ModuleNumber = sfMod1 | .. | sfModOther-1 | sfModOther moduleNumber:RawNum *)
- IF tag = sfModOther THEN
- R.RawNum(tag);
- ASSERT(tag >= 0);
- ELSE
- tag := tag-sfMod1
- END; (*tag = [0 .. +oo[ *)
- importedModule := ModuleByIndex(module,tag);
- ASSERT(importedModule # NIL);
- R.RawString(typeName);
- type := NIL;
- attribute := indexToAttribute.GetAttribute(tag);
- IF typeName # "" THEN (* first import of struct *)
- identifier := SyntaxTree.NewIdentifier(typeName);
- typeDeclaration := importedModule.moduleScope.FindTypeDeclaration(identifier); (* find type in module *)
- IF (typeDeclaration # NIL) THEN
- qualifiedType := SyntaxTree.NewQualifiedType(Basic.invalidPosition,moduleScope,SyntaxTree.NewQualifiedIdentifier(Basic.invalidPosition,importedModule.name,identifier));
- qualifiedType.SetResolved(typeDeclaration.declaredType);
- qualifiedType.SetTypeDeclaration(typeDeclaration);
- type := qualifiedType;
- END;
- (* add reimport *)
- attribute.indexToType.PutType(attribute.numberTypes,type);
- INC(attribute.numberTypes);
- IF TraceImport IN Trace THEN
- D.Str("Type / Reimport "); D.Str(typeName); D.Str(" in "); D.Str0(importedModule.name); D.Str(":"); D.Int(tag,1-sfMod1); D.Ln;
- END;
- ELSE
- R.RawNum(typeAdr);
- type := attribute.indexToType.GetType(typeAdr);
- IF TraceImport IN Trace THEN
- D.Str("Type / Reimport "); D.Int(typeAdr,1); D.Str(" in "); D.Str0(importedModule.name); D.Str(":"); D.Int(tag,1-sfMod1); D.Ln;
- END;
- END;
- ELSE (* UserType = [sfInvisible] [sfSysFlag flag] UserType2 *)
- IF TraceImport IN Trace THEN
- D.Str("Type / User "); D.Str(name); D.Ln
- END;
- thisIndex := numberTypes; INC(numberTypes);
- IF tag = sfInvisible THEN visibility := SyntaxTree.Internal; R.RawNum(tag) END;
- IF tag = sfHidden THEN visibility := SyntaxTree.Hidden; R.RawNum(tag) END;
- IF tag = sfSysFlag THEN R.RawNum(sysflag); R.RawNum(tag) END;
- (* UserType2 *)
- typtag := tag;
- R.RawNum(tag);
- baseType := Type();
- R.RawString(name);
- CASE typtag OF
- | sfTypeOpenArray:
- IF TraceImport IN Trace THEN
- D.Str("Type / User / OpenArr "); D.Str(name); D.Ln
- END;
- ASSERT(baseType # NIL);
- arrayType := SyntaxTree.NewArrayType(Basic.invalidPosition,moduleScope,SyntaxTree.Open);
- arrayType.SetArrayBase(baseType);
- type := arrayType;
- R.RawNum(SYSTEM.VAL(LONGINT,flags));
- IF sfRealtime IN flags THEN type.SetRealtime(TRUE) END;
- | sfTypeStaticArray:
- IF TraceImport IN Trace THEN
- D.Str("Type / User / Array ");
- D.Int(len,1); D.Str(name); D.Ln
- END;
- ASSERT(baseType # NIL);
- arrayType :=SyntaxTree.NewArrayType(Basic.invalidPosition,moduleScope,SyntaxTree.Static);
- arrayType.SetArrayBase(baseType);
- type := arrayType;
- R.RawNum(SYSTEM.VAL(LONGINT,flags));
- IF sfRealtime IN flags THEN type.SetRealtime(TRUE) END;
- R.RawNum(len);
- size := SyntaxTree.NewIntegerValue(Basic.invalidPosition,len);
- size.SetType(system.longintType);
- arrayType.SetLength(size);
- | sfTypeOpenMathArray:
- IF TraceImport IN Trace THEN
- D.Str("Type / User / MathArray (open) "); D.Str(name); D.Ln
- END;
- ASSERT(baseType # NIL);
- mathArrayType := SyntaxTree.NewMathArrayType(Basic.invalidPosition,moduleScope,SyntaxTree.Open);
- mathArrayType.SetArrayBase(baseType);
- type := mathArrayType;
- R.RawNum(SYSTEM.VAL(LONGINT,flags));
- IF sfRealtime IN flags THEN type.SetRealtime(TRUE) END;
- | sfTypeTensor:
- IF TraceImport IN Trace THEN
- D.Str("Type / User / Tensor "); D.Str(name); D.Ln
- END;
- mathArrayType := SyntaxTree.NewMathArrayType(Basic.invalidPosition,moduleScope,SyntaxTree.Tensor);
- mathArrayType.SetArrayBase(baseType);
- type := mathArrayType;
- R.RawNum(SYSTEM.VAL(LONGINT,flags));
- IF sfRealtime IN flags THEN type.SetRealtime(TRUE) END;
- | sfTypeStaticMathArray:
- IF TraceImport IN Trace THEN
- D.Str("Type / User / MathArray (Static) ");
- D.Int(len,1); D.Str(name); D.Ln
- END;
- ASSERT(baseType # NIL);
- mathArrayType :=SyntaxTree.NewMathArrayType(Basic.invalidPosition,moduleScope,SyntaxTree.Static);
- mathArrayType.SetArrayBase(baseType);
- type := mathArrayType;
- R.RawNum(SYSTEM.VAL(LONGINT,flags));
- IF sfRealtime IN flags THEN type.SetRealtime(TRUE) END;
- R.RawNum(len);
- size := SyntaxTree.NewIntegerValue(Basic.invalidPosition,len);
- size.SetType(system.longintType);
- mathArrayType.SetLength(size);
- | sfTypePointer:
- IF TraceImport IN Trace THEN
- D.Str("Type / User / Pointer "); D.Str(name); D.Ln
- END;
- pointerType := SyntaxTree.NewPointerType(Basic.invalidPosition,moduleScope);
- type := pointerType;
- pointerType.SetPointerBase(baseType);
- R.RawNum(SYSTEM.VAL(LONGINT,flags));
- WITH type: SyntaxTree.PointerType DO
- IF sfUnsafe IN flags THEN type.SetUnsafe(TRUE) END;
- IF sfRealtime IN flags THEN type.SetRealtime(TRUE) END;
- IF sfDisposable IN flags THEN type.SetDisposable(TRUE) END;
- END;
- | sfTypeRecord:
- IF TraceImport IN Trace THEN
- D.Str("Type / User / Record "); D.Str(name); D.Ln
- END;
- recordScope := SyntaxTree.NewRecordScope(moduleScope);
- recordType := SyntaxTree.NewRecordType(Basic.invalidPosition,moduleScope,recordScope);
- type := recordType;
- R.RawNum(SYSTEM.VAL(LONGINT,flags));
- IF sfRealtime IN flags THEN type.SetRealtime(TRUE) END;
- Record(recordType,baseType);
- | sfTypeProcedure:
- IF TraceImport IN Trace THEN
- D.Str("Type / User / Proc "); D.Str(name); D.Ln
- END;
- procedureScope := SyntaxTree.NewProcedureScope(NIL);
- procedureType := SyntaxTree.NewProcedureType(Basic.invalidPosition,moduleScope);
- procedureType.SetReturnType(baseType);
- type := procedureType;
- IF sysflag = sfDelegate THEN procedureType.SetDelegate(TRUE) END;
- R.RawNum(SYSTEM.VAL(LONGINT,flags));
- IF sfWinAPIParam IN flags THEN procedureType.SetCallingConvention(SyntaxTree.WinAPICallingConvention)
- ELSIF sfCParam IN flags THEN procedureType.SetCallingConvention(SyntaxTree.CCallingConvention)
- ELSIF sfDarwinCParam IN flags THEN procedureType.SetCallingConvention(SyntaxTree.DarwinCCallingConvention)
- END;
- IF sfRealtime IN flags THEN procedureType.SetRealtime(TRUE) END;
- ParameterList(callingConvention,procedureScope,procedureType);
- | sfTypeEnumeration:
- IF TraceImport IN Trace THEN
- D.Str("Type / User / Enumerator "); D.Str(name); D.Ln
- END;
- enumerationScope := SyntaxTree.NewEnumerationScope(moduleScope);
- enumerationType := SyntaxTree.NewEnumerationType(Basic.invalidPosition,moduleScope,enumerationScope);
- type := enumerationType;
- enumerationType.SetEnumerationBase(baseType);
- EnumerationList(enumerationScope);
- END;
- IF name # "" THEN
- typeDeclaration := SyntaxTree.NewTypeDeclaration(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- typeDeclaration.SetDeclaredType(type);
- type.SetTypeDeclaration(typeDeclaration);
- typeDeclaration.SetAccess(visibility);
- typeDeclaration.SetState(SyntaxTree.Resolved);
- qualifiedType := SyntaxTree.NewQualifiedType(Basic.invalidPosition,moduleScope, SyntaxTree.NewQualifiedIdentifier(Basic.invalidPosition,SyntaxTree.invalidIdentifier,typeDeclaration.name));
- qualifiedType.SetResolved(type);
- type := qualifiedType;
- type.SetTypeDeclaration(typeDeclaration);
- module.moduleScope.AddTypeDeclaration(typeDeclaration); (* do not replace module.moduleScope by parentScope ! *)
- module.moduleScope.EnterSymbol(typeDeclaration,b);
- END;
- allTypes.PutType(thisIndex,type);
- IF TraceImport IN Trace THEN
- D.Str("resolver.AddType "); D.Str(name); D.Str(" "); D.Int(thisIndex,1); D.Str("");
- D.Ln
- END;
- END;
- RETURN type;
- END Type;
- (*
- Inline = {len:Char {c:Char}} 0X
- *)
- PROCEDURE Inline(scope: SyntaxTree.ProcedureScope);
- VAR ch: CHAR; pos, len: LONGINT; array: SyntaxTree.BinaryCode; newcode: SyntaxTree.Code;
- body: SyntaxTree.Body;
- PROCEDURE Append(ch: CHAR);
- BEGIN
- array.Resize(pos+8);
- array.SetBits(pos,8,ORD(ch));
- INC(pos,8);
- END Append;
- BEGIN
- NEW(array,128*8);
- R.Char(ch);pos := 0;
- REPEAT
- len := ORD(ch);
- WHILE len > 0 DO R.Char(ch); Append(ch); DEC(len) END;
- R.Char(ch);
- UNTIL ch = 0X;
- body := SyntaxTree.NewBody(Basic.invalidPosition,scope);
- newcode := SyntaxTree.NewCode(Basic.invalidPosition,body);
- body.SetCode(newcode);
- scope.SetBody(body);
- newcode.SetBinaryCode(array);
- END Inline;
- (* Symbol = [sfObjFlag flag:RawNum] [sfReadOnly] Type name:RawString *)
- PROCEDURE Symbol(parentScope: SyntaxTree.Scope; VAR type: SyntaxTree.Type; VAR name: SyntaxTree.IdentifierString; VAR visibility: SET; VAR untraced, realtime, constructor, operator, isDynamic, isFictive: BOOLEAN; VAR fictiveOffset: LONGINT);
- VAR f,i: LONGINT;
- BEGIN
- IF TraceImport IN Trace THEN
- D.Str("Symbol: --> "); D.Ln
- END;
- untraced := FALSE; realtime := FALSE; constructor := FALSE; isDynamic := FALSE; isFictive := FALSE;
- visibility:=SyntaxTree.Public+SyntaxTree.Protected+SyntaxTree.Internal;
- WHILE tag=sfObjFlag DO
- R.RawNum(f);
- IF f = sfFictive THEN isFictive := TRUE; untraced := TRUE; TRACE(fictiveOffset); R.RawNum(fictiveOffset);
- ELSIF f = sfUntraced THEN untraced := TRUE
- ELSIF f = sfRealtime THEN realtime := TRUE
- ELSIF f = sfOperator THEN operator := TRUE;
- ELSIF f = sfDynamic THEN isDynamic := TRUE;
- ELSE D.Str("Object: unknown objflag"); D.Ln
- END;
- R.RawNum(tag);
- END;
- IF tag=sfReadOnly THEN visibility := visibility * SyntaxTree.ReadOnly; R.RawNum(tag) END;
- type := Type();
- R.RawString(name);
- IF ~operator & (name[0] = "&") THEN
- constructor := TRUE;
- i := 0; REPEAT name[i] := name[i+1]; INC(i) UNTIL name[i] = 0X;
- END;
- IF name = "" THEN
- visibility := visibility * SyntaxTree.Internal;
- END;
- IF TraceImport IN Trace THEN
- D.Str("<-- "); D.Str(name); D.Ln
- END;
- END Symbol;
- (*
- SymbolFile =
- coeOptions:RawSet
- Imports
- [sfSysFlag sysFlags:Number]
- [sfConst {Symbol Value}]
- [sfVar {Symbol}]
- [sfXProcedure {Symbol ParameterList}]
- [sfOperator {Symbol ParameterList [sfInline Inline]}]
- [sfCProcedure {Symbol ParameterList Inline}]
- [sfAlias {Type name:RawString}]
- [sfType {Type}]
- sfEnd
- *)
- PROCEDURE Module;
- VAR flags: SET; untraced, realtime, constructor,operator, isDynamic, isFictive: BOOLEAN; callingConvention: LONGINT; fOffset: LONGINT;
- BEGIN
- R.RawSet(flags);
- Imports;
- R.RawNum(tag);
- flags := {};
- IF tag = sfSysFlag THEN
- R.RawNum(SYSTEM.VAL(LONGINT, flags));
- R.RawNum(tag);
- END;
- IF TraceImport IN Trace THEN D.Str("importing constants"); D.Ln; END;
- IF tag=sfConst THEN R.RawNum(tag);
- WHILE (tag < sfVar) OR (tag > sfEnd) DO
- operator := FALSE;
- Symbol(moduleScope,type,name, visibility,untraced,realtime,constructor,operator, isDynamic, isFictive, fOffset);
- ASSERT(type # NIL);
- value := Value(type);
- constant := SyntaxTree.NewConstant(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- constant.SetValue(value);
- constant.SetType(value.type);
- constant.SetAccess(visibility);
- constant.SetState(SyntaxTree.Resolved);
- moduleScope.AddConstant(constant);
- moduleScope.EnterSymbol(constant,b);
- R.RawNum(tag)
- END
- END;
- IF TraceImport IN Trace THEN D.Str("importing variables"); D.Ln; END;
- IF tag=sfVar THEN R.RawNum(tag);
- WHILE (tag < sfXProcedure) OR (tag > sfEnd) DO
- operator := FALSE;
- Symbol(moduleScope,type,name, visibility,untraced,realtime,constructor,operator, isDynamic,isFictive, fOffset);
- ASSERT(type # NIL);
- variable := SyntaxTree.NewVariable(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- variable.SetType(type);
- variable.SetAccess(visibility);
- variable.SetState(SyntaxTree.Resolved);
- IF isFictive THEN
- TRACE(fOffset);
- variable.SetFictive(fOffset);
- variable.SetUntraced(TRUE);
- END;
- moduleScope.AddVariable(variable);
- moduleScope.EnterSymbol(variable,b);
- R.RawNum(tag)
- END
- END;
- IF TraceImport IN Trace THEN D.Str("importing procedures"); D.Ln; END;
- IF tag=sfXProcedure THEN R.RawNum(tag);
- WHILE (tag < sfOperator) OR (tag > sfEnd) DO
- operator := FALSE;
- Symbol(moduleScope,type,name, visibility,untraced,realtime,constructor,operator, isDynamic, isFictive, fOffset);
- ASSERT(~(constructor));
- procedureScope := SyntaxTree.NewProcedureScope(moduleScope);
- procedureType := SyntaxTree.NewProcedureType(Basic.invalidPosition,moduleScope);
- procedureType.SetReturnType(type);
- procedure := SyntaxTree.NewProcedure(Basic.invalidPosition,SyntaxTree.NewIdentifier(name),procedureScope);
- procedure.SetType(procedureType);
- procedure.SetAccess(visibility);
- ParameterList(callingConvention,procedureScope,procedureType);
- procedureType.SetRealtime(realtime);
- procedure.SetState(SyntaxTree.Resolved);
- procedure.SetConstructor(constructor);
- moduleScope.AddProcedure(procedure);
- moduleScope.EnterSymbol(procedure,b);
- R.RawNum(tag)
- END
- END;
- IF TraceImport IN Trace THEN D.Str("importing operators"); D.Ln; END;
- IF tag=sfOperator THEN R.RawNum(tag);
- WHILE (tag < sfCProcedure) OR (tag > sfEnd) DO
- operator := TRUE;
- Symbol(moduleScope,type,name, visibility,untraced,realtime,constructor,operator, isDynamic, isFictive, fOffset);
- ASSERT(~(constructor));
- procedureScope := SyntaxTree.NewProcedureScope(moduleScope);
- procedureType := SyntaxTree.NewProcedureType(Basic.invalidPosition,moduleScope);
- procedureType.SetReturnType(type);
- procedureType.SetRealtime(realtime);
- procedure := SyntaxTree.NewOperator(Basic.invalidPosition,SyntaxTree.NewIdentifier(name),procedureScope);
- procedure.SetType(procedureType);
- procedure.SetAccess(visibility);
- procedure(SyntaxTree.Operator).SetDynamic(isDynamic);
- ParameterList(callingConvention,procedureScope,procedureType);
- procedureType.SetCallingConvention(callingConvention);
- procedure.SetState(SyntaxTree.Resolved);
- module.moduleScope.AddProcedure(procedure);
- module.moduleScope.AddOperator(procedure(SyntaxTree.Operator));
- module.moduleScope.EnterSymbol(procedure,b);
- R.RawNum(tag);
- IF tag = sfInline THEN
- Inline(procedureScope);
- procedure.SetInline(TRUE);
- R.RawNum(tag);
- END;
- END
- END;
- IF TraceImport IN Trace THEN D.Str("importing inline procedures"); D.Ln; END;
- IF tag = sfCProcedure THEN R.RawNum(tag);
- WHILE (tag < sfAlias) OR (tag > sfEnd) DO
- operator := FALSE;
- Symbol(moduleScope,type,name, visibility,untraced, realtime, constructor,operator, isDynamic, isFictive, fOffset);
- ASSERT(~(constructor));
- procedureScope := SyntaxTree.NewProcedureScope(moduleScope);
- procedureType := SyntaxTree.NewProcedureType(Basic.invalidPosition,moduleScope);
- procedure := SyntaxTree.NewProcedure(Basic.invalidPosition,SyntaxTree.NewIdentifier(name),procedureScope);
- procedureType.SetReturnType(type);
- procedure.SetInline(TRUE);
- procedure.SetType(procedureType);
- procedure.SetAccess(visibility);
- ParameterList(callingConvention,procedureScope,procedureType);
- procedure.SetState(SyntaxTree.Resolved);
- module.moduleScope.AddProcedure(procedure);
- module.moduleScope.EnterSymbol(procedure,b);
- Inline(procedureScope);
- R.RawNum(tag);
- END
- END;
- IF TraceImport IN Trace THEN D.Str("importing type declaration aliases"); D.Ln; END;
- IF tag=sfAlias THEN R.RawNum(tag);
- WHILE (tag < sfType) OR (tag > sfEnd) DO
- type := Type();
- R.RawString(name);
- IF TraceImport IN Trace THEN D.Str("alias:"); D.Str(name); D.Ln END;
- typeDeclaration := SyntaxTree.NewTypeDeclaration(Basic.invalidPosition,SyntaxTree.NewIdentifier(name));
- typeDeclaration.SetDeclaredType(type);
- visibility := SyntaxTree.Public+SyntaxTree.Protected+SyntaxTree.Internal;
- typeDeclaration.SetAccess(visibility);
- typeDeclaration.SetState(SyntaxTree.Resolved);
- IF ~(type IS SyntaxTree.BasicType) THEN
- type.SetTypeDeclaration(typeDeclaration);
- END;
- module.moduleScope.AddTypeDeclaration(typeDeclaration);
- module.moduleScope.EnterSymbol(typeDeclaration,b);
- R.RawNum(tag)
- END
- END;
- IF TraceImport IN Trace THEN D.Str("importing type declaration"); D.Ln; END;
- IF tag=sfType THEN
- R.RawNum(tag);
- WHILE tag # sfEnd DO
- type := Type();
- R.RawNum(tag)
- END
- END;
- END Module;
- PROCEDURE InitBasic(type: SyntaxTree.Type; tag: LONGINT);
- BEGIN
- predefType[tag] := type;
- END InitBasic;
- PROCEDURE Init;
- BEGIN
- (*Built-In types*)
- InitBasic(system.booleanType,sfTypeBoolean);
- InitBasic(system.characterType,sfTypeChar8);
- InitBasic(Global.Character16,sfTypeChar16);
- InitBasic(Global.Character32,sfTypeChar32);
- InitBasic(system.shortintType, sfTypeShortint);
- InitBasic(system.integerType, sfTypeInteger);
- InitBasic(system.longintType, sfTypeLongint);
- InitBasic(system.hugeintType, sfTypeHugeint);
- InitBasic(Global.Unsigned8, sfTypeUnsigned8);
- InitBasic(Global.Unsigned16, sfTypeUnsigned16);
- InitBasic(Global.Unsigned32, sfTypeUnsigned32);
- InitBasic(Global.Unsigned64, sfTypeUnsigned64);
- InitBasic(Global.Float32, sfTypeReal);
- InitBasic(Global.Float64, sfTypeLongreal);
- InitBasic(system.setType, sfTypeSet);
- InitBasic(system.anyType, sfTypeAny);
- InitBasic(system.objectType, sfTypeObject);
- InitBasic(system.nilType, sfTypeNilType);
- InitBasic(NIL, sfTypeNoType);
- InitBasic(system.byteType, sfTypeByte);
- InitBasic(system.sizeType, sfTypeSize);
- InitBasic(system.addressType, sfTypeAddress);
- END Init;
- BEGIN
- Init;
- i := 0; numberTypes := 0; numberReimports := 0;
- COPY(moduleName,fileName);
- NEW(allTypes,32); NEW(indexToAttribute,32);
- ASSERT(fileName # "SYSTEM");
- IF ~OpenSymFile(fileName, path, extension, R, version) THEN (*! reintroduce flexible extension *)
- RETURN NIL
- END;
- IF TraceImport IN Trace THEN
- D.Str("BINARY SYMBOL FILE IMPORT "); D.Str(moduleName); D.Ln;
- END;
- (* as the context is not encoded in the symbol file, we have to deduce it from the filename, this is ugly but necessary
- to keep consistency with old compiler
- *)
- Global.ContextFromName(moduleName,moduleIdentifier,contextIdentifier);
- moduleScope := SyntaxTree.NewModuleScope();
- module:= SyntaxTree.NewModule(fileName,Basic.invalidPosition,moduleIdentifier,moduleScope,Scanner.Uppercase);
- module.SetContext(contextIdentifier);
- IF importCache = NIL THEN importCache := SyntaxTree.NewModuleScope(); END;
- Module;
- stamp := Kernel.GetTicks();
- NEW(resolver,system,SELF,importCache);
- resolver.Resolve(module,allTypes);
- module.SetState(SyntaxTree.Resolved);
- IF TraceImport IN Trace THEN
- D.Str("BINARY SYMBOL FILE IMPORT DONE "); D.Str(moduleName); D.Ln;
- END;
- (* if import error then module := NIL *)
- RETURN module
- END Import;
- PROCEDURE Export(module: SyntaxTree.Module; importCache: SyntaxTree.ModuleScope): BOOLEAN;
- VAR w: Files.Writer; lookup: TypeToIndex; indexToAttribute: IndexToAttribute; numberType: LONGINT; flags: SET;
- (* Imports = {moduleName:RawString} 0X *)
- PROCEDURE Imports(import: SyntaxTree.Import);
- VAR name: SyntaxTree.IdentifierString;
- BEGIN
- WHILE import # NIL DO
- IF ~Global.IsSystemModule(import.module) THEN
- Global.ModuleFileName(import.module.name,import.module.context,name);
- (*! maybe the context and module name should be stored as different names ? *)
- IF TraceExport IN Trace THEN
- D.Str("import: "); D.Str(name); D.Ln;
- END;
- w.RawString(name);
- END;
- import := import.nextImport;
- END;
- w.RawNum(0); (* end of imports *)
- END Imports;
- (* Value = [RawNum | RawHInt | RawReal | RawLReal | RawString] *)
- PROCEDURE Value(v: SyntaxTree.Value);
- VAR type: SyntaxTree.Type;
- BEGIN
- type := v.type.resolved;
- IF type IS SyntaxTree.BooleanType THEN w.RawNum(SYSTEM.VAL(SHORTINT,v(SyntaxTree.BooleanValue).value))
- ELSIF type IS SyntaxTree.CharacterType THEN w.RawNum(ORD(v(SyntaxTree.CharacterValue).value));
- (*
- ELSIF type = Global.Char16 THEN w.RawNum(ORD(v(SyntaxTree.CharacterValue).value));
- ELSIF type = Global.Char32 THEN w.RawNum(ORD(v(SyntaxTree.CharacterValue).value));
- *)
- ELSIF (type IS SyntaxTree.IntegerType) & (type.sizeInBits = 64) THEN w.RawHInt(v(SyntaxTree.IntegerValue).hvalue);
- ELSIF (type IS SyntaxTree.IntegerType) & (type.sizeInBits = 32) & ~type(SyntaxTree.IntegerType).signed THEN w.RawHInt(v(SyntaxTree.IntegerValue).hvalue);
- ELSIF (type IS SyntaxTree.IntegerType) & (type.sizeInBits <= 32) THEN w.RawNum(v(SyntaxTree.IntegerValue).value);
- ELSIF type IS SyntaxTree.SetType THEN w.RawNum(SYSTEM.VAL(LONGINT,v(SyntaxTree.SetValue).value));
- ELSIF type IS SyntaxTree.FloatType THEN
- IF type.sizeInBits = 32 THEN w.RawReal(SHORT(v(SyntaxTree.RealValue).value));
- ELSE w.RawLReal(v(SyntaxTree.RealValue).value);
- END;
- ELSIF type IS SyntaxTree.StringType THEN w.RawLInt(v(SyntaxTree.StringValue).length); w.RawString(v(SyntaxTree.StringValue).value^);
- ELSIF type IS SyntaxTree.NilType THEN
- ELSIF type IS SyntaxTree.ByteType THEN HALT(100)
- ELSIF type IS SyntaxTree.EnumerationType THEN w.RawNum(v(SyntaxTree.EnumerationValue).value);
- ELSE HALT(200);
- END;
- END Value;
- (*
- Record =
- mode:RawNum priority:Char {variable:Symbol}
- [sfTProcedure {Symbol [name:RawString] ParameterList [sfInline Inline]} ]
- sfEnd
- *)
- PROCEDURE Record(record: SyntaxTree.RecordType);
- VAR scope: SyntaxTree.RecordScope; variable: SyntaxTree.Variable; procedure: SyntaxTree.Procedure; name: SyntaxTree.IdentifierString; flags,mode: SET;
- procedureType: SyntaxTree.ProcedureType; body: SyntaxTree.Body; first: BOOLEAN;
- BEGIN
- scope := record.recordScope;
- IF record.recordScope.bodyProcedure # NIL THEN
- body := record.recordScope.bodyProcedure.procedureScope.body;
- IF body.isActive THEN INCL(mode,sfActive) END;
- IF body.isSafe THEN INCL(mode,sfSafe) END;
- END;
- IF record.IsProtected() THEN INCL(mode,sfProtected) END;
- IF record.pointerType # NIL THEN INCL(mode,sfClass) END;
- w.RawNum(SYSTEM.VAL(LONGINT,mode));
- w.Char(0X); (*! record priority *)
- variable := scope.firstVariable;
- WHILE variable # NIL DO
- ASSERT(variable.type # NIL);
- Symbol(variable.type,variable.name,variable.access,variable.untraced,FALSE, FALSE, FALSE, FALSE, variable.fictive, variable.fictiveOffset);
- variable := variable.nextVariable;
- END;
- procedure := scope.firstProcedure;
- IF procedure # NIL THEN
- w.RawNum(sfTProcedure);
- WHILE procedure # NIL DO
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- IF (procedure.access * SyntaxTree.Internal = procedure.access) THEN (* not exported method *)
- Symbol(procedureType.returnType,procedure.name,procedure.access,FALSE, procedureType.isRealtime,procedure.isConstructor,procedure IS SyntaxTree.Operator, FALSE, FALSE, 0);
- procedure.GetName(name);
- w.RawString(name);
- ELSE (* exported method *)
- Symbol(procedureType.returnType,procedure.name,SyntaxTree.Public (*! for compatiblity should be procedure.access *),
- FALSE, procedureType.isRealtime,procedure.isConstructor, procedure IS SyntaxTree.Operator, FALSE, FALSE, 0
- );
- END;
- ParameterList(procedure.type(SyntaxTree.ProcedureType));
- (*! inline *)
- procedure := procedure.nextProcedure;
- END;
- END;
- w.RawNum(sfEnd);
- END Record;
- (* returns the index of module importedModule in the list of module module *)
- PROCEDURE ModuleIndex(module: SyntaxTree.Module; importedModule: SyntaxTree.Module): LONGINT;
- VAR import: SyntaxTree.Import; index: LONGINT;
- BEGIN import := module.moduleScope.firstImport;
- index := 0;
- WHILE (import # NIL) & (import.module # importedModule) DO
- IF (* (import.direct) & *) ~Global.IsSystemModule(import.module) THEN INC(index) END;
- import := import.nextImport;
- END;
- ASSERT(import # NIL);
- RETURN index;
- END ModuleIndex;
- (*
- Type =
- TypeReference
- |BasicType
- |ImportedType
- |UserType.
- TypeReference = number:RawNum(<0)
- BasicType = sfTypeBoolean | .. | sfLastType.
- ImportedType = ModuleNumber (structName:RawString | 0X typeIndex:RawNum)
- ModuleNumber = sfMod1 | .. | sfModOther-1 | sfModOther moduleNumber:RawNum
- UserType = [sfInvisible] [sfSysFlag sysFlag:RawNum] UserType2
- UserType2=
- sfTypeOpenArray baseType:Type name:RawString flags:RawNum
- |sfTypeStaticArray baseType:Type name:RawString flags:RawNum length:RawNum
- |sfOpenMathArray baseType:Type name:RawString
- |sfStaticMathArray baseType:Type name:RawString length:RawNum
- |sfTypeTensor baseType:Type name:RawString
- |sfTypePointer baseType:Type name:RawString flags:RawNum
- |sfTypeRecord baseType:Type name:RawString flags:RawNum Record
- |sfTypeProcedure baseType:Type name:RawString flags:RawNum ParameterList
- |sfTypeEnumeration enumerationBase:Type name:RawString
- *)
- PROCEDURE Type(type: SyntaxTree.Type);
- VAR typeIndex,moduleIndex: LONGINT; name:SyntaxTree.IdentifierString; importedModule: SyntaxTree.Module; attribute: Attribute;
- baseType: SyntaxTree.Type; typeDeclaration : SyntaxTree.TypeDeclaration; flags: SET; size: LONGINT;
- BEGIN
- IF type = NIL THEN
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / NIL "); D.Ln
- END;
- w.RawNum(sfTypeNoType); RETURN
- END;
- type := type.resolved;
- typeDeclaration := type.typeDeclaration;
- IF (typeDeclaration # NIL) & (typeDeclaration.declaredType.resolved # type) THEN typeDeclaration := NIL END;
- size := type.sizeInBits;
- IF type IS SyntaxTree.BasicType THEN (* BasicType *)
- IF type IS SyntaxTree.BooleanType THEN w.RawNum(sfTypeBoolean);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Boolean "); D.Ln
- END;
- ELSIF type IS SyntaxTree.CharacterType THEN
- IF size = 8 THEN
- w.RawNum(sfTypeChar8);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Char8"); D.Ln
- END;
- ELSIF size = 16 THEN
- w.RawNum(sfTypeChar16);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Char16"); D.Ln
- END;
- ELSIF size = 32 THEN
- w.RawNum(sfTypeChar32);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Char32"); D.Ln
- END;
- END
- ELSIF type IS SyntaxTree.IntegerType THEN
- IF type(SyntaxTree.IntegerType).signed THEN
- IF size = 8 THEN
- w.RawNum(sfTypeShortint);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Shortint"); D.Ln
- END;
- ELSIF size = 16 THEN
- w.RawNum(sfTypeInteger);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Integer"); D.Ln
- END;
- ELSIF size = 32 THEN
- w.RawNum(sfTypeLongint);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Longint"); D.Ln
- END;
- ELSIF size = 64 THEN w.RawNum(sfTypeHugeint);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Hugeint"); D.Ln
- END;
- END;
- ELSE
- IF size = 8 THEN
- w.RawNum(sfTypeUnsigned8);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Unsigned8"); D.Ln
- END;
- ELSIF size = 16 THEN
- w.RawNum(sfTypeUnsigned16);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Unsigned16"); D.Ln
- END;
- ELSIF size = 32 THEN
- w.RawNum(sfTypeUnsigned32);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Unsigned32"); D.Ln
- END;
- ELSIF size = 64 THEN w.RawNum(sfTypeUnsigned64);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Unsigned64"); D.Ln
- END;
- END;
- END;
- ELSIF type IS SyntaxTree.FloatType THEN
- IF size = 32 THEN
- w.RawNum(sfTypeReal);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Real"); D.Ln
- END;
- ELSIF size = 64 THEN
- w.RawNum(sfTypeLongreal);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Longreal"); D.Ln
- END;
- END;
- ELSIF type IS SyntaxTree.ComplexType THEN
- IF size = 64 THEN
- w.RawNum(sfTypeComplex);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Complex"); D.Ln
- END;
- ELSIF size = 128 THEN
- w.RawNum(sfTypeLongcomplex);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Longcomplex"); D.Ln
- END;
- END;
- ELSIF type IS SyntaxTree.SetType THEN
- w.RawNum(sfTypeSet);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Set"); D.Ln
- END;
- ELSIF type IS SyntaxTree.NilType THEN w.RawNum(sfTypeNilType);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / NilType"); D.Ln
- END;
- ELSIF type IS SyntaxTree.AnyType THEN w.RawNum(sfTypeAny);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Any"); D.Ln
- END;
- ELSIF type IS SyntaxTree.ObjectType THEN
- w.RawNum(sfTypeObject);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Object"); D.Ln
- END;
- ELSIF type IS SyntaxTree.ByteType THEN
- w.RawNum(sfTypeByte);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Byte"); D.Ln
- END;
- ELSIF type IS SyntaxTree.RangeType THEN w.RawNum(sfTypeRange);
- IF TraceExport IN Trace THEN
- D.Str("Type / Basic / Range"); D.Ln
- END;
- ELSIF type IS SyntaxTree.AddressType THEN w.RawNum(sfTypeAddress) (*! compatibility with PACO *)
- ELSIF type IS SyntaxTree.SizeType THEN w.RawNum(sfTypeSize)
- ELSE HALT(100)
- END;
- ELSIF type IS SyntaxTree.StringType THEN (* special case BasicType : StringType *)
- IF TraceExport IN Trace THEN
- D.Str("Type / String "); D.Ln
- END;
- w.RawNum(sfTypeString); (*! string length should be written here also *)
- ELSIF (typeDeclaration # NIL) & (typeDeclaration.scope # NIL) & (typeDeclaration.scope.ownerModule # module) THEN (* ImportedType *)
- (* imported, reexport:
- ImportedType = ModuleNumber (structName:RawString | 0X typeIndex:RawNum)
- ModuleNumber = sfMod1 | .. | sfModOther-1 | sfModOther moduleNumber:RawNum
- *)
- typeDeclaration.GetName(name);
- importedModule := typeDeclaration.scope.ownerModule;
- moduleIndex := ModuleIndex(module,importedModule);
- ASSERT(moduleIndex >= 0);
- IF moduleIndex >= sfModOther - sfMod1 THEN w.RawNum(sfModOther); w.RawNum(moduleIndex)
- ELSE w.RawNum(sfMod1 + moduleIndex)
- END;
- attribute := indexToAttribute.GetAttribute(moduleIndex);
- typeIndex := attribute.typeToIndex.GetIndex(type);
- IF TraceExport IN Trace THEN
- D.Str("Type / Reexport "); D.Str(name); D.Str(":"); D.Int(typeIndex,1); D.String(" in "); D.Str0(importedModule.name); D.String(":"); D.Int(moduleIndex,1);D.Ln
- END;
- IF typeIndex = Undef THEN (* not yet written import: structName:RawString *)
- type.typeDeclaration.GetName(name);
- w.RawString(name);
- attribute.typeToIndex.PutIndex(type,attribute.numberTypes); INC(attribute.numberTypes);
- ELSE (* previously written import: 0X typeIndex:RawNum *)
- w.Char(0X); w.RawNum(typeIndex);
- END;
- ELSE
- IF TraceExport IN Trace THEN
- D.Str("Type / User "); D.Ln
- END;
- typeIndex := lookup.GetIndex(type);
- IF typeIndex # Undef THEN (* already written: TypeReference = number:RawNum (<0)*)
- IF TraceExport IN Trace THEN
- D.Str("Type / User / AlreadyWritten "); D.Ln
- END;
- w.RawNum(-typeIndex)
- ELSE (* UserType *)
- IF TraceExport IN Trace THEN D.Str("Type / UserType "); D.Ln END;
- lookup.PutIndex(type,numberType); INC(numberType);
- name:="";
- IF typeDeclaration#NIL THEN typeDeclaration.GetName(name);
- IF typeDeclaration.access = SyntaxTree.Hidden THEN
- w.RawNum(sfHidden);
- ELSIF typeDeclaration.access* SyntaxTree.Public={} THEN
- w.RawNum(sfInvisible);
- END;
- END;
- flags := {};
- IF type IS SyntaxTree.RecordType THEN
- IF TraceExport IN Trace THEN D.Str("Type / UserType / RecordType "); D.Str(name); D.Ln END;
- WITH type: SyntaxTree.RecordType DO
- w.RawNum(sfTypeRecord);
- baseType := type.baseType;
- Type(baseType);
- w.RawString(name);
- IF type.isRealtime THEN INCL(flags,sfRealtime) END;
- w.RawNum(SYSTEM.VAL(LONGINT,flags));
- Record(type)
- END
- ELSIF type IS SyntaxTree.PointerType THEN
- IF TraceExport IN Trace THEN D.Str("Type / UserType / PointerType "); D.Str(name); D.Ln END;
- w.RawNum(sfTypePointer);
- Type(type(SyntaxTree.PointerType).pointerBase);
- w.RawString(name);
- WITH type: SyntaxTree.PointerType DO
- IF type.isUnsafe THEN INCL(flags,sfUnsafe) END;
- IF type.isRealtime THEN INCL(flags,sfRealtime) END;
- IF type.isDisposable THEN INCL(flags,sfDisposable) END;
- END;
- w.RawNum(SYSTEM.VAL(LONGINT,flags));
- ELSIF type IS SyntaxTree.ArrayType THEN
- IF TraceExport IN Trace THEN D.Str("Type / UserType / ArrayType "); D.Str(name); D.Ln END;
- WITH type: SyntaxTree.ArrayType DO
- IF type.form = SyntaxTree.Open THEN
- w.RawNum(sfTypeOpenArray)
- ELSIF type.form = SyntaxTree.Static THEN
- w.RawNum(sfTypeStaticArray)
- ELSE HALT(100)
- END;
- Type(type.arrayBase);
- w.RawString(name);
- IF type.isRealtime THEN INCL(flags,sfRealtime) END;
- w.RawNum(SYSTEM.VAL(LONGINT,flags));
- IF type.form = SyntaxTree.Static THEN
- w.RawNum(type.staticLength);
- END;
- END;
- ELSIF type IS SyntaxTree.MathArrayType THEN
- IF TraceExport IN Trace THEN D.Str("Type / UserType / MathArrayType "); D.Str(name); D.Ln END;
- WITH type: SyntaxTree.MathArrayType DO
- IF type.form = SyntaxTree.Open THEN
- w.RawNum(sfTypeOpenMathArray)
- ELSIF type.form = SyntaxTree.Static THEN
- w.RawNum(sfTypeStaticMathArray)
- ELSIF type.form = SyntaxTree.Tensor THEN
- w.RawNum(sfTypeTensor)
- ELSE HALT(100)
- END;
- Type(type.arrayBase);
- w.RawString(name);
- IF type.isRealtime THEN INCL(flags,sfRealtime) END;
- w.RawNum(SYSTEM.VAL(LONGINT,flags));
- IF type.form = SyntaxTree.Static THEN
- w.RawNum(type.staticLength);
- END;
- END;
- ELSIF type IS SyntaxTree.ProcedureType THEN
- IF TraceExport IN Trace THEN D.Str("Type / UserType / ProcedureType"); D.Str(name); D.Ln END;
- WITH type: SyntaxTree.ProcedureType DO
- IF type.isDelegate THEN
- w.RawNum(sfSysFlag); w.RawNum(sfDelegate);
- END;
- w.RawNum(sfTypeProcedure);
- Type(type.returnType);
- w.RawString(name);
- IF type.callingConvention = SyntaxTree.WinAPICallingConvention THEN
- INCL(flags,sfWinAPIParam);
- ELSIF type.callingConvention = SyntaxTree.CCallingConvention THEN
- INCL(flags,sfCParam);
- ELSIF type.callingConvention = SyntaxTree.DarwinCCallingConvention THEN
- INCL(flags,sfDarwinCParam);
- END;
- IF type.isRealtime THEN
- INCL(flags,sfRealtime)
- END;
- w.RawNum(SYSTEM.VAL(LONGINT,flags));
- ParameterList(type);
- END;
- ELSIF type IS SyntaxTree.EnumerationType THEN
- IF TraceExport IN Trace THEN D.Str("Type / UserType / EnumerationType"); D.Str(name); D.Ln END;
- WITH type: SyntaxTree.EnumerationType DO
- w.RawNum(sfTypeEnumeration);
- Type(type.enumerationBase);
- w.RawString(name);
- EnumerationList(type.enumerationScope);
- END;
- ELSE HALT(200)
- END;
- END;
- END;
- END Type;
- (*
- EnumerationList = {name:RawString} 0X;
- *)
- PROCEDURE EnumerationList(enumerationScope: SyntaxTree.EnumerationScope);
- VAR name: SyntaxTree.IdentifierString; enumerator: SyntaxTree.Constant;
- BEGIN
- enumerator := enumerationScope.firstConstant;
- WHILE enumerator # NIL DO
- enumerator.GetName(name);
- IF enumerator.access * SyntaxTree.Public = {} THEN
- w.RawString("@");
- ELSE
- w.RawString(name);
- END;
- Value(enumerator.value.resolved);
- enumerator := enumerator.nextConstant;
- END;
- w.RawString("");
- END EnumerationList;
- (* ParameterList =
- { [sfObjFlag sfWinAPIParam | sfObjFlag sfCParam | sfObjFlag sfDarwinCParam] [sfVar] [sfReadOnly] Type name:RawString } sfEnd
- *)
- PROCEDURE ParameterList(procedureType: SyntaxTree.ProcedureType);
- VAR flags: SET; name: SyntaxTree.IdentifierString;
- PROCEDURE Parameters(parameter: SyntaxTree.Parameter; reverse: BOOLEAN);
- VAR procedureType: SyntaxTree.ProcedureType;
- BEGIN
- WHILE parameter # NIL DO
- (*! the calling convention should not be expressed via the parameters (compatiblity with old compiler) *)
- procedureType := parameter.ownerType(SyntaxTree.ProcedureType);
- IF procedureType.callingConvention = SyntaxTree.WinAPICallingConvention THEN
- w.RawNum(sfObjFlag); w.RawNum(sfWinAPIParam);
- ELSIF procedureType.callingConvention = SyntaxTree.CCallingConvention THEN
- w.RawNum(sfObjFlag); w.RawNum(sfCParam);
- ELSIF procedureType.callingConvention = SyntaxTree.DarwinCCallingConvention THEN
- w.RawNum(sfObjFlag); w.RawNum(sfDarwinCParam);
- END;
- IF parameter.kind = SyntaxTree.VarParameter THEN
- w.RawNum(sfVar)
- ELSIF parameter.kind = SyntaxTree.ConstParameter THEN
- IF (parameter.type.resolved IS SyntaxTree.ArrayType) OR (parameter.type.resolved IS SyntaxTree.RecordType) THEN
- w.RawNum(sfVar);
- END; (* cf. FingerPrint.FPSignature *)
- w.RawNum(sfReadOnly);
- END;
- Type(parameter.type);
- parameter.GetName(name);
- w.RawString(name);
- IF reverse THEN
- parameter := parameter.prevParameter
- ELSE
- parameter := parameter.nextParameter
- END;
- END;
- END Parameters;
- BEGIN
- IF procedureType.callingConvention # SyntaxTree.OberonCallingConvention THEN
- (*! if a procedure has a return type, then it has a return parameter (new)
- ASSERT(procedureType.returnParameter = NIL);
- *)
- Parameters(procedureType.lastParameter,TRUE);
- ELSE
- Parameters(procedureType.firstParameter,FALSE);
- END;
- w.RawNum(sfEnd);
- END ParameterList;
- PROCEDURE Inline(procedureScope: SyntaxTree.ProcedureScope);
- VAR len,count,pos: LONGINT; code: SyntaxTree.Code; ch: CHAR;
- BEGIN
- code := procedureScope.body.code;
- IF code.inlineCode # NIL THEN
- len := code.inlineCode.GetSize() DIV 8;
- ELSE
- len := 0
- END;
- count := 0; pos := 0;
- IF len = 0 THEN
- w.Char(0X);
- ELSE
- WHILE pos < len DO
- IF count = 0 THEN
- count := 255;
- IF len < 255 THEN count := len END;
- w.Char(CHR(count))
- END;
- ch := CHR(code.inlineCode.GetBits(pos*8,8));
- w.Char(ch);
- INC(pos); DEC(count)
- END;
- END;
- w.Char(0X);
- END Inline;
- (* Symbol =
- [sfObjFlag flag:RawNum] [sfReadOnly] Type Name
- *)
- PROCEDURE Symbol(type: SyntaxTree.Type; name: SyntaxTree.Identifier; visibility: SET;untraced, realtime, constructor, operator, isDynamic, isFictive: BOOLEAN; fOffset: LONGINT);
- VAR string,string2: SyntaxTree.IdentifierString;
- BEGIN
- IF TraceExport IN Trace THEN
- Basic.GetString(name,string);
- D.Str("Symbol "); D.Str(string); D.Ln;
- END;
- IF isFictive THEN w.RawNum(sfObjFlag); w.RawNum(sfFictive); TRACE(fOffset); w.RawNum(fOffset);
- ELSIF untraced THEN w.RawNum(sfObjFlag); w.RawNum(sfUntraced)
- ELSIF realtime THEN w.RawNum(sfObjFlag); w.RawNum(sfRealtime)
- END;
- IF operator THEN w.RawNum(sfObjFlag); w.RawNum(sfOperator) END;
- IF isDynamic THEN w.RawNum(sfObjFlag); w.RawNum(sfDynamic) END;
- IF (SyntaxTree.PublicRead IN visibility) & ~(SyntaxTree.PublicWrite IN visibility) THEN
- w.RawNum(sfReadOnly);
- END;
- Type(type);
- IF visibility * SyntaxTree.Internal = visibility THEN
- string2 := "";
- IF constructor THEN string2 := "&" END;
- ELSE Basic.GetString(name,string);
- IF constructor THEN
- Basic.Concat(string2,"&",string,"");
- ELSE
- string2 := string
- END;
- END;
- w.RawString(string2);
- END Symbol;
- (*
- SymbolFile =
- flags:RawSet
- Imports
- [sfSysFlag flags:Number]
- [sfConst {Symbol Value}]
- [sfVar {Symbol}]
- [sfXProcedure {Symbol ParameterList}]
- [sfOperator {Symbol ParameterList [sfInline Inline]}]
- [sfCProcedure {Symbol ParameterList Inline}]
- [sfAlias {declaredType:Type Name}]
- [sfType {declaredType:Type}]
- sfEnd
- *)
- PROCEDURE Module(module: SyntaxTree.Module);
- VAR constant: SyntaxTree.Constant; name: SyntaxTree.IdentifierString; first: BOOLEAN;
- variable: SyntaxTree.Variable; typeDeclaration: SyntaxTree.TypeDeclaration; procedure: SyntaxTree.Procedure;
- procedureType: SyntaxTree.ProcedureType;
- BEGIN
- IF TraceExport IN Trace THEN
- module.GetName(name);
- D.Str("BINARY SYMBOL FILE EXPORT "); D.Str(name); D.Ln;
- END;
- w.RawSet({}); (* compilation flags *)
- (* overloading flags omitted *)
- (* import section: write names of imported modules *)
- Imports(module.moduleScope.firstImport);
- (* constants *)
- IF TraceExport IN Trace THEN
- D.Str("exporting constants "); D.Ln;
- END;
- first :=TRUE;
- constant := module.moduleScope.firstConstant;
- WHILE constant # NIL DO
- IF constant.access * SyntaxTree.Public # {} THEN
- IF first THEN w.RawNum(sfConst); first := FALSE END;
- Symbol(constant.type,constant.name,SyntaxTree.Public (*! for compatiblity should be constant.access *) ,FALSE,FALSE,FALSE,FALSE, FALSE, FALSE, 0);
- constant.GetName(name);
- Value(constant.value.resolved(SyntaxTree.Value))
- END;
- constant := constant.nextConstant;
- END;
- (* variables *)
- IF TraceExport IN Trace THEN
- D.Str("exporting variables "); D.Ln;
- END;
- first := TRUE;
- variable := module.moduleScope.firstVariable;
- WHILE variable # NIL DO
- IF variable.access * SyntaxTree.Public # {} THEN
- IF first THEN w.RawNum(sfVar); first := FALSE END;
- Symbol(variable.type,variable.name,variable.access,variable.untraced, FALSE, FALSE, FALSE, FALSE, variable.fictive, variable.fictiveOffset);
- END;
- variable := variable.nextVariable;
- END;
- (* procedures: normal *)
- IF TraceExport IN Trace THEN
- D.Str("exporting procedures "); D.Ln;
- END;
- first := TRUE;
- procedure := module.moduleScope.firstProcedure;
- WHILE procedure # NIL DO
- IF (procedure.access * SyntaxTree.Public # {}) & ~(procedure IS SyntaxTree.Operator) THEN
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- IF ~procedure.isInline THEN
- IF first THEN w.RawNum(sfXProcedure); first := FALSE END;
- Symbol(procedureType.returnType,procedure.name,SyntaxTree.Public (*! for compatiblity should be procedure.access *),
- FALSE, procedureType.isRealtime, procedure.isConstructor, FALSE, FALSE, FALSE, 0);
- ParameterList(procedureType);
- END;
- END;
- procedure := procedure.nextProcedure;
- END;
- (* procedures: operators *)
- IF TraceExport IN Trace THEN
- D.Str("exporting operators"); D.Ln;
- END;
- first := TRUE;
- procedure := module.moduleScope.firstProcedure;
- WHILE procedure # NIL DO
- IF (procedure.access * SyntaxTree.Public # {}) & (procedure IS SyntaxTree.Operator) THEN
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- IF first THEN w.RawNum(sfOperator); first := FALSE END;
- Symbol(procedureType.returnType,procedure.name,SyntaxTree.Public (*! for compatiblity should be procedure.access *),
- FALSE, procedure.isInline, procedure.isConstructor, FALSE, procedure(SyntaxTree.Operator).isDynamic, FALSE, 0);
- ParameterList(procedureType);
- IF procedure.isInline THEN
- w.RawNum(sfInline); Inline(procedure.procedureScope);
- END;
- END;
- procedure := procedure.nextProcedure;
- END;
- (* procedures: inline *)
- IF TraceExport IN Trace THEN
- D.Str("exporting inline procedures"); D.Ln;
- END;
- first := TRUE;
- procedure := module.moduleScope.firstProcedure;
- WHILE procedure # NIL DO
- IF (procedure.access * SyntaxTree.Public # {}) & ~(procedure IS SyntaxTree.Operator) THEN
- procedureType := procedure.type(SyntaxTree.ProcedureType);
- IF procedure.isInline THEN
- IF first THEN w.RawNum(sfCProcedure); first := FALSE END;
- Symbol(procedureType.returnType,procedure.name,SyntaxTree.Public (*! for compatiblity should be procedure.access *),
- FALSE, procedure.isInline, procedure.isConstructor, FALSE, FALSE, FALSE, 0);
- ParameterList(procedureType);
- Inline(procedure.procedureScope);
- END;
- END;
- procedure := procedure.nextProcedure;
- END;
- (* type declarations: aliases *)
- IF TraceExport IN Trace THEN
- D.Str("exporting type declarations aliases"); D.Ln;
- END;
- first := TRUE;
- typeDeclaration := module.moduleScope.firstTypeDeclaration;
- WHILE typeDeclaration # NIL DO
- IF typeDeclaration.access * SyntaxTree.Public # {} THEN
- IF typeDeclaration.declaredType IS SyntaxTree.QualifiedType THEN
- IF first THEN w.RawNum(sfAlias); first := FALSE END;
- Type(typeDeclaration.declaredType);
- typeDeclaration.GetName(name);
- w.RawString(name);
- END;
- END;
- typeDeclaration := typeDeclaration.nextTypeDeclaration;
- END;
- (* type declarations: declarations *)
- IF TraceExport IN Trace THEN
- D.Str("exporting type declarations"); D.Ln;
- END;
- first := TRUE;
- typeDeclaration := module.moduleScope.firstTypeDeclaration;
- WHILE typeDeclaration # NIL DO
- IF typeDeclaration.access * SyntaxTree.Public # {} THEN
- IF ~(typeDeclaration.declaredType IS SyntaxTree.QualifiedType) THEN
- IF first THEN w.RawNum(sfType); first := FALSE END;
- Type(typeDeclaration.declaredType);
- END;
- END;
- typeDeclaration := typeDeclaration.nextTypeDeclaration;
- END;
- IF TraceExport IN Trace THEN
- module.GetName(name);
- D.Str("BINARY SYMBOL FILE EXPORT DONE "); D.Str(name); D.Ln;
- END;
- w.RawNum(sfEnd);
- END Module;
- BEGIN
- file := Files.New("");
- IF ~noInterfaceCheck THEN
- InterfaceComparison.CompareThis(module,SELF,diagnostics,importCache,flags);
- IF noRedefinition OR noModification THEN
- IF (InterfaceComparison.Redefined IN flags) THEN
- Basic.Error(diagnostics, module.sourceName, Basic.invalidPosition, " no redefinition of symbol file allowed");
- RETURN FALSE;
- END;
- END;
- IF noModification THEN
- IF (InterfaceComparison.Extended IN flags) THEN
- Basic.Error(diagnostics, module.sourceName,Basic.invalidPosition, " no extension of symbol file allowed");
- RETURN FALSE;
- END;
- END;
- END;
- NEW(w,file,0);
- NEW(lookup,100); NEW(indexToAttribute,16);
- numberType := 0;
- Module(module);
- w.Update();
- Files.Register(file);
- RETURN TRUE
- END Export;
- PROCEDURE DefineOptions*(options: Options.Options);
- BEGIN
- options.Add(0X,"symbolFileExtension",Options.String);
- options.Add(0X,"noRedefinition",Options.Flag);
- options.Add(0X,"noModification",Options.Flag);
- options.Add(0X,"noInterfaceCheck",Options.Flag);
- END DefineOptions;
- PROCEDURE GetOptions*(options: Options.Options);
- BEGIN
- IF ~options.GetString("symbolFileExtension",extension) THEN
- extension := Machine.DefaultObjectFileExtension
- END;
- noRedefinition := options.GetFlag("noRedefinition");
- noModification := options.GetFlag("noModification");
- noInterfaceCheck := options.GetFlag("noInterfaceCheck");
- END GetOptions;
- END BinarySymbolFile;
- VAR
- (* move to basic *)
- PROCEDURE MakeFileName(VAR file: ARRAY OF CHAR; CONST name, prefix, suffix: ARRAY OF CHAR);
- VAR i, j: LONGINT;
- BEGIN
- i := 0; WHILE prefix[i] # 0X DO file[i] := prefix[i]; INC(i) END;
- j := 0; WHILE name[j] # 0X DO file[i+j] := name[j]; INC(j) END;
- INC(i, j);
- j := 0; WHILE suffix[j] # 0X DO file[i+j] := suffix[j]; INC(j) END;
- file[i+j] := 0X;
- END MakeFileName;
- (** OpenSymFile - Open a symfile for reading *)
- PROCEDURE OpenSymFile(CONST name,prefix,suffix: ARRAY OF CHAR; VAR r: Streams.Reader; VAR version: CHAR): BOOLEAN;
- VAR res: BOOLEAN; file: Files.FileName; f: Files.File; R: Files.Reader; dummy: LONGINT; ch: CHAR;
- BEGIN
- res := FALSE;
- MakeFileName(file, name, prefix, suffix);
- f := Files.Old(file);
- IF f # NIL THEN
- NEW(R,f,0);
- r := R;
- r.Char(ch);
- IF ch = FileTag THEN
- r.Char(version);
- ASSERT(version = NoZeroCompress); r.Char(version);
- IF version = FileVersion THEN
- r.RawNum(dummy); (*skip symfile size*)
- ELSIF (version >= FileVersionOC) & (version <= FileVersionCurrent) THEN
- r.RawLInt(dummy); (* new in OC: symbol file size uncompressed *)
- ELSE
- HALT(100)
- END;
- res := TRUE
- END
- END;
- RETURN res
- END OpenSymFile;
- PROCEDURE Get*(): Formats.SymbolFileFormat;
- VAR symbolFileFormat: BinarySymbolFile;
- BEGIN
- NEW(symbolFileFormat); symbolFileFormat.file := Files.New(""); RETURN symbolFileFormat
- END Get;
- PROCEDURE Test*(context: Commands.Context);
- VAR moduleName: SyntaxTree.IdentifierString; module: SyntaxTree.Module;
- log2: Basic.Writer; time: LONGINT;
- p: Printout.Printer;
- symbolFileFormat: BinarySymbolFile;
- options: Options.Options;
- extension: Basic.FileName;
- BEGIN
- NEW(options);
- NEW(symbolFileFormat);
- symbolFileFormat.DefineOptions(options);
- IF options.Parse(context.arg,context.error) THEN
- symbolFileFormat.GetOptions(options);
- context.arg.SkipWhitespace; context.arg.String(moduleName);
- time := Kernel.GetTicks();
- symbolFileFormat.Initialize(NIL,Global.DefaultSystem(),"");
- module := symbolFileFormat.Import(moduleName,NIL);
- time := Kernel.GetTicks()-time;
- D.Str("importer elapsed ms: "); D.Int(time,10); D.Ln;
- D.Update;
- log2 := Basic.GetWriter(Basic.GetDebugWriter("SymbolFile"));
- p := Printout.NewPrinter(log2,Printout.SymbolFile,FALSE);
- log2.String("Interface of "); log2.String(moduleName); log2.Ln;
- log2.Ln;
- p.Module(module);
- log2.Ln;
- log2.Ln;
- log2.String(" -------------------------------------------------------------- "); log2.Ln;
- log2.Ln;
- log2.Ln;
- p := Printout.NewPrinter(log2,Printout.All,TRUE);
- p.Module(module);
- log2.Update;
- END;
- END Test;
- END FoxBinarySymbolFile.
- SystemTools.Free FoxBinarySymbolFile ~
- FoxBinarySymbolFile.Test Visualizer ~
- Compiler.Compile -PCtp Visualizer.Sym ~
- FoxBinarySymbolFile.Test Oberon.Oberon ~
- FoxBinarySymbolFile.Test --symbolFileExtension=".Obw" Dump ~
|