// // // The Nimrod Compiler // (c) Copyright 2009 Andreas Rumpf // // See the file "copying.txt", included in this // distribution, for details about the copyright. // unit ast; // abstract syntax tree + symbol table interface {$include 'config.inc'} uses nsystem, charsets, msgs, nhashes, nversion, options, strutils, crc, ropes, idents, lists; const ImportTablePos = 0; ModuleTablePos = 1; type TCallingConvention = ( ccDefault, // proc has no explicit calling convention ccStdCall, // procedure is stdcall ccCDecl, // cdecl ccSafeCall, // safecall ccSysCall, // system call ccInline, // proc should be inlined ccNoInline, // proc should not be inlined ccFastCall, // fastcall (pass parameters in registers) ccClosure, // proc has a closure ccNoConvention // needed for generating proper C procs sometimes ); const CallingConvToStr: array [TCallingConvention] of string = ( '', 'stdcall', 'cdecl', 'safecall', 'syscall', 'inline', 'noinline', 'fastcall', 'closure', 'noconv'); (*[[[cog def toEnum(name, elems, prefixlen=0): body = "" strs = "" prefix = "" counter = 0 for e in elems: if counter % 4 == 0: prefix = "\n " else: prefix = "" body = body + prefix + e + ', ' strs = strs + prefix + "'%s', " % e[prefixlen:] counter = counter + 1 return ("type\n T%s = (%s);\n T%ss = set of T%s;\n" % (name, body[:-2], name, name), "const\n %sToStr: array [T%s] of string = (%s);\n" % (name, name, strs[:-2])) enums = eval(open("data/ast.yml").read()) for key, val in enums.items(): (a, b) = toEnum(key, val) cog.out(a) cog.out(b) ]]]*) type TNodeKind = ( nkNone, nkEmpty, nkIdent, nkSym, nkType, nkCharLit, nkIntLit, nkInt8Lit, nkInt16Lit, nkInt32Lit, nkInt64Lit, nkFloatLit, nkFloat32Lit, nkFloat64Lit, nkStrLit, nkRStrLit, nkTripleStrLit, nkMetaNode, nkNilLit, nkDotCall, nkCommand, nkCall, nkCallStrLit, nkExprEqExpr, nkExprColonExpr, nkIdentDefs, nkVarTuple, nkInfix, nkPrefix, nkPostfix, nkPar, nkCurly, nkBracket, nkBracketExpr, nkPragmaExpr, nkRange, nkDotExpr, nkCheckedFieldExpr, nkDerefExpr, nkIfExpr, nkElifExpr, nkElseExpr, nkLambda, nkAccQuoted, nkTableConstr, nkBind, nkSymChoice, nkHiddenStdConv, nkHiddenSubConv, nkHiddenCallConv, nkConv, nkCast, nkAddr, nkHiddenAddr, nkHiddenDeref, nkObjDownConv, nkObjUpConv, nkChckRangeF, nkChckRange64, nkChckRange, nkStringToCString, nkCStringToString, nkPassAsOpenArray, nkAsgn, nkFastAsgn, nkGenericParams, nkFormalParams, nkOfInherit, nkModule, nkProcDef, nkMethodDef, nkConverterDef, nkMacroDef, nkTemplateDef, nkIteratorDef, nkOfBranch, nkElifBranch, nkExceptBranch, nkElse, nkMacroStmt, nkAsmStmt, nkPragma, nkIfStmt, nkWhenStmt, nkForStmt, nkWhileStmt, nkCaseStmt, nkVarSection, nkConstSection, nkConstDef, nkTypeSection, nkTypeDef, nkYieldStmt, nkTryStmt, nkFinally, nkRaiseStmt, nkReturnStmt, nkBreakStmt, nkContinueStmt, nkBlockStmt, nkDiscardStmt, nkStmtList, nkImportStmt, nkFromStmt, nkIncludeStmt, nkCommentStmt, nkStmtListExpr, nkBlockExpr, nkStmtListType, nkBlockType, nkTypeOfExpr, nkObjectTy, nkTupleTy, nkRecList, nkRecCase, nkRecWhen, nkRefTy, nkPtrTy, nkVarTy, nkDistinctTy, nkProcTy, nkEnumTy, nkEnumFieldDef, nkReturnToken); TNodeKinds = set of TNodeKind; const NodeKindToStr: array [TNodeKind] of string = ( 'nkNone', 'nkEmpty', 'nkIdent', 'nkSym', 'nkType', 'nkCharLit', 'nkIntLit', 'nkInt8Lit', 'nkInt16Lit', 'nkInt32Lit', 'nkInt64Lit', 'nkFloatLit', 'nkFloat32Lit', 'nkFloat64Lit', 'nkStrLit', 'nkRStrLit', 'nkTripleStrLit', 'nkMetaNode', 'nkNilLit', 'nkDotCall', 'nkCommand', 'nkCall', 'nkCallStrLit', 'nkExprEqExpr', 'nkExprColonExpr', 'nkIdentDefs', 'nkVarTuple', 'nkInfix', 'nkPrefix', 'nkPostfix', 'nkPar', 'nkCurly', 'nkBracket', 'nkBracketExpr', 'nkPragmaExpr', 'nkRange', 'nkDotExpr', 'nkCheckedFieldExpr', 'nkDerefExpr', 'nkIfExpr', 'nkElifExpr', 'nkElseExpr', 'nkLambda', 'nkAccQuoted', 'nkTableConstr', 'nkBind', 'nkSymChoice', 'nkHiddenStdConv', 'nkHiddenSubConv', 'nkHiddenCallConv', 'nkConv', 'nkCast', 'nkAddr', 'nkHiddenAddr', 'nkHiddenDeref', 'nkObjDownConv', 'nkObjUpConv', 'nkChckRangeF', 'nkChckRange64', 'nkChckRange', 'nkStringToCString', 'nkCStringToString', 'nkPassAsOpenArray', 'nkAsgn', 'nkFastAsgn', 'nkGenericParams', 'nkFormalParams', 'nkOfInherit', 'nkModule', 'nkProcDef', 'nkMethodDef', 'nkConverterDef', 'nkMacroDef', 'nkTemplateDef', 'nkIteratorDef', 'nkOfBranch', 'nkElifBranch', 'nkExceptBranch', 'nkElse', 'nkMacroStmt', 'nkAsmStmt', 'nkPragma', 'nkIfStmt', 'nkWhenStmt', 'nkForStmt', 'nkWhileStmt', 'nkCaseStmt', 'nkVarSection', 'nkConstSection', 'nkConstDef', 'nkTypeSection', 'nkTypeDef', 'nkYieldStmt', 'nkTryStmt', 'nkFinally', 'nkRaiseStmt', 'nkReturnStmt', 'nkBreakStmt', 'nkContinueStmt', 'nkBlockStmt', 'nkDiscardStmt', 'nkStmtList', 'nkImportStmt', 'nkFromStmt', 'nkIncludeStmt', 'nkCommentStmt', 'nkStmtListExpr', 'nkBlockExpr', 'nkStmtListType', 'nkBlockType', 'nkTypeOfExpr', 'nkObjectTy', 'nkTupleTy', 'nkRecList', 'nkRecCase', 'nkRecWhen', 'nkRefTy', 'nkPtrTy', 'nkVarTy', 'nkDistinctTy', 'nkProcTy', 'nkEnumTy', 'nkEnumFieldDef', 'nkReturnToken'); type TSymFlag = ( sfUsed, sfStar, sfMinus, sfInInterface, sfFromGeneric, sfGlobal, sfForward, sfImportc, sfExportc, sfVolatile, sfRegister, sfPure, sfResult, sfNoSideEffect, sfSideEffect, sfMainModule, sfSystemModule, sfNoReturn, sfAddrTaken, sfCompilerProc, sfProcvar, sfDiscriminant, sfDeprecated, sfInClosure, sfTypeCheck, sfCompileTime, sfThreadVar, sfMerge, sfDeadCodeElim, sfBorrow); TSymFlags = set of TSymFlag; const SymFlagToStr: array [TSymFlag] of string = ( 'sfUsed', 'sfStar', 'sfMinus', 'sfInInterface', 'sfFromGeneric', 'sfGlobal', 'sfForward', 'sfImportc', 'sfExportc', 'sfVolatile', 'sfRegister', 'sfPure', 'sfResult', 'sfNoSideEffect', 'sfSideEffect', 'sfMainModule', 'sfSystemModule', 'sfNoReturn', 'sfAddrTaken', 'sfCompilerProc', 'sfProcvar', 'sfDiscriminant', 'sfDeprecated', 'sfInClosure', 'sfTypeCheck', 'sfCompileTime', 'sfThreadVar', 'sfMerge', 'sfDeadCodeElim', 'sfBorrow'); type TTypeKind = ( tyNone, tyBool, tyChar, tyEmpty, tyArrayConstr, tyNil, tyExpr, tyStmt, tyTypeDesc, tyGenericInvokation, tyGenericBody, tyGenericInst, tyGenericParam, tyDistinct, tyEnum, tyOrdinal, tyArray, tyObject, tyTuple, tySet, tyRange, tyPtr, tyRef, tyVar, tySequence, tyProc, tyPointer, tyOpenArray, tyString, tyCString, tyForward, tyInt, tyInt8, tyInt16, tyInt32, tyInt64, tyFloat, tyFloat32, tyFloat64, tyFloat128); TTypeKinds = set of TTypeKind; const TypeKindToStr: array [TTypeKind] of string = ( 'tyNone', 'tyBool', 'tyChar', 'tyEmpty', 'tyArrayConstr', 'tyNil', 'tyExpr', 'tyStmt', 'tyTypeDesc', 'tyGenericInvokation', 'tyGenericBody', 'tyGenericInst', 'tyGenericParam', 'tyDistinct', 'tyEnum', 'tyOrdinal', 'tyArray', 'tyObject', 'tyTuple', 'tySet', 'tyRange', 'tyPtr', 'tyRef', 'tyVar', 'tySequence', 'tyProc', 'tyPointer', 'tyOpenArray', 'tyString', 'tyCString', 'tyForward', 'tyInt', 'tyInt8', 'tyInt16', 'tyInt32', 'tyInt64', 'tyFloat', 'tyFloat32', 'tyFloat64', 'tyFloat128'); type TNodeFlag = ( nfNone, nfBase2, nfBase8, nfBase16, nfAllConst, nfTransf, nfSem); TNodeFlags = set of TNodeFlag; const NodeFlagToStr: array [TNodeFlag] of string = ( 'nfNone', 'nfBase2', 'nfBase8', 'nfBase16', 'nfAllConst', 'nfTransf', 'nfSem'); type TTypeFlag = ( tfVarargs, tfNoSideEffect, tfFinal, tfAcyclic, tfEnumHasWholes); TTypeFlags = set of TTypeFlag; const TypeFlagToStr: array [TTypeFlag] of string = ( 'tfVarargs', 'tfNoSideEffect', 'tfFinal', 'tfAcyclic', 'tfEnumHasWholes'); type TSymKind = ( skUnknown, skConditional, skDynLib, skParam, skGenericParam, skTemp, skType, skConst, skVar, skProc, skMethod, skIterator, skConverter, skMacro, skTemplate, skField, skEnumField, skForVar, skModule, skLabel, skStub); TSymKinds = set of TSymKind; const SymKindToStr: array [TSymKind] of string = ( 'skUnknown', 'skConditional', 'skDynLib', 'skParam', 'skGenericParam', 'skTemp', 'skType', 'skConst', 'skVar', 'skProc', 'skMethod', 'skIterator', 'skConverter', 'skMacro', 'skTemplate', 'skField', 'skEnumField', 'skForVar', 'skModule', 'skLabel', 'skStub'); {[[[end]]]} type // symbols that require compiler magic: TMagic = ( //[[[cog //magics = eval(open("data/magic.yml").read()) //for i in range(0, len(magics)-1): // cog.out("m" + magics[i] + ", ") // if (i+1) % 6 == 0: cog.outl("") //cog.outl("m" + magics[-1]) //]]] mNone, mDefined, mDefinedInScope, mLow, mHigh, mSizeOf, mIs, mEcho, mSucc, mPred, mInc, mDec, mOrd, mNew, mNewFinalize, mNewSeq, mLengthOpenArray, mLengthStr, mLengthArray, mLengthSeq, mIncl, mExcl, mCard, mChr, mGCref, mGCunref, mAddI, mSubI, mMulI, mDivI, mModI, mAddI64, mSubI64, mMulI64, mDivI64, mModI64, mShrI, mShlI, mBitandI, mBitorI, mBitxorI, mMinI, mMaxI, mShrI64, mShlI64, mBitandI64, mBitorI64, mBitxorI64, mMinI64, mMaxI64, mAddF64, mSubF64, mMulF64, mDivF64, mMinF64, mMaxF64, mAddU, mSubU, mMulU, mDivU, mModU, mAddU64, mSubU64, mMulU64, mDivU64, mModU64, mEqI, mLeI, mLtI, mEqI64, mLeI64, mLtI64, mEqF64, mLeF64, mLtF64, mLeU, mLtU, mLeU64, mLtU64, mEqEnum, mLeEnum, mLtEnum, mEqCh, mLeCh, mLtCh, mEqB, mLeB, mLtB, mEqRef, mEqProc, mEqUntracedRef, mLePtr, mLtPtr, mEqCString, mXor, mUnaryMinusI, mUnaryMinusI64, mAbsI, mAbsI64, mNot, mUnaryPlusI, mBitnotI, mUnaryPlusI64, mBitnotI64, mUnaryPlusF64, mUnaryMinusF64, mAbsF64, mZe8ToI, mZe8ToI64, mZe16ToI, mZe16ToI64, mZe32ToI64, mZeIToI64, mToU8, mToU16, mToU32, mToFloat, mToBiggestFloat, mToInt, mToBiggestInt, mCharToStr, mBoolToStr, mIntToStr, mInt64ToStr, mFloatToStr, mCStrToStr, mStrToStr, mEnumToStr, mAnd, mOr, mEqStr, mLeStr, mLtStr, mEqSet, mLeSet, mLtSet, mMulSet, mPlusSet, mMinusSet, mSymDiffSet, mConStrStr, mConArrArr, mConArrT, mConTArr, mConTT, mSlice, mAppendStrCh, mAppendStrStr, mAppendSeqElem, mInRange, mInSet, mRepr, mExit, mSetLengthStr, mSetLengthSeq, mAssert, mSwap, mIsNil, mArrToSeq, mCopyStr, mCopyStrLast, mNewString, mArray, mOpenArray, mRange, mSet, mSeq, mOrdinal, mInt, mInt8, mInt16, mInt32, mInt64, mFloat, mFloat32, mFloat64, mBool, mChar, mString, mCstring, mPointer, mEmptySet, mIntSetBaseType, mNil, mExpr, mStmt, mTypeDesc, mIsMainModule, mCompileDate, mCompileTime, mNimrodVersion, mNimrodMajor, mNimrodMinor, mNimrodPatch, mCpuEndian, mHostOS, mHostCPU, mNaN, mInf, mNegInf, mNLen, mNChild, mNSetChild, mNAdd, mNAddMultiple, mNDel, mNKind, mNIntVal, mNFloatVal, mNSymbol, mNIdent, mNGetType, mNStrVal, mNSetIntVal, mNSetFloatVal, mNSetSymbol, mNSetIdent, mNSetType, mNSetStrVal, mNNewNimNode, mNCopyNimNode, mNCopyNimTree, mStrToIdent, mIdentToStr, mEqIdent, mEqNimrodNode, mNHint, mNWarning, mNError //[[[end]]] ); type PNode = ^TNode; PNodePtr = ^{@ptr}PNode; TNodeSeq = array of PNode; PType = ^TType; PSym = ^TSym; TNode = {@ignore} record typ: PType; strVal: string; comment: string; sons: TNodeSeq; // else! info: TLineInfo; flags: TNodeFlags; case Kind: TNodeKind of nkCharLit, nkIntLit, nkInt8Lit, nkInt16Lit, nkInt32Lit, nkInt64Lit: (intVal: biggestInt); nkFloatLit, nkFloat32Lit, nkFloat64Lit: (floatVal: biggestFloat); nkSym: (sym: PSym); nkIdent: (ident: PIdent); nkMetaNode: (nodePtr: PNodePtr); end; {@emit record // on a 32bit machine, this takes 32 bytes typ: PType; comment: string; info: TLineInfo; flags: TNodeFlags; case Kind: TNodeKind of nkCharLit..nkInt64Lit: (intVal: biggestInt); nkFloatLit..nkFloat64Lit: (floatVal: biggestFloat); nkStrLit..nkTripleStrLit: (strVal: string); nkSym: (sym: PSym); nkIdent: (ident: PIdent); nkMetaNode: (nodePtr: PNodePtr); else (sons: TNodeSeq); end acyclic; } TSymSeq = array of PSym; TStrTable = object // a table[PIdent] of PSym counter: int; data: TSymSeq; end; // -------------- backend information ------------------------------- TLocKind = ( locNone, // no location locTemp, // temporary location locLocalVar, // location is a local variable locGlobalVar, // location is a global variable locParam, // location is a parameter locField, // location is a record field locArrayElem, // location is an array element locExpr, // "location" is really an expression locProc, // location is a proc (an address of a procedure) locData, // location is a constant locCall, // location is a call expression locOther // location is something other ); TLocFlag = ( lfIndirect, // backend introduced a pointer lfParamCopy, // backend introduced a parameter copy (LLVM) lfNoDeepCopy, // no need for a deep copy lfNoDecl, // do not declare it in C lfDynamicLib, // link symbol to dynamic library lfExportLib, // export symbol for dynamic library generation lfHeader // include header file for symbol ); TStorageLoc = ( OnUnknown, // location is unknown (stack, heap or static) OnStack, // location is on hardware stack OnHeap // location is on heap or global (reference counting needed) ); TLocFlags = set of TLocFlag; TLoc = record k: TLocKind; // kind of location s: TStorageLoc; flags: TLocFlags; // location's flags t: PType; // type of location r: PRope; // rope value of location (code generators) a: int; // location's "address", i.e. slot for temporaries end; // ---------------- end of backend information ------------------------------ TLibKind = (libHeader, libDynamic); TLib = object(lists.TListEntry) // also misused for headers! kind: TLibKind; generated: bool; // needed for the backends: name: PRope; path: string; end; PLib = ^TLib; TSym = object(TIdObj) // symbols are identical iff they have the same // id! kind: TSymKind; magic: TMagic; typ: PType; name: PIdent; info: TLineInfo; owner: PSym; flags: TSymFlags; tab: TStrTable; // interface table for modules ast: PNode; // syntax tree of proc, iterator, etc.: // the whole proc including header; this is used // for easy generation of proper error messages // for variant record fields the discriminant // expression options: TOptions; position: int; // used for many different things: // for enum fields its position; // for fields its offset // for parameters its position // for a conditional: // 1 iff the symbol is defined, else 0 // (or not in symbol table) offset: int; // offset of record field loc: TLoc; annex: PLib; // additional fields (seldom used, so we use a // reference to another object to safe space) end; TTypeSeq = array of PType; TType = object(TIdObj) // types are identical iff they have the // same id; there may be multiple copies of a type // in memory! kind: TTypeKind; // kind of type sons: TTypeSeq; // base types, etc. n: PNode; // node for types: // for range types a nkRange node // for record types a nkRecord node // for enum types a list of symbols // else: unused flags: TTypeFlags; // flags of the type callConv: TCallingConvention; // for procs owner: PSym; // the 'owner' of the type sym: PSym; // types have the sym associated with them // it is used for converting types to strings size: BiggestInt; // the size of the type in bytes // -1 means that the size is unkwown align: int; // the type's alignment requirements containerID: int; // used for type checking of generics loc: TLoc; end; TPair = record key, val: PObject; end; TPairSeq = array of TPair; TTable = record // the same as table[PObject] of PObject counter: int; data: TPairSeq; end; TIdPair = record key: PIdObj; val: PObject; end; TIdPairSeq = array of TIdPair; TIdTable = record // the same as table[PIdent] of PObject counter: int; data: TIdPairSeq; end; TIdNodePair = record key: PIdObj; val: PNode; end; TIdNodePairSeq = array of TIdNodePair; TIdNodeTable = record // the same as table[PIdObj] of PNode counter: int; data: TIdNodePairSeq; end; TNodePair = record h: THash; // because it is expensive to compute! key: PNode; val: int; end; TNodePairSeq = array of TNodePair; TNodeTable = record // the same as table[PNode] of int; // nodes are compared by structure! counter: int; data: TNodePairSeq; end; TObjectSeq = array of PObject; TObjectSet = record counter: int; data: TObjectSeq; end; const OverloadableSyms = {@set}[skProc, skMethod, skIterator, skConverter, skModule]; const // "MagicToStr" array: MagicToStr: array [TMagic] of string = ( //[[[cog //for i in range(0, len(magics)-1): // cog.out("'%s', " % magics[i]) // if (i+1) % 6 == 0: cog.outl("") //cog.outl("'%s'" % magics[-1]) //]]] 'None', 'Defined', 'DefinedInScope', 'Low', 'High', 'SizeOf', 'Is', 'Echo', 'Succ', 'Pred', 'Inc', 'Dec', 'Ord', 'New', 'NewFinalize', 'NewSeq', 'LengthOpenArray', 'LengthStr', 'LengthArray', 'LengthSeq', 'Incl', 'Excl', 'Card', 'Chr', 'GCref', 'GCunref', 'AddI', 'SubI', 'MulI', 'DivI', 'ModI', 'AddI64', 'SubI64', 'MulI64', 'DivI64', 'ModI64', 'ShrI', 'ShlI', 'BitandI', 'BitorI', 'BitxorI', 'MinI', 'MaxI', 'ShrI64', 'ShlI64', 'BitandI64', 'BitorI64', 'BitxorI64', 'MinI64', 'MaxI64', 'AddF64', 'SubF64', 'MulF64', 'DivF64', 'MinF64', 'MaxF64', 'AddU', 'SubU', 'MulU', 'DivU', 'ModU', 'AddU64', 'SubU64', 'MulU64', 'DivU64', 'ModU64', 'EqI', 'LeI', 'LtI', 'EqI64', 'LeI64', 'LtI64', 'EqF64', 'LeF64', 'LtF64', 'LeU', 'LtU', 'LeU64', 'LtU64', 'EqEnum', 'LeEnum', 'LtEnum', 'EqCh', 'LeCh', 'LtCh', 'EqB', 'LeB', 'LtB', 'EqRef', 'EqProc', 'EqUntracedRef', 'LePtr', 'LtPtr', 'EqCString', 'Xor', 'UnaryMinusI', 'UnaryMinusI64', 'AbsI', 'AbsI64', 'Not', 'UnaryPlusI', 'BitnotI', 'UnaryPlusI64', 'BitnotI64', 'UnaryPlusF64', 'UnaryMinusF64', 'AbsF64', 'Ze8ToI', 'Ze8ToI64', 'Ze16ToI', 'Ze16ToI64', 'Ze32ToI64', 'ZeIToI64', 'ToU8', 'ToU16', 'ToU32', 'ToFloat', 'ToBiggestFloat', 'ToInt', 'ToBiggestInt', 'CharToStr', 'BoolToStr', 'IntToStr', 'Int64ToStr', 'FloatToStr', 'CStrToStr', 'StrToStr', 'EnumToStr', 'And', 'Or', 'EqStr', 'LeStr', 'LtStr', 'EqSet', 'LeSet', 'LtSet', 'MulSet', 'PlusSet', 'MinusSet', 'SymDiffSet', 'ConStrStr', 'ConArrArr', 'ConArrT', 'ConTArr', 'ConTT', 'Slice', 'AppendStrCh', 'AppendStrStr', 'AppendSeqElem', 'InRange', 'InSet', 'Repr', 'Exit', 'SetLengthStr', 'SetLengthSeq', 'Assert', 'Swap', 'IsNil', 'ArrToSeq', 'CopyStr', 'CopyStrLast', 'NewString', 'Array', 'OpenArray', 'Range', 'Set', 'Seq', 'Ordinal', 'Int', 'Int8', 'Int16', 'Int32', 'Int64', 'Float', 'Float32', 'Float64', 'Bool', 'Char', 'String', 'Cstring', 'Pointer', 'EmptySet', 'IntSetBaseType', 'Nil', 'Expr', 'Stmt', 'TypeDesc', 'IsMainModule', 'CompileDate', 'CompileTime', 'NimrodVersion', 'NimrodMajor', 'NimrodMinor', 'NimrodPatch', 'CpuEndian', 'HostOS', 'HostCPU', 'NaN', 'Inf', 'NegInf', 'NLen', 'NChild', 'NSetChild', 'NAdd', 'NAddMultiple', 'NDel', 'NKind', 'NIntVal', 'NFloatVal', 'NSymbol', 'NIdent', 'NGetType', 'NStrVal', 'NSetIntVal', 'NSetFloatVal', 'NSetSymbol', 'NSetIdent', 'NSetType', 'NSetStrVal', 'NNewNimNode', 'NCopyNimNode', 'NCopyNimTree', 'StrToIdent', 'IdentToStr', 'EqIdent', 'EqNimrodNode', 'NHint', 'NWarning', 'NError' //[[[end]]] ); const GenericTypes: TTypeKinds = {@set}[ tyGenericInvokation, tyGenericBody, tyGenericParam ]; StructuralEquivTypes: TTypeKinds = {@set}[ tyArrayConstr, tyNil, tyTuple, tyArray, tySet, tyRange, tyPtr, tyRef, tyVar, tySequence, tyProc, tyOpenArray ]; ConcreteTypes: TTypeKinds = {@set}[ // types of the expr that may occur in:: // var x = expr tyBool, tyChar, tyEnum, tyArray, tyObject, tySet, tyTuple, tyRange, tyPtr, tyRef, tyVar, tySequence, tyProc, tyPointer, tyOpenArray, tyString, tyCString, tyInt..tyInt64, tyFloat..tyFloat128 ]; ConstantDataTypes: TTypeKinds = {@set}[tyArray, tySet, tyTuple]; ExportableSymKinds = {@set}[skVar, skConst, skProc, skMethod, skType, skIterator, skMacro, skTemplate, skConverter, skStub]; PersistentNodeFlags: TNodeFlags = {@set}[ nfBase2, nfBase8, nfBase16, nfAllConst]; namePos = 0; genericParamsPos = 1; paramsPos = 2; pragmasPos = 3; codePos = 4; resultPos = 5; dispatcherPos = 6; var gId: int; function getID: int; procedure setID(id: int); procedure IDsynchronizationPoint(idRange: int); // creator procs: function NewSym(symKind: TSymKind; Name: PIdent; owner: PSym): PSym; function NewType(kind: TTypeKind; owner: PSym): PType; overload; function newNode(kind: TNodeKind): PNode; function newIntNode(kind: TNodeKind; const intVal: BiggestInt): PNode; function newIntTypeNode(kind: TNodeKind; const intVal: BiggestInt; typ: PType): PNode; function newFloatNode(kind: TNodeKind; const floatVal: BiggestFloat): PNode; function newStrNode(kind: TNodeKind; const strVal: string): PNode; function newIdentNode(ident: PIdent; const info: TLineInfo): PNode; function newSymNode(sym: PSym): PNode; function newNodeI(kind: TNodeKind; const info: TLineInfo): PNode; function newNodeIT(kind: TNodeKind; const info: TLineInfo; typ: PType): PNode; procedure initStrTable(out x: TStrTable); procedure initTable(out x: TTable); procedure initIdTable(out x: TIdTable); procedure initObjectSet(out x: TObjectSet); procedure initIdNodeTable(out x: TIdNodeTable); procedure initNodeTable(out x: TNodeTable); // copy procs: function copyType(t: PType; owner: PSym; keepId: bool): PType; function copySym(s: PSym; keepId: bool = false): PSym; procedure assignType(dest, src: PType); procedure copyStrTable(out dest: TStrTable; const src: TStrTable); procedure copyTable(out dest: TTable; const src: TTable); procedure copyObjectSet(out dest: TObjectSet; const src: TObjectSet); procedure copyIdTable(var dest: TIdTable; const src: TIdTable); function sonsLen(n: PNode): int; overload; function sonsLen(n: PType): int; overload; function lastSon(n: PNode): PNode; overload; function lastSon(n: PType): PType; overload; procedure newSons(father: PNode; len: int); overload; procedure newSons(father: PType; len: int); overload; procedure addSon(father, son: PNode); overload; procedure addSon(father, son: PType); overload; procedure addSonIfNotNil(father, n: PNode); procedure delSon(father: PNode; idx: int); function hasSonWith(n: PNode; kind: TNodeKind): boolean; function hasSubnodeWith(n: PNode; kind: TNodeKind): boolean; procedure replaceSons(n: PNode; oldKind, newKind: TNodeKind); function sonsNotNil(n: PNode): bool; // for assertions function copyNode(src: PNode): PNode; // does not copy its sons! function copyTree(src: PNode): PNode; // does copy its sons! procedure discardSons(father: PNode); const // for all kind of hash tables: GrowthFactor = 2; // must be power of 2, > 0 StartSize = 8; // must be power of 2, > 0 function SameValue(a, b: PNode): Boolean; // a, b are literals function leValue(a, b: PNode): Boolean; // a <= b? a, b are literals function ValueToString(a: PNode): string; // ------------- efficient integer sets ------------------------------------- {@ignore} type TBitScalar = int32; // FPC produces wrong code for ``int`` {@emit type TBitScalar = int; } const InitIntSetSize = 8; // must be a power of two! TrunkShift = 9; BitsPerTrunk = 1 shl TrunkShift; // needs to be a power of 2 and divisible by 64 TrunkMask = BitsPerTrunk-1; IntsPerTrunk = BitsPerTrunk div (sizeof(TBitScalar)*8); IntShift = 5+ord(sizeof(TBitScalar)=8); // 5 or 6, depending on int width IntMask = 1 shl IntShift -1; type PTrunk = ^TTrunk; TTrunk = record next: PTrunk; // all nodes are connected with this pointer key: int; // start address at bit 0 bits: array [0..IntsPerTrunk-1] of TBitScalar; // a bit vector end; TTrunkSeq = array of PTrunk; TIntSet = record counter, max: int; head: PTrunk; data: TTrunkSeq; end; function IntSetContains(const s: TIntSet; key: int): bool; procedure IntSetIncl(var s: TIntSet; key: int); procedure IntSetExcl(var s: TIntSet; key: int); procedure IntSetInit(var s: TIntSet); function IntSetContainsOrIncl(var s: TIntSet; key: int): bool; const debugIds = false; procedure registerID(id: PIdObj); implementation var usedIds: TIntSet; procedure registerID(id: PIdObj); begin if debugIDs then if (id.id = -1) or IntSetContainsOrIncl(usedIds, id.id) then InternalError('ID already used: ' + toString(id.id)); end; function getID: int; begin result := gId; inc(gId) end; procedure setId(id: int); begin gId := max(gId, id+1); end; procedure IDsynchronizationPoint(idRange: int); begin gId := (gId div IdRange +1) * IdRange + 1; end; function leValue(a, b: PNode): Boolean; // a <= b? begin result := false; case a.kind of nkCharLit..nkInt64Lit: if b.kind in [nkCharLit..nkInt64Lit] then result := a.intVal <= b.intVal; nkFloatLit..nkFloat64Lit: if b.kind in [nkFloatLit..nkFloat64Lit] then result := a.floatVal <= b.floatVal; nkStrLit..nkTripleStrLit: begin if b.kind in [nkStrLit..nkTripleStrLit] then result := a.strVal <= b.strVal; end else InternalError(a.info, 'leValue'); end end; function SameValue(a, b: PNode): Boolean; begin result := false; case a.kind of nkCharLit..nkInt64Lit: if b.kind in [nkCharLit..nkInt64Lit] then result := a.intVal = b.intVal; nkFloatLit..nkFloat64Lit: if b.kind in [nkFloatLit..nkFloat64Lit] then result := a.floatVal = b.floatVal; nkStrLit..nkTripleStrLit: begin if b.kind in [nkStrLit..nkTripleStrLit] then result := a.strVal = b.strVal; end else InternalError(a.info, 'SameValue'); end end; function ValueToString(a: PNode): string; begin case a.kind of nkCharLit..nkInt64Lit: result := ToString(a.intVal); nkFloatLit, nkFloat32Lit, nkFloat64Lit: result := toStringF(a.floatVal); nkStrLit..nkTripleStrLit: result := a.strVal; else begin InternalError(a.info, 'valueToString'); result := '' end end end; procedure copyStrTable(out dest: TStrTable; const src: TStrTable); var i: int; begin dest.counter := src.counter; {@emit if isNil(src.data) then exit; } setLength(dest.data, length(src.data)); for i := 0 to high(src.data) do dest.data[i] := src.data[i]; end; procedure copyIdTable(var dest: TIdTable; const src: TIdTable); var i: int; begin dest.counter := src.counter; {@emit if isNil(src.data) then exit; } {@ignore} setLength(dest.data, length(src.data)); {@emit newSeq(dest.data, length(src.data)); } for i := 0 to high(src.data) do dest.data[i] := src.data[i]; end; procedure copyTable(out dest: TTable; const src: TTable); var i: int; begin dest.counter := src.counter; {@emit if isNil(src.data) then exit; } setLength(dest.data, length(src.data)); for i := 0 to high(src.data) do dest.data[i] := src.data[i]; end; procedure copyObjectSet(out dest: TObjectSet; const src: TObjectSet); var i: int; begin dest.counter := src.counter; {@emit if isNil(src.data) then exit; } setLength(dest.data, length(src.data)); for i := 0 to high(src.data) do dest.data[i] := src.data[i]; end; procedure discardSons(father: PNode); begin father.sons := nil; end; function newNode(kind: TNodeKind): PNode; begin new(result); {@ignore} FillChar(result^, sizeof(result^), 0); {@emit} result.kind := kind; //result.info := UnknownLineInfo(); inlined: result.info.fileIndex := int32(-1); result.info.col := int16(-1); result.info.line := int16(-1); end; function newIntNode(kind: TNodeKind; const intVal: BiggestInt): PNode; begin result := newNode(kind); result.intVal := intVal end; function newIntTypeNode(kind: TNodeKind; const intVal: BiggestInt; typ: PType): PNode; begin result := newIntNode(kind, intVal); result.typ := typ; end; function newFloatNode(kind: TNodeKind; const floatVal: BiggestFloat): PNode; begin result := newNode(kind); result.floatVal := floatVal end; function newStrNode(kind: TNodeKind; const strVal: string): PNode; begin result := newNode(kind); result.strVal := strVal end; function newIdentNode(ident: PIdent; const info: TLineInfo): PNode; begin result := newNode(nkIdent); result.ident := ident; result.info := info; end; function newSymNode(sym: PSym): PNode; begin result := newNode(nkSym); result.sym := sym; result.typ := sym.typ; result.info := sym.info; end; function newNodeI(kind: TNodeKind; const info: TLineInfo): PNode; begin result := newNode(kind); result.info := info; end; function newNodeIT(kind: TNodeKind; const info: TLineInfo; typ: PType): PNode; begin result := newNode(kind); result.info := info; result.typ := typ; end; function NewType(kind: TTypeKind; owner: PSym): PType; overload; begin new(result); {@ignore} FillChar(result^, sizeof(result^), 0); {@emit} result.kind := kind; result.owner := owner; result.size := -1; result.align := 2; // default alignment result.id := getID(); if debugIds then RegisterId(result); //if result.id < 2000 then // MessageOut(typeKindToStr[kind] +{&} ' has id: ' +{&} toString(result.id)); end; procedure assignType(dest, src: PType); var i: int; begin dest.kind := src.kind; dest.flags := src.flags; dest.callConv := src.callConv; dest.n := src.n; dest.size := src.size; dest.align := src.align; dest.containerID := src.containerID; newSons(dest, sonsLen(src)); for i := 0 to sonsLen(src)-1 do dest.sons[i] := src.sons[i]; end; function copyType(t: PType; owner: PSym; keepId: bool): PType; begin result := newType(t.Kind, owner); assignType(result, t); if keepId then result.id := t.id else begin result.id := getID(); if debugIds then RegisterId(result); end; result.sym := t.sym; // backend-info should not be copied end; function copySym(s: PSym; keepId: bool = false): PSym; begin result := newSym(s.kind, s.name, s.owner); result.ast := nil; // BUGFIX; was: s.ast which made problems result.info := s.info; result.typ := s.typ; if keepId then result.id := s.id else begin result.id := getID(); if debugIds then RegisterId(result); end; result.flags := s.flags; result.magic := s.magic; copyStrTable(result.tab, s.tab); result.options := s.options; result.position := s.position; result.loc := s.loc; result.annex := s.annex; // BUGFIX end; function NewSym(symKind: TSymKind; Name: PIdent; owner: PSym): PSym; // generates a symbol and initializes the hash field too begin new(result); {@ignore} FillChar(result^, sizeof(result^), 0); {@emit} result.Name := Name; result.Kind := symKind; result.flags := {@set}[]; result.info := UnknownLineInfo(); result.options := gOptions; result.owner := owner; result.offset := -1; result.id := getID(); if debugIds then RegisterId(result); //if result.id < 2000 then // MessageOut(name.s +{&} ' has id: ' +{&} toString(result.id)); end; procedure initStrTable(out x: TStrTable); begin x.counter := 0; {@emit newSeq(x.data, startSize); } {@ignore} setLength(x.data, startSize); fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); {@emit} end; procedure initTable(out x: TTable); begin x.counter := 0; {@emit newSeq(x.data, startSize); } {@ignore} setLength(x.data, startSize); fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); {@emit} end; procedure initIdTable(out x: TIdTable); begin x.counter := 0; {@emit newSeq(x.data, startSize); } {@ignore} setLength(x.data, startSize); fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); {@emit} end; procedure initObjectSet(out x: TObjectSet); begin x.counter := 0; {@emit newSeq(x.data, startSize); } {@ignore} setLength(x.data, startSize); fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); {@emit} end; procedure initIdNodeTable(out x: TIdNodeTable); begin x.counter := 0; {@emit newSeq(x.data, startSize); } {@ignore} setLength(x.data, startSize); fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); {@emit} end; procedure initNodeTable(out x: TNodeTable); begin x.counter := 0; {@emit newSeq(x.data, startSize); } {@ignore} setLength(x.data, startSize); fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); {@emit} end; function sonsLen(n: PType): int; begin {@ignore} result := length(n.sons); {@emit if isNil(n.sons) then result := 0 else result := length(n.sons); } end; procedure newSons(father: PType; len: int); var i, L: int; begin {@emit if isNil(father.sons) then father.sons := @[]; } L := length(father.sons); setLength(father.sons, L + len); {@ignore} for i := L to L+len-1 do father.sons[i] := nil // needed for FPC {@emit} end; procedure addSon(father, son: PType); var L: int; begin {@ignore} L := length(father.sons); setLength(father.sons, L+1); father.sons[L] := son; {@emit if isNil(father.sons) then father.sons := @[]; } {@emit add(father.sons, son); } assert((father.kind <> tyGenericInvokation) or (son.kind <> tyGenericInst)); end; function sonsLen(n: PNode): int; begin {@ignore} result := length(n.sons); {@emit if isNil(n.sons) then result := 0 else result := length(n.sons); } end; procedure newSons(father: PNode; len: int); var i, L: int; begin {@emit if isNil(father.sons) then father.sons := @[]; } L := length(father.sons); setLength(father.sons, L + len); {@ignore} for i := L to L+len-1 do father.sons[i] := nil // needed for FPC {@emit} end; procedure addSon(father, son: PNode); var L: int; begin {@ignore} L := length(father.sons); setLength(father.sons, L+1); father.sons[L] := son; {@emit if isNil(father.sons) then father.sons := @[]; } {@emit add(father.sons, son); } end; procedure delSon(father: PNode; idx: int); var len, i: int; begin {@emit if isNil(father.sons) then exit; } len := sonsLen(father); for i := idx to len-2 do father.sons[i] := father.sons[i+1]; setLength(father.sons, len-1); end; function copyNode(src: PNode): PNode; // does not copy its sons! begin if src = nil then begin result := nil; exit end; result := newNode(src.kind); result.info := src.info; result.typ := src.typ; result.flags := src.flags * PersistentNodeFlags; case src.Kind of nkCharLit..nkInt64Lit: result.intVal := src.intVal; nkFloatLit, nkFloat32Lit, nkFloat64Lit: result.floatVal := src.floatVal; nkSym: result.sym := src.sym; nkIdent: result.ident := src.ident; nkStrLit..nkTripleStrLit: result.strVal := src.strVal; nkMetaNode: result.nodePtr := src.nodePtr; else begin end; end; end; function copyTree(src: PNode): PNode; // copy a whole syntax tree; performs deep copying var i: int; begin if src = nil then begin result := nil; exit end; result := newNode(src.kind); result.info := src.info; result.typ := src.typ; result.flags := src.flags * PersistentNodeFlags; case src.Kind of nkCharLit..nkInt64Lit: result.intVal := src.intVal; nkFloatLit, nkFloat32Lit, nkFloat64Lit: result.floatVal := src.floatVal; nkSym: result.sym := src.sym; nkIdent: result.ident := src.ident; nkStrLit..nkTripleStrLit: result.strVal := src.strVal; nkMetaNode: result.nodePtr := src.nodePtr; else begin result.sons := nil; newSons(result, sonsLen(src)); for i := 0 to sonsLen(src)-1 do result.sons[i] := copyTree(src.sons[i]); end; end end; function lastSon(n: PNode): PNode; begin result := n.sons[sonsLen(n)-1]; end; function lastSon(n: PType): PType; begin result := n.sons[sonsLen(n)-1]; end; function hasSonWith(n: PNode; kind: TNodeKind): boolean; var i: int; begin for i := 0 to sonsLen(n)-1 do begin if (n.sons[i] <> nil) and (n.sons[i].kind = kind) then begin result := true; exit end end; result := false end; function hasSubnodeWith(n: PNode; kind: TNodeKind): boolean; var i: int; begin case n.kind of nkEmpty..nkNilLit: result := n.kind = kind; else begin for i := 0 to sonsLen(n)-1 do begin if (n.sons[i] <> nil) and (n.sons[i].kind = kind) or hasSubnodeWith(n.sons[i], kind) then begin result := true; exit end end; result := false end end end; procedure replaceSons(n: PNode; oldKind, newKind: TNodeKind); var i: int; begin for i := 0 to sonsLen(n)-1 do if n.sons[i].kind = oldKind then n.sons[i].kind := newKind end; function sonsNotNil(n: PNode): bool; var i: int; begin for i := 0 to sonsLen(n)-1 do if n.sons[i] = nil then begin result := false; exit end; result := true end; procedure addSonIfNotNil(father, n: PNode); begin if n <> nil then addSon(father, n) end; // ---------------- efficient integer sets ---------------------------------- // Same algorithm as the one the GC uses function mustRehash(len, counter: int): bool; begin assert(len > counter); result := (len * 2 < counter * 3) or (len-counter < 4); end; function nextTry(h, maxHash: THash): THash; begin result := ((5*h) + 1) and maxHash; // For any initial h in range(maxHash), repeating that maxHash times // generates each int in range(maxHash) exactly once (see any text on // random-number generation for proof). end; procedure IntSetInit(var s: TIntSet); begin {@ignore} fillChar(s, sizeof(s), 0); {@emit} {@ignore} setLength(s.data, InitIntSetSize); fillChar(s.data[0], length(s.data)*sizeof(s.data[0]), 0); {@emit newSeq(s.data, InitIntSetSize); } s.max := InitIntSetSize-1; s.counter := 0; s.head := nil end; function IntSetGet(const t: TIntSet; key: int): PTrunk; var h: int; begin h := key and t.max; while t.data[h] <> nil do begin if t.data[h].key = key then begin result := t.data[h]; exit end; h := nextTry(h, t.max) end; result := nil end; procedure IntSetRawInsert(const t: TIntSet; var data: TTrunkSeq; desc: PTrunk); var h: int; begin h := desc.key and t.max; while data[h] <> nil do begin assert(data[h] <> desc); h := nextTry(h, t.max) end; assert(data[h] = nil); data[h] := desc end; procedure IntSetEnlarge(var t: TIntSet); var n: TTrunkSeq; i, oldMax: int; begin oldMax := t.max; t.max := ((t.max+1)*2)-1; {@ignore} setLength(n, t.max + 1); fillChar(n[0], length(n)*sizeof(n[0]), 0); {@emit newSeq(n, t.max+1); } for i := 0 to oldmax do if t.data[i] <> nil then IntSetRawInsert(t, n, t.data[i]); {@ignore} t.data := n; {@emit swap(t.data, n); } end; function IntSetPut(var t: TIntSet; key: int): PTrunk; var h: int; begin h := key and t.max; while t.data[h] <> nil do begin if t.data[h].key = key then begin result := t.data[h]; exit end; h := nextTry(h, t.max) end; if mustRehash(t.max+1, t.counter) then IntSetEnlarge(t); inc(t.counter); h := key and t.max; while t.data[h] <> nil do h := nextTry(h, t.max); assert(t.data[h] = nil); new(result); {@ignore} fillChar(result^, sizeof(result^), 0); {@emit} result.next := t.head; result.key := key; t.head := result; t.data[h] := result; end; // ---------- slightly higher level procs ---------------------------------- function IntSetContains(const s: TIntSet; key: int): bool; var u: TBitScalar; t: PTrunk; begin t := IntSetGet(s, shru(key, TrunkShift)); if t <> nil then begin u := key and TrunkMask; result := (t.bits[shru(u, IntShift)] and shlu(1, u and IntMask)) <> 0 end else result := false end; procedure IntSetIncl(var s: TIntSet; key: int); var u: TBitScalar; t: PTrunk; begin t := IntSetPut(s, shru(key, TrunkShift)); u := key and TrunkMask; t.bits[shru(u, IntShift)] := t.bits[shru(u, IntShift)] or shlu(1, u and IntMask); end; procedure IntSetExcl(var s: TIntSet; key: int); var u: TBitScalar; t: PTrunk; begin t := IntSetGet(s, shru(key, TrunkShift)); if t <> nil then begin u := key and TrunkMask; t.bits[shru(u, IntShift)] := t.bits[shru(u, IntShift)] and not shlu(1, u and IntMask); end end; function IntSetContainsOrIncl(var s: TIntSet; key: int): bool; var u: TBitScalar; t: PTrunk; begin t := IntSetGet(s, shru(key, TrunkShift)); if t <> nil then begin u := key and TrunkMask; result := (t.bits[shru(u, IntShift)] and shlu(1, u and IntMask)) <> 0; if not result then t.bits[shru(u, IntShift)] := t.bits[shru(u, IntShift)] or shlu(1, u and IntMask); end else begin IntSetIncl(s, key); result := false end end; (* procedure IntSetDebug(const s: TIntSet); var it: PTrunk; i, j: int; begin it := s.head; while it <> nil do begin for i := 0 to high(it.bits) do for j := 0 to BitsPerInt-1 do begin if (it.bits[j] and (1 shl j)) <> 0 then MessageOut('Contains key: ' + toString(it.key + i * BitsPerInt + j)); end; it := it.next end end;*) initialization if debugIDs then IntSetInit(usedIds); end.