123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481 |
- 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;
- 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(-1); 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(-1,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(-1,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(-1,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,-1,FALSE) ELSE value := Global.NewBooleanValue(system,-1,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(-1,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 (-1,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(-1,i);
- ELSIF size=64 THEN
- R.RawHInt(huge);
- IF TraceImport IN Trace THEN D.Str("InConst / HInt / "); D.Ln END;
- value := SyntaxTree.NewIntegerValue (-1,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(-1,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(-1,r);
- ELSIF size = 64 THEN
- R.RawLReal(lr);
- IF TraceImport IN Trace THEN D.Str("InConst / LongReal / "); D.Ln END;
- value := SyntaxTree.NewRealValue(-1,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(-1,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(-1,i);
- ELSIF type IS SyntaxTree.NilType THEN
- IF TraceImport IN Trace THEN D.Str("InConst / Nil"); D.Ln END;
- value := SyntaxTree.NewNilValue(-1);
- 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(-1,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(-1,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(-1,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(-1,SyntaxTree.NewIdentifier(name),procedureScope);
- procedure := operator
- ELSE
- procedure := SyntaxTree.NewProcedure(-1,SyntaxTree.NewIdentifier(name),procedureScope);
- END;
- procedureType := SyntaxTree.NewProcedureType(-1,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(-1,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(-1,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(-1,moduleScope,SyntaxTree.NewQualifiedIdentifier(-1,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 = 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(-1,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(-1,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(-1,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(-1,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(-1,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(-1,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(-1,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(-1,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(-1,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(-1,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(-1,moduleScope,enumerationScope);
- type := enumerationType;
- enumerationType.SetEnumerationBase(baseType);
- EnumerationList(enumerationScope);
- END;
- IF name # "" THEN
- typeDeclaration := SyntaxTree.NewTypeDeclaration(-1,SyntaxTree.NewIdentifier(name));
- typeDeclaration.SetDeclaredType(type);
- type.SetTypeDeclaration(typeDeclaration);
- typeDeclaration.SetAccess(visibility);
- typeDeclaration.SetState(SyntaxTree.Resolved);
- qualifiedType := SyntaxTree.NewQualifiedType(-1,moduleScope, SyntaxTree.NewQualifiedIdentifier(-1,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(-1,scope);
- newcode := SyntaxTree.NewCode(-1,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(-1,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(-1,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(-1,moduleScope);
- procedureType.SetReturnType(type);
- procedure := SyntaxTree.NewProcedure(-1,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(-1,moduleScope);
- procedureType.SetReturnType(type);
- procedureType.SetRealtime(realtime);
- procedure := SyntaxTree.NewOperator(-1,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(-1,moduleScope);
- procedure := SyntaxTree.NewProcedure(-1,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(-1,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,-1,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.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
- diagnostics.Error(module.sourceName,Diagnostics.Invalid,Diagnostics.Invalid," no redefinition of symbol file allowed");
- RETURN FALSE;
- END;
- END;
- IF noModification THEN
- IF (InterfaceComparison.Extended IN flags) THEN
- diagnostics.Error(module.sourceName,Diagnostics.Invalid,Diagnostics.Invalid," 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 ~
|