diff options
Diffstat (limited to 'nim')
61 files changed, 5120 insertions, 6357 deletions
diff --git a/nim/ast.pas b/nim/ast.pas index 587284d56..c84262db4 100644 --- a/nim/ast.pas +++ b/nim/ast.pas @@ -1,1122 +1,1426 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2008 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, hashes, - 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 - 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', '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 += prefix + e + ', ' - strs += prefix + "'%s', " % e[prefixlen:] - counter += 1 - - return ("type\n T%s = (%s);\n T%ss = set of T%s;\n" - % (name, body.rstrip(", "), name, name), - "const\n %sToStr: array [T%s] of string = (%s);\n" - % (name, name, strs.rstrip(", "))) - -enums = eval(file("data/ast.yml").read()) -for key, val in enums.iteritems(): - (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, nkGenericCall, nkExplicitTypeListCall, - nkExprEqExpr, nkExprColonExpr, nkIdentDefs, nkInfix, - nkPrefix, nkPostfix, nkPar, nkCurly, - nkBracket, nkBracketExpr, nkPragmaExpr, nkRange, - nkDotExpr, nkCheckedFieldExpr, nkDerefExpr, nkIfExpr, - nkElifExpr, nkElseExpr, nkLambda, nkAccQuoted, - nkHeaderQuoted, nkTableConstr, nkQualified, nkHiddenStdConv, - nkHiddenSubConv, nkHiddenCallConv, nkConv, nkCast, - nkAddr, nkHiddenAddr, nkHiddenDeref, nkObjDownConv, - nkObjUpConv, nkChckRangeF, nkChckRange64, nkChckRange, - nkStringToCString, nkCStringToString, nkPassAsOpenArray, nkAsgn, - nkDefaultTypeParam, nkGenericParams, nkFormalParams, nkOfInherit, - nkModule, nkProcDef, 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, nkImportAs, - nkIncludeStmt, nkAccessStmt, nkCommentStmt, nkStmtListExpr, - nkBlockExpr, nkVm, nkTypeOfExpr, nkObjectTy, - nkTupleTy, nkRecList, nkRecCase, nkRecWhen, - nkRefTy, nkPtrTy, nkVarTy, 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', 'nkGenericCall', 'nkExplicitTypeListCall', - 'nkExprEqExpr', 'nkExprColonExpr', 'nkIdentDefs', 'nkInfix', - 'nkPrefix', 'nkPostfix', 'nkPar', 'nkCurly', - 'nkBracket', 'nkBracketExpr', 'nkPragmaExpr', 'nkRange', - 'nkDotExpr', 'nkCheckedFieldExpr', 'nkDerefExpr', 'nkIfExpr', - 'nkElifExpr', 'nkElseExpr', 'nkLambda', 'nkAccQuoted', - 'nkHeaderQuoted', 'nkTableConstr', 'nkQualified', 'nkHiddenStdConv', - 'nkHiddenSubConv', 'nkHiddenCallConv', 'nkConv', 'nkCast', - 'nkAddr', 'nkHiddenAddr', 'nkHiddenDeref', 'nkObjDownConv', - 'nkObjUpConv', 'nkChckRangeF', 'nkChckRange64', 'nkChckRange', - 'nkStringToCString', 'nkCStringToString', 'nkPassAsOpenArray', 'nkAsgn', - 'nkDefaultTypeParam', 'nkGenericParams', 'nkFormalParams', 'nkOfInherit', - 'nkModule', 'nkProcDef', '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', 'nkImportAs', - 'nkIncludeStmt', 'nkAccessStmt', 'nkCommentStmt', 'nkStmtListExpr', - 'nkBlockExpr', 'nkVm', 'nkTypeOfExpr', 'nkObjectTy', - 'nkTupleTy', 'nkRecList', 'nkRecCase', 'nkRecWhen', - 'nkRefTy', 'nkPtrTy', 'nkVarTy', 'nkProcTy', - 'nkEnumTy', 'nkEnumFieldDef', 'nkReturnToken'); -type - TSymFlag = ( - sfTypeCheck, sfForward, sfImportc, sfExportc, - sfVolatile, sfUsed, sfWrite, sfRegister, - sfPure, sfCodeGenerated, sfPrivate, sfGlobal, - sfResult, sfNoSideEffect, sfMainModule, sfSystemModule, - sfNoReturn, sfAddrTaken, sfInInterface, sfNoStatic, - sfCompilerProc, sfCppMethod, sfDiscriminant, sfDeprecated, - sfInClosure, sfIsCopy, sfStar, sfMinus); - TSymFlags = set of TSymFlag; -const - SymFlagToStr: array [TSymFlag] of string = ( - 'sfTypeCheck', 'sfForward', 'sfImportc', 'sfExportc', - 'sfVolatile', 'sfUsed', 'sfWrite', 'sfRegister', - 'sfPure', 'sfCodeGenerated', 'sfPrivate', 'sfGlobal', - 'sfResult', 'sfNoSideEffect', 'sfMainModule', 'sfSystemModule', - 'sfNoReturn', 'sfAddrTaken', 'sfInInterface', 'sfNoStatic', - 'sfCompilerProc', 'sfCppMethod', 'sfDiscriminant', 'sfDeprecated', - 'sfInClosure', 'sfIsCopy', 'sfStar', 'sfMinus'); -type - TTypeKind = ( - tyNone, tyBool, tyChar, tyEmptySet, - tyArrayConstr, tyNil, tyGeneric, tyGenericInst, - tyGenericParam, tyEnum, tyAnyEnum, 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', 'tyEmptySet', - 'tyArrayConstr', 'tyNil', 'tyGeneric', 'tyGenericInst', - 'tyGenericParam', 'tyEnum', 'tyAnyEnum', '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); - TNodeFlags = set of TNodeFlag; -const - NodeFlagToStr: array [TNodeFlag] of string = ( - 'nfNone', 'nfBase2', 'nfBase8', 'nfBase16', - 'nfAllConst'); -type - TTypeFlag = ( - tfIsDistinct, tfGeneric, tfExternal, tfImported, - tfInfoGenerated, tfSemChecked, tfHasOutParams, tfEnumHasWholes, - tfVarargs, tfFinal); - TTypeFlags = set of TTypeFlag; -const - TypeFlagToStr: array [TTypeFlag] of string = ( - 'tfIsDistinct', 'tfGeneric', 'tfExternal', 'tfImported', - 'tfInfoGenerated', 'tfSemChecked', 'tfHasOutParams', 'tfEnumHasWholes', - 'tfVarargs', 'tfFinal'); -type - TSymKind = ( - skUnknownSym, skConditional, skDynLib, skParam, - skTypeParam, skTemp, skType, skConst, - skVar, skProc, skIterator, skConverter, - skMacro, skTemplate, skField, skEnumField, - skForVar, skModule, skLabel); - TSymKinds = set of TSymKind; -const - SymKindToStr: array [TSymKind] of string = ( - 'skUnknownSym', 'skConditional', 'skDynLib', 'skParam', - 'skTypeParam', 'skTemp', 'skType', 'skConst', - 'skVar', 'skProc', 'skIterator', 'skConverter', - 'skMacro', 'skTemplate', 'skField', 'skEnumField', - 'skForVar', 'skModule', 'skLabel'); -{[[[end]]]} - -type - // symbols that require compiler magic: - TMagic = ( - //[[[cog - //magics = eval(file("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, mNew, mNewFinalize, mLow, mHigh, - mSizeOf, mRegisterFinalizer, mSucc, mPred, mInc, mDec, - mLengthOpenArray, mLengthStr, mLengthArray, mLengthSeq, mIncl, mExcl, - mCard, mOrd, mChr, 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, mAnd, mOr, mEqStr, mLeStr, - mLtStr, mEqSet, mLeSet, mLtSet, mMulSet, mPlusSet, - mMinusSet, mSymDiffSet, mConStrStr, mConArrArr, mConArrT, mConTArr, - mConTT, mSlice, mAppendStrCh, mAppendStrStr, mAppendSeqElem, mAppendSeqSeq, - mInRange, mInSet, mIs, mAsgn, mRepr, mExit, - mSetLengthStr, mSetLengthSeq, mAssert, mSwap, mIsNil, mArray, - mOpenArray, mRange, mSet, mSeq, mCompileDate, mCompileTime, - mNimrodVersion, mNimrodMajor, mNimrodMinor, mNimrodPatch, mCpuEndian, 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, mNHint, mNWarning, mNError - //[[[end]]] - ); - -type - PNode = ^TNode; - PNodePtr = ^{@ptr}PNode; - TNodeSeq = array of PNode; - - PType = ^TType; - PSym = ^TSym; - - TNode = {@ignore} record // keep this below 32 bytes; - // otherwise the AST grows too much - 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 // keep this below 32 bytes; otherwise the AST grows too much - 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; } - - 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 - locImmediate, // location is an immediate value - 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 - lfNoDeepCopy, // no need for a deep copy - lfNoDecl, // do not declare it in C - lfDynamicLib, // link symbol to dynamic library - 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 ------------------------------ - - TSym = object(TIdObj) // symbols are identical iff they have the same - // id! - kind: TSymKind; - typ: PType; - name: PIdent; - info: TLineInfo; - owner: PSym; - flags: TSymFlags; - magic: TMagic; - 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: PObject; // additional fields (seldom used, so we use a - // reference to another object to safe space) - end; - - PTypeSeq = 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: PTypeSeq; // 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; - - // these are not part of the syntax tree, but nevertherless inherit from TNode - 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: PNode; - end; - TNodePairSeq = array of TNodePair; - - TNodeTable = record // the same as table[PNode] of PNode; - // nodes are compared by structure! - counter: int; - data: TNodePairSeq; - end; - - TObjectSeq = array of PObject; - - TObjectSet = record - counter: int; - data: TObjectSeq; - end; - TLibKind = (libHeader, libDynamic, libDynamicGenerated); - TLib = object(lists.TListEntry) // also misused for headers! - kind: TLibKind; - // needed for the backends: - name: PRope; - path: string; - syms: TObjectSet; - end; - PLib = ^TLib; - -const - OverloadableSyms = {@set}[skProc, skIterator, skConverter]; - -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', 'New', 'NewFinalize', 'Low', 'High', - 'SizeOf', 'RegisterFinalizer', 'Succ', 'Pred', 'Inc', 'Dec', - 'LengthOpenArray', 'LengthStr', 'LengthArray', 'LengthSeq', 'Incl', 'Excl', - 'Card', 'Ord', 'Chr', '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', 'And', 'Or', 'EqStr', 'LeStr', - 'LtStr', 'EqSet', 'LeSet', 'LtSet', 'MulSet', 'PlusSet', - 'MinusSet', 'SymDiffSet', 'ConStrStr', 'ConArrArr', 'ConArrT', 'ConTArr', - 'ConTT', 'Slice', 'AppendStrCh', 'AppendStrStr', 'AppendSeqElem', 'AppendSeqSeq', - 'InRange', 'InSet', 'Is', 'Asgn', 'Repr', 'Exit', - 'SetLengthStr', 'SetLengthSeq', 'Assert', 'Swap', 'IsNil', 'Array', - 'OpenArray', 'Range', 'Set', 'Seq', 'CompileDate', 'CompileTime', - 'NimrodVersion', 'NimrodMajor', 'NimrodMinor', 'NimrodPatch', 'CpuEndian', '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', 'NHint', 'NWarning', 'NError' - //[[[end]]] - ); - -const - GenericTypes: TTypeKinds = {@set}[tyGeneric, tyGenericParam]; - - StructuralEquivTypes: TTypeKinds = {@set}[ - tyEmptySet, 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, skType, - skIterator, skMacro, skTemplate, skConverter]; - namePos = 0; - genericParamsPos = 1; - paramsPos = 2; - pragmasPos = 3; - codePos = 4; - resultPos = 5; - -function getID: int; -procedure setID(id: 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): 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); - -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; - -implementation - -var - gId: int; - -function getID: int; -begin - inc(gId); - result := gId -end; - -procedure setId(id: int); -begin - gId := max(gId, id) -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 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(); -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() -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): PType; -begin - result := newType(t.Kind, owner); - assignType(result, t); - if owner = t.owner then result.id := t.id - else result.id := getID(); - 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 result.id := getID(); - 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() -end; - -procedure initStrTable(out x: TStrTable); -begin - x.counter := 0; -{@emit - x.data := []; } - setLength(x.data, startSize); -{@ignore} - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initTable(out x: TTable); -begin - x.counter := 0; -{@emit - x.data := []; } - setLength(x.data, startSize); -{@ignore} - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initIdTable(out x: TIdTable); -begin - x.counter := 0; -{@emit - x.data := []; } - setLength(x.data, startSize); -{@ignore} - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initObjectSet(out x: TObjectSet); -begin - x.counter := 0; -{@emit - x.data := []; } - setLength(x.data, startSize); -{@ignore} - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initIdNodeTable(out x: TIdNodeTable); -begin - x.counter := 0; -{@emit - x.data := []; } - setLength(x.data, startSize); -{@ignore} - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initNodeTable(out x: TNodeTable); -begin - x.counter := 0; -{@emit - x.data := []; } - setLength(x.data, startSize); -{@ignore} - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -function sonsLen(n: PType): int; -begin - if n.sons = nil then result := 0 - else result := length(n.sons) -end; - -procedure newSons(father: PType; len: int); -var - i, L: int; -begin -{@emit - if father.sons = nil 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 -{@emit - if father.sons = nil then father.sons := []; } - L := length(father.sons); - setLength(father.sons, L+1); - father.sons[L] := son; -end; - -function sonsLen(n: PNode): int; -begin - if n.sons = nil then result := 0 - else result := length(n.sons) -end; - -procedure newSons(father: PNode; len: int); -var - i, L: int; -begin -{@emit - if father.sons = nil 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 -{@emit - if father.sons = nil then father.sons := []; } - L := length(father.sons); - setLength(father.sons, L+1); - father.sons[L] := son; -end; - -procedure delSon(father: PNode; idx: int); -var - len, i: int; -begin -{@emit - if father.sons = nil 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; - 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; - 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; - -end. +// +// +// The Nimrod Compiler +// (c) Copyright 2008 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, hashes, + 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 + TTypeFlag = ( + tfVarargs, tfFinal, tfAcyclic, tfEnumHasWholes); + TTypeFlags = set of TTypeFlag; +const + TypeFlagToStr: array [TTypeFlag] of string = ( + 'tfVarargs', 'tfFinal', 'tfAcyclic', 'tfEnumHasWholes'); +type + TTypeKind = ( + tyNone, tyBool, tyChar, tyEmpty, + tyArrayConstr, tyNil, tyGeneric, tyGenericInst, + tyGenericParam, tyEnum, tyAnyEnum, 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', 'tyGeneric', 'tyGenericInst', + 'tyGenericParam', 'tyEnum', 'tyAnyEnum', '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 + TSymFlag = ( + sfUsed, sfStar, sfMinus, sfInInterface, + sfFromGeneric, sfGlobal, sfForward, sfImportc, + sfExportc, sfVolatile, sfRegister, sfPure, + sfResult, sfNoSideEffect, sfMainModule, sfSystemModule, + sfNoReturn, sfAddrTaken, sfCompilerProc, sfCppMethod, + sfDiscriminant, sfDeprecated, sfInClosure, sfTypeCheck, + sfCompileTime, sfThreadVar, sfMerge); + TSymFlags = set of TSymFlag; +const + SymFlagToStr: array [TSymFlag] of string = ( + 'sfUsed', 'sfStar', 'sfMinus', 'sfInInterface', + 'sfFromGeneric', 'sfGlobal', 'sfForward', 'sfImportc', + 'sfExportc', 'sfVolatile', 'sfRegister', 'sfPure', + 'sfResult', 'sfNoSideEffect', 'sfMainModule', 'sfSystemModule', + 'sfNoReturn', 'sfAddrTaken', 'sfCompilerProc', 'sfCppMethod', + 'sfDiscriminant', 'sfDeprecated', 'sfInClosure', 'sfTypeCheck', + 'sfCompileTime', 'sfThreadVar', 'sfMerge'); +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 + TSymKind = ( + skUnknownSym, skConditional, skDynLib, skParam, + skTypeParam, skTemp, skType, skConst, + skVar, skProc, skIterator, skConverter, + skMacro, skTemplate, skField, skEnumField, + skForVar, skModule, skLabel, skStub); + TSymKinds = set of TSymKind; +const + SymKindToStr: array [TSymKind] of string = ( + 'skUnknownSym', 'skConditional', 'skDynLib', 'skParam', + 'skTypeParam', 'skTemp', 'skType', 'skConst', + 'skVar', 'skProc', 'skIterator', 'skConverter', + 'skMacro', 'skTemplate', 'skField', 'skEnumField', + 'skForVar', 'skModule', 'skLabel', 'skStub'); +type + TNodeKind = ( + nkNone, nkEmpty, nkIdent, nkSym, + nkType, nkCharLit, nkIntLit, nkInt8Lit, + nkInt16Lit, nkInt32Lit, nkInt64Lit, nkFloatLit, + nkFloat32Lit, nkFloat64Lit, nkStrLit, nkRStrLit, + nkTripleStrLit, nkMetaNode, nkNilLit, nkDotCall, + nkCommand, nkCall, nkGenericCall, nkExplicitTypeListCall, + nkExprEqExpr, nkExprColonExpr, nkIdentDefs, nkInfix, + nkPrefix, nkPostfix, nkPar, nkCurly, + nkBracket, nkBracketExpr, nkPragmaExpr, nkRange, + nkDotExpr, nkCheckedFieldExpr, nkDerefExpr, nkIfExpr, + nkElifExpr, nkElseExpr, nkLambda, nkAccQuoted, + nkHeaderQuoted, nkTableConstr, nkQualified, nkHiddenStdConv, + nkHiddenSubConv, nkHiddenCallConv, nkConv, nkCast, + nkAddr, nkHiddenAddr, nkHiddenDeref, nkObjDownConv, + nkObjUpConv, nkChckRangeF, nkChckRange64, nkChckRange, + nkStringToCString, nkCStringToString, nkPassAsOpenArray, nkAsgn, + nkDefaultTypeParam, nkGenericParams, nkFormalParams, nkOfInherit, + nkModule, nkProcDef, 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, nkImportAs, + nkIncludeStmt, nkAccessStmt, nkCommentStmt, nkStmtListExpr, + nkBlockExpr, nkStmtListType, nkBlockType, nkVm, + nkTypeOfExpr, nkObjectTy, nkTupleTy, nkRecList, + nkRecCase, nkRecWhen, nkRefTy, nkPtrTy, + nkVarTy, 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', 'nkGenericCall', 'nkExplicitTypeListCall', + 'nkExprEqExpr', 'nkExprColonExpr', 'nkIdentDefs', 'nkInfix', + 'nkPrefix', 'nkPostfix', 'nkPar', 'nkCurly', + 'nkBracket', 'nkBracketExpr', 'nkPragmaExpr', 'nkRange', + 'nkDotExpr', 'nkCheckedFieldExpr', 'nkDerefExpr', 'nkIfExpr', + 'nkElifExpr', 'nkElseExpr', 'nkLambda', 'nkAccQuoted', + 'nkHeaderQuoted', 'nkTableConstr', 'nkQualified', 'nkHiddenStdConv', + 'nkHiddenSubConv', 'nkHiddenCallConv', 'nkConv', 'nkCast', + 'nkAddr', 'nkHiddenAddr', 'nkHiddenDeref', 'nkObjDownConv', + 'nkObjUpConv', 'nkChckRangeF', 'nkChckRange64', 'nkChckRange', + 'nkStringToCString', 'nkCStringToString', 'nkPassAsOpenArray', 'nkAsgn', + 'nkDefaultTypeParam', 'nkGenericParams', 'nkFormalParams', 'nkOfInherit', + 'nkModule', 'nkProcDef', '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', 'nkImportAs', + 'nkIncludeStmt', 'nkAccessStmt', 'nkCommentStmt', 'nkStmtListExpr', + 'nkBlockExpr', 'nkStmtListType', 'nkBlockType', 'nkVm', + 'nkTypeOfExpr', 'nkObjectTy', 'nkTupleTy', 'nkRecList', + 'nkRecCase', 'nkRecWhen', 'nkRefTy', 'nkPtrTy', + 'nkVarTy', 'nkProcTy', 'nkEnumTy', 'nkEnumFieldDef', + 'nkReturnToken'); +{[[[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, mLow, mHigh, mSizeOf, mIs, + mSucc, mPred, mInc, mDec, mOrd, mNew, + mNewFinalize, mNewSeq, mRegisterFinalizer, 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, + mAnd, mOr, mEqStr, mLeStr, mLtStr, mEqSet, + mLeSet, mLtSet, mMulSet, mPlusSet, mMinusSet, mSymDiffSet, + mConStrStr, mConArrArr, mConArrT, mConTArr, mConTT, mSlice, + mAppendStrCh, mAppendStrStr, mAppendSeqElem, mAppendSeqSeq, mInRange, mInSet, + mAsgn, mRepr, mExit, mSetLengthStr, mSetLengthSeq, mAssert, + mSwap, mIsNil, mArrToSeq, mArray, mOpenArray, mRange, + mSet, mSeq, mInt, mInt8, mInt16, mInt32, + mInt64, mFloat, mFloat32, mFloat64, mBool, mChar, + mString, mCstring, mPointer, mAnyEnum, mEmptySet, mIntSetBaseType, + mNil, mIsMainModule, mCompileDate, mCompileTime, mNimrodVersion, mNimrodMajor, + mNimrodMinor, mNimrodPatch, mCpuEndian, 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, 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 + locImmediate, // location is an immediate value + 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 + lfNoDeepCopy, // no need for a deep copy + lfNoDecl, // do not declare it in C + lfDynamicLib, // link symbol to dynamic library + 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, libDynamicGenerated); + TLib = object(lists.TListEntry) // also misused for headers! + kind: TLibKind; + // 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; + + // these are not part of the syntax tree, but nevertherless inherit from TNode + 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, skIterator, skConverter]; + +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', 'Low', 'High', 'SizeOf', 'Is', + 'Succ', 'Pred', 'Inc', 'Dec', 'Ord', 'New', + 'NewFinalize', 'NewSeq', 'RegisterFinalizer', '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', + 'And', 'Or', 'EqStr', 'LeStr', 'LtStr', 'EqSet', + 'LeSet', 'LtSet', 'MulSet', 'PlusSet', 'MinusSet', 'SymDiffSet', + 'ConStrStr', 'ConArrArr', 'ConArrT', 'ConTArr', 'ConTT', 'Slice', + 'AppendStrCh', 'AppendStrStr', 'AppendSeqElem', 'AppendSeqSeq', 'InRange', 'InSet', + 'Asgn', 'Repr', 'Exit', 'SetLengthStr', 'SetLengthSeq', 'Assert', + 'Swap', 'IsNil', 'ArrToSeq', 'Array', 'OpenArray', 'Range', + 'Set', 'Seq', 'Int', 'Int8', 'Int16', 'Int32', + 'Int64', 'Float', 'Float32', 'Float64', 'Bool', 'Char', + 'String', 'Cstring', 'Pointer', 'AnyEnum', 'EmptySet', 'IntSetBaseType', + 'Nil', 'IsMainModule', 'CompileDate', 'CompileTime', 'NimrodVersion', 'NimrodMajor', + 'NimrodMinor', 'NimrodPatch', 'CpuEndian', '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', 'NHint', 'NWarning', 'NError' + //[[[end]]] + ); + +const + GenericTypes: TTypeKinds = {@set}[tyGeneric, 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, 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; + +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 ------------------------------------- +const + IntsPerTrunk = 8; + InitIntSetSize = 8; // must be a power of two! + BitsPerTrunk = IntsPerTrunk * sizeof(int) * 8; + BitsPerInt = sizeof(int) * 8; + +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 int; // 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 IntSetInit(var s: TIntSet); + +function IntSetContainsOrIncl(var s: TIntSet; key: int): bool; + + +const + debugIds = false; + +procedure registerID(id: PIdObj); + +// owner handling: +function getCurrOwner(): PSym; +procedure PushOwner(owner: PSym); +procedure PopOwner; + +implementation + +var + gOwners: array of PSym; // owner stack (used for initializing the + // owner field of syms) + // the documentation comment always gets + // assigned to the current owner + // BUGFIX: global array is needed! +{@emit gOwners := @[]; } + +function getCurrOwner(): PSym; +begin + result := gOwners[high(gOwners)]; +end; + +procedure PushOwner(owner: PSym); +var + len: int; +begin + len := length(gOwners); + setLength(gOwners, len+1); + gOwners[len] := owner; +end; + +procedure PopOwner; +var + len: int; +begin + len := length(gOwners); + if (len <= 0) then InternalError('popOwner'); + setLength(gOwners, len - 1); +end; + +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); } +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 transform(key: int): int; +begin + if key < 0 then result := 1000000000 + key // avoid negative numbers! + else result := key +end; + +function IntSetContains(const s: TIntSet; key: int): bool; +var + u: int; + t: PTrunk; +begin + u := transform(key); + t := IntSetGet(s, u div BitsPerTrunk); + if t <> nil then begin + u := u mod BitsPerTrunk; + result := (t.bits[u div BitsPerInt] + and (1 shl (u mod BitsPerInt))) <> 0 + end + else + result := false +end; + +procedure IntSetIncl(var s: TIntSet; key: int); +var + u: int; + t: PTrunk; +begin + u := transform(key); + t := IntSetPut(s, u div BitsPerTrunk); + u := u mod BitsPerTrunk; + t.bits[u div BitsPerInt] := t.bits[u div BitsPerInt] + or (1 shl (u mod BitsPerInt)); +end; + +function IntSetContainsOrIncl(var s: TIntSet; key: int): bool; +var + u: int; + t: PTrunk; +begin + u := transform(key); + t := IntSetGet(s, u div BitsPerTrunk); + if t <> nil then begin + u := u mod BitsPerTrunk; + result := (t.bits[u div BitsPerInt] + and (1 shl (u mod BitsPerInt))) <> 0; + if not result then + t.bits[u div BitsPerInt] := t.bits[u div BitsPerInt] + or (1 shl (u mod BitsPerInt)); + end + else begin + IntSetIncl(s, key); + result := false + end +end; + + +initialization + if debugIDs then IntSetInit(usedIds); +end. diff --git a/nim/astalgo.pas b/nim/astalgo.pas index a7ee3fc83..ddd646efb 100644 --- a/nim/astalgo.pas +++ b/nim/astalgo.pas @@ -133,7 +133,8 @@ procedure debug(n: PNode); overload; // --------------------------- ident tables ---------------------------------- -function IdTableGet(const t: TIdTable; key: PIdObj): PObject; +function IdTableGet(const t: TIdTable; key: PIdObj): PObject; overload; +function IdTableGet(const t: TIdTable; key: int): PObject; overload; procedure IdTablePut(var t: TIdTable; key: PIdObj; val: PObject); function IdTableHasObjectAsKey(const t: TIdTable; key: PIdObj): bool; @@ -145,33 +146,6 @@ procedure IdNodeTablePut(var t: TIdNodeTable; key: PIdObj; val: PNode); procedure writeIdNodeTable(const t: TIdNodeTable); -// ------------- efficient integer sets ------------------------------------- -const - IntsPerTrunk = 8; - InitIntSetSize = 8; // must be a power of two! - BitsPerTrunk = IntsPerTrunk * sizeof(int) * 8; - BitsPerInt = sizeof(int) * 8; - -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 int; // 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 IntSetInit(var s: TIntSet); - -function IntSetContainsOrIncl(var s: TIntSet; key: int): bool; - // --------------------------------------------------------------------------- function getSymFromList(list: PNode; ident: PIdent; start: int = 0): PSym; function lookupInRecord(n: PNode; field: PIdent): PSym; @@ -181,6 +155,24 @@ function getModule(s: PSym): PSym; function mustRehash(len, counter: int): bool; function nextTry(h, maxHash: THash): THash; +// ------------- table[int, int] --------------------------------------------- +const + InvalidKey = low(int); + +type + TIIPair = record + key, val: int; + end; + TIIPairSeq = array of TIIPair; + TIITable = record // table[int, int] + counter: int; + data: TIIPairSeq; + end; + +procedure initIITable(out x: TIITable); +function IITableGet(const t: TIITable; key: int): int; +procedure IITablePut(var t: TIITable; key, val: int); + implementation function lookupInRecord(n: PNode; field: PIdent): PSym; @@ -281,14 +273,14 @@ begin result := nil; res := '"' + ''; for i := strStart to length(s)+strStart-1 do begin - if i mod MaxLineLength = 0 then begin + if (i-strStart+1) mod MaxLineLength = 0 then begin res := res +{&} '"' +{&} nl; app(result, toRope(res)); res := '"'+''; // reset end; res := res +{&} toYamlChar(s[i]); end; - res := res + '"'; + addChar(res, '"'); app(result, toRope(res)); end; @@ -349,16 +341,16 @@ begin toRope(toLinenumber(info)), toRope(toColumn(info))]); end; -function treeToYamlAux(n: PNode; var marker: TObjectSet; +function treeToYamlAux(n: PNode; var marker: TIntSet; indent: int; maxRecDepth: int): PRope; forward; -function symToYamlAux(n: PSym; var marker: TObjectSet; +function symToYamlAux(n: PSym; var marker: TIntSet; indent: int; maxRecDepth: int): PRope; forward; -function typeToYamlAux(n: PType; var marker: TObjectSet; +function typeToYamlAux(n: PType; var marker: TIntSet; indent: int; maxRecDepth: int): PRope; forward; -function strTableToYaml(const n: TStrTable; var marker: TObjectSet; +function strTableToYaml(const n: TStrTable; var marker: TIntSet; indent: int; maxRecDepth: int): PRope; var istr: PRope; @@ -396,14 +388,14 @@ begin appf(result, '$n$1}', [spaces(indent)]); end; -function symToYamlAux(n: PSym; var marker: TObjectSet; +function symToYamlAux(n: PSym; var marker: TIntSet; indent: int; maxRecDepth: int): PRope; var ast: PRope; begin if n = nil then result := toRope('null') - else if ObjectSetContainsOrIncl(marker, n) then + else if IntSetContainsOrIncl(marker, n.id) then result := ropef('"$1 @$2"', [ toRope(n.name.s), toRope(strutils.toHex({@cast}TAddress(n), sizeof(n)*2))]) @@ -424,12 +416,12 @@ begin // YYY: backend info? end; -function typeToYamlAux(n: PType; var marker: TObjectSet; +function typeToYamlAux(n: PType; var marker: TIntSet; indent: int; maxRecDepth: int): PRope; begin if n = nil then result := toRope('null') - else if objectSetContainsOrIncl(marker, n) then + else if intSetContainsOrIncl(marker, n.id) then result := ropef('"$1 @$2"', [ toRope(typeKindToStr[n.kind]), toRope(strutils.toHex({@cast}TAddress(n), sizeof(n)*2))]) @@ -446,7 +438,7 @@ begin end end; -function treeToYamlAux(n: PNode; var marker: TObjectSet; indent: int; +function treeToYamlAux(n: PNode; var marker: TIntSet; indent: int; maxRecDepth: int): PRope; var istr: PRope; @@ -503,25 +495,25 @@ end; function treeToYaml(n: PNode; indent: int = 0; maxRecDepth: int = -1): PRope; var - marker: TObjectSet; + marker: TIntSet; begin - initObjectSet(marker); + IntSetInit(marker); result := treeToYamlAux(n, marker, indent, maxRecDepth) end; function typeToYaml(n: PType; indent: int = 0; maxRecDepth: int = -1): PRope; var - marker: TObjectSet; + marker: TIntSet; begin - initObjectSet(marker); + IntSetInit(marker); result := typeToYamlAux(n, marker, indent, maxRecDepth) end; function symToYaml(n: PSym; indent: int = 0; maxRecDepth: int = -1): PRope; var - marker: TObjectSet; + marker: TIntSet; begin - initObjectSet(marker); + IntSetInit(marker); result := symToYamlAux(n, marker, indent, maxRecDepth) end; @@ -617,7 +609,7 @@ const EmptySeq = nil; {@emit const - EmptySeq = []; + EmptySeq = @[]; } function nextTry(h, maxHash: THash): THash; @@ -661,11 +653,12 @@ var n: TObjectSeq; i: int; begin +{@ignore} n := emptySeq; setLength(n, length(t.data) * growthFactor); -{@ignore} fillChar(n[0], length(n)*sizeof(n[0]), 0); -{@emit} +{@emit + newSeq(n, length(t.data) * growthFactor); } for i := 0 to high(t.data) do if t.data[i] <> nil then objectSetRawInsert(n, t.data[i]); {@ignore} @@ -769,11 +762,12 @@ var n: TPairSeq; i: int; begin +{@ignore} n := emptySeq; setLength(n, length(t.data) * growthFactor); -{@ignore} fillChar(n[0], length(n)*sizeof(n[0]), 0); -{@emit} +{@emit + newSeq(n, length(t.data) * growthFactor); } for i := 0 to high(t.data) do if t.data[i].key <> nil then TableRawInsert(n, t.data[i].key, t.data[i].val); @@ -833,11 +827,12 @@ var n: TSymSeq; i: int; begin +{@ignore} n := emptySeq; setLength(n, length(t.data) * growthFactor); -{@ignore} fillChar(n[0], length(n)*sizeof(n[0]), 0); -{@emit} +{@emit + newSeq(n, length(t.data) * growthFactor); } for i := 0 to high(t.data) do if t.data[i] <> nil then StrTableRawInsert(n, t.data[i]); {@ignore} @@ -1022,13 +1017,13 @@ begin result := false end; -function IdTableRawGet(const t: TIdTable; key: PIdObj): int; +function IdTableRawGet(const t: TIdTable; key: int): int; var h: THash; begin - h := key.id and high(t.data); // start with real hash value + h := key and high(t.data); // start with real hash value while t.data[h].key <> nil do begin - if (t.data[h].key.id = key.id) then begin + if (t.data[h].key.id = key) then begin result := h; exit end; h := nextTry(h, high(t.data)) @@ -1040,7 +1035,7 @@ function IdTableHasObjectAsKey(const t: TIdTable; key: PIdObj): bool; var index: int; begin - index := IdTableRawGet(t, key); + index := IdTableRawGet(t, key.id); if index >= 0 then result := t.data[index].key = key else result := false end; @@ -1049,6 +1044,15 @@ function IdTableGet(const t: TIdTable; key: PIdObj): PObject; var index: int; begin + index := IdTableRawGet(t, key.id); + if index >= 0 then result := t.data[index].val + else result := nil +end; + +function IdTableGet(const t: TIdTable; key: int): PObject; +var + index: int; +begin index := IdTableRawGet(t, key); if index >= 0 then result := t.data[index].val else result := nil @@ -1074,18 +1078,18 @@ var index, i: int; n: TIdPairSeq; begin - index := IdTableRawGet(t, key); + index := IdTableRawGet(t, key.id); if index >= 0 then begin assert(t.data[index].key <> nil); t.data[index].val := val end else begin if mustRehash(length(t.data), t.counter) then begin - {@emit n := [];} - setLength(n, length(t.data) * growthFactor); {@ignore} + setLength(n, length(t.data) * growthFactor); fillChar(n[0], length(n)*sizeof(n[0]), 0); - {@emit} + {@emit + newSeq(n, length(t.data) * growthFactor); } for i := 0 to high(t.data) do if t.data[i].key <> nil then IdTableRawInsert(n, t.data[i].key, t.data[i].val); @@ -1166,11 +1170,11 @@ begin end else begin if mustRehash(length(t.data), t.counter) then begin - {@emit n := [];} - setLength(n, length(t.data) * growthFactor); {@ignore} + setLength(n, length(t.data) * growthFactor); fillChar(n[0], length(n)*sizeof(n[0]), 0); - {@emit} + {@emit + newSeq(n, length(t.data) * growthFactor); } for i := 0 to high(t.data) do if t.data[i].key <> nil then IdNodeTableRawInsert(n, t.data[i].key, t.data[i].val); @@ -1185,156 +1189,86 @@ begin end; end; -// ---------------- efficient integer sets ---------------------------------- -// Same algorithm as the one the GC uses +// ------------- int-to-int-mapping ------------------------------------------ -procedure IntSetInit(var s: TIntSet); +procedure initIITable(out x: TIITable); +var + i: int; begin + x.counter := 0; {@ignore} - fillChar(s, sizeof(s), 0); + setLength(x.data, startSize); {@emit - s.data := []; } - setLength(s.data, InitIntSetSize); -{@ignore} - fillChar(s.data[0], length(s.data)*sizeof(s.data[0]), 0); -{@emit} - s.max := InitIntSetSize-1; - s.counter := 0; - s.head := nil + newSeq(x.data, startSize); } + for i := 0 to startSize-1 do x.data[i].key := InvalidKey; end; -function IntSetGet(const t: TIntSet; key: int): PTrunk; +function IITableRawGet(const t: TIITable; key: int): int; var - h: int; + h: THash; 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 + h := key and high(t.data); // start with real hash value + while t.data[h].key <> InvalidKey do begin + if (t.data[h].key = key) then begin + result := 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) + h := nextTry(h, high(t.data)) end; - assert(data[h] = nil); - data[h] := desc + result := -1 end; -procedure IntSetEnlarge(var t: TIntSet); +function IITableGet(const t: TIITable; key: int): int; var - n: TTrunkSeq; - i, oldMax: int; + index: int; begin - oldMax := t.max; - t.max := ((t.max+1)*2)-1; - {@emit n := []} - setLength(n, t.max + 1); -{@ignore} - fillChar(n[0], length(n)*sizeof(n[0]), 0); -{@emit} - 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); -} + index := IITableRawGet(t, key); + if index >= 0 then result := t.data[index].val + else result := InvalidKey end; -function IntSetPut(var t: TIntSet; key: int): PTrunk; +procedure IITableRawInsert(var data: TIIPairSeq; + key, val: int); var - h: int; + h: THash; 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) + h := key and high(data); + while data[h].key <> InvalidKey do begin + assert(data[h].key <> key); + h := nextTry(h, high(data)) 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 transform(key: int): int; -begin - if key < 0 then result := 1000000000 + key // avoid negative numbers! - else result := key -end; - -function IntSetContains(const s: TIntSet; key: int): bool; -var - u: int; - t: PTrunk; -begin - u := transform(key); - t := IntSetGet(s, u div BitsPerTrunk); - if t <> nil then begin - u := u mod BitsPerTrunk; - result := (t.bits[u div BitsPerInt] - and (1 shl (u mod BitsPerInt))) <> 0 - end - else - result := false + assert(data[h].key = InvalidKey); + data[h].key := key; + data[h].val := val; end; -procedure IntSetIncl(var s: TIntSet; key: int); +procedure IITablePut(var t: TIITable; key, val: int); var - u: int; - t: PTrunk; + index, i: int; + n: TIIPairSeq; begin - u := transform(key); - t := IntSetPut(s, u div BitsPerTrunk); - u := u mod BitsPerTrunk; - t.bits[u div BitsPerInt] := t.bits[u div BitsPerInt] - or (1 shl (u mod BitsPerInt)); -end; - -function IntSetContainsOrIncl(var s: TIntSet; key: int): bool; -var - u: int; - t: PTrunk; -begin - u := transform(key); - t := IntSetGet(s, u div BitsPerTrunk); - if t <> nil then begin - u := u mod BitsPerTrunk; - result := (t.bits[u div BitsPerInt] - and (1 shl (u mod BitsPerInt))) <> 0; - if not result then - t.bits[u div BitsPerInt] := t.bits[u div BitsPerInt] - or (1 shl (u mod BitsPerInt)); + index := IITableRawGet(t, key); + if index >= 0 then begin + assert(t.data[index].key <> InvalidKey); + t.data[index].val := val end else begin - IntSetIncl(s, key); - result := false - end + if mustRehash(length(t.data), t.counter) then begin + {@ignore} + setLength(n, length(t.data) * growthFactor); + {@emit + newSeq(n, length(t.data) * growthFactor); } + for i := 0 to high(n) do n[i].key := InvalidKey; + for i := 0 to high(t.data) do + if t.data[i].key <> InvalidKey then + IITableRawInsert(n, t.data[i].key, t.data[i].val); + {@ignore} + t.data := n; + {@emit + swap(t.data, n); } + end; + IITableRawInsert(t.data, key, val); + inc(t.counter) + end; end; end. diff --git a/nim/backends.pas b/nim/backends.pas deleted file mode 100644 index e1ac616e9..000000000 --- a/nim/backends.pas +++ /dev/null @@ -1,59 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2008 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit backends; - -// This module only contains the PBackend type declaration/interface, each -// backend has to adhere to. - -interface - -{$include 'config.inc'} - -uses - nsystem, idents, ropes, msgs, ast; - -type - PBackend = ^TBackend; - - TBackendEvent = (eNone, eAfterModule); - TEventMask = set of TBackendEvent; - TBackend = object(NObject) - eventMask: TEventMask; - module: PSym; - filename: string; - backendCreator: function (oldBackend: PBackend; module: PSym; - const filename: string): PBackend; - afterModuleEvent: procedure (b: PBackend; module: PNode); - // triggered AFTER a whole module has been checked for semantics - end; - -function backendCreator(b: PBackend; module: PSym; - const filename: string): PBackend; -function newBackend(module: PSym; const filename: string): PBackend; - -implementation - -function newBackend(module: PSym; const filename: string): PBackend; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.backendCreator := backendCreator; - result.module := module; - result.filename := filename; -end; - -function backendCreator(b: PBackend; module: PSym; - const filename: string): PBackend; -begin - result := newBackend(module, filename); -end; - -end. diff --git a/nim/bitsets.pas b/nim/bitsets.pas index ba039a786..78c6d1f36 100644 --- a/nim/bitsets.pas +++ b/nim/bitsets.pas @@ -8,7 +8,7 @@ // unit bitsets; -// this unit handles Nimrod sets; it implements symbolic sets +// this unit handles Nimrod sets; it implements bit sets // the code here should be reused in the Nimrod standard library interface @@ -44,57 +44,58 @@ implementation function BitSetIn(const x: TBitSet; const e: BiggestInt): Boolean; begin - result := (x[int(e div ElemSize)] and (1 shl (e mod ElemSize))) <> 0 + result := (x[int(e div ElemSize)] and toU8(int(1 shl (e mod ElemSize)))) <> toU8(0) end; procedure BitSetIncl(var x: TBitSet; const elem: BiggestInt); begin assert(elem >= 0); - x[int(elem div ElemSize)] := toU8(x[int(elem div ElemSize)] or - int(1 shl (elem mod ElemSize))) + x[int(elem div ElemSize)] := x[int(elem div ElemSize)] or + toU8(int(1 shl (elem mod ElemSize))) end; procedure BitSetExcl(var x: TBitSet; const elem: BiggestInt); begin - x[int(elem div ElemSize)] := toU8(x[int(elem div ElemSize)] and - not int(1 shl (elem mod ElemSize))) + x[int(elem div ElemSize)] := x[int(elem div ElemSize)] and + not toU8(int(1 shl (elem mod ElemSize))) end; procedure BitSetInit(out b: TBitSet; len: int); begin - {@emit b := [];} - setLength(b, len); {@ignore} + setLength(b, len); fillChar(b[0], length(b)*sizeof(b[0]), 0); -{@emit} +{@emit + newSeq(b, len); +} end; procedure BitSetUnion(var x: TBitSet; const y: TBitSet); var i: int; begin - for i := 0 to high(x) do x[i] := toU8(x[i] or int(y[i])) + for i := 0 to high(x) do x[i] := x[i] or y[i] end; procedure BitSetDiff(var x: TBitSet; const y: TBitSet); var i: int; begin - for i := 0 to high(x) do x[i] := toU8(x[i] and not int(y[i])) + for i := 0 to high(x) do x[i] := x[i] and not y[i] end; procedure BitSetSymDiff(var x: TBitSet; const y: TBitSet); var i: int; begin - for i := 0 to high(x) do x[i] := toU8(x[i] xor int(y[i])) + for i := 0 to high(x) do x[i] := x[i] xor y[i] end; procedure BitSetIntersect(var x: TBitSet; const y: TBitSet); var i: int; begin - for i := 0 to high(x) do x[i] := toU8(x[i] and int(y[i])) + for i := 0 to high(x) do x[i] := x[i] and y[i] end; function BitSetEquals(const x, y: TBitSet): Boolean; @@ -102,7 +103,7 @@ var i: int; begin for i := 0 to high(x) do - if (x[i] <> int(y[i])) then begin + if x[i] <> y[i] then begin result := false; exit; end; result := true @@ -113,7 +114,7 @@ var i: int; begin for i := 0 to high(x) do - if (x[i] and not int(y[i])) <> 0 then begin + if (x[i] and not y[i]) <> byte(0) then begin result := false; exit; end; result := true diff --git a/nim/ccgexprs.pas b/nim/ccgexprs.pas index 7668f114a..97828680b 100644 --- a/nim/ccgexprs.pas +++ b/nim/ccgexprs.pas @@ -24,7 +24,7 @@ end; function int32Literal(i: Int): PRope; begin - if i = low(int32) then + if i = int(low(int32)) then // Nimrod has the same bug for the same reasons :-) result := toRope('(-2147483647 -1)') else @@ -32,7 +32,7 @@ begin end; function genHexLiteral(v: PNode): PRope; -// in C hex literals are unsigned (at least I think so) +// hex literals are unsigned in C (at least I think so) // so we don't generate hex literals any longer. begin if not (v.kind in [nkIntLit..nkInt64Lit]) then @@ -42,15 +42,16 @@ end; function getStrLit(m: BModule; const s: string): PRope; begin - inc(gunique); - result := con('Str', toRope(gunique)); + useMagic(m, 'TGenericSeq'); + result := con('TMP', toRope(getID())); appf(m.s[cfsData], 'STRING_LITERAL($1, $2, $3);$n', - [result, makeCString(s), ToRope(length(s))]) + [result, makeCString(s), ToRope(length(s))]); end; function genLiteral(p: BProc; v: PNode; ty: PType): PRope; overload; var f: biggestFloat; + id: int; begin if ty = nil then internalError(v.info, 'genLiteral: ty is nil'); case v.kind of @@ -75,8 +76,18 @@ begin nkNilLit: result := toRope('0'+''); nkStrLit..nkTripleStrLit: begin - if skipVarGenericRange(ty).kind = tyString then - result := ropef('((string) &$1)', [getStrLit(p.module, v.strVal)]) + if skipVarGenericRange(ty).kind = tyString then begin + id := NodeTableTestOrSet(p.module.dataCache, v, gid); + if id = gid then begin + // string literal not found in the cache: + useMagic(p.module, 'NimStringDesc'); + result := ropef('((NimStringDesc*) &$1)', + [getStrLit(p.module, v.strVal)]) + end + else + result := ropef('((NimStringDesc*) &TMP$1)', + [toRope(id)]); + end else result := makeCString(v.strVal) end; @@ -138,21 +149,27 @@ begin end end else - result := toRope('0x' + ToHex(bitSetToWord(cs, size), size * 2)) + result := intLiteral(bitSetToWord(cs, size)) + // result := toRope('0x' + ToHex(bitSetToWord(cs, size), size * 2)) end; function genSetNode(p: BProc; n: PNode): PRope; var cs: TBitSet; - size: int; + size, id: int; begin size := int(getSize(n.typ)); toBitSet(n, cs); if size > 8 then begin - result := getTempName(); - appf(p.module.s[cfsData], - 'static NIM_CONST $1 $2 = $3;', - [getTypeDesc(p.module, n.typ), result, genRawSetData(cs, size)]) + id := NodeTableTestOrSet(p.module.dataCache, n, gid); + result := con('TMP', toRope(id)); + if id = gid then begin + // not found in cache: + inc(gid); + appf(p.module.s[cfsData], + 'static NIM_CONST $1 $2 = $3;', + [getTypeDesc(p.module, n.typ), result, genRawSetData(cs, size)]) + end end else result := genRawSetData(cs, size) @@ -209,15 +226,48 @@ begin result := ropef('((NU8)($1))', [result]) end; -procedure genRefAssign(p: BProc; const dest, src: TLoc); +type + TAssignmentFlag = (needToCopy, needForSubtypeCheck, + afDestIsNil, afDestIsNotNil, + afSrcIsNil, afSrcIsNotNil); + TAssignmentFlags = set of TAssignmentFlag; + +procedure genRefAssign(p: BProc; const dest, src: TLoc; + flags: TAssignmentFlags); begin if (dest.s = OnStack) or not (optRefcGC in gGlobalOptions) then // location is on hardware stack appf(p.s[cpsStmts], '$1 = $2;$n', [rdLoc(dest), rdLoc(src)]) else if dest.s = OnHeap then begin // location is on heap - UseMagic(p.module, 'asgnRef'); - appf(p.s[cpsStmts], 'asgnRef((void**) $1, $2);$n', - [addrLoc(dest), rdLoc(src)]) + // now the writer barrier is inlined for performance: + (* + if afSrcIsNotNil in flags then begin + UseMagic(p.module, 'nimGCref'); + appf(p.s[cpsStmts], 'nimGCref($1);$n', [rdLoc(src)]); + end + else if not (afSrcIsNil in flags) then begin + UseMagic(p.module, 'nimGCref'); + appf(p.s[cpsStmts], 'if ($1) nimGCref($1);$n', [rdLoc(src)]); + end; + if afDestIsNotNil in flags then begin + UseMagic(p.module, 'nimGCunref'); + appf(p.s[cpsStmts], 'nimGCunref($1);$n', [rdLoc(dest)]); + end + else if not (afDestIsNil in flags) then begin + UseMagic(p.module, 'nimGCunref'); + appf(p.s[cpsStmts], 'if ($1) nimGCunref($1);$n', [rdLoc(dest)]); + end; + appf(p.s[cpsStmts], '$1 = $2;$n', [rdLoc(dest), rdLoc(src)]); *) + if canFormAcycle(dest.t) then begin + UseMagic(p.module, 'asgnRef'); + appf(p.s[cpsStmts], 'asgnRef((void**) $1, $2);$n', + [addrLoc(dest), rdLoc(src)]) + end + else begin + UseMagic(p.module, 'asgnRefNoCycle'); + appf(p.s[cpsStmts], 'asgnRefNoCycle((void**) $1, $2);$n', + [addrLoc(dest), rdLoc(src)]) + end end else begin UseMagic(p.module, 'unsureAsgnRef'); @@ -226,10 +276,6 @@ begin end end; -type - TAssignmentFlag = (needToCopy, needForSubtypeCheck); - TAssignmentFlags = set of TAssignmentFlag; - procedure genAssignment(p: BProc; const dest, src: TLoc; flags: TAssignmentFlags); overload; // This function replaces all other methods for generating @@ -240,10 +286,10 @@ begin; ty := skipVarGenericRange(dest.t); case ty.kind of tyRef: - genRefAssign(p, dest, src); + genRefAssign(p, dest, src, flags); tySequence: begin if not (needToCopy in flags) then - genRefAssign(p, dest, src) + genRefAssign(p, dest, src, flags) else begin useMagic(p.module, 'genericSeqAssign'); // BUGFIX appf(p.s[cpsStmts], 'genericSeqAssign($1, $2, $3);$n', @@ -252,16 +298,16 @@ begin; end; tyString: begin if not (needToCopy in flags) then - genRefAssign(p, dest, src) + genRefAssign(p, dest, src, flags) else begin useMagic(p.module, 'copyString'); if (dest.s = OnStack) or not (optRefcGC in gGlobalOptions) then appf(p.s[cpsStmts], '$1 = copyString($2);$n', [rdLoc(dest), rdLoc(src)]) else if dest.s = OnHeap then begin - useMagic(p.module, 'asgnRef'); + useMagic(p.module, 'asgnRefNoCycle'); useMagic(p.module, 'copyString'); // BUGFIX - appf(p.s[cpsStmts], 'asgnRef((void**) $1, copyString($2));$n', + appf(p.s[cpsStmts], 'asgnRefNoCycle((void**) $1, copyString($2));$n', [addrLoc(dest), rdLoc(src)]) end else begin @@ -337,15 +383,15 @@ end; procedure expr(p: BProc; e: PNode; var d: TLoc); forward; -function initLocExpr(p: BProc; e: PNode): TLoc; +procedure initLocExpr(p: BProc; e: PNode; var result: TLoc); begin - result := initLoc(locNone, getUniqueType(e.typ), OnUnknown); + initLoc(result, locNone, getUniqueType(e.typ), OnUnknown); expr(p, e, result) end; procedure getDestLoc(p: BProc; var d: TLoc; typ: PType); begin - if d.k = locNone then d := getTemp(p, typ) + if d.k = locNone then getTemp(p, typ, d) end; procedure putLocIntoDest(p: BProc; var d: TLoc; const s: TLoc); @@ -364,7 +410,7 @@ var a: TLoc; begin if d.k <> locNone then begin // need to generate an assignment here - a := initLoc(locExpr, getUniqueType(t), OnUnknown); + initLoc(a, locExpr, getUniqueType(t), OnUnknown); a.r := r; if lfNoDeepCopy in d.flags then genAssignment(p, d, a, {@set}[]) @@ -387,13 +433,25 @@ var begin if (d.k <> locNone) then InternalError(e.info, 'binaryStmt'); if magic <> '' then useMagic(p.module, magic); - a := InitLocExpr(p, e.sons[1]); - b := InitLocExpr(p, e.sons[2]); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); appf(p.s[cpsStmts], frmt, [rdLoc(a), rdLoc(b)]); freeTemp(p, a); freeTemp(p, b) end; +procedure unaryStmt(p: BProc; e: PNode; var d: TLoc; + const magic, frmt: string); +var + a: TLoc; +begin + if (d.k <> locNone) then InternalError(e.info, 'unaryStmt'); + if magic <> '' then useMagic(p.module, magic); + InitLocExpr(p, e.sons[1], a); + appf(p.s[cpsStmts], frmt, [rdLoc(a)]); + freeTemp(p, a); +end; + procedure binaryStmtChar(p: BProc; e: PNode; var d: TLoc; const magic, frmt: string); var @@ -401,8 +459,8 @@ var begin if (d.k <> locNone) then InternalError(e.info, 'binaryStmtChar'); if magic <> '' then useMagic(p.module, magic); - a := InitLocExpr(p, e.sons[1]); - b := InitLocExpr(p, e.sons[2]); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); appf(p.s[cpsStmts], frmt, [rdCharLoc(a), rdCharLoc(b)]); freeTemp(p, a); freeTemp(p, b) @@ -416,9 +474,10 @@ begin if magic <> '' then useMagic(p.module, magic); assert(e.sons[1].typ <> nil); assert(e.sons[2].typ <> nil); - a := InitLocExpr(p, e.sons[1]); - b := InitLocExpr(p, e.sons[2]); - putIntoDest(p, d, e.typ, ropef(frmt, [rdLoc(a), rdLoc(b)])); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); + putIntoDest(p, d, e.typ, + ropef(frmt, [rdLoc(a), rdLoc(b), getTypeDesc(p.module, e.typ)])); if d.k <> locExpr then begin // BACKPORT freeTemp(p, a); freeTemp(p, b) @@ -433,8 +492,8 @@ begin if magic <> '' then useMagic(p.module, magic); assert(e.sons[1].typ <> nil); assert(e.sons[2].typ <> nil); - a := InitLocExpr(p, e.sons[1]); - b := InitLocExpr(p, e.sons[2]); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); putIntoDest(p, d, e.typ, ropef(frmt, [rdCharLoc(a), rdCharLoc(b)])); if d.k <> locExpr then begin // BACKPORT freeTemp(p, a); @@ -448,8 +507,9 @@ var a: TLoc; begin if magic <> '' then useMagic(p.module, magic); - a := InitLocExpr(p, e.sons[1]); - putIntoDest(p, d, e.typ, ropef(frmt, [rdLoc(a)])); + InitLocExpr(p, e.sons[1], a); + putIntoDest(p, d, e.typ, ropef(frmt, + [rdLoc(a), getTypeDesc(p.module, e.typ)])); if d.k <> locExpr then // BACKPORT freeTemp(p, a) end; @@ -460,7 +520,7 @@ var a: TLoc; begin if magic <> '' then useMagic(p.module, magic); - a := InitLocExpr(p, e.sons[1]); + InitLocExpr(p, e.sons[1], a); putIntoDest(p, d, e.typ, ropef(frmt, [rdCharLoc(a)])); if d.k <> locExpr then // BACKPORT freeTemp(p, a) @@ -472,15 +532,16 @@ const 'addInt64', 'subInt64', 'mulInt64', 'divInt64', 'modInt64' ); binWoOverflowTab: array [mAddi..mModi64] of string = ( - '($1 + $2)', '($1 - $2)', '($1 * $2)', '($1 / $2)', '($1 % $2)', + '($3)($1 + $2)', '($3)($1 - $2)', '($3)($1 * $2)', '($3)($1 / $2)', + '($3)($1 % $2)', '($1 + $2)', '($1 - $2)', '($1 * $2)', '($1 / $2)', '($1 % $2)' ); binArithTab: array [mShrI..mXor] of string = ( - '(NI)((NU)($1) >> (NU)($2))', // ShrI - '(NI)((NU)($1) << (NU)($2))', // ShlI - '($1 & $2)', // BitandI - '($1 | $2)', // BitorI - '($1 ^ $2)', // BitxorI + '($3)((NU)($1) >> (NU)($2))', // ShrI + '($3)((NU)($1) << (NU)($2))', // ShlI + '($3)($1 & $2)', // BitandI + '($3)($1 | $2)', // BitorI + '($3)($1 ^ $2)', // BitxorI '(($1 <= $2) ? $1 : $2)', // MinI '(($1 >= $2) ? $1 : $2)', // MaxI '(NI64)((NU64)($1) >> (NU64)($2))', // ShrI64 @@ -498,11 +559,11 @@ const '(($1 <= $2) ? $1 : $2)', // MinF64 '(($1 >= $2) ? $1 : $2)', // MaxF64 - '(NI)((NU)($1) + (NU)($2))', // AddU - '(NI)((NU)($1) - (NU)($2))', // SubU - '(NI)((NU)($1) * (NU)($2))', // MulU - '(NI)((NU)($1) / (NU)($2))', // DivU - '(NI)((NU)($1) % (NU)($2))', // ModU + '($3)((NU)($1) + (NU)($2))', // AddU + '($3)((NU)($1) - (NU)($2))', // SubU + '($3)((NU)($1) * (NU)($2))', // MulU + '($3)((NU)($1) / (NU)($2))', // DivU + '($3)((NU)($1) % (NU)($2))', // ModU '(NI64)((NU64)($1) + (NU64)($2))', // AddU64 '(NI64)((NU64)($1) - (NU64)($2))', // SubU64 '(NI64)((NU64)($1) * (NU64)($2))', // MulU64 @@ -545,8 +606,8 @@ const ); unArithTab: array [mNot..mToBiggestInt] of string = ( '!($1)', // Not - '+($1)', // UnaryPlusI - '~($1)', // BitnotI + '$1', // UnaryPlusI + '(($2) ~($1))', // BitnotI '+($1)', // UnaryPlusI64 '~($1)', // BitnotI64 '+($1)', // UnaryPlusF64 @@ -576,9 +637,9 @@ const 'absInt64' // AbsI64 ); unWoOverflowTab: array [mUnaryMinusI..mAbsI64] of string = ( - '-($1)', // UnaryMinusI + '(($2)-($1))', // UnaryMinusI '-($1)', // UnaryMinusI64 - 'abs($1)', // AbsI + '($2)abs($1)', // AbsI '($1 > 0? ($1) : -($1))' // AbsI64 ); @@ -588,11 +649,38 @@ begin end; procedure binaryArithOverflow(p: BProc; e: PNode; var d: TLoc; op: TMagic); +var + a, b: TLoc; begin - if optOverflowCheck in p.options then - binaryExpr(p, e, d, binOverflowTab[op], binOverflowTab[op] + '($1, $2)') - else + if not (optOverflowCheck in p.options) then binaryExpr(p, e, d, '', binWoOverflowTab[op]) + else begin + case op of + mAddi..mModi: begin + if (skipGeneric(e.typ).kind = tyInt) then + binaryExpr(p, e, d, binOverflowTab[op], + binOverflowTab[op] + '($1, $2)') + else begin + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); + UseMagic(p.module, binOverflowTab[op]); + UseMagic(p.module, 'raiseOverflow'); + a.r := ropef(binOverflowTab[op] + '($1, $2)', + [rdLoc(a), rdLoc(b)]); + if d.k = locNone then getTemp(p, getSysType(tyInt), d); + genAssignment(p, d, a, {@set}[]); + appf(p.s[cpsStmts], 'if ($1 < $2 || $1 > $3) raiseOverflow();$n', + [rdLoc(d), intLiteral(firstOrd(e.typ)), + intLiteral(lastOrd(e.typ))]); + d.t := e.typ; + d.r := ropef('($1)($2)', [getTypeDesc(p.module, e.typ), rdLoc(d)]); + end + end; + mAddi64..mModi64: + binaryExpr(p, e, d, binOverflowTab[op], binOverflowTab[op] + '($1, $2)'); + else InternalError(e.info, 'binaryArithOverflow'); + end + end end; procedure unaryArith(p: BProc; e: PNode; var d: TLoc; op: TMagic); @@ -603,7 +691,7 @@ end; procedure unaryArithOverflow(p: BProc; e: PNode; var d: TLoc; op: TMagic); begin if optOverflowCheck in p.options then - unaryExpr(p, e, d, unOverflowTab[op], unOverflowTab[op] + '($1)') + unaryExpr(p, e, d, unOverflowTab[op], '($2)' + unOverflowTab[op] + '($1)') else unaryExpr(p, e, d, '', unWoOverflowTab[op]) end; @@ -615,7 +703,7 @@ begin if mapType(e.sons[0].typ) = ctArray then expr(p, e.sons[0], d) else begin - a := initLocExpr(p, e.sons[0]); + initLocExpr(p, e.sons[0], a); case skipGeneric(a.t).kind of tyRef: d.s := OnHeap; tyVar: d.s := OnUnknown; @@ -633,7 +721,7 @@ begin if mapType(e.sons[0].typ) = ctArray then expr(p, e.sons[0], d) else begin - a := InitLocExpr(p, e.sons[0]); + InitLocExpr(p, e.sons[0], a); putIntoDest(p, d, e.typ, addrLoc(a)); if d.k <> locExpr then freeTemp(p, a) end @@ -641,7 +729,7 @@ end; function genRecordFieldAux(p: BProc; e: PNode; var d, a: TLoc): PType; begin - a := initLocExpr(p, e.sons[0]); + initLocExpr(p, e.sons[0], a); if (e.sons[1].kind <> nkSym) then InternalError(e.info, 'genRecordFieldAux'); if d.k = locNone then d.s := a.s; {@discard} getTypeDesc(p.module, a.t); // fill the record's fields.loc @@ -679,12 +767,13 @@ var a, u, v, test: TLoc; f, field, op: PSym; ty: PType; - r: PRope; - i: int; + r, strLit: PRope; + i, id: int; it: PNode; begin if optFieldCheck in p.options then begin useMagic(p.module, 'raiseFieldError'); + useMagic(p.module, 'NimStringDesc'); ty := genRecordFieldAux(p, e.sons[0], d, a); r := rdLoc(a); f := e.sons[0].sons[1].sym; @@ -706,19 +795,26 @@ begin op := it.sons[0].sym; if op.magic = mNot then it := it.sons[1]; assert(it.sons[2].kind = nkSym); - test := initLoc(locNone, it.typ, OnStack); - u := InitLocExpr(p, it.sons[1]); - v := initLoc(locExpr, it.sons[2].typ, OnUnknown); + initLoc(test, locNone, it.typ, OnStack); + InitLocExpr(p, it.sons[1], u); + initLoc(v, locExpr, it.sons[2].typ, OnUnknown); v.r := ropef('$1.$2', [r, it.sons[2].sym.loc.r]); genInExprAux(p, it, u, v, test); + + id := NodeTableTestOrSet(p.module.dataCache, + newStrNode(nkStrLit, field.name.s), gid); + if id = gid then + strLit := getStrLit(p.module, field.name.s) + else + strLit := con('TMP', toRope(id)); if op.magic = mNot then appf(p.s[cpsStmts], - 'if ($1) raiseFieldError(((string) &$2));$n', - [rdLoc(test), getStrLit(p.module, field.name.s)]) + 'if ($1) raiseFieldError(((NimStringDesc*) &$2));$n', + [rdLoc(test), strLit]) else appf(p.s[cpsStmts], - 'if (!($1)) raiseFieldError(((string) &$2));$n', - [rdLoc(test), getStrLit(p.module, field.name.s)]) + 'if (!($1)) raiseFieldError(((NimStringDesc*) &$2));$n', + [rdLoc(test), strLit]) end; appf(r, '.$1', [field.loc.r]); putIntoDest(p, d, field.typ, r); @@ -733,17 +829,24 @@ var ty: PType; first: PRope; begin - a := initLocExpr(p, e.sons[0]); - b := initLocExpr(p, e.sons[1]); + initLocExpr(p, e.sons[0], a); + initLocExpr(p, e.sons[1], b); ty := skipPtrsGeneric(skipVarGenericRange(a.t)); first := intLiteral(firstOrd(ty)); // emit range check: - if optBoundsCheck in p.options then + if (optBoundsCheck in p.options) then if b.k <> locImmediate then begin // semantic pass has already checked: useMagic(p.module, 'raiseIndexError'); - appf(p.s[cpsStmts], - 'if ($1 < $2 || $1 > $3) raiseIndexError();$n', - [rdCharLoc(b), first, intLiteral(lastOrd(ty))]) + if firstOrd(ty) = 0 then begin + if lastOrd(b.t) > lastOrd(ty) then + appf(p.s[cpsStmts], + 'if ((NU)($1) > (NU)($2)) raiseIndexError();$n', + [rdCharLoc(b), intLiteral(lastOrd(ty))]) + end + else + appf(p.s[cpsStmts], + 'if ($1 < $2 || $1 > $3) raiseIndexError();$n', + [rdCharLoc(b), first, intLiteral(lastOrd(ty))]) end; if d.k = locNone then d.s := a.s; putIntoDest(p, d, elemType(skipVarGeneric(ty)), ropef('$1[($2)-$3]', @@ -757,8 +860,8 @@ var a, b: TLoc; ty: PType; begin - a := initLocExpr(p, e.sons[0]); - b := initLocExpr(p, e.sons[1]); + initLocExpr(p, e.sons[0], a); + initLocExpr(p, e.sons[1], b); ty := skipVarGenericRange(a.t); if d.k = locNone then d.s := a.s; putIntoDest(p, d, elemType(skipVarGeneric(ty)), ropef('$1[$2]', @@ -771,13 +874,13 @@ procedure genOpenArrayElem(p: BProc; e: PNode; var d: TLoc); var a, b: TLoc; begin - a := initLocExpr(p, e.sons[0]); - b := initLocExpr(p, e.sons[1]); + initLocExpr(p, e.sons[0], a); + initLocExpr(p, e.sons[1], b); // emit range check: - if optBoundsCheck in p.options then begin + if (optBoundsCheck in p.options) then begin useMagic(p.module, 'raiseIndexError'); appf(p.s[cpsStmts], - 'if ((NU)($1) > (NU)($2Len0)) raiseIndexError();$n', [rdLoc(b), a.r]) + 'if ((NU)($1) > (NU)($2Len0)) raiseIndexError();$n', [rdLoc(b), rdLoc(a)]) end; if d.k = locNone then d.s := a.s; putIntoDest(p, d, elemType(skipVarGeneric(a.t)), ropef('$1[$2]', @@ -791,20 +894,20 @@ var a, b: TLoc; ty: PType; begin - a := initLocExpr(p, e.sons[0]); - b := initLocExpr(p, e.sons[1]); + initLocExpr(p, e.sons[0], a); + initLocExpr(p, e.sons[1], b); ty := skipVarGenericRange(a.t); if ty.kind in [tyRef, tyPtr] then ty := skipVarGenericRange(ty.sons[0]); // emit range check: - if optBoundsCheck in p.options then begin + if (optBoundsCheck in p.options) then begin useMagic(p.module, 'raiseIndexError'); if ty.kind = tyString then appf(p.s[cpsStmts], - 'if ((NU)($1) > (NU)($2->len)) raiseIndexError();$n', + 'if ((NU)($1) > (NU)($2->Sup.len)) raiseIndexError();$n', [rdLoc(b), rdLoc(a)]) else appf(p.s[cpsStmts], - 'if ((NU)($1) >= (NU)($2->len)) raiseIndexError();$n', + 'if ((NU)($1) >= (NU)($2->Sup.len)) raiseIndexError();$n', [rdLoc(b), rdLoc(a)]) end; if d.k = locNone then d.s := OnHeap; @@ -841,7 +944,7 @@ var L: TLabel; tmp: TLoc; begin - tmp := getTemp(p, e.typ); // force it into a temp! + getTemp(p, e.typ, tmp); // force it into a temp! expr(p, e.sons[1], tmp); L := getLabel(p); if m = mOr then @@ -877,13 +980,13 @@ var a, tmp: TLoc; Lend, Lelse: TLabel; begin - tmp := getTemp(p, n.typ); // force it into a temp! + getTemp(p, n.typ, tmp); // force it into a temp! Lend := getLabel(p); for i := 0 to sonsLen(n)-1 do begin it := n.sons[i]; case it.kind of nkElifExpr: begin - a := initLocExpr(p, it.sons[0]); + initLocExpr(p, it.sons[0], a); Lelse := getLabel(p); appf(p.s[cpsStmts], 'if (!$1) goto $2;$n', [rdLoc(a), Lelse]); freeTemp(p, a); @@ -909,55 +1012,51 @@ end; procedure genCall(p: BProc; t: PNode; var d: TLoc); var param: PSym; - a: array of TLoc; invalidRetType: bool; typ: PType; pl: PRope; // parameter list - op, list: TLoc; + op, list, a: TLoc; len, i: int; begin -{@emit - a := []; -} - op := initLocExpr(p, t.sons[0]); + // this is a hotspot in the compiler + initLocExpr(p, t.sons[0], op); pl := con(op.r, '('+''); - typ := getUniqueType(t.sons[0].typ); + //typ := getUniqueType(t.sons[0].typ); + typ := t.sons[0].typ; // getUniqueType() is too expensive here! assert(typ.kind = tyProc); invalidRetType := isInvalidReturnType(typ.sons[0]); len := sonsLen(t); - setLength(a, len-1); for i := 1 to len-1 do begin - a[i-1] := initLocExpr(p, t.sons[i]); // generate expression for param + initLocExpr(p, t.sons[i], a); // generate expression for param assert(sonsLen(typ) = sonsLen(typ.n)); if (i < sonsLen(typ)) then begin assert(typ.n.sons[i].kind = nkSym); param := typ.n.sons[i].sym; - if ccgIntroducedPtr(param) then app(pl, addrLoc(a[i-1])) - else app(pl, rdLoc(a[i-1])); + if ccgIntroducedPtr(param) then app(pl, addrLoc(a)) + else app(pl, rdLoc(a)); end else - app(pl, rdLoc(a[i-1])); + app(pl, rdLoc(a)); if (i < len-1) or (invalidRetType and (typ.sons[0] <> nil)) then app(pl, ', ') end; if (typ.sons[0] <> nil) and invalidRetType then begin - if d.k = locNone then d := getTemp(p, typ.sons[0]); + if d.k = locNone then getTemp(p, typ.sons[0], d); app(pl, addrLoc(d)); end; app(pl, ')'+''); - for i := 0 to high(a) do - freeTemp(p, a[i]); // important to free the temporaries - freeTemp(p, op); if (typ.sons[0] <> nil) and not invalidRetType then begin - if d.k = locNone then d := getTemp(p, typ.sons[0]); + if d.k = locNone then getTemp(p, typ.sons[0], d); assert(d.t <> nil); // generate an assignment to d: - list := initLoc(locCall, nil, OnUnknown); + initLoc(list, locCall, nil, OnUnknown); list.r := pl; genAssignment(p, d, list, {@set}[]) // no need for deep copying end - else - appf(p.s[cpsStmts], '$1;$n', [pl]) + else begin + app(p.s[cpsStmts], pl); + app(p.s[cpsStmts], ';' + tnl) + end end; procedure genStrConcat(p: BProc; e: PNode; var d: TLoc); @@ -984,17 +1083,17 @@ var L, i: int; begin useMagic(p.module, 'rawNewString'); - tmp := getTemp(p, e.typ); + getTemp(p, e.typ, tmp); L := 0; appends := nil; lens := nil; -{@emit - a := []; -} +{@ignore} setLength(a, sonsLen(e)-1); +{@emit + newSeq(a, sonsLen(e)-1); } for i := 0 to sonsLen(e)-2 do begin // compute the length expression: - a[i] := initLocExpr(p, e.sons[i+1]); + initLocExpr(p, e.sons[i+1], a[i]); if skipVarGenericRange(e.sons[i+1].Typ).kind = tyChar then begin Inc(L); useMagic(p.module, 'appendChar'); @@ -1004,7 +1103,7 @@ begin if e.sons[i+1].kind in [nkStrLit..nkTripleStrLit] then // string literal? Inc(L, length(e.sons[i+1].strVal)) else - appf(lens, '$1->len + ', [rdLoc(a[i])]); + appf(lens, '$1->Sup.len + ', [rdLoc(a[i])]); useMagic(p.module, 'appendString'); appf(appends, 'appendString($1, $2);$n', [tmp.r, rdLoc(a[i])]) end @@ -1044,14 +1143,14 @@ begin L := 0; appends := nil; lens := nil; -{@emit - a := []; -} +{@ignore} setLength(a, sonsLen(e)-1); +{@emit + newSeq(a, sonsLen(e)-1); } expr(p, e.sons[1], a[0]); for i := 0 to sonsLen(e)-3 do begin // compute the length expression: - a[i+1] := initLocExpr(p, e.sons[i+2]); + initLocExpr(p, e.sons[i+2], a[i+1]); if skipVarGenericRange(e.sons[i+2].Typ).kind = tyChar then begin Inc(L); useMagic(p.module, 'appendChar'); @@ -1062,7 +1161,7 @@ begin if e.sons[i+2].kind in [nkStrLit..nkTripleStrLit] then // string literal? Inc(L, length(e.sons[i+2].strVal)) else - appf(lens, '$1->len + ', [rdLoc(a[i+1])]); + appf(lens, '$1->Sup.len + ', [rdLoc(a[i+1])]); useMagic(p.module, 'appendString'); appf(appends, 'appendString($1, $2);$n', [rdLoc(a[0]), rdLoc(a[i+1])]) @@ -1077,23 +1176,50 @@ end; procedure genSeqElemAppend(p: BProc; e: PNode; var d: TLoc); // seq &= x --> -// seq = (typeof seq) incrSeq( (TGenericSeq*) seq, sizeof(x)); +// seq = (typeof seq) incrSeq(&seq->Sup, sizeof(x)); // seq->data[seq->len-1] = x; var a, b, dest: TLoc; begin useMagic(p.module, 'incrSeq'); - a := InitLocExpr(p, e.sons[1]); - b := InitLocExpr(p, e.sons[2]); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); appf(p.s[cpsStmts], - '$1 = ($2) incrSeq((TGenericSeq*) $1, sizeof($3));$n', + '$1 = ($2) incrSeq(&($1)->Sup, sizeof($3));$n', [rdLoc(a), getTypeDesc(p.module, skipVarGeneric(e.sons[1].typ)), getTypeDesc(p.module, skipVarGeneric(e.sons[2].Typ))]); - dest := initLoc(locExpr, b.t, OnHeap); - dest.r := ropef('$1->data[$1->len-1]', [rdLoc(a)]); - genAssignment(p, dest, b, {@set}[needToCopy]); - freeTemp(p, a); - freeTemp(p, b) + initLoc(dest, locExpr, b.t, OnHeap); + dest.r := ropef('$1->data[$1->Sup.len-1]', [rdLoc(a)]); + genAssignment(p, dest, b, {@set}[needToCopy, afDestIsNil]); +end; + +procedure genObjectInit(p: BProc; t: PType; const a: TLoc; takeAddr: bool); +var + r: PRope; + s: PType; +begin + case analyseObjectWithTypeField(t) of + frNone: begin end; + frHeader: begin + r := rdLoc(a); + if not takeAddr then r := ropef('(*$1)', [r]); + s := t; + while (s.kind = tyObject) and (s.sons[0] <> nil) do begin + app(r, '.Sup'); + s := skipGeneric(s.sons[0]); + end; + appf(p.s[cpsStmts], '$1.m_type = $2;$n', + [r, genTypeInfo(p.module, t)]) + end; + frEmbedded: begin + // worst case for performance: + useMagic(p.module, 'objectInit'); + if takeAddr then r := addrLoc(a) + else r := rdLoc(a); + appf(p.s[cpsStmts], 'objectInit($1, $2);$n', + [r, genTypeInfo(p.module, t)]) + end + end end; procedure genNew(p: BProc; e: PNode); @@ -1103,20 +1229,63 @@ var begin useMagic(p.module, 'newObj'); refType := skipVarGenericRange(e.sons[1].typ); - a := InitLocExpr(p, e.sons[1]); - b := initLoc(locExpr, a.t, OnHeap); + InitLocExpr(p, e.sons[1], a); + initLoc(b, locExpr, a.t, OnHeap); b.r := ropef('($1) newObj($2, sizeof($3))', [getTypeDesc(p.module, reftype), genTypeInfo(p.module, refType), getTypeDesc(p.module, skipGenericRange(reftype.sons[0]))]); genAssignment(p, a, b, {@set}[]); // set the object type: bt := skipGenericRange(refType.sons[0]); - if containsObject(bt) then begin - useMagic(p.module, 'objectInit'); - appf(p.s[cpsStmts], 'objectInit($1, $2);$n', - [rdLoc(a), genTypeInfo(p.module, bt)]) + genObjectInit(p, bt, a, false); +end; + +procedure genNewSeq(p: BProc; e: PNode); +var + a, b, c: TLoc; + seqtype: PType; +begin + useMagic(p.module, 'newSeq'); + seqType := skipVarGenericRange(e.sons[1].typ); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); + initLoc(c, locExpr, a.t, OnHeap); + c.r := ropef('($1) newSeq($2, $3)', + [getTypeDesc(p.module, seqtype), + genTypeInfo(p.module, seqType), + rdLoc(b)]); + genAssignment(p, a, c, {@set}[]); +end; + +procedure genIs(p: BProc; n: PNode; var d: TLoc); +var + a: TLoc; + dest, t: PType; + r, nilcheck: PRope; +begin + initLocExpr(p, n.sons[1], a); + dest := skipPtrsGeneric(n.sons[2].typ); + useMagic(p.module, 'isObj'); + r := rdLoc(a); + nilCheck := nil; + t := skipGeneric(a.t); + while t.kind in [tyVar, tyPtr, tyRef] do begin + if t.kind <> tyVar then nilCheck := r; + r := ropef('(*$1)', [r]); + t := skipGeneric(t.sons[0]) end; - freeTemp(p, a) + if gCmd <> cmdCompileToCpp then + while (t.kind = tyObject) and (t.sons[0] <> nil) do begin + app(r, '.Sup'); + t := skipGeneric(t.sons[0]); + end; + if nilCheck <> nil then + r := ropef('(($1) && isObj($2.m_type, $3))', + [nilCheck, r, genTypeInfo(p.module, dest)]) + else + r := ropef('isObj($1.m_type, $2)', + [r, genTypeInfo(p.module, dest)]); + putIntoDest(p, d, n.typ, r); end; procedure genNewFinalize(p: BProc; e: PNode); @@ -1127,9 +1296,9 @@ var begin useMagic(p.module, 'newObj'); refType := skipVarGenericRange(e.sons[1].typ); - a := InitLocExpr(p, e.sons[1]); - f := InitLocExpr(p, e.sons[2]); - b := initLoc(locExpr, a.t, OnHeap); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], f); + initLoc(b, locExpr, a.t, OnHeap); ti := genTypeInfo(p.module, refType); appf(p.module.s[cfsTypeInit3], '$1->finalizer = (void*)$2;$n', [ ti, rdLoc(f)]); @@ -1139,13 +1308,7 @@ begin genAssignment(p, a, b, {@set}[]); // set the object type: bt := skipGenericRange(refType.sons[0]); - if containsObject(bt) then begin - useMagic(p.module, 'objectInit'); - appf(p.s[cpsStmts], 'objectInit($1, $2);$n', - [rdLoc(a), genTypeInfo(p.module, bt)]) - end; - freeTemp(p, a); - freeTemp(p, f) + genObjectInit(p, bt, a, false); end; procedure genRepr(p: BProc; e: PNode; var d: TLoc); @@ -1153,7 +1316,7 @@ var a: TLoc; t: PType; begin - a := InitLocExpr(p, e.sons[1]); + InitLocExpr(p, e.sons[1], a); t := skipVarGenericRange(e.sons[1].typ); case t.kind of tyInt..tyInt64: begin @@ -1192,7 +1355,7 @@ begin tyOpenArray: putIntoDest(p, d, e.typ, ropef('$1, $1Len0', [rdLoc(a)])); tyString, tySequence: - putIntoDest(p, d, e.typ, ropef('$1->data, $1->len', [rdLoc(a)])); + putIntoDest(p, d, e.typ, ropef('$1->data, $1->Sup.len', [rdLoc(a)])); tyArray, tyArrayConstr: putIntoDest(p, d, e.typ, ropef('$1, $2', [rdLoc(a), toRope(lengthOrd(a.t))])); @@ -1221,9 +1384,11 @@ procedure genDollar(p: BProc; n: PNode; var d: TLoc; const magic, frmt: string); var a: TLoc; begin - a := InitLocExpr(p, n.sons[1]); + InitLocExpr(p, n.sons[1], a); UseMagic(p.module, magic); - putIntoDest(p, d, n.typ, ropef(frmt, [rdLoc(a)])) + a.r := ropef(frmt, [rdLoc(a)]); + if d.k = locNone then getTemp(p, n.typ, d); + genAssignment(p, d, a, {@set}[]); end; procedure genArrayLen(p: BProc; e: PNode; var d: TLoc; op: TMagic); @@ -1238,13 +1403,18 @@ begin if op = mHigh then unaryExpr(p, e, d, '', '($1Len0-1)') else - unaryExpr(p, e, d, '', '$1Len0/*len*/'); + unaryExpr(p, e, d, '', '$1Len0'); end; + tyCstring: + if op = mHigh then + unaryExpr(p, e, d, '', '(strlen($1)-1)') + else + unaryExpr(p, e, d, '', 'strlen($1)'); tyString, tySequence: if op = mHigh then - unaryExpr(p, e, d, '', '($1->len-1)') + unaryExpr(p, e, d, '', '($1->Sup.len-1)') else - unaryExpr(p, e, d, '', '$1->len'); + unaryExpr(p, e, d, '', '$1->Sup.len'); tyArray, tyArrayConstr: begin // YYY: length(sideeffect) is optimized away incorrectly? if op = mHigh then @@ -1264,11 +1434,11 @@ var begin assert(d.k = locNone); useMagic(p.module, 'setLengthSeq'); - a := InitLocExpr(p, e.sons[1]); - b := InitLocExpr(p, e.sons[2]); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); t := skipVarGeneric(e.sons[1].typ); appf(p.s[cpsStmts], - '$1 = ($3) setLengthSeq((TGenericSeq*) ($1), sizeof($4), $2);$n', + '$1 = ($3) setLengthSeq(&($1)->Sup, sizeof($4), $2);$n', [rdLoc(a), rdLoc(b), getTypeDesc(p.module, t), getTypeDesc(p.module, t.sons[0])]); freeTemp(p, a); @@ -1288,9 +1458,9 @@ procedure genSwap(p: BProc; e: PNode; var d: TLoc); var a, b, tmp: TLoc; begin - tmp := getTemp(p, skipVarGeneric(e.sons[1].typ)); - a := InitLocExpr(p, e.sons[1]); // eval a - b := InitLocExpr(p, e.sons[2]); // eval b + getTemp(p, skipVarGeneric(e.sons[1].typ), tmp); + InitLocExpr(p, e.sons[1], a); // eval a + InitLocExpr(p, e.sons[2], b); // eval b genAssignment(p, tmp, a, {@set}[]); genAssignment(p, a, b, {@set}[]); genAssignment(p, b, tmp, {@set}[]); @@ -1348,8 +1518,8 @@ var a, b: TLoc; begin assert(d.k = locNone); - a := InitLocExpr(p, e.sons[1]); - b := InitLocExpr(p, e.sons[2]); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); appf(p.s[cpsStmts], frmt, [rdLoc(a), rdSetElemLoc(b, a.t)]); freeTemp(p, a); freeTemp(p, b) @@ -1364,22 +1534,22 @@ begin if (e.sons[1].Kind = nkCurly) and fewCmps(e.sons[1]) then begin // a set constructor but not a constant set: // do not emit the set, but generate a bunch of comparisons - a := initLocExpr(p, e.sons[2]); - b := initLoc(locExpr, e.typ, OnUnknown); + initLocExpr(p, e.sons[2], a); + initLoc(b, locExpr, e.typ, OnUnknown); b.r := toRope('('+''); len := sonsLen(e.sons[1]); - {@emit c := [];} + {@emit c := @[];} for i := 0 to len-1 do begin if e.sons[1].sons[i].Kind = nkRange then begin setLength(c, length(c)+2); - c[high(c)-1] := InitLocExpr(p, e.sons[1].sons[i].sons[0]); - c[high(c)] := InitLocExpr(p, e.sons[1].sons[i].sons[1]); + InitLocExpr(p, e.sons[1].sons[i].sons[0], c[high(c)-1]); + InitLocExpr(p, e.sons[1].sons[i].sons[1], c[high(c)]); appf(b.r, '$1 >= $2 && $1 <= $3', [rdCharLoc(a), rdCharLoc(c[high(c)-1]), rdCharLoc(c[high(c)])]) end else begin setLength(c, length(c)+1); - c[high(c)] := InitLocExpr(p, e.sons[1].sons[i]); + InitLocExpr(p, e.sons[1].sons[i], c[high(c)]); appf(b.r, '$1 == $2', [rdCharLoc(a), rdCharLoc(c[high(c)])]) end; if i < len - 1 then @@ -1395,8 +1565,8 @@ begin else begin assert(e.sons[1].typ <> nil); assert(e.sons[2].typ <> nil); - a := InitLocExpr(p, e.sons[1]); - b := InitLocExpr(p, e.sons[2]); + InitLocExpr(p, e.sons[1], a); + InitLocExpr(p, e.sons[2], b); genInExprAux(p, e, a, b, d); end end; @@ -1459,11 +1629,10 @@ begin mCard: unaryExprChar(p, e, d, 'countBitsVar', 'countBitsVar($1, ' + ToString(size) + ')'); mLtSet, mLeSet: begin - i := getTemp(p, getSysType(tyInt)); // our counter - a := initLocExpr(p, e.sons[1]); - b := initLocExpr(p, e.sons[2]); - if d.k = locNone then - d := getTemp(p, a.t); + getTemp(p, getSysType(tyInt), i); // our counter + initLocExpr(p, e.sons[1], a); + initLocExpr(p, e.sons[2], b); + if d.k = locNone then getTemp(p, a.t, d); appf(p.s[cpsStmts], lookupOpr[op], [rdLoc(i), toRope(size), rdLoc(d), rdLoc(a), rdLoc(b)]); freeTemp(p, a); @@ -1475,11 +1644,10 @@ begin '(memcmp($1, $2, ' + ToString(size) + ')==0)'); mMulSet, mPlusSet, mMinusSet, mSymDiffSet: begin // we inline the simple for loop for better code generation: - i := getTemp(p, getSysType(tyInt)); // our counter - a := initLocExpr(p, e.sons[1]); - b := initLocExpr(p, e.sons[2]); - if d.k = locNone then - d := getTemp(p, a.t); + getTemp(p, getSysType(tyInt), i); // our counter + initLocExpr(p, e.sons[1], a); + initLocExpr(p, e.sons[2], b); + if d.k = locNone then getTemp(p, a.t, d); appf(p.s[cpsStmts], 'for ($1 = 0; $1 < $2; $1++) $n' + ' $3[$1] = $4[$1] $6 $5[$1];$n', [rdLoc(i), toRope(size), @@ -1510,7 +1678,7 @@ const var a: TLoc; begin - a := InitLocExpr(p, e.sons[1]); + InitLocExpr(p, e.sons[1], a); if (skipGenericRange(e.typ).kind in ValueTypes) and not (lfIndirect in a.flags) then putIntoDest(p, d, e.typ, ropef('(*($1*) ($2))', @@ -1528,12 +1696,12 @@ var begin dest := skipVarGeneric(n.typ); if not (optRangeCheck in p.options) then begin - a := InitLocExpr(p, n.sons[0]); + InitLocExpr(p, n.sons[0], a); putIntoDest(p, d, n.typ, ropef('(($1) ($2))', [getTypeDesc(p.module, dest), rdCharLoc(a)])); end else begin - a := InitLocExpr(p, n.sons[0]); + InitLocExpr(p, n.sons[0], a); useMagic(p.module, magic); putIntoDest(p, d, dest, ropef('(($1)' +{&} magic +{&} '($2, $3, $4))', @@ -1555,16 +1723,16 @@ var dest: PType; begin dest := skipVarGeneric(n.typ); - a := initLocExpr(p, n.sons[0]); - case a.t.kind of + initLocExpr(p, n.sons[0], a); + case skipVarGeneric(a.t).kind of tyOpenArray: putIntoDest(p, d, dest, ropef('$1, $1Len0', [rdLoc(a)])); tyString, tySequence: - putIntoDest(p, d, dest, ropef('$1->data, $1->len', [rdLoc(a)])); + putIntoDest(p, d, dest, ropef('$1->data, $1->Sup.len', [rdLoc(a)])); tyArray, tyArrayConstr: putIntoDest(p, d, dest, ropef('$1, $2', [rdLoc(a), toRope(lengthOrd(a.t))])); - else InternalError(n.sons[0].info, 'passToOpenArray()') + else InternalError(n.sons[0].info, 'passToOpenArray: ' + typeToString(a.t)) end; if d.k <> locExpr then freeTemp(p, a) end; @@ -1573,7 +1741,7 @@ procedure convStrToCStr(p: BProc; n: PNode; var d: TLoc); var a: TLoc; begin - a := initLocExpr(p, n.sons[0]); + initLocExpr(p, n.sons[0], a); putIntoDest(p, d, skipVarGeneric(n.typ), ropef('$1->data', [rdLoc(a)])); if d.k <> locExpr then freeTemp(p, a) end; @@ -1583,12 +1751,85 @@ var a: TLoc; begin useMagic(p.module, 'cstrToNimstr'); - a := initLocExpr(p, n.sons[0]); + initLocExpr(p, n.sons[0], a); putIntoDest(p, d, skipVarGeneric(n.typ), ropef('cstrToNimstr($1)', [rdLoc(a)])); if d.k <> locExpr then freeTemp(p, a) end; +procedure genStrEquals(p: BProc; e: PNode; var d: TLoc); +var + a, b: PNode; + x: TLoc; +begin + a := e.sons[1]; + b := e.sons[2]; + if (a.kind = nkNilLit) or (b.kind = nkNilLit) then + binaryExpr(p, e, d, '', '($1 == $2)') + else if (a.kind in [nkStrLit..nkTripleStrLit]) and (a.strVal = '') then begin + initLocExpr(p, e.sons[2], x); + putIntoDest(p, d, e.typ, ropef('(($1) && ($1)->Sup.len == 0)', [rdLoc(x)])); + end + else if (b.kind in [nkStrLit..nkTripleStrLit]) and (b.strVal = '') then begin + initLocExpr(p, e.sons[1], x); + putIntoDest(p, d, e.typ, ropef('(($1) && ($1)->Sup.len == 0)', [rdLoc(x)])); + end + else + binaryExpr(p, e, d, 'eqStrings', 'eqStrings($1, $2)'); +end; + +procedure genSeqConstr(p: BProc; t: PNode; var d: TLoc); +var + newSeq, arr: TLoc; + i: int; +begin + useMagic(p.module, 'newSeq'); + if d.k = locNone then getTemp(p, t.typ, d); + // generate call to newSeq before adding the elements per hand: + + initLoc(newSeq, locExpr, t.typ, OnHeap); + newSeq.r := ropef('($1) newSeq($2, $3)', + [getTypeDesc(p.module, t.typ), + genTypeInfo(p.module, t.typ), intLiteral(sonsLen(t))]); + genAssignment(p, d, newSeq, {@set}[afSrcIsNotNil]); + for i := 0 to sonsLen(t)-1 do begin + initLoc(arr, locExpr, elemType(skipGeneric(t.typ)), OnHeap); + arr.r := ropef('$1->data[$2]', [rdLoc(d), intLiteral(i)]); + arr.s := OnHeap; // we know that sequences are on the heap + expr(p, t.sons[i], arr) + end +end; + +procedure genArrToSeq(p: BProc; t: PNode; var d: TLoc); +var + newSeq, elem, a, arr: TLoc; + L, i: int; +begin + if t.kind = nkBracket then begin + t.sons[1].typ := t.typ; + genSeqConstr(p, t.sons[1], d); + exit + end; + useMagic(p.module, 'newSeq'); + if d.k = locNone then getTemp(p, t.typ, d); + // generate call to newSeq before adding the elements per hand: + L := int(lengthOrd(t.sons[1].typ)); + initLoc(newSeq, locExpr, t.typ, OnHeap); + newSeq.r := ropef('($1) newSeq($2, $3)', + [getTypeDesc(p.module, t.typ), + genTypeInfo(p.module, t.typ), intLiteral(L)]); + genAssignment(p, d, newSeq, {@set}[afSrcIsNotNil]); + initLocExpr(p, t.sons[1], a); + for i := 0 to L-1 do begin + initLoc(elem, locExpr, elemType(skipGeneric(t.typ)), OnHeap); + elem.r := ropef('$1->data[$2]', [rdLoc(d), intLiteral(i)]); + elem.s := OnHeap; // we know that sequences are on the heap + initLoc(arr, locExpr, elemType(skipGeneric(t.sons[1].typ)), a.s); + arr.r := ropef('$1[$2]', [rdLoc(a), intLiteral(i)]); + genAssignment(p, elem, arr, {@set}[afDestIsNil, needToCopy]); + end +end; + procedure genMagicExpr(p: BProc; e: PNode; var d: TLoc; op: TMagic); var a: TLoc; @@ -1602,7 +1843,7 @@ begin mAddi..mModi64: binaryArithOverflow(p, e, d, op); mRepr: genRepr(p, e, d); mAsgn: begin - a := InitLocExpr(p, e.sons[1]); + InitLocExpr(p, e.sons[1], a); assert(a.t <> nil); expr(p, e.sons[2], a); freeTemp(p, a) @@ -1616,7 +1857,7 @@ begin end; mSucc: begin // XXX: range checking? if not (optOverflowCheck in p.Options) then - binaryExpr(p, e, d, '', '$1 - $2') + binaryExpr(p, e, d, '', '$1 + $2') else binaryExpr(p, e, d, 'addInt', 'addInt($1, $2)') end; @@ -1624,7 +1865,7 @@ begin mAppendStrCh: binaryStmt(p, e, d, 'addChar', '$1 = addChar($1, $2);$n'); mAppendStrStr: genStrAppend(p, e, d); mAppendSeqElem: genSeqElemAppend(p, e, d); - mEqStr: binaryExpr(p, e, d, 'eqStrings', 'eqStrings($1, $2)'); + mEqStr: genStrEquals(p, e, d); mLeStr: binaryExpr(p, e, d, 'cmpStrings', '(cmpStrings($1, $2) <= 0)'); mLtStr: binaryExpr(p, e, d, 'cmpStrings', '(cmpStrings($1, $2) < 0)'); mIsNil: unaryExpr(p, e, d, '', '$1 == 0'); @@ -1645,11 +1886,13 @@ begin [filen, line, rdLoc(d)]) end end; + mIs: genIs(p, e, d); mNew: genNew(p, e); mNewFinalize: genNewFinalize(p, e); + mNewSeq: genNewSeq(p, e); mSizeOf: putIntoDest(p, d, e.typ, - ropef('sizeof($1)', [getTypeDesc(p.module, e.sons[1].typ)])); + ropef('((NI)sizeof($1))', [getTypeDesc(p.module, e.sons[1].typ)])); mChr: genCast(p, e, d); // expr(p, e.sons[1], d); mOrd: genOrd(p, e, d); mLengthArray, mHigh, mLengthStr, mLengthSeq, mLengthOpenArray: @@ -1670,17 +1913,45 @@ begin else binaryStmt(p, e, d, 'subInt', '$1 = subInt($1, $2);$n') end; + mGCref: unaryStmt(p, e, d, 'nimGCref', 'nimGCref($1);$n'); + mGCunref: unaryStmt(p, e, d, 'nimGCunref', 'nimGCunref($1);$n'); mSetLengthStr: genSetLengthStr(p, e, d); mSetLengthSeq: genSetLengthSeq(p, e, d); mIncl, mExcl, mCard, mLtSet, mLeSet, mEqSet, mMulSet, mPlusSet, mMinusSet, mInSet: genSetOp(p, e, d, op); mExit: genCall(p, e, d); + mArrToSeq: genArrToSeq(p, e, d); mNLen..mNError: liMessage(e.info, errCannotGenerateCodeForX, e.sons[0].sym.name.s); else internalError(e.info, 'genMagicExpr: ' + magicToStr[op]); end end; +function genConstExpr(p: BProc; n: PNode): PRope; forward; + +function handleConstExpr(p: BProc; n: PNode; var d: TLoc): bool; +var + id: int; + t: PType; +begin + if (nfAllConst in n.flags) and (d.k = locNone) + and (sonsLen(n) > 0) then begin + t := getUniqueType(n.typ); + {@discard} getTypeDesc(p.module, t); // so that any fields are initialized + id := NodeTableTestOrSet(p.module.dataCache, n, gid); + fillLoc(d, locData, t, con('TMP', toRope(id)), OnHeap); + if id = gid then begin + // expression not found in the cache: + inc(gid); + appf(p.module.s[cfsData], 'NIM_CONST $1 $2 = $3;$n', + [getTypeDesc(p.module, t), d.r, genConstExpr(p, n)]); + end; + result := true + end + else + result := false +end; + procedure genSetConstr(p: BProc; e: PNode; var d: TLoc); // example: { a..b, c, d, e, f..g } // we have to emit an expression of the form: @@ -1694,14 +1965,14 @@ begin if nfAllConst in e.flags then putIntoDest(p, d, e.typ, genSetNode(p, e)) else begin - if d.k = locNone then d := getTemp(p, e.typ); + if d.k = locNone then getTemp(p, e.typ, d); if getSize(e.typ) > 8 then begin // big set: appf(p.s[cpsStmts], 'memset($1, 0, sizeof($1));$n', [rdLoc(d)]); for i := 0 to sonsLen(e)-1 do begin if e.sons[i].kind = nkRange then begin - idx := getTemp(p, getSysType(tyInt)); // our counter - a := initLocExpr(p, e.sons[i].sons[1]); - b := initLocExpr(p, e.sons[i].sons[2]); + getTemp(p, getSysType(tyInt), idx); // our counter + initLocExpr(p, e.sons[i].sons[0], a); + initLocExpr(p, e.sons[i].sons[1], b); appf(p.s[cpsStmts], 'for ($1 = $3; $1 <= $4; $1++) $n' + '$2[$1/8] |=(1<<($1%8));$n', @@ -1712,7 +1983,7 @@ begin freeTemp(p, idx) end else begin - a := initLocExpr(p, e.sons[i]); + initLocExpr(p, e.sons[i], a); appf(p.s[cpsStmts], '$1[$2/8] |=(1<<($2%8));$n', [rdLoc(d), rdSetElemLoc(a, e.typ)]); freeTemp(p, a) @@ -1724,9 +1995,9 @@ begin appf(p.s[cpsStmts], '$1 = 0;$n', [rdLoc(d)]); for i := 0 to sonsLen(e) - 1 do begin if e.sons[i].kind = nkRange then begin - idx := getTemp(p, getSysType(tyInt)); // our counter - a := initLocExpr(p, e.sons[i].sons[1]); - b := initLocExpr(p, e.sons[i].sons[2]); + getTemp(p, getSysType(tyInt), idx); // our counter + initLocExpr(p, e.sons[i].sons[0], a); + initLocExpr(p, e.sons[i].sons[1], b); appf(p.s[cpsStmts], 'for ($1 = $3; $1 <= $4; $1++) $n' +{&} '$2 |=(1<<((' +{&} ts +{&} ')($1)%(sizeof(' +{&}ts+{&}')*8)));$n', @@ -1737,7 +2008,7 @@ begin freeTemp(p, idx) end else begin - a := initLocExpr(p, e.sons[i]); + initLocExpr(p, e.sons[i], a); appf(p.s[cpsStmts], '$1 |=(1<<((' +{&} ts +{&} ')($2)%(sizeof(' +{&}ts+{&} ')*8)));$n', @@ -1758,20 +2029,22 @@ var begin // the code generator assumes that there are only tuple constructors with // field names! - t := getUniqueType(n.typ); - {@discard} getTypeDesc(p.module, t); // so that any fields are initialized - if d.k = locNone then d := getTemp(p, t); - if t.n = nil then InternalError(n.info, 'genTupleConstr'); - if sonsLen(t.n) <> sonsLen(n) then - InternalError(n.info, 'genTupleConstr'); - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if it.kind <> nkExprColonExpr then InternalError(n.info, 'genTupleConstr'); - rec := initLoc(locExpr, it.sons[1].typ, d.s); - if (t.n.sons[i].kind <> nkSym) then + if not handleConstExpr(p, n, d) then begin + t := getUniqueType(n.typ); + {@discard} getTypeDesc(p.module, t); // so that any fields are initialized + if d.k = locNone then getTemp(p, t, d); + if t.n = nil then InternalError(n.info, 'genTupleConstr'); + if sonsLen(t.n) <> sonsLen(n) then InternalError(n.info, 'genTupleConstr'); - rec.r := ropef('$1.$2', [rdLoc(d), mangleRecFieldName(t.n.sons[i].sym, t)]); - expr(p, it.sons[1], rec); + for i := 0 to sonsLen(n)-1 do begin + it := n.sons[i]; + if it.kind <> nkExprColonExpr then InternalError(n.info, 'genTupleConstr'); + initLoc(rec, locExpr, it.sons[1].typ, d.s); + if (t.n.sons[i].kind <> nkSym) then + InternalError(n.info, 'genTupleConstr'); + rec.r := ropef('$1.$2', [rdLoc(d), mangleRecFieldName(t.n.sons[i].sym, t)]); + expr(p, it.sons[1], rec); + end end end; @@ -1780,34 +2053,13 @@ var arr: TLoc; i: int; begin - if d.k = locNone then d := getTemp(p, n.typ); - for i := 0 to sonsLen(n)-1 do begin - arr := initLoc(locExpr, elemType(skipGeneric(n.typ)), d.s); - arr.r := ropef('$1[$2]', [rdLoc(d), intLiteral(i)]); - expr(p, n.sons[i], arr) - end -end; - -procedure genSeqConstr(p: BProc; t: PNode; var d: TLoc); -var - newSeq, arr: TLoc; - i: int; -begin - useMagic(p.module, 'newSeq'); - if d.k = locNone then - d := getTemp(p, t.typ); - // generate call to newSeq before adding the elements per hand: - - newSeq := initLoc(locExpr, t.typ, OnHeap); - newSeq.r := ropef('($1) newSeq($2, $3)', - [getTypeDesc(p.module, t.typ), - genTypeInfo(p.module, t.typ), toRope(sonsLen(t))]); - genAssignment(p, d, newSeq, {@set}[]); - for i := 0 to sonsLen(t)-1 do begin - arr := initLoc(locExpr, elemType(skipGeneric(t.typ)), OnHeap); - arr.r := ropef('$1->data[$2]', [rdLoc(d), intLiteral(i)]); - arr.s := OnHeap; // we know that sequences are on the heap - expr(p, t.sons[i], arr) + if not handleConstExpr(p, n, d) then begin + if d.k = locNone then getTemp(p, n.typ, d); + for i := 0 to sonsLen(n)-1 do begin + initLoc(arr, locExpr, elemType(skipGeneric(n.typ)), d.s); + arr.r := ropef('$1[$2]', [rdLoc(d), intLiteral(i)]); + expr(p, n.sons[i], arr) + end end end; @@ -1833,7 +2085,7 @@ var dest, t: PType; r, nilCheck: PRope; begin - a := initLocExpr(p, n.sons[0]); + initLocExpr(p, n.sons[0], a); dest := skipPtrsGeneric(n.typ); if (optObjCheck in p.options) and not (isPureObject(dest)) then begin useMagic(p.module, 'chckObj'); @@ -1877,7 +2129,7 @@ begin else begin dest := skipPtrsGeneric(n.typ); src := skipPtrsGeneric(n.sons[0].typ); - a := initLocExpr(p, n.sons[0]); + initLocExpr(p, n.sons[0], a); r := rdLoc(a); if skipGeneric(n.sons[0].typ).kind in [tyRef, tyPtr, tyVar] then begin app(r, '->Sup'); @@ -1941,7 +2193,7 @@ begin putIntoDest(p, d, e.typ, genLiteral(p, e)); d.k := locImmediate // for removal of index checks end; - nkCall, nkHiddenCallConv: begin + nkCall, nkHiddenCallConv, nkInfix, nkPrefix, nkPostfix, nkCommand: begin if (e.sons[0].kind = nkSym) and (e.sons[0].sym.magic <> mNone) then genMagicExpr(p, e, d, e.sons[0].sym.magic) @@ -2017,8 +2269,6 @@ begin end; end; -function genConstExpr(p: BProc; n: PNode): PRope; forward; - function genConstSimpleList(p: BProc; n: PNode): PRope; var len, i: int; diff --git a/nim/ccgstmts.pas b/nim/ccgstmts.pas index a59ef42d2..b00751edd 100644 --- a/nim/ccgstmts.pas +++ b/nim/ccgstmts.pas @@ -48,25 +48,16 @@ begin app(p.s[cpsStmts], 'goto BeforeRet;' + tnl) end; -procedure genObjectInit(p: BProc; sym: PSym); -begin - if containsObject(sym.typ) then begin - useMagic(p.module, 'objectInit'); - appf(p.s[cpsInit], 'objectInit($1, $2);$n', - [addrLoc(sym.loc), genTypeInfo(p.module, sym.typ)]) - end -end; - procedure initVariable(p: BProc; v: PSym); begin if containsGarbageCollectedRef(v.typ) or (v.ast = nil) then // Language change: always initialize variables if v.ast == nil! if not (skipVarGenericRange(v.typ).Kind in [tyArray, tyArrayConstr, tySet, tyTuple, tyObject]) then - appf(p.s[cpsStmts], '$1 = 0;$n', [v.loc.r]) + appf(p.s[cpsStmts], '$1 = 0;$n', [rdLoc(v.loc)]) else - appf(p.s[cpsStmts], 'memset((void*)&$1, 0, sizeof($1));$n', - [v.loc.r]) + appf(p.s[cpsStmts], 'memset((void*)$1, 0, sizeof($2));$n', + [addrLoc(v.loc), rdLoc(v.loc)]) end; procedure genVarStmt(p: BProc; n: PNode); @@ -93,7 +84,7 @@ begin genLineDir(p, a); expr(p, a.sons[2], v.loc); end; - genObjectInit(p, v); // XXX: correct position? + genObjectInit(p, v.typ, v.loc, true); // correct position end end; @@ -147,7 +138,7 @@ begin it := n.sons[i]; case it.kind of nkElifBranch: begin - a := initLocExpr(p, it.sons[0]); + initLocExpr(p, it.sons[0], a); Lelse := getLabel(p); appf(p.s[cpsStmts], 'if (!$1) goto $2;$n', [rdLoc(a), Lelse]); freeTemp(p, a); @@ -177,17 +168,23 @@ begin genLineDir(p, t); assert(sonsLen(t) = 2); inc(p.labels); - Labl := con('L'+'', toRope(p.labels)); + Labl := con('LA', toRope(p.labels)); len := length(p.blocks); setLength(p.blocks, len+1); - p.blocks[len].id := p.labels; // positive because we use it right away: + p.blocks[len].id := -p.labels; // negative because it isn't used yet p.blocks[len].nestedTryStmts := p.nestedTryStmts; app(p.s[cpsStmts], 'while (1) {' + tnl); - a := initLocExpr(p, t.sons[0]); - appf(p.s[cpsStmts], 'if (!$1) goto $2;$n', [rdLoc(a), Labl]); + initLocExpr(p, t.sons[0], a); + if (t.sons[0].kind <> nkIntLit) or (t.sons[0].intVal = 0) then begin + p.blocks[len].id := abs(p.blocks[len].id); + appf(p.s[cpsStmts], 'if (!$1) goto $2;$n', [rdLoc(a), Labl]); + end; freeTemp(p, a); genStmts(p, t.sons[1]); - appf(p.s[cpsStmts], '} $1: ;$n', [Labl]); + if p.blocks[len].id > 0 then + appf(p.s[cpsStmts], '} $1: ;$n', [Labl]) + else + app(p.s[cpsStmts], '}'+tnl); setLength(p.blocks, length(p.blocks)-1) end; @@ -210,7 +207,7 @@ begin if t.kind = nkBlockExpr then genStmtListExpr(p, t.sons[1], d) else genStmts(p, t.sons[1]); if p.blocks[idx].id > 0 then // label has been used: - appf(p.s[cpsStmts], 'L$1: ;$n', [toRope(p.blocks[idx].id)]); + appf(p.s[cpsStmts], 'LA$1: ;$n', [toRope(p.blocks[idx].id)]); setLength(p.blocks, idx) end; @@ -236,7 +233,7 @@ begin end; p.blocks[idx].id := abs(p.blocks[idx].id); // label is used finishTryStmt(p, p.nestedTryStmts - p.blocks[idx].nestedTryStmts); - appf(p.s[cpsStmts], 'goto L$1;$n', [toRope(p.blocks[idx].id)]) + appf(p.s[cpsStmts], 'goto LA$1;$n', [toRope(p.blocks[idx].id)]) end; procedure genAsmStmt(p: BProc; t: PNode); @@ -287,7 +284,7 @@ begin genLineDir(p, t); if t.sons[0] <> nil then begin if gCmd <> cmdCompileToCpp then useMagic(p.module, 'raiseException'); - a := InitLocExpr(p, t.sons[0]); + InitLocExpr(p, t.sons[0], a); e := rdLoc(a); freeTemp(p, a); typ := t.sons[0].typ; @@ -324,15 +321,15 @@ begin len := sonsLen(b); for i := 0 to len - 2 do begin if b.sons[i].kind = nkRange then begin - x := initLocExpr(p, b.sons[i].sons[0]); - y := initLocExpr(p, b.sons[i].sons[1]); + initLocExpr(p, b.sons[i].sons[0], x); + initLocExpr(p, b.sons[i].sons[1], y); freeTemp(p, x); freeTemp(p, y); appf(p.s[cpsStmts], rangeFormat, [rdCharLoc(e), rdCharLoc(x), rdCharLoc(y), labl]) end else begin - x := initLocExpr(p, b.sons[i]); + initLocExpr(p, b.sons[i], x); freeTemp(p, x); appf(p.s[cpsStmts], eqFormat, [rdCharLoc(e), rdCharLoc(x), labl]) @@ -347,7 +344,7 @@ var begin Lend := getLabel(p); for i := 1 to sonsLen(t) - 1 do begin - appf(p.s[cpsStmts], 'L$1: ;$n', [toRope(labId+i)]); + appf(p.s[cpsStmts], 'LA$1: ;$n', [toRope(labId+i)]); if t.sons[i].kind = nkOfBranch then begin len := sonsLen(t.sons[i]); genStmts(p, t.sons[i].sons[len-1]); @@ -366,17 +363,17 @@ var a: TLoc; i, labId: int; begin - a := initLocExpr(p, t.sons[0]); + initLocExpr(p, t.sons[0], a); // fist pass: gnerate ifs+goto: labId := p.labels; for i := 1 to sonsLen(t) - 1 do begin inc(p.labels); if t.sons[i].kind = nkOfBranch then genCaseGenericBranch(p, t.sons[i], a, rangeFormat, eqFormat, - con('L'+'', toRope(p.labels))) + con('LA', toRope(p.labels))) else // else statement - appf(p.s[cpsStmts], 'goto L$1;$n', [toRope(p.labels)]); + appf(p.s[cpsStmts], 'goto LA$1;$n', [toRope(p.labels)]); end; // second pass: generate statements genCaseSecondPass(p, t, labId); @@ -416,13 +413,13 @@ begin else begin a := 0; for i := 0 to Length(s)-1 do begin - a := a +{%} Ord(s[i]); - a := a +{%} a shl 10; - a := a xor (a shr 6); + a := a +{%} int32(Ord(s[i])); + a := a +{%} a shl int32(10); + a := a xor (a shr int32(6)); end; - a := a +{%} a shl 3; - a := a xor (a shr 11); - a := a +{%} a shl 15; + a := a +{%} a shl int32(3); + a := a xor (a shr int32(11)); + a := a +{%} a shl int32(15); result := a end end; @@ -450,7 +447,7 @@ begin len := sonsLen(b); for i := 0 to len - 2 do begin assert(b.sons[i].kind <> nkRange); - x := initLocExpr(p, b.sons[i]); + initLocExpr(p, b.sons[i], x); freeTemp(p, x); assert(b.sons[i].kind in [nkStrLit..nkTripleStrLit]); j := int(hashString(b.sons[i].strVal) and high(branches)); @@ -473,14 +470,16 @@ begin if strings > stringCaseThreshold then begin useMagic(p.module, 'hashString'); bitMask := nmath.nextPowerOfTwo(strings)-1; + {@ignore} setLength(branches, bitMask+1); - a := initLocExpr(p, t.sons[0]); + {@emit newSeq(branches, bitMask+1);} + initLocExpr(p, t.sons[0], a); // fist pass: gnerate ifs+goto: labId := p.labels; for i := 1 to sonsLen(t) - 1 do begin inc(p.labels); if t.sons[i].kind = nkOfBranch then - genCaseStringBranch(p, t.sons[i], a, con('L'+'', toRope(p.labels)), + genCaseStringBranch(p, t.sons[i], a, con('LA', toRope(p.labels)), branches) else begin // else statement: nothing to do yet @@ -497,7 +496,7 @@ begin app(p.s[cpsStmts], '}' + tnl); // else statement: if t.sons[sonsLen(t)-1].kind <> nkOfBranch then - appf(p.s[cpsStmts], 'goto L$1;$n', [toRope(p.labels)]); + appf(p.s[cpsStmts], 'goto LA$1;$n', [toRope(p.labels)]); // third pass: generate statements genCaseSecondPass(p, t, labId); freeTemp(p, a); @@ -540,7 +539,7 @@ begin break end; if canGenerateSwitch then begin - a := initLocExpr(p, t.sons[0]); + initLocExpr(p, t.sons[0], a); appf(p.s[cpsStmts], 'switch ($1) {$n', [rdCharLoc(a)]); freeTemp(p, a); for i := 1 to sonsLen(t)-1 do begin @@ -821,7 +820,7 @@ var a: TLoc; begin genLineDir(p, e); // BUGFIX - a := InitLocExpr(p, e.sons[0]); + InitLocExpr(p, e.sons[0], a); assert(a.t <> nil); expr(p, e.sons[1], a); freeTemp(p, a) @@ -837,10 +836,10 @@ begin if inCheckpoint(t.info) then MessageOut(renderTree(t)); case t.kind of - nkEmpty: begin end; // nothing to do! - nkStmtList: - for i := 0 to sonsLen(t) - 1 do - genStmts(p, t.sons[i]); + nkEmpty: begin end; // nothing to do! + nkStmtList: begin + for i := 0 to sonsLen(t)-1 do genStmts(p, t.sons[i]); + end; nkBlockStmt: genBlock(p, t, a); nkIfStmt: genIfStmt(p, t); nkWhileStmt: genWhileStmt(p, t); @@ -852,23 +851,25 @@ begin nkBreakStmt: genBreakStmt(p, t); nkCall: begin genLineDir(p, t); - a := initLocExpr(p, t); + initLocExpr(p, t, a); freeTemp(p, a); end; nkAsgn: genAsgn(p, t); nkDiscardStmt: begin genLineDir(p, t); - a := initLocExpr(p, t.sons[0]); + initLocExpr(p, t.sons[0], a); freeTemp(p, a) end; nkAsmStmt: genAsmStmt(p, t); - nkTryStmt: + nkTryStmt: begin if gCmd = cmdCompileToCpp then genTryStmtCpp(p, t) else genTryStmt(p, t); + end; nkRaiseStmt: genRaiseStmt(p, t); nkTypeSection: begin - // nothing to do: - // we generate only when the symbol is accessed + // we have to emit the type information for object types here to support + // seperate compilation: + genTypeSection(p.module, t); end; nkCommentStmt, nkNilLit, nkIteratorDef, nkIncludeStmt, nkImportStmt, nkFromStmt, nkTemplateDef, nkMacroDef: begin end; diff --git a/nim/ccgtypes.pas b/nim/ccgtypes.pas index 329d9f60c..2c238ce84 100644 --- a/nim/ccgtypes.pas +++ b/nim/ccgtypes.pas @@ -7,16 +7,27 @@ // distribution, for details about the copyright. // +//var +// newDummyVar: int; // just to check the rodgen mechanism + // ------------------------- Name Mangling -------------------------------- function mangle(const name: string): string; var i: int; begin - if name[strStart] in ['A'..'Z', '0'..'9', 'a'..'z'] then - result := toUpper(name[strStart])+'' - else - result := 'HEX' + toHex(ord(name[strStart]), 2); + case name[strStart] of + 'a'..'z': begin + result := ''; + addChar(result, chr(ord(name[strStart]) - ord('a') + ord('A'))); + end; + '0'..'9', 'A'..'Z': begin + result := ''; + addChar(result, name[strStart]); + end; + else + result := 'HEX' + toHex(ord(name[strStart]), 2); + end; for i := strStart+1 to length(name) + strStart-1 do begin case name[i] of 'A'..'Z': addChar(result, chr(ord(name[i]) - ord('A') + ord('a'))); @@ -29,11 +40,28 @@ end; function mangleName(s: PSym): PRope; begin - result := ropef('$1_$2', [toRope(mangle(s.name.s)), toRope(s.id)]); - if optGenMapping in gGlobalOptions then - if s.owner <> nil then - appf(gMapping, '$1.$2 $3$n', - [toRope(s.owner.Name.s), toRope(s.name.s), result]) + result := s.loc.r; + if result = nil then begin + result := toRope(mangle(s.name.s)); + app(result, '_'+''); + app(result, toRope(s.id)); + if optGenMapping in gGlobalOptions then + if s.owner <> nil then + appf(gMapping, '"$1.$2": $3$n', + [toRope(s.owner.Name.s), toRope(s.name.s), result]); + s.loc.r := result; + end +end; + +function getTypeName(typ: PType): PRope; +begin + if (typ.sym <> nil) and ([sfImportc, sfExportc] * typ.sym.flags <> []) then + result := typ.sym.loc.r + else begin + if typ.loc.r = nil then typ.loc.r := con('TY', toRope(typ.id)); + result := typ.loc.r + end; + if result = nil then InternalError('getTypeName: ' + typeKindToStr[typ.kind]); end; // ------------------------------ C type generator ------------------------ @@ -44,7 +72,7 @@ begin tyNone: result := ctVoid; tyBool: result := ctBool; tyChar: result := ctChar; - tyEmptySet, tySet: begin + tySet: begin case int(getSize(typ)) of 1: result := ctInt8; 2: result := ctInt16; @@ -90,7 +118,8 @@ begin end end; -function getTypeDesc(m: BModule; typ: PType): PRope; forward; +function getTypeDescAux(m: BModule; typ: PType; + var check: TIntSet): PRope; forward; function needsComplexAssignment(typ: PType): bool; begin @@ -107,7 +136,8 @@ begin result := true else begin case mapType(rettype) of - ctArray: result := true; + ctArray: + result := not (skipGeneric(rettype).kind in [tyVar, tyRef, tyPtr]); ctStruct: result := needsComplexAssignment(skipGeneric(rettype)); else result := false; end @@ -119,18 +149,20 @@ const 'N_STDCALL', 'N_CDECL', 'N_SAFECALL', 'N_SYSCALL', // this is probably not correct for all platforms, // but one can //define it to what you want so there will no problem - 'N_INLINE', 'N_FASTCALL', 'N_CLOSURE', 'N_NOCONV'); + 'N_INLINE', 'N_NOINLINE', 'N_FASTCALL', 'N_CLOSURE', 'N_NOCONV'); function CacheGetType(const tab: TIdTable; key: PType): PRope; begin // returns nil if we need to declare this type - result := PRope(TableGetType(tab, key)) + // since types are now unique via the ``GetUniqueType`` mechanism, this slow + // linear search is not necessary anymore: + result := PRope(IdTableGet(tab, key)) end; function getTempName(): PRope; begin - inc(gUnique); - result := con('T'+'', toRope(gUnique)) + result := con('TMP', toRope(gId)); + inc(gId); end; function ccgIntroducedPtr(s: PSym): bool; @@ -166,7 +198,8 @@ begin end end; -procedure genProcParams(m: BModule; t: PType; out rettype, params: PRope); +procedure genProcParams(m: BModule; t: PType; out rettype, params: PRope; + var check: TIntSet); var i, j: int; param: PSym; @@ -177,12 +210,12 @@ begin // C cannot return arrays (what a poor language...) rettype := toRope('void') else - rettype := getTypeDesc(m, t.sons[0]); + rettype := getTypeDescAux(m, t.sons[0], check); for i := 1 to sonsLen(t.n)-1 do begin if t.n.sons[i].kind <> nkSym then InternalError(t.n.info, 'genProcParams'); param := t.n.sons[i].sym; fillLoc(param.loc, locParam, param.typ, mangleName(param), OnStack); - app(params, getTypeDesc(m, param.typ)); + app(params, getTypeDescAux(m, param.typ, check)); if ccgIntroducedPtr(param) then begin app(params, '*'+''); include(param.loc.flags, lfIndirect); @@ -203,7 +236,7 @@ begin end; if (t.sons[0] <> nil) and isInvalidReturnType(t.sons[0]) then begin if params <> nil then app(params, ', '); - app(params, getTypeDesc(m, t.sons[0])); + app(params, getTypeDescAux(m, t.sons[0], check)); if mapType(t.sons[0]) <> ctArray then app(params, '*'+''); app(params, ' Result'); end; @@ -227,25 +260,16 @@ begin result := (t.sym <> nil) and (sfImportc in t.sym.flags) end; -function getTypeName(typ: PType): PRope; -begin - if (typ.sym <> nil) and ([sfImportc, sfExportc] * typ.sym.flags <> []) then - result := typ.sym.loc.r - else begin - if typ.loc.r = nil then typ.loc.r := con('Ty', toRope(typ.id)); - result := typ.loc.r - end -end; - -function typeNameOrLiteral(typ: PType; const literal: string): PRope; +function typeNameOrLiteral(t: PType; const literal: string): PRope; begin - if isImportedType(typ) then - result := getTypeName(typ) + if (t.sym <> nil) and (sfImportc in t.sym.flags) and + (t.sym.magic = mNone) then + result := getTypeName(t) else result := toRope(literal) end; -function getSimpleTypeDesc(typ: PType): PRope; +function getSimpleTypeDesc(m: BModule; typ: PType): PRope; const NumericalTypeToStr: array [tyInt..tyFloat128] of string = ( 'NI', 'NI8', 'NI16', 'NI32', 'NI64', 'NF', 'NF32', 'NF64', 'NF128'); @@ -267,14 +291,17 @@ begin end end end; - tyString: result := typeNameOrLiteral(typ, 'string'); + tyString: begin + useMagic(m, 'NimStringDesc'); + result := typeNameOrLiteral(typ, 'NimStringDesc*'); + end; tyCstring: result := typeNameOrLiteral(typ, 'NCSTRING'); tyBool: result := typeNameOrLiteral(typ, 'NIM_BOOL'); tyChar: result := typeNameOrLiteral(typ, 'NIM_CHAR'); tyNil: result := typeNameOrLiteral(typ, '0'+''); tyInt..tyFloat128: result := typeNameOrLiteral(typ, NumericalTypeToStr[typ.Kind]); - tyRange: result := getSimpleTypeDesc(typ.sons[0]); + tyRange: result := getSimpleTypeDesc(m, typ.sons[0]); else result := nil; end end; @@ -284,7 +311,7 @@ begin if typ = nil then result := toRope('void') else begin - result := getSimpleTypeDesc(typ); + result := getSimpleTypeDesc(m, typ); if result = nil then result := CacheGetType(m.typeCache, typ) end @@ -325,7 +352,7 @@ begin end; function genRecordFieldsAux(m: BModule; n: PNode; accessExpr: PRope; - rectype: PType): PRope; + rectype: PType; var check: TIntSet): PRope; var i: int; ae, uname, sname, a: PRope; @@ -336,13 +363,14 @@ begin case n.kind of nkRecList: begin for i := 0 to sonsLen(n)-1 do begin - app(result, genRecordFieldsAux(m, n.sons[i], accessExpr, rectype)); + app(result, genRecordFieldsAux(m, n.sons[i], accessExpr, + rectype, check)); end end; nkRecCase: begin if (n.sons[0].kind <> nkSym) then InternalError(n.info, 'genRecordFieldsAux'); - app(result, genRecordFieldsAux(m, n.sons[0], accessExpr, rectype)); + app(result, genRecordFieldsAux(m, n.sons[0], accessExpr, rectype, check)); uname := toRope(mangle(n.sons[0].sym.name.s)+ 'U'); if accessExpr <> nil then ae := ropef('$1.$2', [accessExpr, uname]) else ae := uname; @@ -354,14 +382,14 @@ begin if k.kind <> nkSym then begin sname := con('S'+'', toRope(i)); a := genRecordFieldsAux(m, k, ropef('$1.$2', [ae, sname]), - rectype); + rectype, check); if a <> nil then begin app(result, 'struct {'); app(result, a); appf(result, '} $1;$n', [sname]); end end - else app(result, genRecordFieldsAux(m, k, ae, rectype)); + else app(result, genRecordFieldsAux(m, k, ae, rectype, check)); end; else internalError('genRecordFieldsAux(record case branch)'); end; @@ -375,18 +403,19 @@ begin if accessExpr <> nil then ae := ropef('$1.$2', [accessExpr, sname]) else ae := sname; fillLoc(field.loc, locField, field.typ, ae, OnUnknown); - appf(result, '$1 $2;$n', [getTypeDesc(m, field.loc.t), sname]) + appf(result, '$1 $2;$n', [getTypeDescAux(m, field.loc.t, check), sname]) end; else internalError(n.info, 'genRecordFieldsAux()'); end end; -function getRecordFields(m: BModule; typ: PType): PRope; +function getRecordFields(m: BModule; typ: PType; var check: TIntSet): PRope; begin - result := genRecordFieldsAux(m, typ.n, nil, typ); + result := genRecordFieldsAux(m, typ.n, nil, typ, check); end; -function getRecordDesc(m: BModule; typ: PType; name: PRope): PRope; +function getRecordDesc(m: BModule; typ: PType; name: PRope; + var check: TIntSet): PRope; var desc: PRope; hasField: bool; @@ -406,18 +435,18 @@ begin end else if gCmd = cmdCompileToCpp then begin result := ropef('struct $1 : public $2 {$n', - [name, getTypeDesc(m, typ.sons[0])]); + [name, getTypeDescAux(m, typ.sons[0], check)]); hasField := true end else begin result := ropef('struct $1 {$n $2 Sup;$n', - [name, getTypeDesc(m, typ.sons[0])]); + [name, getTypeDescAux(m, typ.sons[0], check)]); hasField := true end end else result := ropef('struct $1 {$n', [name]); - desc := getRecordFields(m, typ); + desc := getRecordFields(m, typ, check); if (desc = nil) and not hasField then // no fields in struct are not valid in C, so generate a dummy: appf(result, 'char dummy;$n', []) @@ -435,7 +464,7 @@ begin m.typeStack[L] := typ; end; -function getTypeDesc(m: BModule; typ: PType): PRope; +function getTypeDescAux(m: BModule; typ: PType; var check: TIntSet): PRope; // returns only the type's name var name, rettype, desc, recdesc: PRope; @@ -443,12 +472,18 @@ var t, et: PType; begin t := getUniqueType(typ); - if t = nil then InternalError('getTypeDesc: t == nil'); + if t = nil then InternalError('getTypeDescAux: t == nil'); if t.sym <> nil then useHeader(m, t.sym); result := getTypePre(m, t); if result <> nil then exit; + if IntSetContainsOrIncl(check, t.id) then begin + InternalError('cannot generate C type for: ' + typeToString(typ)); + // XXX: this BUG is hard to fix -> we need to introduce helper structs, + // but determining when this needs to be done is hard. We should split + // C type generation into an analysis and a code generation phase somehow. + end; case t.Kind of - tyRef, tyPtr, tyVar, tyOpenArray: begin + tyRef, tyPtr, tyVar: begin et := getUniqueType(t.sons[0]); if et.kind in [tyArrayConstr, tyArray, tyOpenArray] then et := getUniqueType(elemType(et)); @@ -469,15 +504,20 @@ begin end; else begin // else we have a strong dependency :-( - result := con(getTypeDesc(m, et), '*'+''); + result := con(getTypeDescAux(m, et, check), '*'+''); IdTablePut(m.typeCache, t, result) end end end; + tyOpenArray: begin + et := getUniqueType(t.sons[0]); + result := con(getTypeDescAux(m, et, check), '*'+''); + IdTablePut(m.typeCache, t, result) + end; tyProc: begin result := getTypeName(t); IdTablePut(m.typeCache, t, result); - genProcParams(m, t, rettype, desc); + genProcParams(m, t, rettype, desc, check); if not isImportedType(t) then begin if t.callConv <> ccClosure then appf(m.s[cfsTypes], 'typedef $1_PTR($2, $3) $4;$n', @@ -501,12 +541,14 @@ begin end; assert(CacheGetType(m.typeCache, t) = nil); IdTablePut(m.typeCache, t, con(result, '*'+'')); - if not isImportedType(t) then + if not isImportedType(t) then begin + useMagic(m, 'TGenericSeq'); appf(m.s[cfsSeqTypes], 'struct $2 {$n' + - ' NI len, space;$n' + + ' TGenericSeq Sup;$n' + ' $1 data[SEQ_DECL_SIZE];$n' + - '};$n', [getTypeDesc(m, t.sons[0]), result]); + '};$n', [getTypeDescAux(m, t.sons[0], check), result]); + end; app(result, '*'+''); end; tyArrayConstr, tyArray: begin @@ -516,7 +558,7 @@ begin IdTablePut(m.typeCache, t, result); if not isImportedType(t) then appf(m.s[cfsTypes], 'typedef $1 $2[$3];$n', - [getTypeDesc(m, t.sons[1]), result, ToRope(n)]) + [getTypeDescAux(m, t.sons[1], check), result, ToRope(n)]) end; tyObject, tyTuple: begin result := CacheGetType(m.forwTypeCache, t); @@ -528,7 +570,8 @@ begin IdTablePut(m.forwTypeCache, t, result) end; IdTablePut(m.typeCache, t, result); - recdesc := getRecordDesc(m, t, result); // always call for sideeffects + // always call for sideeffects: + recdesc := getRecordDesc(m, t, result, check); if not isImportedType(t) then app(m.s[cfsTypes], recdesc); end; tySet: begin @@ -546,14 +589,22 @@ begin end end end; - tyGenericInst: result := getTypeDesc(m, lastSon(t)); + tyGenericInst: result := getTypeDescAux(m, lastSon(t), check); else begin - InternalError('getTypeDesc(' + typeKindToStr[t.kind] + ')'); + InternalError('getTypeDescAux(' + typeKindToStr[t.kind] + ')'); result := nil end end end; +function getTypeDesc(m: BModule; typ: PType): PRope; +var + check: TIntSet; +begin + IntSetInit(check); + result := getTypeDescAux(m, typ, check); +end; + procedure finishTypeDescriptions(m: BModule); var i: int; @@ -568,14 +619,16 @@ end; function genProcHeader(m: BModule; prc: PSym): PRope; var rettype, params: PRope; + check: TIntSet; begin // using static is needed for inline procs if (prc.typ.callConv = ccInline) then result := toRope('static ') else result := nil; + IntSetInit(check); fillLoc(prc.loc, locProc, prc.typ, mangleName(prc), OnUnknown); - genProcParams(m, prc.typ, rettype, params); + genProcParams(m, prc.typ, rettype, params, check); appf(result, '$1($2, $3)$4', [toRope(CallingConvToStr[prc.typ.callConv]), rettype, prc.loc.r, params]) @@ -583,25 +636,33 @@ end; // ----------------------- type information ---------------------------------- -var - gTypeInfoGenerated: TIntSet; - function genTypeInfo(m: BModule; typ: PType): PRope; forward; -procedure allocMemTI(m: BModule; name: PRope); +function getNimNode(m: BModule): PRope; +begin + result := ropef('$1[$2]', [m.typeNodesName, toRope(m.typeNodes)]); + inc(m.typeNodes); +end; + +function getNimType(m: BModule): PRope; +begin + result := ropef('$1[$2]', [m.nimTypesName, toRope(m.nimTypes)]); + inc(m.nimTypes); +end; + +procedure allocMemTI(m: BModule; typ: PType; name: PRope); var tmp: PRope; begin - tmp := getTempName(); - appf(m.s[cfsTypeInit1], 'static TNimType $1;$n', [tmp]); + tmp := getNimType(m); appf(m.s[cfsTypeInit2], '$2 = &$1;$n', [tmp, name]); end; procedure genTypeInfoAuxBase(m: BModule; typ: PType; name, base: PRope); var - nimtypeKind: int; + nimtypeKind, flags: int; begin - allocMemTI(m, name); + allocMemTI(m, typ, name); if (typ.kind = tyObject) and (tfFinal in typ.flags) and (typ.sons[0] = nil) then nimtypeKind := ord(high(TTypeKind))+1 // tyPureObject @@ -612,7 +673,15 @@ begin '$1->kind = $3;$n' + '$1->base = $4;$n', [ name, getTypeDesc(m, typ), toRope(nimtypeKind), base]); - appf(m.s[cfsVars], 'TNimType* $1;$n', [name]); + // compute type flags for GC optimization + flags := 0; + if not containsGarbageCollectedRef(typ) then flags := flags or 1; + if not canFormAcycle(typ) then flags := flags or 2; + //else MessageOut('can contain a cycle: ' + typeToString(typ)); + if flags <> 0 then + appf(m.s[cfsTypeInit3], '$1->flags = $2;$n', [name, toRope(flags)]); + appf(m.s[cfsVars], 'TNimType* $1; /* $2 */$n', + [name, toRope(typeToString(typ))]); end; procedure genTypeInfoAux(m: BModule; typ: PType; name: PRope); @@ -643,10 +712,8 @@ begin appf(m.s[cfsTypeInit1], 'static TNimNode* $1[$2];$n', [tmp, toRope(len)]); for i := 0 to len-1 do begin - tmp2 := getTempName(); - appf(m.s[cfsTypeInit1], 'static TNimNode $1;$n', [tmp2]); - appf(m.s[cfsTypeInit3], '$1[$2] = &$3;$n', - [tmp, toRope(i), tmp2]); + tmp2 := getNimNode(m); + appf(m.s[cfsTypeInit3], '$1[$2] = &$3;$n', [tmp, toRope(i), tmp2]); genObjectFields(m, typ, n.sons[i], tmp2); end; appf(m.s[cfsTypeInit3], @@ -676,10 +743,8 @@ begin [tmp, toRope(lengthOrd(field.typ)+1)]); for i := 1 to len-1 do begin b := n.sons[i]; // branch - tmp2 := getTempName(); - appf(m.s[cfsTypeInit1], 'static TNimNode $1;$n', [tmp2]); + tmp2 := getNimNode(m); genObjectFields(m, typ, lastSon(b), tmp2); - //writeln(output, renderTree(b.sons[j])); case b.kind of nkOfBranch: begin if sonsLen(b) < 2 then @@ -728,42 +793,54 @@ var begin if typ.kind = tyObject then genTypeInfoAux(m, typ, name) else genTypeInfoAuxBase(m, typ, name, toRope('0'+'')); - tmp := getTempName(); - appf(m.s[cfsTypeInit1], 'static TNimNode $1;$n', [tmp]); + tmp := getNimNode(m); genObjectFields(m, typ, typ.n, tmp); appf(m.s[cfsTypeInit3], '$1->node = &$2;$n', [name, tmp]); end; procedure genEnumInfo(m: BModule; typ: PType; name: PRope); var - tmp, tmp2, tmp3: PRope; - len, i: int; + nodePtrs, elemNode, enumNames, enumArray, counter, specialCases: PRope; + len, i, firstNimNode: int; field: PSym; begin + // Type information for enumerations is quite heavy, so we do some + // optimizations here: The ``typ`` field is never set, as it is redundant + // anyway. We generate a cstring array and a loop over it. Exceptional + // positions will be reset after the loop. genTypeInfoAux(m, typ, name); - tmp := getTempName(); - tmp2 := getTempName(); + nodePtrs := getTempName(); len := sonsLen(typ.n); - appf(m.s[cfsTypeInit1], 'static TNimNode* $1[$2];$n' + - 'static TNimNode $3;$n', - [tmp, toRope(len), tmp2]); + appf(m.s[cfsTypeInit1], 'static TNimNode* $1[$2];$n', [nodePtrs, toRope(len)]); + enumNames := nil; + specialCases := nil; + firstNimNode := m.typeNodes; for i := 0 to len-1 do begin assert(typ.n.sons[i].kind = nkSym); field := typ.n.sons[i].sym; - tmp3 := getTempName(); - appf(m.s[cfsTypeInit1], 'static TNimNode $1;$n', [tmp3]); - appf(m.s[cfsTypeInit3], '$1[$2] = &$3;$n' + - '$3.kind = 1;$n' + - '$3.offset = $4;$n' + - '$3.typ = $5;$n' + - '$3.name = $6;$n', - [tmp, toRope(i), tmp3, - toRope(field.position), - name, makeCString(field.name.s)]); + elemNode := getNimNode(m); + app(enumNames, makeCString(field.name.s)); + if i < len-1 then app(enumNames, ', '+tnl); + if field.position <> i then + appf(specialCases, '$1.offset = $2;$n', [elemNode, toRope(field.position)]); end; + enumArray := getTempName(); + counter := getTempName(); + appf(m.s[cfsTypeInit1], 'NI $1;$n', [counter]); + appf(m.s[cfsTypeInit1], 'static char* NIM_CONST $1[$2] = {$n$3};$n', + [enumArray, toRope(len), enumNames]); + appf(m.s[cfsTypeInit3], 'for ($1 = 0; $1 < $2; $1++) {$n' + + '$3[$1+$4].kind = 1;$n' + + '$3[$1+$4].offset = $1;$n' + + '$3[$1+$4].name = $5[$1];$n' + + '$6[$1] = &$3[$1+$4];$n' + + '}$n', + [counter, toRope(len), m.typeNodesName, toRope(firstNimNode), + enumArray, nodePtrs]); + app(m.s[cfsTypeInit3], specialCases); appf(m.s[cfsTypeInit3], '$1.len = $2; $1.kind = 2; $1.sons = &$3[0];$n$4->node = &$1;$n', [ - tmp2, toRope(len), tmp, name]); + getNimNode(m), toRope(len), nodePtrs, name]); end; procedure genSetInfo(m: BModule; typ: PType; name: PRope); @@ -772,8 +849,7 @@ var begin assert(typ.sons[0] <> nil); genTypeInfoAux(m, typ, name); - tmp := getTempName(); - appf(m.s[cfsTypeInit1], 'static TNimNode $1;$n', [tmp]); + tmp := getNimNode(m); appf(m.s[cfsTypeInit3], '$1.len = $2; $1.kind = 0;$n' + '$3->node = &$1;$n', [tmp, toRope(firstOrd(typ)), name]); @@ -784,28 +860,96 @@ begin genTypeInfoAuxBase(m, typ, name, genTypeInfo(m, typ.sons[1])); end; +var + gToTypeInfoId: TIiTable; + +(* // this does not work any longer thanks to separate compilation: +function getTypeInfoName(t: PType): PRope; +begin + result := ropef('NTI$1', [toRope(t.id)]); +end;*) + function genTypeInfo(m: BModule; typ: PType): PRope; var t: PType; + id: int; + dataGen: bool; begin t := getUniqueType(typ); - result := ropef('NTI$1', [toRope(t.id)]); + id := IiTableGet(gToTypeInfoId, t.id); + if id = invalidKey then begin + dataGen := false; + case t.kind of + tyEnum, tyBool: begin + id := t.id; + dataGen := true + end; + tyObject: begin + if sfPure in t.sym.flags then + id := getID() + else begin + id := t.id; + dataGen := true + end + end + else + id := getID(); + end; + IiTablePut(gToTypeInfoId, t.id, id); + end + else + dataGen := true; + result := ropef('NTI$1', [toRope(id)]); if not IntSetContainsOrIncl(m.typeInfoMarker, t.id) then begin // declare type information structures: useMagic(m, 'TNimType'); useMagic(m, 'TNimNode'); - appf(m.s[cfsVars], 'extern TNimType* $1;$n', [result]); + if dataGen then + appf(m.s[cfsVars], 'extern TNimType* $1; /* $2 */$n', + [result, toRope(typeToString(t))]); end; - if IntSetContainsOrIncl(gTypeInfoGenerated, t.id) then exit; + if dataGen then exit; case t.kind of - tyPointer, tyProc, tyBool, tyChar, tyCString, tyString, tyInt..tyFloat128: + tyPointer, tyProc, tyBool, tyChar, tyCString, tyString, + tyInt..tyFloat128, tyVar: genTypeInfoAuxBase(m, t, result, toRope('0'+'')); tyRef, tyPtr, tySequence, tyRange: genTypeInfoAux(m, t, result); tyArrayConstr, tyArray: genArrayInfo(m, t, result); tySet: genSetInfo(m, t, result); tyEnum: genEnumInfo(m, t, result); tyObject, tyTuple: genObjectInfo(m, t, result); - tyVar: result := genTypeInfo(m, typ.sons[0]); else InternalError('genTypeInfo(' + typekindToStr[t.kind] + ')'); end end; + +procedure genTypeSection(m: BModule; n: PNode); +var + i: int; + a: PNode; + t: PType; +begin + for i := 0 to sonsLen(n)-1 do begin + a := n.sons[i]; + if a.kind = nkCommentStmt then continue; + if (a.sons[0].kind <> nkSym) then InternalError(a.info, 'genTypeSection'); + t := a.sons[0].sym.typ; + if (a.sons[2] = nil) + or not (a.sons[2].kind in [nkSym, nkIdent, nkAccQuoted]) then + if t <> nil then + case t.kind of + tyEnum, tyBool: begin + useMagic(m, 'TNimType'); + useMagic(m, 'TNimNode'); + genEnumInfo(m, t, ropef('NTI$1', [toRope(t.id)])); + end; + tyObject: begin + if not (sfPure in t.sym.flags) then begin + useMagic(m, 'TNimType'); + useMagic(m, 'TNimNode'); + genObjectInfo(m, t, ropef('NTI$1', [toRope(t.id)])); + end + end + else begin end + end + end +end; diff --git a/nim/ccgutils.pas b/nim/ccgutils.pas index 09cd504bc..8e3775d22 100644 --- a/nim/ccgutils.pas +++ b/nim/ccgutils.pas @@ -6,7 +6,6 @@ // See the file "copying.txt", included in this // distribution, for details about the copyright. // - unit ccgutils; interface @@ -35,21 +34,28 @@ var t: PType; h: THash; begin + // this was a hotspot in the compiler! result := key; if key = nil then exit; - assert(key.kind <> tyForward); - if key.kind = tyGenericInst then begin - result := GetUniqueType(lastSon(key)); - exit - end; - if IdTableHasObjectAsKey(gTypeTable, key) then exit; - // we have to do a slow linear search because types may need - // to be compared by their structure: - for h := 0 to high(gTypeTable.data) do begin - t := PType(gTypeTable.data[h].key); - if (t <> nil) and sameType(t, key) then begin result := t; exit end + case key.Kind of + tyEmpty, tyChar, tyBool, tyNil, tyPointer, tyString, tyCString, + tyInt..tyFloat128, tyProc, tyEnum, tyObject, tyAnyEnum: begin end; + tyNone, tyForward: + InternalError('GetUniqueType: ' + typeToString(key)); + tyGenericParam, tyGeneric, tySequence, + tyOpenArray, tySet, tyVar, tyRef, tyPtr, tyArrayConstr, + tyArray, tyTuple, tyRange: begin + // we have to do a slow linear search because types may need + // to be compared by their structure: + if IdTableHasObjectAsKey(gTypeTable, key) then exit; + for h := 0 to high(gTypeTable.data) do begin + t := PType(gTypeTable.data[h].key); + if (t <> nil) and sameType(t, key) then begin result := t; exit end + end; + IdTablePut(gTypeTable, key, key); + end; + tyGenericInst: result := GetUniqueType(lastSon(key)); end; - IdTablePut(gTypeTable, key, key); end; function TableGetType(const tab: TIdTable; key: PType): PObject; @@ -102,7 +108,7 @@ begin end; res := res +{&} toCChar(s[i]); end; - res := res +{&} '"'+''; + addChar(res, '"'); app(result, toRope(res)); end; diff --git a/nim/cgen.pas b/nim/cgen.pas index 677a9b0ac..2f89c4208 100644 --- a/nim/cgen.pas +++ b/nim/cgen.pas @@ -6,7 +6,6 @@ // See the file "copying.txt", included in this // distribution, for details about the copyright. // - unit cgen; // This is the new C code generator; much cleaner and faster @@ -19,10 +18,10 @@ interface uses nsystem, ast, astalgo, strutils, hashes, trees, platform, magicsys, extccomp, options, nversion, nimsets, msgs, crc, bitsets, idents, - lists, types, ccgutils, nos, ntime, ropes, nmath, backends, - wordrecg, rnimsyn; - -function CBackend(b: PBackend; module: PSym; const filename: string): PBackend; + lists, types, ccgutils, nos, ntime, ropes, nmath, passes, rodread, + wordrecg, rnimsyn, treetab; + +function cgenPass(): TPass; implementation @@ -95,7 +94,6 @@ type // (the vars must be volatile then) labels: Natural; // for generating unique labels in the C proc blocks: array of TBlock; // nested blocks - locals: array of TLoc; // locNone means slot is free again options: TOptions; // options that should be used for code // generation; this is the same as prc.options // unless prc == nil @@ -105,7 +103,9 @@ type module: BModule; // used to prevent excessive parameter passing end; TTypeSeq = array of PType; - TCGen = object(TBackend) // represents a C source file + TCGen = object(TPassContext) // represents a C source file + module: PSym; + filename: string; s: TCFileSections; // sections of the C file cfilename: string; // filename of the module (including path, // without extension) @@ -114,18 +114,21 @@ type declaredThings: TIntSet; // things we have declared in this .c file debugDeclared: TIntSet; // for debugging purposes headerFiles: TLinkedList; // needed headers to include - //unique: Natural; // for generating unique names typeInfoMarker: TIntSet; // needed for generating type information initProc: BProc; // code for init procedure typeStack: TTypeSeq; // used for type generation + dataCache: TNodeTable; + typeNodes, nimTypes: int;// used for type info generation + typeNodesName, nimTypesName: PRope; // used for type info generation end; var - gUnique: Natural; mainModProcs, mainModInit: PRope; // parts of the main module gMapping: PRope; // the generated mapping file (if requested) + gProcProfile: Natural; // proc profile counter -function initLoc(k: TLocKind; typ: PType; s: TStorageLoc): TLoc; + +procedure initLoc(var result: TLoc; k: TLocKind; typ: PType; s: TStorageLoc); begin result.k := k; result.s := s; @@ -162,11 +165,8 @@ begin result.options := gOptions; {@ignore} setLength(result.blocks, 0); - setLength(result.locals, 0); -{@emit - result.blocks := [];} {@emit - result.locals := [];} + result.blocks := @[];} end; function isSimpleConst(typ: PType): bool; @@ -179,15 +179,12 @@ procedure useHeader(m: BModule; sym: PSym); begin if lfHeader in sym.loc.Flags then begin assert(sym.annex <> nil); - {@discard} lists.IncludeStr(m.headerFiles, PLib(sym.annex).path) + {@discard} lists.IncludeStr(m.headerFiles, sym.annex.path) end end; procedure UseMagic(m: BModule; const name: string); forward; -// ----------------------------- name mangling -// +++++++++++++++++++++++++++++ type generation -// +++++++++++++++++++++++++++++ type info generation {$include 'ccgtypes.pas'} // ------------------------------ Manager of temporaries ------------------ @@ -198,41 +195,20 @@ begin result := sameType(skipGenericRange(a), skipGenericRange(b)) end; -function getTemp(p: BProc; t: PType): TLoc; -var - i, index: int; - name: PRope; -begin (* - for i := 0 to high(p.locals) do begin - assert(i = p.locals[i].a); - if (p.locals[i].k = locNone) and beEqualTypes(p.locals[i].t, t) then begin - // free slot of the appropriate type? - p.locals[i].k := locTemp; // is filled again - result := p.locals[i]; - exit - end - end; *) - // not found: - index := length(p.locals); - setLength(p.locals, index+1); - // declare the new temporary: - name := con('Loc', toRope(index)); - appf(p.s[cpsLocals], '$1 $2; /* temporary */$n', - [getTypeDesc(p.module, t), name]); - p.locals[index].k := locTemp; - p.locals[index].a := index; - p.locals[index].r := name; - p.locals[index].t := getUniqueType(t); - p.locals[index].s := OnStack; - p.locals[index].flags := {@set}[]; - result := p.locals[index] // BUGFIX! +procedure getTemp(p: BProc; t: PType; var result: TLoc); +begin + inc(p.labels); + result.r := con('LOC', toRope(p.labels)); + appf(p.s[cpsLocals], '$1 $2;$n', [getTypeDesc(p.module, t), result.r]); + result.k := locTemp; + result.a := -1; + result.t := getUniqueType(t); + result.s := OnStack; + result.flags := {@set}[]; end; procedure freeTemp(p: BProc; const temp: TLoc); -begin (* - if (temp.a >= 0) and (temp.a < length(p.locals)) and - (p.locals[temp.a].k = locTemp) then - p.locals[temp.a].k := locNone *) +begin end; // -------------------------- Variable manager ---------------------------- @@ -245,6 +221,8 @@ begin app(m.s[cfsVars], ' register'); if sfVolatile in s.flags then app(m.s[cfsVars], ' volatile'); + if sfThreadVar in s.flags then + app(m.s[cfsVars], ' NIM_THREADVAR'); appf(m.s[cfsVars], ' $1;$n', [s.loc.r]) end end; @@ -314,7 +292,7 @@ end; function getLabel(p: BProc): TLabel; begin inc(p.labels); - result := con('L'+'', toRope(p.labels)) + result := con('LA', toRope(p.labels)) end; procedure fixLabel(p: BProc; labl: TLabel); @@ -344,10 +322,11 @@ begin lib.kind := libDynamicGenerated; useMagic(m, 'nimLoadLibrary'); useMagic(m, 'nimUnloadLibrary'); + useMagic(m, 'NimStringDesc'); tmp := getTempName(); appf(m.s[cfsVars], 'static void* $1;$n', [tmp]); appf(m.s[cfsDynLibInit], - '$1 = nimLoadLibrary((string) &$2);$n', + '$1 = nimLoadLibrary((NimStringDesc*) &$2);$n', [tmp, getStrLit(m, lib.path)]); appf(m.s[cfsDynLibDeinit], 'if ($1 != NIM_NIL) nimUnloadLibrary($1);$n', [tmp]); @@ -361,7 +340,7 @@ var lib: PLib; extname, tmp: PRope; begin - lib := PLib(sym.annex); + lib := sym.annex; extname := sym.loc.r; loadDynamicLib(m, lib); useMagic(m, 'nimGetProcAddr'); @@ -434,7 +413,7 @@ procedure genProc(m: BModule; prc: PSym); var p: BProc; generatedProc, header, returnStmt: PRope; - i: int; + i, profileId: int; res, param: PSym; begin useHeader(m, prc); @@ -454,21 +433,20 @@ begin returnStmt := nil; assert(prc.ast <> nil); - if not (sfPure in prc.flags) then begin + if not (sfPure in prc.flags) and (prc.typ.sons[0] <> nil) then begin + res := prc.ast.sons[resultPos].sym; // get result symbol if not isInvalidReturnType(prc.typ.sons[0]) then begin - res := prc.ast.sons[resultPos].sym; // get result symbol // declare the result symbol: assignLocalVar(p, res); assert(res.loc.r <> nil); - initVariable(p, res); - genObjectInit(p, res); returnStmt := ropef('return $1;$n', [rdLoc(res.loc)]); end - else if (prc.typ.sons[0] <> nil) then begin - res := prc.ast.sons[resultPos].sym; // get result symbol + else begin fillResult(res); - assignParam(p, res) - end + assignParam(p, res); + end; + initVariable(p, res); + genObjectInit(p, res.typ, res.loc, true); end; for i := 1 to sonsLen(prc.typ.n)-1 do begin param := prc.typ.n.sons[i].sym; @@ -492,16 +470,31 @@ begin [makeCString(prc.owner.name.s +{&} '.' +{&} prc.name.s), makeCString(toFilename(prc.info))])); end; + if optProfiler in prc.options then begin + if gProcProfile >= 64*1024 then // XXX: hard coded value! + InternalError(prc.info, 'too many procedures for profiling'); + useMagic(m, 'profileData'); + app(p.s[cpsLocals], 'ticks NIM_profilingStart;'+tnl); + if prc.loc.a < 0 then begin + appf(m.s[cfsDebugInit], 'profileData[$1].procname = $2;$n', + [toRope(gProcProfile), + makeCString(prc.owner.name.s +{&} '.' +{&} prc.name.s)]); + prc.loc.a := gProcProfile; + inc(gProcProfile); + end; + prepend(p.s[cpsInit], toRope('NIM_profilingStart = getticks();' + tnl)); + end; app(generatedProc, con(p.s)); if p.beforeRetNeeded then app(generatedProc, 'BeforeRet: ;' + tnl); if optStackTrace in prc.options then app(generatedProc, 'framePtr = framePtr->prev;' + tnl); + if optProfiler in prc.options then + appf(generatedProc, + 'profileData[$1].total += elapsed(getticks(), NIM_profilingStart);$n', + [toRope(prc.loc.a)]); app(generatedProc, returnStmt); app(generatedProc, '}' + tnl); - // only now we can free the syntax tree: - //if prc.typ.callConv <> ccInline then - // prc.ast.sons[codePos] := nil; end; app(m.s[cfsProcs], generatedProc); end @@ -524,6 +517,8 @@ begin app(m.s[cfsVars], ' register'); if sfVolatile in sym.flags then app(m.s[cfsVars], ' volatile'); + if sfThreadVar in sym.flags then + app(m.s[cfsVars], ' NIM_THREADVAR'); appf(m.s[cfsVars], ' $1;$n', [sym.loc.r]) end end; @@ -572,22 +567,28 @@ end; function getFileHeader(const cfilenoext: string): PRope; begin - result := ropef( - '/* Generated by the Nimrod Compiler v$1 */$n' + - '/* (c) 2008 Andreas Rumpf */$n' + - '/* Compiled for: $2, $3, $4 */$n' + - '/* Command for C compiler:$n $5 */$n', - [toRope(versionAsString), toRope(platform.OS[targetOS].name), - toRope(platform.CPU[targetCPU].name), - toRope(extccomp.CC[extccomp.ccompiler].name), - toRope(getCompileCFileCmd(cfilenoext))]); + if optCompileOnly in gGlobalOptions then + result := ropef( + '/* Generated by the Nimrod Compiler v$1 */$n' + + '/* (c) 2008 Andreas Rumpf */$n', + [toRope(versionAsString)]) + else + result := ropef( + '/* Generated by the Nimrod Compiler v$1 */$n' + + '/* (c) 2008 Andreas Rumpf */$n' + + '/* Compiled for: $2, $3, $4 */$n' + + '/* Command for C compiler:$n $5 */$n', + [toRope(versionAsString), toRope(platform.OS[targetOS].name), + toRope(platform.CPU[targetCPU].name), + toRope(extccomp.CC[extccomp.ccompiler].name), + toRope(getCompileCFileCmd(cfilenoext))]); case platform.CPU[targetCPU].intSize of 16: appf(result, '$ntypedef short int NI;$n' + - 'typedef unsigned short int NU;$n', []); + 'typedef unsigned short int NU;$n', []); 32: appf(result, '$ntypedef long int NI;$n' + - 'typedef unsigned long int NU;$n', []); + 'typedef unsigned long int NU;$n', []); 64: appf(result, '$ntypedef long long int NI;$n' + - 'typedef unsigned long long int NU;$n', []); + 'typedef unsigned long long int NU;$n', []); else begin end end end; @@ -645,18 +646,43 @@ begin appf(m.s[cfsProcs], frmt, [gBreakpoints, mainModInit]) end; +function getInitName(m: PSym): PRope; +begin + result := con(m.name.s, toRope('Init')); +end; + +procedure registerModuleToMain(m: PSym); +var + initname: PRope; +begin + initname := getInitName(m); + appf(mainModProcs, 'N_NOINLINE(void, $1)(void);$n', + [initname]); + if not (sfSystemModule in m.flags) then + appf(mainModInit, '$1();$n', [initname]); +end; + procedure genInitCode(m: BModule); var initname, prc: PRope; begin - initname := con(m.module.name.s, toRope('Init')); - appf(mainModProcs, 'N_NIMCALL(void, $1)(void);$n', - [initname]); - if not (sfSystemModule in m.module.flags) then - appf(mainModInit, '$1();$n', [initname]); - prc := ropef('N_NIMCALL(void, $1)(void) {$n', [initname]); + if optProfiler in m.initProc.options then begin + // This does not really belong here, but there is no good place for this + // code. I don't want to put this to the proc generation as the + // ``IncludeStr`` call is quite slow. + {@discard} lists.IncludeStr(m.headerFiles, '<cycle.h>'); + end; + initname := getInitName(m.module); + registerModuleToMain(m.module); + prc := ropef('N_NOINLINE(void, $1)(void) {$n', [initname]); + if m.typeNodes > 0 then + appf(m.s[cfsTypeInit1], 'static TNimNode $1[$2];$n', + [m.typeNodesName, toRope(m.typeNodes)]); + if m.nimTypes > 0 then + appf(m.s[cfsTypeInit1], 'static TNimType $1[$2];$n', + [m.nimTypesName, toRope(m.nimTypes)]); if optStackTrace in m.initProc.options then begin - prepend(m.initProc.s[cpsLocals], toRope('volatile TFrame F;' + tnl)); + getFrameDecl(m.initProc); app(prc, m.initProc.s[cpsLocals]); app(prc, m.s[cfsTypeInit1]); appf(prc, @@ -704,13 +730,42 @@ begin intSetInit(result.declaredThings); intSetInit(result.debugDeclared); result.cfilename := filename; + result.filename := filename; initIdTable(result.typeCache); initIdTable(result.forwTypeCache); result.module := module; intSetInit(result.typeInfoMarker); result.initProc := newProc(nil, result); result.initProc.options := gOptions; -{@emit result.typeStack := [];} + initNodeTable(result.dataCache); +{@emit result.typeStack := @[];} + result.typeNodesName := getTempName(); + result.nimTypesName := getTempName(); +end; + +function myOpen(module: PSym; const filename: string): PPassContext; +begin + result := newModule(module, filename); +end; + +function myOpenCached(module: PSym; const filename: string; + rd: PRodReader): PPassContext; +var + cfile, cfilenoext, objFile: string; +begin + //MessageOut('cgen.myOpenCached has been called ' + filename); + cfile := changeFileExt(completeCFilePath(filename), cExt); + cfilenoext := changeFileExt(cfile, ''); + (* + objFile := toObjFile(cfilenoext); + if ExistsFile(objFile) and nos.FileNewer(objFile, cfile) then begin + end + else begin + addFileToCompile(cfilenoext); // is to compile + end; *) + addFileToLink(cfilenoext); + registerModuleToMain(module); + result := nil; end; function shouldRecompile(code: PRope; const cfile, cfilenoext: string): bool; @@ -718,7 +773,7 @@ var objFile: string; begin result := true; - if optCFileCache in gGlobalOptions then begin + if not (optForceFullMake in gGlobalOptions) then begin objFile := toObjFile(cfilenoext); if writeRopeIfNotEqual(code, cfile) then exit; if ExistsFile(objFile) and nos.FileNewer(objFile, cfile) then @@ -728,47 +783,57 @@ begin writeRope(code, cfile); end; -procedure finishModule(b: PBackend; n: PNode); +function myProcess(b: PPassContext; n: PNode): PNode; var - cfile, cfilenoext: string; m: BModule; - code: PRope; begin + result := n; + if b = nil then exit; m := BModule(b); m.initProc.options := gOptions; genStmts(m.initProc, n); +end; + +function myClose(b: PPassContext; n: PNode): PNode; +var + cfile, cfilenoext: string; + m: BModule; + code: PRope; +begin + result := n; + if b = nil then exit; + m := BModule(b); + if n <> nil then begin + m.initProc.options := gOptions; + genStmts(m.initProc, n); + end; // generate code for the init statements of the module: genInitCode(m); finishTypeDescriptions(m); + cfile := completeCFilePath(m.cfilename); + cfilenoext := changeFileExt(cfile, ''); if sfMainModule in m.module.flags then begin - // generate mapping file (if requested): - if gMapping <> nil then - WriteRope(gMapping, ChangeFileExt(cfile + '_map', 'txt')); - // generate main file: app(m.s[cfsProcHeaders], mainModProcs); genMainProc(m); end; - cfile := completeCFilePath(m.cfilename); - cfilenoext := changeFileExt(cfile, ''); code := genModule(m, cfilenoext); if shouldRecompile(code, changeFileExt(cfile, cExt), cfilenoext) then begin addFileToCompile(cfilenoext); // is to compile end; addFileToLink(cfilenoext); + if sfMainModule in m.module.flags then writeMapping(cfile, gMapping); end; -function CBackend(b: PBackend; module: PSym; const filename: string): PBackend; -var - g: BModule; +function cgenPass(): TPass; begin - g := newModule(module, filename); - g.backendCreator := CBackend; - g.eventMask := {@set}[eAfterModule]; - g.afterModuleEvent := finishModule; - result := g; + initPass(result); + result.open := myOpen; + result.openCached := myOpenCached; + result.process := myProcess; + result.close := myClose; end; initialization - intSetInit(gTypeInfoGenerated); + InitIiTable(gToTypeInfoId); end. diff --git a/nim/commands.pas b/nim/commands.pas index ad6f21b07..be863e917 100644 --- a/nim/commands.pas +++ b/nim/commands.pas @@ -16,7 +16,8 @@ interface {$include 'config.inc'} uses - nsystem, charsets, msgs; + nsystem, charsets, nos, msgs, options, nversion, condsyms, strutils, extccomp, + platform, lists, wordrecg; procedure writeCommandLineUsage; @@ -33,10 +34,6 @@ procedure processSwitch(const switch, arg: string; pass: TCmdlinePass; implementation -uses - options, nversion, condsyms, strutils, extccomp, platform, nos, lists, - wordrecg; - {@ignore} const {$ifdef fpc} @@ -54,19 +51,18 @@ const const Usage = '' //[[[cog -//def f(x): return "+{&} '" + x.replace("'", "''")[:-1] + "' +{&} nl" -//for line in file("data/basicopt.txt"): +//from string import replace +//def f(x): return "+{&} '" + replace(x, "'", "''")[:-1] + "' +{&} nl" +//for line in open("data/basicopt.txt").readlines(): // cog.outl(f(line)) //]]] +{&} 'Usage::' +{&} nl +{&} ' nimrod command [options] inputfile [arguments]' +{&} nl +{&} 'Command::' +{&} nl -+{&} ' compile compile project with default code generator (C)' +{&} nl -+{&} ' compile_to_c compile project with C code generator' +{&} nl -+{&} ' compile_to_cpp compile project with C++ code generator' +{&} nl -+{&} ' compile_to_ecmascript compile project to ECMAScript code (experimental)' +{&} nl -+{&} ' doc generate the documentation for inputfile;' +{&} nl -+{&} ' with --run switch opens it with $BROWSER' +{&} nl ++{&} ' compile, c compile project with default code generator (C)' +{&} nl ++{&} ' compile_to_c, cc compile project with C code generator' +{&} nl ++{&} ' doc generate the documentation for inputfile' +{&} nl ++{&} ' rst2html converts a reStructuredText file to HTML' +{&} nl +{&} 'Arguments:' +{&} nl +{&} ' arguments are passed to the program being run (if --run option is selected)' +{&} nl +{&} 'Options:' +{&} nl @@ -74,7 +70,8 @@ const +{&} ' -o, --out:FILE set the output filename' +{&} nl +{&} ' -d, --define:SYMBOL define a conditional symbol' +{&} nl +{&} ' -u, --undef:SYMBOL undefine a conditional symbol' +{&} nl -+{&} ' -b, --force_build force rebuilding of all modules' +{&} nl ++{&} ' -f, --force_build force rebuilding of all modules' +{&} nl ++{&} ' --symbol_files:on|off use symbol files to speed up compilation (buggy!)' +{&} nl +{&} ' --stack_trace:on|off code generation for stack trace ON|OFF' +{&} nl +{&} ' --line_trace:on|off code generation for line trace ON|OFF' +{&} nl +{&} ' --debugger:on|off turn Embedded Nimrod Debugger ON|OFF' +{&} nl @@ -95,7 +92,7 @@ const AdvancedUsage = '' //[[[cog -//for line in file("data/advopt.txt"): +//for line in open("data/advopt.txt").readlines(): // cog.outl(f(line)) //]]] +{&} 'Advanced commands::' +{&} nl @@ -104,21 +101,17 @@ const +{&} ' gen_depend generate a DOT file containing the' +{&} nl +{&} ' module dependency graph' +{&} nl +{&} ' list_def list all defined conditionals and exit' +{&} nl -+{&} ' rst2html converts a reStructuredText file to HTML' +{&} nl +{&} ' check checks the project for syntax and semantic' +{&} nl +{&} ' parse parses a single file (for debugging Nimrod)' +{&} nl -+{&} ' scan tokenizes a single file (for debugging Nimrod)' +{&} nl -+{&} ' debugtrans for debugging the transformation pass' +{&} nl +{&} 'Advanced options:' +{&} nl +{&} ' -w, --warnings:on|off warnings ON|OFF' +{&} nl +{&} ' --warning[X]:on|off specific warning X ON|OFF' +{&} nl +{&} ' --hints:on|off hints ON|OFF' +{&} nl +{&} ' --hint[X]:on|off specific hint X ON|OFF' +{&} nl -+{&} ' --cc:C_COMPILER set the C/C++ compiler to use' +{&} nl +{&} ' --lib:PATH set the system library path' +{&} nl +{&} ' -c, --compile_only compile only; do not assemble or link' +{&} nl +{&} ' --no_linking compile but do not link' +{&} nl -+{&} ' --gen_script generate a compile script (in the ''rod_gen''' +{&} nl ++{&} ' --gen_script generate a compile script (in the ''nimcache''' +{&} nl +{&} ' subdirectory named ''compile_$project$scriptext'')' +{&} nl +{&} ' --os:SYMBOL set the target operating system (cross-compilation)' +{&} nl +{&} ' --cpu:SYMBOL set the target processor (cross-compilation)' +{&} nl @@ -127,50 +120,16 @@ const +{&} ' -l, --passl:OPTION pass an option to the linker' +{&} nl +{&} ' --gen_mapping generate a mapping file containing' +{&} nl +{&} ' (Nimrod, mangled) identifier pairs' +{&} nl -+{&} ' --merge_output generate only one C output file' +{&} nl +{&} ' --line_dir:on|off generation of #line directive ON|OFF' +{&} nl +{&} ' --checkpoints:on|off turn on|off checkpoints; for debugging Nimrod' +{&} nl +{&} ' --skip_cfg do not read the general configuration file' +{&} nl +{&} ' --skip_proj_cfg do not read the project''s configuration file' +{&} nl +{&} ' --import:MODULE_FILE import the given module implicitly for each module' +{&} nl -+{&} ' --maxerr:NUMBER stop compilation after NUMBER errors; broken!' +{&} nl -+{&} ' --ast_cache:on|off caching of ASTs ON|OFF (default: OFF)' +{&} nl -+{&} ' --c_file_cache:on|off caching of generated C files ON|OFF (default: OFF)' +{&} nl +{&} ' --index:FILE use FILE to generate a documenation index file' +{&} nl +{&} ' --putenv:key=value set an environment variable' +{&} nl +{&} ' --list_cmd list the commands used to execute external programs' +{&} nl -+{&} ' -v, --verbose show what Nimrod is doing' +{&} nl -+{&} ' --version show detailed version information' +{&} nl -//[[[end]]] - ; - - VersionInformation = '' -//[[[cog -//for line in file("data/changes.txt"): -// cog.outl(f(line)) -//]]] -+{&} '0.1.0' +{&} nl -+{&} '* new config system' +{&} nl -+{&} '* new build system' +{&} nl -+{&} '* source renderer' +{&} nl -+{&} '* pas2nim integrated' +{&} nl -+{&} '* support for C++' +{&} nl -+{&} '* local variables are always initialized' +{&} nl -+{&} '* Rod file reader and writer' +{&} nl -+{&} '* new --out, -o command line options' +{&} nl -+{&} '* fixed bug in nimconf.pas: we now have several' +{&} nl -+{&} ' string token types' +{&} nl -+{&} '* changed nkIdentDef to nkIdentDefs' +{&} nl -+{&} '* added type(expr) in the parser and the grammer' +{&} nl -+{&} '* added template' +{&} nl -+{&} '* added command calls' +{&} nl -+{&} '* added case in records/objects' +{&} nl -+{&} '* added --skip_proj_cfg switch for nim.dpr' +{&} nl -+{&} '* added missing features to pasparse' +{&} nl -+{&} '* rewrote the source generator' +{&} nl -+{&} '* ``addr`` and ``cast`` are now keywords; grammar updated' +{&} nl -+{&} '* implemented ` notation; grammar updated' +{&} nl -+{&} '* specification replaced by a manual' +{&} nl ++{&} ' --verbosity:0|1|2|3 set Nimrod''s verbosity level (0 is default)' +{&} nl ++{&} ' -v, --version show detailed version information' +{&} nl //[[[end]]] ; @@ -212,7 +171,7 @@ begin versionWritten := true; helpWritten := true; messageOut(format(HelpMessage, [VersionAsString, platform.os[hostOS].name, - cpu[hostCPU].name]) +{&} VersionInformation) + cpu[hostCPU].name])) end end; @@ -378,14 +337,10 @@ begin if pass in {@set}[passCmd2, passPP] then addFileToLink(arg); end; - wDebuginfo: - include(gGlobalOptions, optCDebug); - wCompileOnly, wC: - include(gGlobalOptions, optCompileOnly); - wNoLinking: - include(gGlobalOptions, optNoLinking); - wForceBuild, wF: - include(gGlobalOptions, optForceFullMake); + wDebuginfo: include(gGlobalOptions, optCDebug); + wCompileOnly, wC: include(gGlobalOptions, optCompileOnly); + wNoLinking: include(gGlobalOptions, optNoLinking); + wForceBuild, wF: include(gGlobalOptions, optForceFullMake); wGC: begin case whichKeyword(arg) of wBoehm: begin @@ -406,20 +361,13 @@ begin liMessage(info, errNoneBoehmRefcExpectedButXFound, arg) end end; - wWarnings, wW: - ProcessOnOffSwitch({@set}[optWarns], arg, pass, info); - wWarning: - ProcessSpecificNote(arg, wWarning, pass, info); - wHint: - ProcessSpecificNote(arg, wHint, pass, info); - wHints: - ProcessOnOffSwitch({@set}[optHints], arg, pass, info); - wCheckpoints: - ProcessOnOffSwitch({@set}[optCheckpoints], arg, pass, info); - wStackTrace: - ProcessOnOffSwitch({@set}[optStackTrace], arg, pass, info); - wLineTrace: - ProcessOnOffSwitch({@set}[optLineTrace], arg, pass, info); + wWarnings, wW: ProcessOnOffSwitch({@set}[optWarns], arg, pass, info); + wWarning: ProcessSpecificNote(arg, wWarning, pass, info); + wHint: ProcessSpecificNote(arg, wHint, pass, info); + wHints: ProcessOnOffSwitch({@set}[optHints], arg, pass, info); + wCheckpoints: ProcessOnOffSwitch({@set}[optCheckpoints], arg, pass, info); + wStackTrace: ProcessOnOffSwitch({@set}[optStackTrace], arg, pass, info); + wLineTrace: ProcessOnOffSwitch({@set}[optLineTrace], arg, pass, info); wDebugger: begin ProcessOnOffSwitch({@set}[optEndb], arg, pass, info); if optEndb in gOptions then @@ -427,26 +375,19 @@ begin else UndefSymbol('endb') end; - wChecks, wX: - ProcessOnOffSwitch(checksOptions, arg, pass, info); - wObjChecks: - ProcessOnOffSwitch({@set}[optObjCheck], arg, pass, info); - wFieldChecks: - ProcessOnOffSwitch({@set}[optFieldCheck], arg, pass, info); - wRangeChecks: - ProcessOnOffSwitch({@set}[optRangeCheck], arg, pass, info); - wBoundChecks: - ProcessOnOffSwitch({@set}[optBoundsCheck], arg, pass, info); - wOverflowChecks: - ProcessOnOffSwitch({@set}[optOverflowCheck], arg, pass, info); - wLineDir: - ProcessOnOffSwitch({@set}[optLineDir], arg, pass, info); - wAssertions, wA: - ProcessOnOffSwitch({@set}[optAssert], arg, pass, info); - wCFileCache: - ProcessOnOffSwitchG({@set}[optCFileCache], arg, pass, info); - wAstCache: - ProcessOnOffSwitchG({@set}[optAstCache], arg, pass, info); + wProfiler: begin + ProcessOnOffSwitch({@set}[optProfiler], arg, pass, info); + if optProfiler in gOptions then DefineSymbol('profiler') + else UndefSymbol('profiler') + end; + wChecks, wX: ProcessOnOffSwitch(checksOptions, arg, pass, info); + wObjChecks: ProcessOnOffSwitch({@set}[optObjCheck], arg, pass, info); + wFieldChecks: ProcessOnOffSwitch({@set}[optFieldCheck], arg, pass, info); + wRangeChecks: ProcessOnOffSwitch({@set}[optRangeCheck], arg, pass, info); + wBoundChecks: ProcessOnOffSwitch({@set}[optBoundsCheck], arg, pass, info); + wOverflowChecks: ProcessOnOffSwitch({@set}[optOverflowCheck], arg, pass, info); + wLineDir: ProcessOnOffSwitch({@set}[optLineDir], arg, pass, info); + wAssertions, wA: ProcessOnOffSwitch({@set}[optAssert], arg, pass, info); wOpt: begin case whichKeyword(arg) of wSpeed: begin @@ -505,10 +446,8 @@ begin expectArg(switch, arg, pass, info); options.addImplicitMod(arg); end; - wListCmd: - include(gGlobalOptions, optListCmd); - wGenMapping: - include(gGlobalOptions, optGenMapping); + wListCmd: include(gGlobalOptions, optListCmd); + wGenMapping: include(gGlobalOptions, optGenMapping); wOS: begin if (pass = passCmd1) then begin theOS := platform.NameToOS(arg); @@ -533,26 +472,18 @@ begin end end end; - wRun, wR: - include(gGlobalOptions, optRun); - wVerbose, wV: - include(gGlobalOptions, optVerbose); - wMergeOutput: - include(gGlobalOptions, optMergeOutput); - wVersion: - writeVersionInfo(pass); - wAdvanced: - writeAdvancedUsage(pass); - wHelp, wH: - helpOnError(pass); - wCompileSys: - include(gGlobalOptions, optCompileSys); - wSkipCfg: - include(gGlobalOptions, optSkipConfigFile); - wSkipProjCfg: - include(gGlobalOptions, optSkipProjConfigFile); - wGenScript: - include(gGlobalOptions, optGenScript); + wRun, wR: include(gGlobalOptions, optRun); + wVerbosity: begin + expectArg(switch, arg, pass, info); + gVerbosity := parseInt(arg); + end; + wVersion, wV: writeVersionInfo(pass); + wAdvanced: writeAdvancedUsage(pass); + wHelp, wH: helpOnError(pass); + wSymbolFiles: ProcessOnOffSwitchG({@set}[optSymbolFiles], arg, pass, info); + wSkipCfg: include(gGlobalOptions, optSkipConfigFile); + wSkipProjCfg: include(gGlobalOptions, optSkipProjConfigFile); + wGenScript: include(gGlobalOptions, optGenScript); wLib: begin expectArg(switch, arg, pass, info); libpath := processPath(arg) diff --git a/nim/condsyms.pas b/nim/condsyms.pas index 369ceafad..c018a37ea 100644 --- a/nim/condsyms.pas +++ b/nim/condsyms.pas @@ -6,7 +6,6 @@ // See the file "copying.txt", included in this // distribution, for details about the copyright. // - unit condsyms; // This module handles the conditional symbols. @@ -16,7 +15,7 @@ unit condsyms; interface uses - ast, astalgo, msgs, hashes, platform, strutils, idents; + nsystem, ast, astalgo, msgs, hashes, platform, strutils, idents; var gSymbols: TStrTable; @@ -29,6 +28,8 @@ procedure UndefSymbol(const symbol: string); function isDefined(symbol: PIdent): Boolean; procedure ListSymbols; +function countDefinedSymbols: int; + implementation procedure DefineSymbol(const symbol: string); @@ -39,7 +40,12 @@ begin i := getIdent(symbol); sym := StrTableGet(gSymbols, i); if sym = nil then begin - sym := NewSym(skConditional, i, nil); + new(sym); // circumvent the ID mechanism + {@ignore} + fillChar(sym^, sizeof(sym^), 0); + {@emit} + sym.kind := skConditional; + sym.name := i; StrTableAdd(gSymbols, sym); end; sym.position := 1; @@ -75,6 +81,19 @@ begin MessageOut('-- End of list --'); end; +function countDefinedSymbols: int; +var + it: TTabIter; + s: PSym; +begin + s := InitTabIter(it, gSymbols); + result := 0; + while s <> nil do begin + if s.position = 1 then inc(result); + s := nextIter(it, gSymbols); + end; +end; + procedure InitDefines; begin initStrTable(gSymbols); @@ -92,7 +111,7 @@ begin DefineSymbol('win32'); end; osLinux, osMorphOS, osSkyOS, osIrix, osPalmOS, osQNX, - osAtari: begin + osAtari, osAix: begin // these are all 'unix-like' DefineSymbol('unix'); DefineSymbol('posix'); diff --git a/nim/copying.txt b/nim/copying.txt deleted file mode 100644 index 65b743e4a..000000000 --- a/nim/copying.txt +++ /dev/null @@ -1,18 +0,0 @@ -======================================================= - The Nimrod Compiler - Copyright (C) 2004-2008 Andreas Rumpf -======================================================= - -This program is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public License -as published by the Free Software Foundation; version 2 -of the License. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. diff --git a/nim/crc.pas b/nim/crc.pas index d4c5d0661..429f0ec30 100644 --- a/nim/crc.pas +++ b/nim/crc.pas @@ -21,6 +21,8 @@ type const InitCrc32 = TCrc32(-1); + InitAdler32 = int32(1); + function updateCrc32(val: Byte; crc: TCrc32): TCrc32; overload; function updateCrc32(val: Char; crc: TCrc32): TCrc32; overload; @@ -29,6 +31,9 @@ function strCrc32(const s: string): TCrc32; function crcFromFile(const filename: string): TCrc32; +function updateAdler32(adler: int32; buf: pointer; len: int): int32; + + implementation {@ignore} @@ -121,12 +126,12 @@ const function updateCrc32(val: Byte; crc: TCrc32): TCrc32; overload; begin - result := crc32Table[(int(crc) xor val) and $ff] xor (crc shr 8); + result := crc32Table[(int(crc) xor (int(val) and $ff)) and $ff] xor (int(crc) shr 8); end; function updateCrc32(val: Char; crc: TCrc32): TCrc32; overload; begin - result := updateCrc32(ord(val), crc); + result := updateCrc32(byte(ord(val)), crc); end; function strCrc32(const s: string): TCrc32; @@ -173,6 +178,39 @@ begin CloseFile(bin); end; + +const + base = int32(65521); { largest prime smaller than 65536 } + {NMAX = 5552; original code with unsigned 32 bit integer } + { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 } + nmax = 3854; { code with signed 32 bit integer } + { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 } + { The penalty is the time loss in the extra MOD-calls. } + +function updateAdler32(adler: int32; buf: pointer; len: int): int32; +var + s1, s2: int32; + L, k, b: int; +begin + s1 := adler and int32($ffff); + s2 := (adler shr int32(16)) and int32($ffff); + L := len; + b := 0; + while (L > 0) do begin + if L < nmax then k := L + else k := nmax; + dec(L, k); + while (k > 0) do begin + s1 := s1 +{%} int32(({@cast}cstring(buf))[b]); + s2 := s2 +{%} s1; + inc(b); dec(k); + end; + s1 := modu(s1, base); + s2 := modu(s2, base); + end; + result := (s2 shl int32(16)) or s1; +end; + {@ignore} {$ifdef Q_on} {$undef Q_on} diff --git a/nim/docgen.pas b/nim/docgen.pas index a6d2725c3..fd835db57 100644 --- a/nim/docgen.pas +++ b/nim/docgen.pas @@ -114,11 +114,11 @@ begin {@ignore} fillChar(result^, sizeof(result^), 0); {@emit - result.tocPart := []; + result.tocPart := @[]; } result.filename := filename; result.id := 100; - result.splitAfter := 25; + result.splitAfter := 20; s := getConfigVar('split.item.toc'); if s <> '' then result.splitAfter := parseInt(s); @@ -212,19 +212,51 @@ begin '&': dest := dest + '&'; '<': dest := dest + '<'; '>': dest := dest + '>'; + '"': dest := dest + '"'; else addChar(dest, c) end end; -function toXml(const s: string; splitAfter: int = -1): string; +function nextSplitPoint(const s: string; start: int): int; var i: int; begin + result := start; + while result < length(s)+strStart do begin + case s[result] of + '_': exit; + 'a'..'z': begin + if result+1 < length(s)+strStart then + if s[result+1] in ['A'..'Z'] then exit; + end; + else begin end; + end; + inc(result); + end; + dec(result); // last valid index +end; + +function toXml(const s: string; splitAfter: int = -1): string; +var + i, j, k, partLen: int; +begin result := ''; - for i := strStart to length(s)+strStart-1 do begin - if (splitAfter >= 0) and ((i-strStart+1) mod splitAfter = 0) then - addChar(result, ' '); - addXmlChar(result, s[i]) + if splitAfter >= 0 then begin + partLen := 0; + j := strStart; + while j < length(s)+strStart do begin + k := nextSplitPoint(s, j); + if partLen + k - j + 1 > splitAfter then begin + partLen := 0; + addChar(result, ' '); + end; + for i := j to k do addXmlChar(result, s[i]); + inc(partLen, k - j + 1); + j := k+1; + end; + end + else begin + for i := strStart to length(s)+strStart-1 do addXmlChar(result, s[i]) end end; diff --git a/nim/ecmasgen.pas b/nim/ecmasgen.pas index 53ab4f069..d50be9b0c 100644 --- a/nim/ecmasgen.pas +++ b/nim/ecmasgen.pas @@ -19,15 +19,17 @@ interface uses nsystem, ast, astalgo, strutils, hashes, trees, platform, magicsys, extccomp, options, nversion, nimsets, msgs, crc, bitsets, idents, - lists, types, nos, ntime, ropes, nmath, backends, ccgutils, wordrecg, rnimsyn; + lists, types, nos, ntime, ropes, nmath, passes, ccgutils, wordrecg, rnimsyn, + rodread; -function EcmasBackend(b: PBackend; module: PSym; - const filename: string): PBackend; +function ecmasgenPass(): TPass; implementation type - TEcmasGen = object(TBackend) + TEcmasGen = object(TPassContext) + filename: string; + module: PSym; end; BModule = ^TEcmasGen; @@ -93,7 +95,7 @@ begin {@ignore} fillChar(p, sizeof(p), 0); {@emit - p.blocks := [];} + p.blocks := @[];} p.options := options; p.module := module; p.procDef := procDef; @@ -103,8 +105,7 @@ end; const MappedToObject = {@set}[tyObject, tyArray, tyArrayConstr, tyTuple, - tyEmptySet, tyOpenArray, tySet, tyVar, - tyRef, tyPtr]; + tyOpenArray, tySet, tyVar, tyRef, tyPtr]; function mapType(typ: PType): TEcmasTypeKind; begin @@ -129,10 +130,10 @@ begin end; tyString, tySequence: result := etyInt; // little hack to get the right semantics - tyObject, tyArray, tyArrayConstr, tyTuple, tyEmptySet, tyOpenArray: + tyObject, tyArray, tyArrayConstr, tyTuple, tyOpenArray: result := etyObject; tyNil: result := etyNull; - tyGenericInst, tyGenericParam, tyGeneric, tyNone, tyForward: + tyGenericInst, tyGenericParam, tyGeneric, tyNone, tyForward, tyEmpty: result := etyNone; tyProc: result := etyProc; tyCString: result := etyString; @@ -1832,38 +1833,56 @@ begin end end; -procedure finishModule(b: PBackend; n: PNode); +function myProcess(b: PPassContext; n: PNode): PNode; var m: BModule; - outfile: string; p: TProc; r: TCompRes; - code: PRope; begin + result := n; m := BModule(b); - if m.module = nil then InternalError(n.info, 'finishModule'); + if m.module = nil then InternalError(n.info, 'myProcess'); initProc(p, globals, m, nil, m.module.options); genModule(p, n, r); app(p.globals.code, p.data); app(p.globals.code, mergeStmt(r)); +end; + +function myClose(b: PPassContext; n: PNode): PNode; +var + m: BModule; + code: PRope; + outfile: string; +begin + result := myProcess(b, n); + m := BModule(b); if sfMainModule in m.module.flags then begin // write the file: - code := con(p.globals.typeInfo, p.globals.code); + code := con(globals.typeInfo, globals.code); outfile := changeFileExt(completeCFilePath(m.filename), 'js'); {@discard} writeRopeIfNotEqual(con(genHeader(), code), outfile); - end; + end end; -function EcmasBackend(b: PBackend; module: PSym; - const filename: string): PBackend; -var - g: BModule; +function myOpenCached(s: PSym; const filename: string; + rd: PRodReader): PPassContext; +begin + InternalError('symbol files are not possible with the Ecmas code generator'); + result := nil; +end; + +function myOpen(s: PSym; const filename: string): PPassContext; +begin + result := newModule(s, filename); +end; + +function ecmasgenPass(): TPass; begin - g := newModule(module, filename); - g.backendCreator := EcmasBackend; - g.eventMask := {@set}[eAfterModule]; - g.afterModuleEvent := finishModule; - result := g; + InitPass(result); + result.open := myOpen; + result.close := myClose; + result.openCached := myOpenCached; + result.process := myProcess; end; end. diff --git a/nim/eval.pas b/nim/eval.pas deleted file mode 100644 index 501667c80..000000000 --- a/nim/eval.pas +++ /dev/null @@ -1,1177 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2008 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -// This file implements the evaluator for Nimrod code. -// The evaluator is very slow, but simple. Since this -// is used mainly for evaluating macros and some other -// stuff at compile time, performance is not that -// important. Later a real interpreter may get out of this... - -// We reuse the TTranscon type here:: -// -// TTransCon = record # part of TContext; stackable -// mapping: TIdNodeTable # mapping from symbols to nodes -// owner: PSym # current owner; proc that is evaluated -// forStmt: PNode # unused -// next: PTransCon # for stacking; up the call stack - -const - evalMaxIterations = 10000000; // max iterations of all loops - evalMaxRecDepth = 100000; // max recursion depth for evaluation - -type - PBinding = PContext; - PCallStack = PTransCon; - -var - emptyNode: PNode; - -function evalAux(c: PContext; n: PNode): PNode; forward; - -procedure stackTraceAux(x: PCallStack); -begin - if x <> nil then begin - stackTraceAux(x.next); - messageOut(format('file: $1, line: $2', [toFilename(x.forStmt.info), - toString(toLineNumber(x.forStmt.info))])); - end -end; - -procedure stackTrace(c: PBinding; n: PNode; msg: TMsgKind; - const arg: string = ''); -begin - messageOut('stack trace: (most recent call last)'); - stackTraceAux(c.transCon); - liMessage(n.info, msg, arg); -end; - -function evalIf(c: PBinding; n: PNode): PNode; -var - i, len: int; -begin - i := 0; - len := sonsLen(n); - while (i < len) and (sonsLen(n.sons[i]) >= 2) do begin - result := evalAux(c, n.sons[i].sons[0]); - if result.kind = nkExceptBranch then exit; - if (result.kind = nkIntLit) and (result.intVal <> 0) then begin - result := evalAux(c, n.sons[i].sons[1]); - exit - end; - inc(i) - end; - if (i < len) and (sonsLen(n.sons[i]) < 2) then // eval else-part - result := evalAux(c, n.sons[0]) - else - result := emptyNode -end; - -function evalCase(c: PBinding; n: PNode): PNode; -var - i, j: int; - res: PNode; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - res := result; - result := emptyNode; - for i := 1 to sonsLen(n)-1 do begin - if n.sons[i].kind = nkOfBranch then begin - for j := 0 to sonsLen(n.sons[i])-2 do begin - if overlap(res, n.sons[i].sons[j]) then begin - result := evalAux(c, lastSon(n.sons[i])); - exit - end - end - end - else begin - result := evalAux(c, lastSon(n.sons[i])); - end - end; -end; - -var - gWhileCounter: int; // Use a counter to prevend endless loops! - // We make this counter global, because otherwise - // nested loops could make the compiler extremely slow. - gNestedEvals: int; // count the recursive calls to ``evalAux`` to prevent - // endless recursion - -function evalWhile(c: PBinding; n: PNode): PNode; -begin - while true do begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - if getOrdValue(result) = 0 then break; - result := evalAux(c, n.sons[1]); - case result.kind of - nkBreakStmt: begin - if result.sons[0] = nil then begin - result := emptyNode; // consume ``break`` token - break - end - end; - nkExceptBranch, nkReturnToken: break; - else begin end - end; - dec(gWhileCounter); - if gWhileCounter <= 0 then begin - stackTrace(c, n, errTooManyIterations); - break; - end - end -end; - -function evalBlock(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkBreakStmt then begin - if result.sons[0] <> nil then begin - assert(result.sons[0].kind = nkSym); - if n.sons[0] <> nil then begin - assert(n.sons[0].kind = nkSym); - if result.sons[0].sym.id = n.sons[0].sym.id then - result := emptyNode - end - end - else - result := emptyNode // consume ``break`` token - end -end; - -function evalFinally(c: PBinding; n, exc: PNode): PNode; -var - finallyNode: PNode; -begin - finallyNode := lastSon(n); - if finallyNode.kind = nkFinally then begin - result := evalAux(c, finallyNode); - if result.kind <> nkExceptBranch then - result := exc - end - else - result := exc -end; - -function evalTry(c: PBinding; n: PNode): PNode; -var - exc: PNode; - i, j, len, blen: int; -begin - result := evalAux(c, n.sons[0]); - case result.kind of - nkBreakStmt, nkReturnToken: begin end; - nkExceptBranch: begin - // exception token! - exc := result; - i := 1; - len := sonsLen(n); - while (i < len) and (n.sons[i].kind = nkExceptBranch) do begin - blen := sonsLen(n.sons[i]); - if blen = 1 then begin - // general except section: - result := evalAux(c, n.sons[i].sons[0]); - exc := result; - break - end - else begin - for j := 0 to blen-2 do begin - assert(n.sons[i].sons[j].kind = nkType); - if exc.typ.id = n.sons[i].sons[j].typ.id then begin - result := evalAux(c, n.sons[i].sons[blen-1]); - exc := result; - break - end - end - end; - inc(i); - end; - result := evalFinally(c, n, exc); - end; - else - result := evalFinally(c, n, emptyNode); - end -end; - -function getNullValue(typ: PType; const info: TLineInfo): PNode; -var - i: int; - t: PType; -begin - t := skipGenericRange(typ); - result := emptyNode; - case t.kind of - tyBool, tyChar, tyInt..tyInt64: result := newNodeIT(nkIntLit, info, t); - tyFloat..tyFloat128: result := newNodeIt(nkFloatLit, info, t); - tyVar, tyPointer, tyPtr, tyRef, tyCString, tySequence, tyString: - result := newNodeIT(nkNilLit, info, t); - tyObject: begin - result := newNodeIT(nkPar, info, t); - internalError(info, 'init to implement'); - end; - tyArray, tyArrayConstr: begin - result := newNodeIT(nkBracket, info, t); - for i := 0 to int(lengthOrd(t))-1 do - addSon(result, getNullValue(elemType(t), info)); - end; - tyTuple: begin - result := newNodeIT(nkPar, info, t); - for i := 0 to sonsLen(t)-1 do - addSon(result, getNullValue(t.sons[i], info)); - end; - else InternalError('getNullValue') - end -end; - -function evalVar(c: PBinding; n: PNode): PNode; -var - i: int; - v: PSym; - a: PNode; -begin - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - assert(a.kind = nkIdentDefs); - assert(a.sons[0].kind = nkSym); - v := a.sons[0].sym; - if a.sons[2] <> nil then begin - result := evalAux(c, a.sons[2]); - if result.kind = nkExceptBranch then exit; - end - else - result := getNullValue(a.sons[0].typ, a.sons[0].info); - IdNodeTablePut(c.transCon.mapping, v, result); - end; - result := emptyNode; -end; - -function evalCall(c: PBinding; n: PNode): PNode; -var - d: PCallStack; - prc: PNode; - i: int; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - prc := result; - // bind the actual params to the local parameter - // of a new binding - d := newTransCon(); - d.forStmt := n; - if prc.kind = nkSym then begin - d.owner := prc.sym; - if not (prc.sym.kind in [skProc, skConverter]) then - InternalError(n.info, 'evalCall'); - end; - setLength(d.params, sonsLen(n)); - for i := 1 to sonsLen(n)-1 do begin - result := evalAux(c, n.sons[i]); - if result.kind = nkExceptBranch then exit; - d.params[i] := result; - end; - if n.typ <> nil then d.params[0] := getNullValue(n.typ, n.info); - pushTransCon(c, d); - result := evalAux(c, prc); - if n.typ <> nil then result := d.params[0]; - popTransCon(c); -end; - -function evalVariable(c: PCallStack; sym: PSym): PNode; -// We need to return a node to the actual value, -// which can be modified. -var - x: PCallStack; -begin - x := c; - while x <> nil do begin - if sfResult in sym.flags then begin - result := x.params[0]; - exit - end; - result := IdNodeTableGet(x.mapping, sym); - if result <> nil then exit; - x := x.next - end; - result := emptyNode; -end; - -function evalArrayAccess(c: PBinding; n: PNode): PNode; -var - x: PNode; - idx: biggestInt; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - x := result; - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - idx := getOrdValue(result); - result := emptyNode; - case x.kind of - nkBracket, nkPar, nkMetaNode: begin - if (idx >= 0) and (idx < sonsLen(x)) then - result := x.sons[int(idx)] - else - stackTrace(c, n, errIndexOutOfBounds); - end; - nkStrLit..nkTripleStrLit: begin - result := newNodeIT(nkCharLit, x.info, getSysType(tyChar)); - if (idx >= 0) and (idx < length(x.strVal)) then - result.intVal := ord(x.strVal[int(idx)+strStart]) - else if idx = length(x.strVal) then begin end - else - stackTrace(c, n, errIndexOutOfBounds); - end; - else - stackTrace(c, n, errIndexNoIntType); - end -end; - -function evalFieldAccess(c: PBinding; n: PNode): PNode; -// a real field access; proc calls have already been -// transformed -// XXX: field checks! -var - x: PNode; - field: PSym; - i: int; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - x := result; - if x.kind <> nkPar then InternalError(n.info, 'evalFieldAccess'); - field := n.sons[1].sym; - for i := 0 to sonsLen(n)-1 do begin - if x.sons[i].kind <> nkExprColonExpr then - InternalError(n.info, 'evalFieldAccess'); - if x.sons[i].sons[0].sym.name.id = field.id then begin - result := x.sons[i].sons[1]; exit - end - end; - stackTrace(c, n, errFieldXNotFound, field.name.s); - result := emptyNode; -end; - -function evalAsgn(c: PBinding; n: PNode): PNode; -var - x: PNode; - i: int; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - x := result; - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - x.kind := result.kind; - x.typ := result.typ; - case x.kind of - nkCharLit..nkInt64Lit: x.intVal := result.intVal; - nkFloatLit..nkFloat64Lit: x.floatVal := result.floatVal; - nkStrLit..nkTripleStrLit: begin - x.strVal := result.strVal; - end - else begin - if not (x.kind in [nkEmpty..nkNilLit]) then begin - discardSons(x); - for i := 0 to sonsLen(result)-1 do addSon(x, result.sons[i]); - end - end - end; - result := emptyNode -end; - -function evalSwap(c: PBinding; n: PNode): PNode; -var - x: PNode; - i: int; - tmpi: biggestInt; - tmpf: biggestFloat; - tmps: string; - tmpn: PNode; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - x := result; - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - if (x.kind <> result.kind) then - stackTrace(c, n, errCannotInterpretNodeX, nodeKindToStr[n.kind]) - else begin - case x.kind of - nkCharLit..nkInt64Lit: begin - tmpi := x.intVal; - x.intVal := result.intVal; - result.intVal := tmpi - end; - nkFloatLit..nkFloat64Lit: begin - tmpf := x.floatVal; - x.floatVal := result.floatVal; - result.floatVal := tmpf; - end; - nkStrLit..nkTripleStrLit: begin - tmps := x.strVal; - x.strVal := result.strVal; - result.strVal := tmps; - end - else begin - tmpn := copyTree(x); - discardSons(x); - for i := 0 to sonsLen(result)-1 do - addSon(x, result.sons[i]); - discardSons(result); - for i := 0 to sonsLen(tmpn)-1 do - addSon(result, tmpn.sons[i]); - end - end - end; - result := emptyNode -end; - -function evalSym(c: PBinding; n: PNode): PNode; -begin - case n.sym.kind of - skProc, skConverter, skMacro: result := n.sym.ast.sons[codePos]; - skVar, skForVar, skTemp: result := evalVariable(c.transCon, n.sym); - skParam: result := c.transCon.params[n.sym.position+1]; - skConst: result := n.sym.ast; - else begin - stackTrace(c, n, errCannotInterpretNodeX, symKindToStr[n.sym.kind]); - result := emptyNode - end - end; - if result = nil then InternalError(n.info, 'evalSym: ' + n.sym.name.s); -end; - -function evalIncDec(c: PBinding; n: PNode; sign: biggestInt): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - case a.kind of - nkCharLit..nkInt64Lit: a.intval := a.intVal + sign * getOrdValue(b); - else internalError(n.info, 'evalIncDec'); - end; - result := emptyNode -end; - -function evalExit(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - liMessage(n.info, hintQuitCalled); - halt(int(getOrdValue(result))); -end; - -function evalOr(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - if result.kind <> nkIntLit then InternalError(n.info, 'evalOr'); - if result.intVal = 0 then result := evalAux(c, n.sons[2]) -end; - -function evalAnd(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - if result.kind <> nkIntLit then InternalError(n.info, 'evalAnd'); - if result.intVal <> 0 then result := evalAux(c, n.sons[2]) -end; - -function evalNew(c: PBinding; n: PNode): PNode; -var - t: PType; -begin - t := skipVarGeneric(n.sons[1].typ); - result := newNodeIT(nkRefTy, n.info, t); - addSon(result, getNullValue(t.sons[0], n.info)); -end; - -function evalDeref(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - if result.kind <> nkRefTy then InternalError(n.info, 'evalDeref'); - result := result.sons[0]; -end; - -function evalAddr(c: PBinding; n: PNode): PNode; -var - a: PNode; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - if result.kind <> nkRefTy then InternalError(n.info, 'evalDeref'); - a := result; - result := newNodeIT(nkRefTy, n.info, makePtrType(c, a.typ)); - addSon(result, a); -end; - -function evalConv(c: PBinding; n: PNode): PNode; -begin - // hm, I cannot think of any conversions that need to be handled here... - result := evalAux(c, n.sons[1]); - result.typ := n.typ; -end; - -function evalCheckedFieldAccess(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[0]); -end; - -function evalUpConv(c: PBinding; n: PNode): PNode; -var - dest, src: PType; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - dest := skipPtrsGeneric(n.typ); - src := skipPtrsGeneric(result.typ); - if inheritanceDiff(src, dest) > 0 then - stackTrace(c, n, errInvalidConversionFromTypeX, typeToString(src)); -end; - -function evalRangeChck(c: PBinding; n: PNode): PNode; -var - x, a, b: PNode; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - x := result; - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - - if leValueConv(a, x) and leValueConv(x, b) then begin - result := x; // a <= x and x <= b - result.typ := n.typ - end - else - stackTrace(c, n, errGenerated, - format(msgKindToString(errIllegalConvFromXtoY), - [typeToString(n.sons[0].typ), typeToString(n.typ)])); -end; - -function evalConvStrToCStr(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - result.typ := n.typ; -end; - -function evalConvCStrToStr(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - result.typ := n.typ; -end; - -function evalRaise(c: PBinding; n: PNode): PNode; -var - a: PNode; -begin - if n.sons[0] <> nil then begin - result := evalAux(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - a := result; - result := newNodeIT(nkExceptBranch, n.info, a.typ); - addSon(result, a); - c.lastException := result; - end - else if c.lastException <> nil then - result := c.lastException - else begin - stackTrace(c, n, errExceptionAlreadyHandled); - result := newNodeIT(nkExceptBranch, n.info, nil); - addSon(result, nil); - end -end; - -function evalReturn(c: PBinding; n: PNode): PNode; -begin - if n.sons[0] <> nil then begin - result := evalAsgn(c, n.sons[0]); - if result.kind = nkExceptBranch then exit; - end; - result := newNodeIT(nkReturnToken, n.info, nil); -end; - -function evalProc(c: PBinding; n: PNode): PNode; -var - v: PSym; -begin - if n.sons[genericParamsPos] = nil then begin - if (resultPos < sonsLen(n)) and (n.sons[resultPos] <> nil) then begin - v := n.sons[resultPos].sym; - result := getNullValue(v.typ, n.info); - IdNodeTablePut(c.transCon.mapping, v, result); - end; - result := evalAux(c, transform(c, n.sons[codePos])); - if result.kind = nkReturnToken then - result := IdNodeTableGet(c.transCon.mapping, v); - end - else - result := emptyNode -end; - -function evalHigh(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - case skipVarGeneric(n.sons[1].typ).kind of - tyOpenArray, tySequence: - result := newIntNodeT(sonsLen(result), n); - tyString: - result := newIntNodeT(length(result.strVal)-1, n); - else InternalError(n.info, 'evalHigh') - end -end; - -function evalSetLengthStr(c: PBinding; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - case a.kind of - nkStrLit..nkTripleStrLit: setLength(a.strVal, int(getOrdValue(b))); - else InternalError(n.info, 'evalSetLengthStr') - end; - result := emptyNode -end; - -function evalSetLengthSeq(c: PBinding; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - if a.kind = nkBracket then setLength(a.sons, int(getOrdValue(b))) - else InternalError(n.info, 'evalSetLengthSeq'); - result := emptyNode -end; - -function evalAssert(c: PBinding; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - if getOrdValue(result) <> 0 then - result := emptyNode - else - stackTrace(c, n, errAssertionFailed) -end; - -function evalIncl(c: PBinding; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - if not inSet(a, b) then addSon(a, copyTree(b)); - result := emptyNode; -end; - -function evalExcl(c: PBinding; n: PNode): PNode; -var - a, b, r: PNode; - i: int; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := newNodeIT(nkCurly, n.info, n.sons[1].typ); - addSon(b, result); - r := diffSets(a, b); - discardSons(a); - for i := 0 to sonsLen(r)-1 do addSon(a, r.sons[i]); - result := emptyNode; -end; - -function evalAppendStrCh(c: PBinding; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - case a.kind of - nkStrLit..nkTripleStrLit: addChar(a.strVal, chr(int(getOrdValue(b)))); - else InternalError(n.info, 'evalAppendStrCh'); - end; - result := emptyNode; -end; - -function getStrValue(n: PNode): string; -begin - case n.kind of - nkStrLit..nkTripleStrLit: result := n.strVal; - else begin InternalError(n.info, 'getStrValue'); result := '' end; - end -end; - -function evalAppendStrStr(c: PBinding; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - case a.kind of - nkStrLit..nkTripleStrLit: a.strVal := a.strVal +{&} getStrValue(b); - else InternalError(n.info, 'evalAppendStrStr'); - end; - result := emptyNode; -end; - -function evalAppendSeqElem(c: PBinding; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - if a.kind = nkBracket then addSon(a, copyTree(b)) - else InternalError(n.info, 'evalAppendSeqElem'); - result := emptyNode; -end; - -function evalAppendSeqSeq(c: PBinding; n: PNode): PNode; -var - a, b: PNode; - i: int; -begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - if a.kind = nkBracket then - for i := 0 to sonsLen(b)-1 do addSon(a, copyTree(b.sons[i])) - else InternalError(n.info, 'evalAppendSeqSeq'); - result := emptyNode; -end; - -function evalMagicOrCall(c: PBinding; n: PNode): PNode; -var - m: TMagic; - a, b: PNode; - k: biggestInt; - i: int; -begin - m := getMagic(n); - case m of - mNone: result := evalCall(c, n); - mSizeOf: internalError(n.info, 'sizeof() should have been evaluated'); - mHigh: result := evalHigh(c, n); - mAssert: result := evalAssert(c, n); - mExit: result := evalExit(c, n); - mNew, mNewFinalize: result := evalNew(c, n); - mSwap: result := evalSwap(c, n); - mInc: result := evalIncDec(c, n, 1); - ast.mDec: result := evalIncDec(c, n, -1); - mSetLengthStr: result := evalSetLengthStr(c, n); - mSetLengthSeq: result := evalSetLengthSeq(c, n); - mIncl: result := evalIncl(c, n); - mExcl: result := evalExcl(c, n); - mAnd: result := evalAnd(c, n); - mOr: result := evalOr(c, n); - - mAppendStrCh: result := evalAppendStrCh(c, n); - mAppendStrStr: result := evalAppendStrStr(c, n); - mAppendSeqElem: result := evalAppendSeqElem(c, n); - mAppendSeqSeq: result := evalAppendSeqSeq(c, n); - - mNLen: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := newNodeIT(nkIntLit, n.info, n.typ); - case a.kind of - nkEmpty..nkNilLit: begin end; - else result.intVal := sonsLen(a); - end - end; - mNChild: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - k := getOrdValue(result); - if (k >= 0) and (k < sonsLen(a)) - and not (a.kind in [nkEmpty..nkNilLit]) then - result := a.sons[int(k)] - else begin - stackTrace(c, n, errIndexOutOfBounds); - result := emptyNode - end; - end; - mNSetChild: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - result := evalAux(c, n.sons[3]); - if result.kind = nkExceptBranch then exit; - k := getOrdValue(b); - if (k >= 0) and (k < sonsLen(a)) - and not (a.kind in [nkEmpty..nkNilLit]) then - a.sons[int(k)] := result - else - stackTrace(c, n, errIndexOutOfBounds); - result := emptyNode; - end; - mNAdd: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - addSon(a, result); - result := emptyNode - end; - mNAddMultiple: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - for i := 0 to sonsLen(result)-1 do addSon(a, result.sons[i]); - result := emptyNode - end; - mNDel: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - result := evalAux(c, n.sons[3]); - if result.kind = nkExceptBranch then exit; - for i := 0 to int(getOrdValue(result))-1 do - delSon(a, int(getOrdValue(b))); - result := emptyNode; - end; - mNKind: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := newNodeIT(nkIntLit, n.info, n.typ); - result.intVal := ord(a.kind); - end; - mNIntVal: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := newNodeIT(nkIntLit, n.info, n.typ); - case a.kind of - nkCharLit..nkInt64Lit: result.intVal := a.intVal; - else InternalError(n.info, 'no int value') - end - end; - mNFloatVal: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := newNodeIT(nkFloatLit, n.info, n.typ); - case a.kind of - nkFloatLit..nkFloat64Lit: result.floatVal := a.floatVal; - else InternalError(n.info, 'no float value') - end - end; - mNSymbol: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - if result.kind <> nkSym then InternalError(n.info, 'no symbol') - end; - mNIdent: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - if result.kind <> nkIdent then InternalError(n.info, 'no symbol') - end; - mNGetType: result := evalAux(c, n.sons[1]); - mNStrVal: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := newNodeIT(nkStrLit, n.info, n.typ); - case a.kind of - nkStrLit..nkTripleStrLit: result.strVal := a.strVal; - else InternalError(n.info, 'no string value') - end - end; - mNSetIntVal: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - a.intVal := result.intVal; // XXX: exception handling? - result := emptyNode - end; - mNSetFloatVal: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - a.floatVal := result.floatVal; // XXX: exception handling? - result := emptyNode - end; - mNSetSymbol: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - a.sym := result.sym; // XXX: exception handling? - result := emptyNode - end; - mNSetIdent: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - a.ident := result.ident; // XXX: exception handling? - result := emptyNode - end; - mNSetType: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - a.typ := result.typ; // XXX: exception handling? - result := emptyNode - end; - mNSetStrVal: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - a.strVal := result.strVal; // XXX: exception handling? - result := emptyNode - end; - mNNewNimNode: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - k := getOrdValue(result); - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - a := result; - if (k < 0) or (k > ord(high(TNodeKind))) then - internalError(n.info, 'request to create a NimNode with invalid kind'); - if a.kind = nkNilLit then - result := newNodeI(TNodeKind(int(k)), n.info) - else - result := newNodeI(TNodeKind(int(k)), a.info) - end; - mNCopyNimNode: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - result := copyNode(result); - end; - mNCopyNimTree: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - result := copyTree(result); - end; - mStrToIdent: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - if not (result.kind in [nkStrLit..nkTripleStrLit]) then - InternalError(n.info, 'no string node'); - a := result; - result := newNodeIT(nkIdent, n.info, n.typ); - result.ident := getIdent(a.strVal); - end; - mIdentToStr: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - if result.kind <> nkIdent then - InternalError(n.info, 'no ident node'); - a := result; - result := newNodeIT(nkStrLit, n.info, n.typ); - result.strVal := a.ident.s; - end; - mEqIdent: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - b := result; - result := newNodeIT(nkIntLit, n.info, n.typ); - if (a.kind = nkIdent) and (b.kind = nkIdent) then - if a.ident.id = b.ident.id then result.intVal := 1 - end; - mNHint: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - liMessage(n.info, hintUser, getStrValue(result)); - result := emptyNode - end; - mNWarning: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - liMessage(n.info, warnUser, getStrValue(result)); - result := emptyNode - end; - mNError: begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - liMessage(n.info, errUser, getStrValue(result)); - result := emptyNode - end; - else begin - result := evalAux(c, n.sons[1]); - if result.kind = nkExceptBranch then exit; - a := result; - if sonsLen(n) > 2 then begin - result := evalAux(c, n.sons[2]); - if result.kind = nkExceptBranch then exit; - end - else - result := nil; - result := evalOp(m, n, a, result); - end - end -end; - -function evalAux(c: PContext; n: PNode): PNode; -var - i: int; -begin - result := emptyNode; - dec(gNestedEvals); - if gNestedEvals <= 0 then stackTrace(c, n, errTooManyIterations); - case n.kind of // atoms: - nkEmpty: result := n; - nkSym: result := evalSym(c, n); - nkType..pred(nkNilLit): result := copyNode(n); - nkNilLit: result := n; // end of atoms - - nkCall, nkHiddenCallConv, nkMacroStmt: result := evalMagicOrCall(c, n); - nkCurly, nkBracket: begin - result := copyNode(n); - for i := 0 to sonsLen(n)-1 do addSon(result, evalAux(c, n.sons[i])); - end; - nkPar: begin - result := copyTree(n); - for i := 0 to sonsLen(n)-1 do - result.sons[i].sons[1] := evalAux(c, n.sons[i].sons[1]); - end; - nkBracketExpr: result := evalArrayAccess(c, n); - nkDotExpr: result := evalFieldAccess(c, n); - nkDerefExpr, nkHiddenDeref: result := evalDeref(c, n); - nkAddr, nkHiddenAddr: result := evalAddr(c, n); - nkHiddenStdConv, nkHiddenSubConv, nkConv: result := evalConv(c, n); - nkAsgn: result := evalAsgn(c, n); - nkWhenStmt, nkIfStmt, nkIfExpr: result := evalIf(c, n); - nkWhileStmt: result := evalWhile(c, n); - nkCaseStmt: result := evalCase(c, n); - nkVarSection: result := evalVar(c, n); - nkTryStmt: result := evalTry(c, n); - nkRaiseStmt: result := evalRaise(c, n); - nkReturnStmt: result := evalReturn(c, n); - nkBreakStmt, nkReturnToken: result := n; - nkBlockExpr, nkBlockStmt: result := evalBlock(c, n); - nkDiscardStmt: result := evalAux(c, n.sons[0]); - nkCheckedFieldExpr: result := evalCheckedFieldAccess(c, n); - nkObjDownConv: result := evalAux(c, n.sons[0]); - nkObjUpConv: result := evalUpConv(c, n); - nkChckRangeF, nkChckRange64, nkChckRange: result := evalRangeChck(c, n); - nkStringToCString: result := evalConvStrToCStr(c, n); - nkCStringToString: result := evalConvCStrToStr(c, n); - nkPassAsOpenArray: result := evalAux(c, n.sons[0]); - - nkStmtListExpr, nkStmtList, nkModule: begin - for i := 0 to sonsLen(n)-1 do begin - result := evalAux(c, n.sons[i]); - case result.kind of - nkExceptBranch, nkReturnToken, nkBreakStmt: break; - else begin end - end - end - end; - nkProcDef, nkMacroDef, nkCommentStmt: begin end; - nkIdentDefs, nkCast, nkYieldStmt, nkAsmStmt, nkForStmt, nkPragmaExpr, - nkQualified, nkLambda, nkContinueStmt: - stackTrace(c, n, errCannotInterpretNodeX, nodeKindToStr[n.kind]); - else InternalError(n.info, 'evalAux: ' + nodekindToStr[n.kind]); - end; - if result = nil then - InternalError(n.info, 'evalAux: returned nil ' + nodekindToStr[n.kind]); - inc(gNestedEvals); -end; - -function eval(c: PContext; n: PNode): PNode; -begin - gWhileCounter := evalMaxIterations; - gNestedEvals := evalMaxRecDepth; - result := evalAux(c, transform(c, n)); - if result.kind = nkExceptBranch then - stackTrace(c, n, errUnhandledExceptionX, typeToString(result.typ)); -end; - -function semMacroExpr(c: PContext; n: PNode; sym: PSym): PNode; -var - p: PTransCon; -begin - p := newTransCon(); - p.forStmt := n; - setLength(p.params, 2); - p.params[0] := newNodeIT(nkNilLit, n.info, sym.typ.sons[0]); - p.params[1] := n; - pushTransCon(c, p); - {@discard} eval(c, sym.ast.sons[codePos]); - result := p.params[0]; - popTransCon(c); - if cyclicTree(result) then liMessage(n.info, errCyclicTree); - result := semStmt(c, result); - // now, that was easy ... - // and we get more flexibility than in any other programming language -end; diff --git a/nim/extccomp.pas b/nim/extccomp.pas index a6d8cc147..5bc7011c1 100644 --- a/nim/extccomp.pas +++ b/nim/extccomp.pas @@ -15,7 +15,8 @@ interface {$include 'config.inc'} uses - nsystem, nimconf, msgs; + nsystem, charsets, lists, ropes, nos, strutils, platform, condsyms, options, + msgs; // some things are read in from the configuration file @@ -89,7 +90,7 @@ const optSpeed: ' -O -p6 '; optSize: ' -O -p6 '; compilerExe: 'lcc'; - compileTmpl: '-e1 $options $include -Fo$objfile $file'; + compileTmpl: '$options $include -Fo$objfile $file'; buildGui: ' -subsystem windows'; buildDll: ' -dll'; linkerExe: 'lcclnk'; @@ -287,13 +288,10 @@ function NameToCC(const name: string): TSystemCC; procedure initVars; procedure setCC(const ccname: string); +procedure writeMapping(const cfile: string; gSymbolMapping: PRope); implementation -uses - charsets, - lists, options, ropes, nos, strutils, platform, condsyms; - var toLink, toCompile, externalToCompile: TLinkedList; linkOptions: string = ''; @@ -301,16 +299,31 @@ var ccompilerpath: string = ''; -procedure initVars; +procedure setCC(const ccname: string); +var + i: TSystemCC; begin - // BUGFIX: '.' forgotten + linkOptions := ''; + ccompiler := nameToCC(ccname); + if ccompiler = ccNone then rawMessage(errUnknownCcompiler, ccname); compileOptions := getConfigVar(CC[ccompiler].name + '.options.always'); - // have the variables not been initialized? ccompilerpath := getConfigVar(CC[ccompiler].name + '.path'); + for i := low(CC) to high(CC) do undefSymbol(CC[i].name); + defineSymbol(CC[ccompiler].name); +end; + +procedure initVars; +var + i: TSystemCC; +begin // we need to define the symbol here, because ``CC`` may have never been set! - setCC(CC[ccompiler].name); + for i := low(CC) to high(CC) do undefSymbol(CC[i].name); + defineSymbol(CC[ccompiler].name); if gCmd = cmdCompileToCpp then cExt := '.cpp'; + addCompileOption(getConfigVar(CC[ccompiler].name + '.options.always')); + if length(ccompilerPath) = 0 then + ccompilerpath := getConfigVar(CC[ccompiler].name + '.path'); end; function completeCFilePath(const cfile: string; @@ -331,28 +344,28 @@ begin end; -procedure setCC(const ccname: string); -var - i: TSystemCC; +procedure addStr(var dest: string; const src: string); begin - ccompiler := nameToCC(ccname); - if ccompiler = ccNone then - rawMessage(errUnknownCcompiler, ccname); - for i := low(CC) to high(CC) do - undefSymbol(CC[i].name); - defineSymbol(CC[ccompiler].name) + dest := dest +{&} src; +end; + +procedure addOpt(var dest: string; const src: string); +begin + if (length(dest) = 0) or (dest[length(dest)-1+strStart] <> ' ') then + addStr(dest, ' '+''); + addStr(dest, src); end; procedure addCompileOption(const option: string); begin if strutils.findSubStr(option, compileOptions, strStart) < strStart then - compileOptions := compileOptions + ' ' +{&} option + addOpt(compileOptions, option) end; procedure addLinkOption(const option: string); begin if findSubStr(option, linkOptions, strStart) < strStart then - linkOptions := linkOptions + ' ' +{&} option + addOpt(linkOptions, option) end; function toObjFile(const filenameWithoutExt: string): string; @@ -378,9 +391,9 @@ end; procedure execExternalProgram(const cmd: string); begin - if optListCmd in gGlobalOptions then + if (optListCmd in gGlobalOptions) or (gVerbosity > 0) then MessageOut('Executing: ' +{&} nl +{&} cmd); - if ExecuteProcess(cmd) <> 0 then + if executeShellCommand(cmd) <> 0 then rawMessage(errExecutionOfProgramFailed); end; @@ -391,12 +404,7 @@ begin splitPath(projectFile, path, scriptname); SplitFilename(scriptname, name, ext); name := appendFileExt('compile_' + name, platform.os[targetOS].scriptExt); - WriteRope(script, joinPath([path, genSubDir, name])); -end; - -procedure addStr(var dest: string; const src: string); -begin - dest := dest +{&} src; + WriteRope(script, joinPath(path, name)); end; function getOptSpeed(c: TSystemCC): string; @@ -420,17 +428,51 @@ begin result := cc[c].optSize // use default settings from this file end; +const + specialFileA = 42; + specialFileB = 42; +var + fileCounter: int; + function getCompileCFileCmd(const cfilename: string; isExternal: bool = false): string; var - cfile, objfile, options, includeCmd, compilePattern: string; + cfile, objfile, options, includeCmd, compilePattern, key, trunk, exe: string; c: TSystemCC; // an alias to ccompiler begin c := ccompiler; options := compileOptions; - if optCDebug in gGlobalOptions then addStr(options, ' ' + getDebug(c)); - if optOptimizeSpeed in gOptions then addStr(options, ' ' + getOptSpeed(c)) - else if optOptimizeSize in gOptions then addStr(options, ' ' + getOptSize(c)); + trunk := getFileTrunk(cfilename); + if optCDebug in gGlobalOptions then begin + key := trunk + '.debug'; + if existsConfigVar(key) then + addOpt(options, getConfigVar(key)) + else + addOpt(options, getDebug(c)) + end; + if (optOptimizeSpeed in gOptions) then begin + //if ((fileCounter >= specialFileA) and (fileCounter <= specialFileB)) then + key := trunk + '.speed'; + if existsConfigVar(key) then + addOpt(options, getConfigVar(key)) + else + addOpt(options, getOptSpeed(c)) + end + else if optOptimizeSize in gOptions then begin + key := trunk + '.size'; + if existsConfigVar(key) then + addOpt(options, getConfigVar(key)) + else + addOpt(options, getOptSize(c)) + end; + key := trunk + '.always'; + if existsConfigVar(key) then + addOpt(options, getConfigVar(key)); + + exe := cc[c].compilerExe; + key := cc[c].name + '.exe'; + if existsConfigVar(key) then + exe := getConfigVar(key); if (optGenDynLib in gGlobalOptions) and (ospNeedsPIC in platform.OS[targetOS].props) then @@ -441,8 +483,7 @@ begin includeCmd := cc[c].includeCmd; // this is more complex than needed, but // a workaround of a FPC bug... addStr(includeCmd, libpath); - compilePattern := quoteIfSpaceExists( - JoinPath(ccompilerpath, cc[c].compilerExe)); + compilePattern := quoteIfSpaceExists(JoinPath(ccompilerpath, exe)); end else begin includeCmd := ''; @@ -458,7 +499,7 @@ begin else objfile := completeCFilePath(toObjFile(cfile)); - result := compilePattern +{&} ' ' +{&} format(cc[c].compileTmpl, + result := format(compilePattern +{&} ' ' +{&} cc[c].compileTmpl, ['file', AppendFileExt(cfile, cExt), 'objfile', objfile, 'options', options, @@ -476,6 +517,7 @@ var begin it := PStrEntry(list.head); while it <> nil do begin + inc(fileCounter); // call the C compiler for the .c file: compileCmd := getCompileCFileCmd(it.data, isExternal); if not (optCompileOnly in gGlobalOptions) then @@ -491,16 +533,15 @@ end; procedure CallCCompiler(const projectfile: string); var it: PStrEntry; - linkCmd, objfiles, exefile, buildgui, builddll: string; + linkCmd, objfiles, exefile, buildgui, builddll, linkerExe: string; c: TSystemCC; // an alias to ccompiler script: PRope; begin if (gGlobalOptions * [optCompileOnly, optGenScript] = [optCompileOnly]) then exit; // speed up that call if only compiling and no script shall be // generated - initVars(); if (toCompile.head = nil) and (externalToCompile.head = nil) then exit; - //initVars(); + fileCounter := 0; c := ccompiler; script := nil; CompileCFile(toCompile, script, false); @@ -508,10 +549,13 @@ begin if not (optNoLinking in gGlobalOptions) then begin // call the linker: + linkerExe := getConfigVar(cc[c].name + '.linkerexe'); + if length(linkerExe) = 0 then linkerExe := cc[c].linkerExe; + if (hostOS <> targetOS) then - linkCmd := cc[c].linkerExe + linkCmd := linkerExe else - linkCmd := quoteIfSpaceExists(JoinPath(ccompilerpath, cc[c].linkerExe)); + linkCmd := quoteIfSpaceExists(JoinPath(ccompilerpath, linkerExe)); if optGenDynLib in gGlobalOptions then buildDll := cc[c].buildDll @@ -546,7 +590,7 @@ begin it := PStrEntry(it.next); end; - linkCmd := linkCmd +{&} ' ' +{&} format(cc[c].linkTmpl, [ + linkCmd := format(linkCmd +{&} ' ' +{&} cc[c].linkTmpl, [ 'builddll', builddll, 'buildgui', buildgui, 'options', linkOptions, @@ -567,4 +611,28 @@ begin end end; +function genMappingFiles(const list: TLinkedList): PRope; +var + it: PStrEntry; +begin + result := nil; + it := PStrEntry(list.head); + while it <> nil do begin + appf(result, '--file:"$1"$n', [toRope(AppendFileExt(it.data, cExt))]); + it := PStrEntry(it.next); + end; +end; + +procedure writeMapping(const cfile: string; gSymbolMapping: PRope); +var + code: PRope; +begin + if not (optGenMapping in gGlobalOptions) then exit; + code := toRope('[C_Files]'+nl); + app(code, genMappingFiles(toCompile)); + app(code, genMappingFiles(externalToCompile)); + appf(code, '[Symbols]$n$1', [gSymbolMapping]); + WriteRope(code, joinPath(projectPath, 'mapping.txt')); +end; + end. diff --git a/nim/gpl.html b/nim/gpl.html deleted file mode 100644 index 0aec9fff0..000000000 --- a/nim/gpl.html +++ /dev/null @@ -1,493 +0,0 @@ -<!DOCTYPE html PUBLIC "-//IETF//DTD HTML 2.0//EN"> -<html> -<head> -<title>GNU General Public License - GNU Project - Free Software Foundation (FSF)</title> -</head> -<body bgcolor="#FFFFFF" text="#000000" link="#1F00FF" alink="#FF0000" vlink="#9900DD"> -<h1>GNU General Public License</h1> -<hr> -<h2>Table of Contents</h2> -<ul> - <li><a name="TOC1" href="gpl.html#SEC1">GNU GENERAL PUBLIC LICENSE</a> -<ul> -<li><a name="TOC2" href="gpl.html#SEC2">Preamble</a> -<li><a name="TOC3" href="gpl.html#SEC3">TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION</a> -<li><a name="TOC4" href="gpl.html#SEC4">How to Apply These Terms to Your New Programs</a> - -</ul> -</ul> - -<p> - -<hr> - -<p> - - - -<h2><a name="SEC1" href="gpl.html#TOC1">GNU GENERAL PUBLIC LICENSE</a></h2> -<p> -Version 2, June 1991 - -</p> - -<pre> -Copyright (C) 1989, 1991 Free Software Foundation, Inc. -59 Temple Place - Suite 330, Boston, MA 02111-1307, USA - -Everyone is permitted to copy and distribute verbatim copies -of this license document, but changing it is not allowed. -</pre> - - - -<h2><a name="SEC2" href="gpl.html#TOC2">Preamble</a></h2> - -<p> - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - -</p> -<p> - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - -</p> -<p> - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - -</p> -<p> - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - -</p> -<p> - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - -</p> -<p> - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - -</p> -<p> - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - -</p> -<p> - The precise terms and conditions for copying, distribution and -modification follow. - -</p> - - -<h2><a name="SEC3" href="gpl.html#TOC3">TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION</a></h2> - - -<p> - -<strong>0.</strong> - This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". -<p> - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - -<p> - -<strong>1.</strong> - You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. -<p> - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. -<p> - -<strong>2.</strong> - You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: -<p> - -<ul> - -<li><strong>a)</strong> - You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - -<p> -<li><strong>b)</strong> - You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - -<p> -<li><strong>c)</strong> - If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) -</ul> - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. -<p> - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. -<p> - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - -<p> - -<strong>3.</strong> - You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - -<!-- we use this doubled UL to get the sub-sections indented, --> -<!-- while making the bullets as unobvious as possible. --> -<ul> - -<li><strong>a)</strong> - Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - -<p> -<li><strong>b)</strong> - Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - -<p> -<li><strong>c)</strong> - Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) -</ul> - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. -<p> - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. -<p> - -<strong>4.</strong> - You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - -<p> - -<strong>5.</strong> - You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - -<p> - -<strong>6.</strong> - Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - -<p> - -<strong>7.</strong> - If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. -<p> - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. -<p> - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. -<p> - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - -<p> - -<strong>8.</strong> - If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - -<p> - -<strong>9.</strong> - The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. -<p> - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - -<p> - - -<strong>10.</strong> - If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - - -<p><strong>NO WARRANTY</strong></p> - -<p> - -<strong>11.</strong> - BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - -<p> - -<strong>12.</strong> - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - -<p> - - -<h2>END OF TERMS AND CONDITIONS</h2> - - - -<h2><a name="SEC4" href="gpl.html#TOC4">How to Apply These Terms to Your New Programs</a></h2> - -<p> - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - -</p> -<p> - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - -</p> - -<pre> -<var>one line to give the program's name and an idea of what it does.</var> -Copyright (C) <var>yyyy</var> <var>name of author</var> - -This program is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public License -as published by the Free Software Foundation; either version 2 -of the License, or (at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -</pre> - -<p> -Also add information on how to contact you by electronic and paper mail. - -</p> -<p> -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - -</p> - -<pre> -Gnomovision version 69, Copyright (C) <var>year</var> <var>name of author</var> -Gnomovision comes with ABSOLUTELY NO WARRANTY; for details -type `show w'. This is free software, and you are welcome -to redistribute it under certain conditions; type `show c' -for details. -</pre> - -<p> -The hypothetical commands <samp>`show w'</samp> and <samp>`show c'</samp> should show -the appropriate parts of the General Public License. Of course, the -commands you use may be called something other than <samp>`show w'</samp> and -<samp>`show c'</samp>; they could even be mouse-clicks or menu items--whatever -suits your program. - -</p> -<p> -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - -</p> - -<pre> -Yoyodyne, Inc., hereby disclaims all copyright -interest in the program `Gnomovision' -(which makes passes at compilers) written -by James Hacker. - -<var>signature of Ty Coon</var>, 1 April 1989 -Ty Coon, President of Vice -</pre> - -<p> -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. -</body></html> diff --git a/nim/hashes.pas b/nim/hashes.pas index 059a42998..cf5ab03bc 100644 --- a/nim/hashes.pas +++ b/nim/hashes.pas @@ -8,6 +8,8 @@ // unit hashes; +{$include 'config.inc'} + interface uses diff --git a/nim/highlite.pas b/nim/highlite.pas index 8547d9904..5ef4acc12 100644 --- a/nim/highlite.pas +++ b/nim/highlite.pas @@ -358,7 +358,7 @@ begin end end; g.len := pos - g.pos; - assert((g.kind = gtEof) or (g.len > 0)); + if (g.kind <> gtEof) and (g.len <= 0) then InternalError('nimNextToken'); g.pos := pos; end; @@ -633,7 +633,7 @@ begin end end; g.len := pos - g.pos; - assert((g.kind = gtEof) or (g.len > 0)); + if (g.kind <> gtEof) and (g.len <= 0) then InternalError('clikeNextToken'); g.pos := pos; end; @@ -711,7 +711,7 @@ begin langCsharp: csharpNextToken(g); langC: cNextToken(g); langJava: javaNextToken(g); - else assert(false); + else InternalError('getNextToken'); end end; diff --git a/nim/idents.pas b/nim/idents.pas index 8779abb2b..44957ba7a 100644 --- a/nim/idents.pas +++ b/nim/idents.pas @@ -30,7 +30,7 @@ type s: string; next: PIdent; // for hash-table chaining h: THash; // hash value of s - end; + end {@acyclic}; function getIdent(const identifier: string): PIdent; overload; function getIdent(const identifier: string; h: THash): PIdent; overload; diff --git a/nim/importer.pas b/nim/importer.pas index 0658783a3..5c49259c2 100644 --- a/nim/importer.pas +++ b/nim/importer.pas @@ -6,9 +6,26 @@ // See the file "copying.txt", included in this // distribution, for details about the copyright. // +unit importer; // This module implements the symbol importing mechanism. +interface + +{$include 'config.inc'} + +uses + nsystem, charsets, strutils, nos, + ast, astalgo, msgs, options, idents, rodread, lookups, semdata, passes; + +function evalImport(c: PContext; n: PNode): PNode; +function evalFrom(c: PContext; n: PNode): PNode; +procedure importAllSymbols(c: PContext; fromMod: PSym); + +function getModuleFile(n: PNode): string; + +implementation + function findModule(const info: TLineInfo; const modulename: string): string; // returns path to module begin @@ -41,32 +58,45 @@ var check, copy, e: PSym; j: int; etyp: PType; // enumeration type + it: TIdentIter; begin - //copy := copySym(s, true); - //copy.ast := s.ast; + // This does not handle stubs, because otherwise loading on demand would be + // basically pointless. So importing stubs is fine here! copy := s; // do not copy symbols when importing! // check if we have already a symbol of the same name: check := StrTableGet(c.tab.stack[importTablePos], s.name); - if check <> nil then begin + if (check <> nil) and (check.id <> copy.id) then begin if not (s.kind in OverloadableSyms) then begin - {@discard} StrTableIncl(c.AmbigiousSymbols, copy); - {@discard} StrTableIncl(c.AmbigiousSymbols, check); - // s and check need to be qualified + // s and check need to be qualified: + IntSetIncl(c.AmbigiousSymbols, copy.id); + IntSetIncl(c.AmbigiousSymbols, check.id); end end; StrTableAdd(c.tab.stack[importTablePos], copy); if s.kind = skType then begin etyp := s.typ; - if etyp.kind = tyEnum then begin + if etyp.kind in [tyBool, tyEnum] then begin for j := 0 to sonsLen(etyp.n)-1 do begin e := etyp.n.sons[j].sym; - if (e.Kind = skEnumField) then rawImportSymbol(c, e) - else InternalError(s.info, 'rawImportSymbol'); + if (e.Kind <> skEnumField) then + InternalError(s.info, 'rawImportSymbol'); + // BUGFIX: because of aliases for enums the symbol may already + // have been put into the symbol table + // BUGFIX: but only iff they are the same symbols! + check := InitIdentIter(it, c.tab.stack[importTablePos], e.name); + while check <> nil do begin + if check.id = e.id then begin e := nil; break end; + check := NextIdentIter(it, c.tab.stack[importTablePos]); + end; + if e <> nil then rawImportSymbol(c, e); + //check := StrTableGet(c.tab.stack[importTablePos], e.name); + //if (check = nil) or (check.id <> e.id) then + // rawImportSymbol(c, e) end end end else if s.kind = skConverter then - addConverter(c, s); + addConverter(c, s); // rodgen assures that converters are no stubs end; procedure importSymbol(c: PContext; ident: PNode; fromMod: PSym); @@ -78,6 +108,7 @@ begin s := StrTableGet(fromMod.tab, ident.ident); if s = nil then liMessage(ident.info, errUndeclaredIdentifier, ident.ident.s); + if s.kind = skStub then loadStub(s); if not (s.Kind in ExportableSymKinds) then InternalError(ident.info, 'importSymbol: 2'); // for an enumeration we have to add all identifiers @@ -106,7 +137,7 @@ begin if s.kind <> skModule then begin if s.kind <> skEnumField then begin if not (s.Kind in ExportableSymKinds) then - InternalError(s.info, 'importAllSymbols'); + InternalError(s.info, 'importAllSymbols: ' + symKindToStr[s.kind]); rawImportSymbol(c, s); // this is correct! end end; @@ -118,14 +149,15 @@ function evalImport(c: PContext; n: PNode): PNode; var m: PSym; i: int; + f: string; begin - result := copyNode(n); + result := n; for i := 0 to sonsLen(n)-1 do begin - m := c.ImportModule(getModuleFile(n.sons[i]), c.b); + f := getModuleFile(n.sons[i]); + m := gImportModule(f); // ``addDecl`` needs to be done before ``importAllSymbols``! addDecl(c, m); // add symbol to symbol table of module importAllSymbols(c, m); - addSon(result, newSymNode(m)); end; end; @@ -133,24 +165,15 @@ function evalFrom(c: PContext; n: PNode): PNode; var m: PSym; i: int; + f: string; begin result := n; checkMinSonsLen(n, 2); - m := c.ImportModule(getModuleFile(n.sons[0]), c.b); + f := getModuleFile(n.sons[0]); + m := gImportModule(f); n.sons[0] := newSymNode(m); addDecl(c, m); // add symbol to symbol table of module for i := 1 to sonsLen(n)-1 do importSymbol(c, n.sons[i], m); end; -function evalInclude(c: PContext; n: PNode): PNode; -var - i: int; - x: PNode; -begin - result := newNodeI(nkStmtList, n.info); - for i := 0 to sonsLen(n)-1 do begin - x := c.includeFile(getModuleFile(n.sons[i])); - x := semStmt(c, x); - addSon(result, x); - end; -end; +end. diff --git a/nim/instgen.pas b/nim/instgen.pas deleted file mode 100644 index e64034f9e..000000000 --- a/nim/instgen.pas +++ /dev/null @@ -1,267 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2008 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -// This module does the instantiation of generic procs and types. - -function generateInstance(c: PContext; fn: PSym; const pt: TIdTable; - const instantiator: TLineInfo): PSym; forward; -// generates an instantiated proc - -type - TInstantiateClosure = object(NObject) - mapping: TIdTable; // map {ptype, psym} to {ptype, psym} - fn: PSym; - module: PSym; - newOwner: PSym; - instantiator: TLineInfo; - end; - PInstantiateClosure = ^TInstantiateClosure; - PInstClosure = PInstantiateClosure; - -function instantiateTree(c: PInstantiateClosure; t: PNode): PNode; forward; -function instantiateSym(c: PInstantiateClosure; sym: PSym): PSym; forward; -function instantiateType(c: PInstantiateClosure; typ: PType): PType; forward; - -function containsGenericTypeIter(t: PType; closure: PObject): bool; -begin - result := t.kind in GenericTypes; -end; - -function containsGenericType(t: PType): bool; -begin - result := iterOverType(t, containsGenericTypeIter, nil); -end; - -function instTypeNode(c: PInstantiateClosure; n: PNode): PNode; -var - i: int; -begin - result := nil; - if n <> nil then begin - result := copyNode(n); - result.typ := instantiateType(c, n.typ); - case n.kind of - nkNone..nkNilLit: begin // a leaf - end; - else begin - for i := 0 to sonsLen(n)-1 do - addSon(result, instTypeNode(c, n.sons[i])); - end - end - end -end; - -function instantiateType(c: PInstantiateClosure; typ: PType): PType; -var - i: int; -begin - result := PType(idTableGet(c.mapping, typ)); - if result <> nil then exit; - if containsGenericType(typ) then begin - result := copyType(typ, c.newOwner); - idTablePut(c.mapping, typ, result); // to avoid cycles - for i := 0 to sonsLen(result)-1 do - result.sons[i] := instantiateType(c, result.sons[i]); - if result.n <> nil then - result.n := instTypeNode(c, result.n); - end - else - result := typ; - if result.Kind in GenericTypes then begin - liMessage(c.instantiator, errCannotInstantiateX, - TypeToString(typ, preferName)); - end - else if result.kind = tyVar then begin - if result.sons[0].kind = tyVar then - liMessage(c.instantiator, errVarVarTypeNotAllowed); - end; -end; - -function instantiateSym(c: PInstantiateClosure; sym: PSym): PSym; -begin - if sym = nil then begin result := nil; exit end; // BUGFIX - result := PSym(idTableGet(c.mapping, sym)); - if (result = nil) then begin - if (sym.owner.id = c.fn.id) or (sym.id = c.fn.id) then begin - result := copySym(sym); - if sym.id = c.fn.id then c.newOwner := result; - include(result.flags, sfIsCopy); - idTablePut(c.mapping, sym, result); // BUGFIX - result.typ := instantiateType(c, sym.typ); - if (result.owner <> nil) and (result.owner.kind = skModule) then - result.owner := c.module // BUGFIX - else - result.owner := instantiateSym(c, result.owner); - if sym.ast <> nil then begin - result.ast := instantiateTree(c, sym.ast); - end - end - else - result := sym // do not copy t! - end -end; - -function instantiateTree(c: PInstantiateClosure; t: PNode): PNode; -var - len, i: int; -begin - if t = nil then begin result := nil; exit end; - result := copyNode(t); - if result.typ <> nil then result.typ := instantiateType(c, result.typ); - case t.kind of - nkNone..pred(nkSym), succ(nkSym)..nkNilLit: begin end; - nkSym: begin - if result.sym <> nil then result.sym := instantiateSym(c, result.sym); - end - else begin - len := sonsLen(t); - if len > 0 then begin - newSons(result, len); - for i := 0 to len-1 do - result.sons[i] := instantiateTree(c, t.sons[i]); - end - end - end -end; - -procedure instantiateGenericParamList(c: PContext; n: PNode; - const pt: TIdTable); -var - i: int; - s, q: PSym; - t: PType; -begin - assert(n.kind = nkGenericParams); - for i := 0 to sonsLen(n)-1 do begin - if n.sons[i].kind = nkDefaultTypeParam then begin - internalError(n.sons[i].info, - 'instantiateGenericParamList() to implement'); - // XXX - end; - assert(n.sons[i].kind = nkSym); - q := n.sons[i].sym; - s := newSym(skType, q.name, getCurrOwner(c)); - t := PType(IdTableGet(pt, q.typ)); - if t = nil then - liMessage(n.sons[i].info, errCannotInstantiateX, s.name.s); - assert(t.kind <> tyGenericParam); - s.typ := t; - addDecl(c, s); - end -end; - -function GenericCacheGet(c: PContext; genericSym, instSym: PSym): PSym; -var - i: int; - a, b: PSym; -begin - result := nil; - for i := 0 to sonsLen(c.generics)-1 do begin - if c.generics.sons[i].kind <> nkExprEqExpr then - InternalError(genericSym.info, 'GenericCacheGet'); - a := c.generics.sons[i].sons[0].sym; - if genericSym.id = a.id then begin - b := c.generics.sons[i].sons[1].sym; - if equalParams(b.typ.n, instSym.typ.n) = paramsEqual then begin - result := b; exit - end - end - end -end; - -procedure GenericCacheAdd(c: PContext; genericSym, instSym: PSym); -var - n: PNode; -begin - n := newNode(nkExprEqExpr); - addSon(n, newSymNode(genericSym)); - addSon(n, newSymNode(instSym)); - addSon(c.generics, n); -end; - -procedure semParamList(c: PContext; n: PNode; s: PSym); forward; -procedure addParams(c: PContext; n: PNode); forward; -procedure addResult(c: PContext; t: PType; const info: TLineInfo); forward; -procedure addResultNode(c: PContext; n: PNode); forward; - -function generateInstance(c: PContext; fn: PSym; const pt: TIdTable; - const instantiator: TLineInfo): PSym; -// generates an instantiated proc -var - oldPrc: PSym; - oldP: PProcCon; - n: PNode; -begin - oldP := c.p; // restore later - result := copySym(fn); - result.owner := getCurrOwner(c); - n := copyTree(fn.ast); - result.ast := n; - pushOwner(c, result); - openScope(c.tab); - assert(n.sons[genericParamsPos] <> nil); - n.sons[namePos] := newSymNode(result); - pushInfoContext(instantiator); - - instantiateGenericParamList(c, n.sons[genericParamsPos], pt); - n.sons[genericParamsPos] := nil; - // semantic checking for the parameters: - if n.sons[paramsPos] <> nil then begin - semParamList(c, n.sons[ParamsPos], result); - addParams(c, result.typ.n); - end - else begin - result.typ := newTypeS(tyProc, c); - addSon(result.typ, nil); - end; - - // now check if we have already such a proc generated - oldPrc := GenericCacheGet(c, fn, result); - if oldPrc = nil then begin - // add it here, so that recursive generic procs are possible: - addDecl(c, result); - if n.sons[codePos] <> nil then begin - c.p := newProcCon(result); - if result.kind in [skProc, skConverter] then begin - addResult(c, result.typ.sons[0], n.info); - addResultNode(c, n); - end; - n.sons[codePos] := semStmtScope(c, n.sons[codePos]); - end; - GenericCacheAdd(c, fn, result); - end - else - result := oldPrc; - popInfoContext(); - closeScope(c.tab); // close scope for parameters - popOwner(c); - c.p := oldP; // restore -end; - -function generateTypeInstance(p: PContext; const pt: TIdTable; - const instantiator: TLineInfo; t: PType): PType; -var - c: PInstantiateClosure; -begin - new(c); -{@ignore} - fillChar(c^, sizeof(c^), 0); -{@emit} - c.mapping := pt; // making a copy is not necessary - c.fn := nil; - c.instantiator := instantiator; - c.module := p.module; - c.newOwner := getCurrOwner(p); - result := instantiateType(c, t); -end; - -function partialSpecialization(c: PContext; n: PNode; s: PSym): PNode; -begin - result := n; -end; diff --git a/nim/lexbase.pas b/nim/lexbase.pas index c840dc6d2..11200f652 100644 --- a/nim/lexbase.pas +++ b/nim/lexbase.pas @@ -16,7 +16,7 @@ unit lexbase; interface uses - nsystem, charsets, strutils; + nsystem, llstream, charsets, strutils; {@emit const @@ -44,25 +44,21 @@ const type TBaseLexer = object(NObject) bufpos: int; - buf: PChar; // NOT zero terminated! + buf: PChar; bufLen: int; // length of buffer in characters - f: TBinaryFile; // we use a binary file here for efficiency + stream: PLLStream; // we read from this stream LineNumber: int; // the current line number // private data: sentinel: int; lineStart: int; // index of last line start in buffer - fileOpened: boolean; end; -function initBaseLexer(out L: TBaseLexer; - const filename: string; - bufLen: int = 8192): boolean; +procedure openBaseLexer(out L: TBaseLexer; + inputstream: PLLStream; + bufLen: int = 8192); // 8K is a reasonable buffer size -procedure initBaseLexerFromBuffer(out L: TBaseLexer; - const buffer: string); - -procedure deinitBaseLexer(var L: TBaseLexer); +procedure closeBaseLexer(var L: TBaseLexer); function getCurrentLine(const L: TBaseLexer; marker: boolean = true): string; function getColNumber(const L: TBaseLexer; pos: int): int; @@ -82,10 +78,10 @@ implementation const chrSize = sizeof(char); -procedure deinitBaseLexer(var L: TBaseLexer); +procedure closeBaseLexer(var L: TBaseLexer); begin dealloc(L.buf); - if L.fileOpened then closeFile(L.f); + LLStreamClose(L.stream); end; {@ignore} @@ -119,8 +115,8 @@ begin if toCopy > 0 then MoveMem(L.buf, addr(L.buf[L.sentinel+1]), toCopy * chrSize); // "moveMem" handles overlapping regions - charsRead := ReadBuffer(L.f, addr(L.buf[toCopy]), (L.sentinel+1) * chrSize) - div chrSize; + charsRead := LLStreamRead(L.stream, addr(L.buf[toCopy]), + (L.sentinel+1) * chrSize) div chrSize; s := toCopy + charsRead; if charsRead < L.sentinel+1 then begin L.buf[s] := EndOfFile; // set end marker @@ -144,8 +140,8 @@ begin L.bufLen := L.BufLen * 2; L.buf := {@cast}PChar(realloc(L.buf, L.bufLen*chrSize)); assert(L.bufLen - oldBuflen = oldBufLen); - charsRead := ReadBuffer(L.f, addr(L.buf[oldBufLen]), oldBufLen*chrSize) - div chrSize; + charsRead := LLStreamRead(L.stream, addr(L.buf[oldBufLen]), + oldBufLen*chrSize) div chrSize; if charsRead < oldBufLen then begin L.buf[oldBufLen+charsRead] := EndOfFile; L.sentinel := oldBufLen+charsRead; @@ -198,8 +194,8 @@ begin end end; -function initBaseLexer(out L: TBaseLexer; const filename: string; - bufLen: int = 8192): boolean; +procedure openBaseLexer(out L: TBaseLexer; inputstream: PLLStream; + bufLen: int = 8192); begin assert(bufLen > 0); L.bufpos := 0; @@ -208,30 +204,8 @@ begin L.sentinel := bufLen-1; L.lineStart := 0; L.linenumber := 1; // lines start at 1 - L.fileOpened := openFile(L.f, filename); - result := L.fileOpened; - if result then begin - fillBuffer(L); - skip_UTF_8_BOM(L) - end; -end; - -procedure initBaseLexerFromBuffer(out L: TBaseLexer; - const buffer: string); -begin - L.bufpos := 0; - L.bufLen := length(buffer)+1; - L.buf := {@cast}PChar(alloc(L.bufLen * chrSize)); - L.sentinel := L.bufLen-1; - L.lineStart := 0; - L.linenumber := 1; // lines start at 1 - L.fileOpened := false; - if L.bufLen > 0 then begin - copyMem(L.buf, {@cast}pointer(buffer), L.bufLen); - L.buf[L.bufLen-1] := EndOfFile; - end - else - L.buf[0] := EndOfFile; + L.stream := inputstream; + fillBuffer(L); skip_UTF_8_BOM(L); end; diff --git a/nim/lookup.pas b/nim/lookup.pas deleted file mode 100644 index 192dba7ca..000000000 --- a/nim/lookup.pas +++ /dev/null @@ -1,237 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2008 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -// This module implements lookup helpers. - -function getSymRepr(s: PSym): string; -begin - case s.kind of - skProc, skConverter, skIterator: result := getProcHeader(s); - else result := s.name.s - end -end; - -procedure CloseScope(var tab: TSymTab); -var - it: TTabIter; - s: PSym; -begin - // check if all symbols have been used and defined: - if (tab.tos > length(tab.stack)) then InternalError('CloseScope'); - s := InitTabIter(it, tab.stack[tab.tos-1]); - while s <> nil do begin - if sfForward in s.flags then - liMessage(s.info, errImplOfXexpected, getSymRepr(s)) - else if ([sfUsed, sfInInterface] * s.flags = []) and - (optHints in s.options) then // BUGFIX: check options in s! - if not (s.kind in [skForVar, skParam]) then - liMessage(s.info, hintXDeclaredButNotUsed, getSymRepr(s)); - s := NextIter(it, tab.stack[tab.tos-1]); - end; - astalgo.rawCloseScope(tab); -end; - -procedure AddSym(var t: TStrTable; n: PSym); -begin - if StrTableIncl(t, n) then liMessage(n.info, errAttemptToRedefine, n.name.s); -end; - -procedure addDecl(c: PContext; sym: PSym); -begin - if SymTabAddUnique(c.tab, sym) = Failure then - liMessage(sym.info, errAttemptToRedefine, sym.Name.s); -end; - -procedure addDeclAt(c: PContext; sym: PSym; at: Natural); -begin - if SymTabAddUniqueAt(c.tab, sym, at) = Failure then - liMessage(sym.info, errAttemptToRedefine, sym.Name.s); -end; - -procedure addOverloadableSymAt(c: PContext; fn: PSym; at: Natural); -var - check: PSym; -begin - if not (fn.kind in OverloadableSyms) then - InternalError(fn.info, 'addOverloadableSymAt'); - check := StrTableGet(c.tab.stack[at], fn.name); - if (check <> nil) and (check.Kind <> fn.kind) then - liMessage(fn.info, errAttemptToRedefine, fn.Name.s); - SymTabAddAt(c.tab, fn, at); -end; - -procedure AddInterfaceDeclAux(c: PContext; sym: PSym); -begin - if (sfInInterface in sym.flags) then begin - // add to interface: - if c.module = nil then InternalError(sym.info, 'AddInterfaceDeclAux'); - StrTableAdd(c.module.tab, sym); - end; - if getCurrOwner(c).kind = skModule then - include(sym.flags, sfGlobal) -end; - -procedure addInterfaceDecl(c: PContext; sym: PSym); -begin // it adds the symbol to the interface if appropriate - addDecl(c, sym); - AddInterfaceDeclAux(c, sym); -end; - -procedure addInterfaceOverloadableSymAt(c: PContext; sym: PSym; at: int); -begin // it adds the symbol to the interface if appropriate - addOverloadableSymAt(c, sym, at); - AddInterfaceDeclAux(c, sym); -end; - -function lookUp(c: PContext; n: PNode): PSym; -// Looks up a symbol. Generates an error in case of nil. -begin - case n.kind of - nkAccQuoted: result := lookup(c, n.sons[0]); - nkSym: begin - result := SymtabGet(c.Tab, n.sym.name); - if result = nil then - liMessage(n.info, errUndeclaredIdentifier, n.sym.name.s); - include(result.flags, sfUsed); - end; - nkIdent: begin - result := SymtabGet(c.Tab, n.ident); - if result = nil then - liMessage(n.info, errUndeclaredIdentifier, n.ident.s); - include(result.flags, sfUsed); - end - else InternalError(n.info, 'lookUp'); - end -end; - -function QualifiedLookUp(c: PContext; n: PNode; ambigiousCheck: bool): PSym; -var - m: PSym; - ident: PIdent; -begin - case n.kind of - nkIdent: begin - result := SymtabGet(c.Tab, n.ident); - if result = nil then - liMessage(n.info, errUndeclaredIdentifier, n.ident.s) - else if ambigiousCheck - and StrTableContains(c.AmbigiousSymbols, result) then - liMessage(n.info, errUseQualifier, n.ident.s) - end; - nkSym: begin - result := SymtabGet(c.Tab, n.sym.name); - if result = nil then - liMessage(n.info, errUndeclaredIdentifier, n.sym.name.s) - else if ambigiousCheck - and StrTableContains(c.AmbigiousSymbols, result) then - liMessage(n.info, errUseQualifier, n.sym.name.s) - end; - nkDotExpr, nkQualified: begin - result := nil; - m := qualifiedLookUp(c, n.sons[0], false); - if (m <> nil) and (m.kind = skModule) then begin - if (n.sons[1].kind = nkIdent) then begin - ident := n.sons[1].ident; - if m = c.module then - // a module may access its private members: - result := StrTableGet(c.tab.stack[ModuleTablePos], ident) - else - result := StrTableGet(m.tab, ident); - if result = nil then - liMessage(n.sons[1].info, errUndeclaredIdentifier, ident.s) - end - else - liMessage(n.sons[1].info, errIdentifierExpected, ''); - end - end; - nkAccQuoted: result := QualifiedLookup(c, n.sons[0], ambigiousCheck); - else begin - result := nil; - //liMessage(n.info, errIdentifierExpected, '') - end; - end; -end; - -type - TOverloadIterMode = (oimNoQualifier, oimSelfModule, oimOtherModule); - TOverloadIter = record - stackPtr: int; - it: TIdentIter; - m: PSym; - mode: TOverloadIterMode; - end; - -function InitOverloadIter(out o: TOverloadIter; c: PContext; n: PNode): PSym; -var - ident: PIdent; -begin - result := nil; - case n.kind of - nkIdent: begin - o.stackPtr := c.tab.tos; - o.mode := oimNoQualifier; - while (result = nil) do begin - dec(o.stackPtr); - if o.stackPtr < 0 then break; - result := InitIdentIter(o.it, c.tab.stack[o.stackPtr], n.ident); - end; - end; - nkSym: begin - o.stackPtr := c.tab.tos; - o.mode := oimNoQualifier; - while (result = nil) do begin - dec(o.stackPtr); - if o.stackPtr < 0 then break; - result := InitIdentIter(o.it, c.tab.stack[o.stackPtr], n.sym.name); - end; - end; - nkDotExpr, nkQualified: begin - o.mode := oimOtherModule; - o.m := qualifiedLookUp(c, n.sons[0], false); - if (o.m <> nil) and (o.m.kind = skModule) then begin - if (n.sons[1].kind = nkIdent) then begin - ident := n.sons[1].ident; - if o.m = c.module then begin - // a module may access its private members: - result := InitIdentIter(o.it, c.tab.stack[ModuleTablePos], ident); - o.mode := oimSelfModule; - end - else - result := InitIdentIter(o.it, o.m.tab, ident); - end - else - liMessage(n.sons[1].info, errIdentifierExpected, ''); - end - end; - nkAccQuoted: result := InitOverloadIter(o, c, n.sons[0]); - else begin end - end -end; - -function nextOverloadIter(var o: TOverloadIter; c: PContext; n: PNode): PSym; -begin - case o.mode of - oimNoQualifier: begin - if n.kind = nkAccQuoted then - result := nextOverloadIter(o, c, n.sons[0]) // BUGFIX - else if o.stackPtr >= 0 then begin - result := nextIdentIter(o.it, c.tab.stack[o.stackPtr]); - while (result = nil) do begin - dec(o.stackPtr); - if o.stackPtr < 0 then break; - result := InitIdentIter(o.it, c.tab.stack[o.stackPtr], o.it.name); - // BUGFIX: o.it.name <-> n.ident - end - end - else result := nil; - end; - oimSelfModule: result := nextIdentIter(o.it, c.tab.stack[ModuleTablePos]); - oimOtherModule: result := nextIdentIter(o.it, o.m.tab); - end -end; diff --git a/nim/magicsys.pas b/nim/magicsys.pas index 2f314065d..55ec0b002 100644 --- a/nim/magicsys.pas +++ b/nim/magicsys.pas @@ -8,8 +8,7 @@ // unit magicsys; -// This module declares built-in System types like int or string in the -// system module. +// Built-in types and compilerprocs are registered here. interface @@ -17,44 +16,102 @@ interface uses nsystem, - ast, astalgo, hashes, msgs, platform, nversion, ntime, idents; + ast, astalgo, hashes, msgs, platform, nversion, ntime, idents, rodread; var // magic symbols in the system module: - notSym: PSym; // 'not' operator (for bool) - countUpSym: PSym; // countup iterator - SystemModule: PSym; - intSetBaseType: PType; - - compilerprocs: TStrTable; +procedure registerSysType(t: PType); function getSysType(const kind: TTypeKind): PType; -function getMatic(m: TMagic; const name: string): PSym; + function getCompilerProc(const name: string): PSym; +procedure registerCompilerProc(s: PSym); procedure InitSystem(var tab: TSymTab); procedure FinishSystem(const tab: TStrTable); -procedure setSize(t: PType; size: int); - implementation var gSysTypes: array [TTypeKind] of PType; + compilerprocs: TStrTable; + +procedure registerSysType(t: PType); +begin + if gSysTypes[t.kind] = nil then gSysTypes[t.kind] := t; +end; + +function newSysType(kind: TTypeKind; size: int): PType; +begin + result := newType(kind, systemModule); + result.size := size; + result.align := size; +end; + +function sysTypeFromName(const name: string): PType; +var + s: PSym; +begin + s := StrTableGet(systemModule.tab, getIdent(name)); + if s = nil then rawMessage(errSystemNeeds, name); + if s.kind = skStub then loadStub(s); + result := s.typ; +end; function getSysType(const kind: TTypeKind): PType; begin result := gSysTypes[kind]; - assert(result <> nil); + if result = nil then begin + case kind of + tyInt: result := sysTypeFromName('int'); + tyInt8: result := sysTypeFromName('int8'); + tyInt16: result := sysTypeFromName('int16'); + tyInt32: result := sysTypeFromName('int32'); + tyInt64: result := sysTypeFromName('int64'); + tyFloat: result := sysTypeFromName('float'); + tyFloat32: result := sysTypeFromName('float32'); + tyFloat64: result := sysTypeFromName('float64'); + tyBool: result := sysTypeFromName('bool'); + tyChar: result := sysTypeFromName('char'); + tyString: result := sysTypeFromName('string'); + tyCstring: result := sysTypeFromName('cstring'); + tyPointer: result := sysTypeFromName('pointer'); + tyAnyEnum: result := newSysType(tyAnyEnum, 1); + tyNil: result := newSysType(tyNil, ptrSize); + else InternalError('request for typekind: ' + typeKindToStr[kind]); + end; + gSysTypes[kind] := result; + end; + if result.kind <> kind then + InternalError('wanted: ' + typeKindToStr[kind] + +{&} ' got: ' +{&} typeKindToStr[result.kind]); + if result = nil then InternalError('type not found: ' + typeKindToStr[kind]); end; - function getCompilerProc(const name: string): PSym; +var + ident: PIdent; begin - result := StrTableGet(compilerprocs, getIdent(name, getNormalizedHash(name))); - if result = nil then rawMessage(errSystemNeeds, name) + ident := getIdent(name, getNormalizedHash(name)); + result := StrTableGet(compilerprocs, ident); + if result = nil then begin + result := StrTableGet(rodCompilerProcs, ident); + if result = nil then rawMessage(errSystemNeeds, name); + strTableAdd(compilerprocs, result); + if result.kind = skStub then loadStub(result); + // A bit hacky that this code is needed here, but it is the easiest + // solution in order to avoid special cases for sfCompilerProc in the + // rodgen module. Another solution would be to always recompile the system + // module. But I don't want to do that as that would mean less testing of + // the new symbol file cache (and worse performance). + end; end; +procedure registerCompilerProc(s: PSym); +begin + strTableAdd(compilerprocs, s); +end; +(* function FindMagic(const tab: TStrTable; m: TMagic; const s: string): PSym; var ti: TIdentIter; @@ -66,11 +123,6 @@ begin end end; -function getMatic(m: TMagic; const name: string): PSym; -begin - result := findMagic(systemModule.tab, m, name); -end; - function NewMagic(kind: TSymKind; const name: string; const info: TLineInfo): PSym; begin @@ -84,7 +136,6 @@ function newMagicType(const info: TLineInfo; kind: TTypeKind; begin result := newType(kind, SystemModule); result.sym := magicSym; - assert(SystemModule <> nil); end; procedure setSize(t: PType; size: int); @@ -93,15 +144,6 @@ begin t.size := size; end; - -// not -(unary) 700 -// * / div mod 600 -// + - 500 -// & .. 400 -// == <= < >= > != in not_in 300 -// and 200 -// or xor 100 - procedure addMagicSym(var tab: TSymTab; sym: PSym; sys: PSym); begin SymTabAdd(tab, sym); @@ -132,13 +174,10 @@ begin s.typ := newMagicType(fakeInfo, tyAnyEnum, s); SymTabAdd(tab, s); end; - +*) procedure InitSystem(var tab: TSymTab); -var - c: PSym; - typ: PType; -begin - initStrTable(compilerprocs); +begin (* + if SystemModule = nil then InternalError('systemModule == nil'); fakeInfo := newLineInfo('system.nim', 1, 1); // symbols with compiler magic are pretended to be in system at line 1 @@ -209,25 +248,26 @@ begin intSetBaseType := newMagicType(fakeInfo, tyRange, nil); addSon(intSetBaseType, gSysTypes[tyInt]); // base type setSize(intSetBaseType, int(gSysTypes[tyInt].size)); - intSetBaseType.n := newNode(nkRange); - intSetBaseType.n.info := fakeInfo; + intSetBaseType.n := newNodeI(nkRange, fakeInfo); addSon(intSetBaseType.n, newIntNode(nkIntLit, 0)); addSon(intSetBaseType.n, newIntNode(nkIntLit, nversion.MaxSetElements-1)); intSetBaseType.n.sons[0].info := fakeInfo; intSetBaseType.n.sons[1].info := fakeInfo; intSetBaseType.n.sons[0].typ := gSysTypes[tyInt]; - intSetBaseType.n.sons[1].typ := gSysTypes[tyInt]; + intSetBaseType.n.sons[1].typ := gSysTypes[tyInt]; *) end; procedure FinishSystem(const tab: TStrTable); -begin +begin (* notSym := findMagic(tab, mNot, 'not'); if (notSym = nil) then rawMessage(errSystemNeeds, 'not'); countUpSym := StrTableGet(tab, getIdent('countup')); if (countUpSym = nil) then - rawMessage(errSystemNeeds, 'countup'); + rawMessage(errSystemNeeds, 'countup'); *) end; +initialization + initStrTable(compilerprocs); end. diff --git a/nim/main.pas b/nim/main.pas index 6e0afda98..7cf3fbd0a 100644 --- a/nim/main.pas +++ b/nim/main.pas @@ -15,10 +15,11 @@ unit main; interface uses - nsystem, strutils, ast, astalgo, scanner, pnimsyn, rnimsyn, options, msgs, - nos, lists, condsyms, paslex, pasparse, rodgen, ropes, trees, - wordrecg, sem, idents, magicsys, backends, docgen, extccomp, cgen, - platform, ecmasgen; + nsystem, llstream, strutils, ast, astalgo, scanner, pnimsyn, rnimsyn, + options, msgs, nos, lists, condsyms, paslex, pasparse, rodread, rodwrite, + ropes, trees, wordrecg, sem, semdata, idents, passes, docgen, + extccomp, cgen, ecmasgen, platform, ptmplsyn, interact, nimconf, importer, + passaux, depends, transf, evals, types; procedure MainCommand(const cmd, filename: string); @@ -33,7 +34,7 @@ type end; TFileModuleMap = array of TFileModuleRec; var - compMods: TFileModuleMap = {@ignore} nil {@emit []}; + compMods: TFileModuleMap = {@ignore} nil {@emit @[]}; // all compiled modules procedure registerModule(const filename: string; module: PSym); @@ -58,28 +59,17 @@ end; // ---------------------------------------------------------------------------- -function getFileTrunk(const filename: string): string; -var - f, e, dir: string; -begin - splitPath(filename, dir, f); - splitFilename(f, result, e); -end; - -function newIsMainModuleSym(module: PSym; isMainModule: bool): PSym; -begin - result := newSym(skConst, getIdent('isMainModule'), module); - result.info := module.info; - result.typ := getSysType(tyBool); - result.ast := newIntNode(nkIntLit, ord(isMainModule)); - result.ast.typ := result.typ; - StrTableAdd(module.tab, result); - if isMainModule then include(module.flags, sfMainModule); -end; - function newModule(const filename: string): PSym; begin - result := newSym(skModule, getIdent(getFileTrunk(filename)), nil); + // We cannot call ``newSym`` here, because we have to circumvent the ID + // mechanism, which we do in order to assign each module a persistent ID. + new(result); +{@ignore} + fillChar(result^, sizeof(result^), 0); +{@emit} + result.id := -1; // for better error checking + result.kind := skModule; + result.name := getIdent(getFileTrunk(filename)); result.owner := result; // a module belongs to itself result.info := newLineInfo(filename, 1, 1); include(result.flags, sfUsed); @@ -89,173 +79,83 @@ begin StrTableAdd(result.tab, result); // a module knows itself end; -procedure msgCompiling(const modname: string); -begin - if optVerbose in gGlobalOptions then MessageOut('compiling: ' + modname); -end; - -procedure msgCompiled(const modname: string); -begin - if optVerbose in gGlobalOptions then MessageOut('compiled: ' + modname); -end; - -function CompileModule(const filename: string; backend: PBackend; +function CompileModule(const filename: string; isMainFile, isSystemFile: bool): PSym; forward; -function importModule(const filename: string; backend: PBackend): PSym; +function importModule(const filename: string): PSym; // this is called by the semantic checking phase begin result := getModule(filename); if result = nil then begin // compile the module - // XXX: here caching could be implemented - result := compileModule(filename, backend, false, false); + result := compileModule(filename, false, false); end else if sfSystemModule in result.flags then liMessage(result.info, errAttemptToRedefine, result.Name.s); end; -function CompileModule(const filename: string; backend: PBackend; +function CompileModule(const filename: string; isMainFile, isSystemFile: bool): PSym; var - ast: PNode; - c: PContext; + rd: PRodReader; + f: string; begin + rd := nil; + f := appendFileExt(filename, nimExt); result := newModule(filename); - result.info := newLineInfo(filename, 1, 1); - msgCompiling(result.name.s); - ast := parseFile(appendFileExt(filename, nimExt)); - if ast = nil then exit; - c := newContext(filename); - c.b := backend.backendCreator(backend, result, filename); - c.module := result; - c.includeFile := parseFile; - c.importModule := importModule; - openScope(c.tab); // scope for imported symbols - SymTabAdd(c.tab, result); - if not isSystemFile then begin - SymTabAdd(c.tab, magicsys.SystemModule); // import the "System" identifier - importAllSymbols(c, magicsys.SystemModule); - SymTabAdd(c.tab, newIsMainModuleSym(result, isMainFile)); + if isMainFile then include(result.flags, sfMainModule); + if isSystemFile then include(result.flags, sfSystemModule); + if (gCmd = cmdCompileToC) or (gCmd = cmdCompileToCpp) then begin + rd := handleSymbolFile(result, f); + if result.id < 0 then + InternalError('handleSymbolFile should have set the module''s ID'); end - else begin - include(result.flags, sfSystemModule); - magicsys.SystemModule := result; // set global variable! - InitSystem(c.tab); // adds magics like "int", "ord" to the system module - end; - {@discard} semModule(c, ast); - rawCloseScope(c.tab); // imported symbols; don't check for unused ones! - msgCompiled(result.name.s); + else + result.id := getID(); + processModule(result, f, nil, rd); end; -procedure CompileProject(const filename: string; backend: PBackend); +procedure CompileProject(const filename: string); begin {@discard} CompileModule( - JoinPath(options.libpath, appendFileExt('system', nimExt)), - backend, false, true); - {@discard} CompileModule(filename, backend, true, false); + JoinPath(options.libpath, appendFileExt('system', nimExt)), false, true); + {@discard} CompileModule(filename, true, false); end; -// ------------ dependency generator ---------------------------------------- - -var - gDotGraph: PRope; // the generated DOT file; we need a global variable - -procedure addDependencyAux(importing, imported: PSym); +procedure semanticPasses; begin - appf(gDotGraph, '$1 -> $2;$n', [toRope(importing.name.s), - toRope(imported.name.s)]); - // s1 -> s2_4 [label="[0-9]"]; -end; - -procedure addDotDependency(b: PBackend; n: PNode); -var - i: int; -begin - if n = nil then exit; - case n.kind of - nkEmpty..nkNilLit: begin end; // atom - nkImportStmt: begin - for i := 0 to sonsLen(n)-1 do begin - assert(n.sons[i].kind = nkSym); - addDependencyAux(b.module, n.sons[i].sym); - end - end; - nkFromStmt: begin - assert(n.sons[0].kind = nkSym); - addDependencyAux(b.module, n.sons[0].sym); - end; - nkStmtList, nkBlockStmt, nkStmtListExpr, nkBlockExpr: begin - for i := 0 to sonsLen(n)-1 do addDotDependency(b, n.sons[i]); - end - else begin end - end -end; - -procedure generateDot(const project: string); -begin - writeRope( - ropef('digraph $1 {$n$2}$n', [ - toRope(changeFileExt(extractFileName(project), '')), gDotGraph]), - changeFileExt(project, 'dot') ); -end; - -function genDependCreator(b: PBackend; module: PSym; - const filename: string): PBackend; -begin - result := newBackend(module, filename); - include(result.eventMask, eAfterModule); - result.afterModuleEvent := addDotDependency; - result.backendCreator := genDependCreator; + registerPass(verbosePass()); + registerPass(sem.semPass()); + registerPass(transf.transfPass()); + registerPass(rodwrite.rodwritePass()); end; procedure CommandGenDepend(const filename: string); -var - b: PBackend; begin - b := genDependCreator(nil, nil, filename); - compileProject(filename, b); + semanticPasses(); + registerPass(genDependPass()); + registerPass(cleanupPass()); + compileProject(filename); generateDot(filename); execExternalProgram('dot -Tpng -o' +{&} changeFileExt(filename, 'png') +{&} ' ' +{&} changeFileExt(filename, 'dot')); end; -// -------------------------------------------------------------------------- - -procedure genDebugTrans(b: PBackend; module: PNode); -begin - if module <> nil then - renderModule(module, getOutFile(b.filename, 'pretty.'+NimExt)); -end; - -function genDebugTransCreator(b: PBackend; module: PSym; - const filename: string): PBackend; -begin - result := newBackend(module, filename); - include(result.eventMask, eAfterModule); - result.backendCreator := genDebugTransCreator; - result.afterModuleEvent := genDebugTrans; -end; - -procedure CommandDebugTrans(const filename: string); -var - b: PBackend; -begin - b := genDebugTransCreator(nil, nil, filename); - compileProject(filename, b); -end; - -// -------------------------------------------------------------------------- - procedure CommandCheck(const filename: string); begin + semanticPasses(); // use an empty backend for semantic checking only - compileProject(filename, newBackend(nil, filename)); + compileProject(filename); end; procedure CommandCompileToC(const filename: string); begin - compileProject(filename, CBackend(nil, nil, filename)); + semanticPasses(); + registerPass(cgen.cgenPass()); + registerPass(cleanupPass()); + compileProject(filename); + //for i := low(TTypeKind) to high(TTypeKind) do + // MessageOut('kind: ' +{&} typeKindToStr[i] +{&} ' = ' +{&} toString(sameTypeA[i])); extccomp.CallCCompiler(changeFileExt(filename, '')); end; @@ -264,7 +164,33 @@ begin include(gGlobalOptions, optSafeCode); setTarget(osEcmaScript, cpuEcmaScript); initDefines(); - compileProject(filename, EcmasBackend(nil, nil, filename)); + + semanticPasses(); + registerPass(ecmasgenPass()); + compileProject(filename); +end; + +procedure CommandInteractive(); +var + m: PSym; +begin + include(gGlobalOptions, optSafeCode); + setTarget(osNimrodVM, cpuNimrodVM); + initDefines(); + + registerPass(verbosePass()); + registerPass(sem.semPass()); + registerPass(transf.transfPass()); + registerPass(evals.evalPass()); + + // load system module: + {@discard} CompileModule( + JoinPath(options.libpath, appendFileExt('system', nimExt)), false, true); + + m := newModule('stdin'); + m.id := getID(); + include(m.flags, sfMainModule); + processModule(m, 'stdin', LLStreamOpenStdIn(), nil); end; // -------------------------------------------------------------------------- @@ -322,12 +248,17 @@ procedure CommandLexPas(const filename: string); var L: TPasLex; tok: TPasTok; + f: string; + stream: PLLStream; begin {@ignore} fillChar(tok, sizeof(tok), 0); fillChar(L, sizeof(L), 0); {@emit} - if OpenLexer(L, appendFileExt(filename, 'pas')) = success then begin + f := appendFileExt(filename, 'pas'); + stream := LLStreamOpen(f, fmRead); + if stream <> nil then begin + OpenLexer(L, f, stream); getPasTok(L, tok); while tok.xkind <> pxEof do begin printPasTok(tok); @@ -335,7 +266,7 @@ begin end end else - rawMessage(errCannotOpenFile, appendFileExt(filename, 'pas')); + rawMessage(errCannotOpenFile, f); closeLexer(L); end; @@ -343,47 +274,44 @@ procedure CommandPas(const filename: string); var p: TPasParser; module: PNode; + f: string; + stream: PLLStream; begin - if OpenPasParser(p, appendFileExt(filename, 'pas')) = failure then begin - rawMessage(errCannotOpenFile, appendFileExt(filename, 'pas')); - exit - end; - module := parseUnit(p); - closePasParser(p); - renderModule(module, getOutFile(filename, NimExt)); -end; - -procedure CommandTestRod(const filename: string); -var - module, rod: PNode; -begin - module := parseFile(appendFileExt(filename, nimExt)); - if module <> nil then begin - generateRod(module, changeFileExt(filename, rodExt)); - rod := readRod(changeFileExt(filename, rodExt), {@set}[]); - assert(rod <> nil); - assert(sameTree(module, rod)); + f := appendFileExt(filename, 'pas'); + stream := LLStreamOpen(f, fmRead); + if stream <> nil then begin + OpenPasParser(p, f, stream); + module := parseUnit(p); + closePasParser(p); + renderModule(module, getOutFile(filename, NimExt)); end + else + rawMessage(errCannotOpenFile, f); end; procedure CommandScan(const filename: string); var L: TLexer; tok: PToken; + f: string; + stream: PLLStream; begin new(tok); {@ignore} fillChar(tok^, sizeof(tok^), 0); {@emit} - if openLexer(L, appendFileExt(filename, nimExt)) = Success then begin + f := appendFileExt(filename, nimExt); + stream := LLStreamOpen(f, fmRead); + if stream <> nil then begin + openLexer(L, f, stream); repeat rawGetTok(L, tok^); - PrintTok(tok) + PrintTok(tok); until tok.tokType = tkEof; - CloseLexer(L) + CloseLexer(L); end else - rawMessage(errCannotOpenFile, appendFileExt(filename, nimExt)); + rawMessage(errCannotOpenFile, f); end; procedure WantFile(const filename: string); @@ -396,16 +324,19 @@ procedure MainCommand(const cmd, filename: string); var dir, f: string; begin + appendStr(searchPaths, options.libpath); if filename <> '' then begin - appendStr(searchPaths, options.libpath); - splitPath(filename, dir, f); // current path is always looked first for modules prependStr(searchPaths, dir); end; + setID(100); + passes.gIncludeFile := parseFile; + passes.gIncludeTmplFile := ptmplsyn.parseTmplFile; + passes.gImportModule := importModule; case whichKeyword(cmd) of - wCompile, wCompileToC: begin + wCompile, wCompileToC, wC, wCC: begin // compile means compileToC currently gCmd := cmdCompileToC; wantFile(filename); @@ -422,7 +353,6 @@ begin CommandCompileToEcmaScript(filename); end; wPretty: begin - // compile means compileToC currently gCmd := cmdPretty; wantFile(filename); //CommandExportSymbols(filename); @@ -430,9 +360,16 @@ begin end; wDoc: begin gCmd := cmdDoc; + LoadSpecialConfig(DocConfig); wantFile(filename); CommandDoc(filename); end; + wRst2html: begin + gCmd := cmdRst2html; + LoadSpecialConfig(DocConfig); + wantFile(filename); + CommandRst2Html(filename); + end; wPas: begin gCmd := cmdPas; wantFile(filename); @@ -468,16 +405,10 @@ begin CommandScan(filename); MessageOut('Beware: Indentation tokens depend on the parser''s state!'); end; - wDebugTrans: begin - gCmd := cmdDebugTrans; - wantFile(filename); - CommandDebugTrans(filename); + wI: begin + gCmd := cmdInteractive; + CommandInteractive(); end; - wRst2html: begin - gCmd := cmdRst2html; - wantFile(filename); - CommandRst2Html(filename); - end else rawMessage(errInvalidCommandX, cmd); end end; diff --git a/nim/msgs.pas b/nim/msgs.pas index 8112b8df7..d65a5a1e4 100644 --- a/nim/msgs.pas +++ b/nim/msgs.pas @@ -1,53 +1,54 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2008 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit msgs; - -interface - -{$include 'config.inc'} - -uses - nsystem, options, strutils, nos; - -//[[[cog -//enum = "type\n TMsgKind = (\n" -//msgs = "const\n MsgKindToStr: array [TMsgKind] of string = (\n" -//warns = "const\n WarningsToStr: array [0..%d] of string = (\n" -//hints = "const\n HintsToStr: array [0..%d] of string = (\n" -//w = 0 # counts the warnings -//h = 0 # counts the hints -// -//for elem in eval(file('data/messages.yml').read()): -// for key, val in elem.iteritems(): -// enum += ' %s,\n' % key -// v = val.replace("'", "''") -// if key.startswith('warn'): -// msgs += " '%s [%s]',\n" % (v, key[4:]) -// warns += " '%s',\n" % key[4:] -// w += 1 -// elif key.startswith('hint'): -// msgs += " '%s [%s]',\n" % (v, key[4:]) -// hints += " '%s',\n" % key[4:] -// h += 1 -// else: -// msgs += " '%s',\n" % v -// -//enum = enum[:-2] + ');\n\n' -//msgs = msgs[:-2] + '\n );\n' -//warns = (warns[:-2] + '\n );\n') % (w-1) -//hints = (hints[:-2] + '\n );\n') % (h-1) -// -//cog.out(enum) -//cog.out(msgs) -//cog.out(warns) -//cog.out(hints) -//]]] +// +// +// The Nimrod Compiler +// (c) Copyright 2008 Andreas Rumpf +// +// See the file "copying.txt", included in this +// distribution, for details about the copyright. +// +unit msgs; + +interface + +{$include 'config.inc'} + +uses + nsystem, options, strutils, nos; + +//[[[cog +//from string import replace +//enum = "type\n TMsgKind = (\n" +//msgs = "const\n MsgKindToStr: array [TMsgKind] of string = (\n" +//warns = "const\n WarningsToStr: array [0..%d] of string = (\n" +//hints = "const\n HintsToStr: array [0..%d] of string = (\n" +//w = 0 # counts the warnings +//h = 0 # counts the hints +// +//for elem in eval(open('data/messages.yml').read()): +// for key, val in elem.items(): +// enum = enum + ' %s,\n' % key +// v = replace(val, "'", "''") +// if key[0:4] == 'warn': +// msgs = msgs + " '%s [%s]',\n" % (v, key[4:]) +// warns = warns + " '%s',\n" % key[4:] +// w = w + 1 +// elif key[0:4] == 'hint': +// msgs = msgs + " '%s [%s]',\n" % (v, key[4:]) +// hints = hints + " '%s',\n" % key[4:] +// h = h + 1 +// else: +// msgs = msgs + " '%s',\n" % v +// +//enum = enum[:-2] + ');\n\n' +//msgs = msgs[:-2] + '\n );\n' +//warns = (warns[:-2] + '\n );\n') % (w-1) +//hints = (hints[:-2] + '\n );\n') % (h-1) +// +//cog.out(enum) +//cog.out(msgs) +//cog.out(warns) +//cog.out(hints) +//]]] type TMsgKind = ( errUnknown, @@ -293,16 +294,17 @@ type warnCommentXIgnored, warnUser, hintSuccess, + hintSuccessX, hintLineTooLong, hintXDeclaredButNotUsed, hintConvToBaseNotNeeded, hintConvFromXtoItselfNotNeeded, hintExprAlwaysX, - hintMo2FileInvalid, - hintModuleHasChanged, - hintCannotOpenMo2File, hintQuitCalled, hintProcessing, + hintCodeBegin, + hintCodeEnd, + hintConf, hintUser); const @@ -439,7 +441,7 @@ const 'computing the type''s size produced an overflow', 'set is too large', 'base type of a set must be an ordinal', - 'inheritance only works non-final objects', + 'inheritance only works with non-final objects', 'inheritance only works with an enum', 'illegal recursion in type ''$1''', 'cannot instantiate: ''$1''', @@ -550,16 +552,17 @@ const 'comment ''$1'' ignored [CommentXIgnored]', '$1 [User]', 'operation successful [Success]', + 'operation successful ($1 lines compiled; $2 sec total) [SuccessX]', 'line too long [LineTooLong]', '''$1'' is declared but not used [XDeclaredButNotUsed]', 'conversion to base object is not needed [ConvToBaseNotNeeded]', 'conversion from $1 to itself is pointless [ConvFromXtoItselfNotNeeded]', 'expression evaluates always to ''$1'' [ExprAlwaysX]', - 'mo2 file ''$1'' is invalid [Mo2FileInvalid]', - 'module ''$1'' has been changed [ModuleHasChanged]', - 'mo2 file ''$1'' does not exist [CannotOpenMo2File]', 'quit() called [QuitCalled]', - 'processing [Processing]', + 'processing $1 [Processing]', + 'generated code listing: [CodeBegin]', + 'end of listing [CodeEnd]', + 'used config file ''$1'' [Conf]', '$1 [User]' ); const @@ -580,261 +583,265 @@ const 'User' ); const - HintsToStr: array [0..11] of string = ( + HintsToStr: array [0..12] of string = ( 'Success', + 'SuccessX', 'LineTooLong', 'XDeclaredButNotUsed', 'ConvToBaseNotNeeded', 'ConvFromXtoItselfNotNeeded', 'ExprAlwaysX', - 'Mo2FileInvalid', - 'ModuleHasChanged', - 'CannotOpenMo2File', 'QuitCalled', 'Processing', + 'CodeBegin', + 'CodeEnd', + 'Conf', 'User' ); -//[[[end]]] - -const - fatalMin = errUnknown; - fatalMax = errInternal; - errMin = errUnknown; - errMax = errUser; - warnMin = warnCannotOpenFile; - warnMax = pred(hintSuccess); - hintMin = hintSuccess; - hintMax = high(TMsgKind); - -type - TNoteKind = warnMin..hintMax; - // "notes" are warnings or hints - TNoteKinds = set of TNoteKind; - - TLineInfo = record - // This is designed to be as small as possible, because it is used - // in syntax nodes. We safe space here by using two int16 and an int32 - // on 64 bit and on 32 bit systems this is only 8 bytes. - line, col: int16; - fileIndex: int32; - end; - -function UnknownLineInfo(): TLineInfo; - -var - gNotes: TNoteKinds = [low(TNoteKind)..high(TNoteKind)]; - gErrorCounter: int = 0; // counts the number of errors - gHintCounter: int = 0; - gWarnCounter: int = 0; - gErrorMax: int = 1; // stop after gErrorMax errors - -const // this format is understood by many text editors: it is the same that - // Borland and Freepascal use - PosErrorFormat = '$1($2, $3) Error: $4'; - PosWarningFormat = '$1($2, $3) Warning: $4'; - PosHintFormat = '$1($2, $3) Hint: $4'; - - RawErrorFormat = 'Error: $1'; - RawWarningFormat = 'Warning: $1'; - RawHintFormat = 'Hint: $1'; - -procedure MessageOut(const s: string); - -procedure rawMessage(const msg: TMsgKind; const arg: string = ''); -procedure liMessage(const info: TLineInfo; const msg: TMsgKind; - const arg: string = ''); - -procedure InternalError(const info: TLineInfo; const errMsg: string); - overload; -procedure InternalError(const errMsg: string); overload; - -function newLineInfo(const filename: string; line, col: int): TLineInfo; - -function ToFilename(const info: TLineInfo): string; -function toColumn(const info: TLineInfo): int; -function ToLinenumber(const info: TLineInfo): int; - -function MsgKindToString(kind: TMsgKind): string; - -// checkpoints are used for debugging: -function checkpoint(const info: TLineInfo; const filename: string; - line: int): boolean; - -procedure addCheckpoint(const info: TLineInfo); overload; -procedure addCheckpoint(const filename: string; line: int); overload; -function inCheckpoint(const current: TLineInfo): boolean; -// prints the line information if in checkpoint - -procedure pushInfoContext(const info: TLineInfo); -procedure popInfoContext; - -implementation - -function UnknownLineInfo(): TLineInfo; -begin - result.line := -1; - result.col := -1; - result.fileIndex := -1; -end; - -{@ignore} -var - filenames: array of string; - msgContext: array of TLineInfo; -{@emit -var - filenames: array of string = []; - msgContext: array of TLineInfo = []; -} - -procedure pushInfoContext(const info: TLineInfo); -var - len: int; -begin - len := length(msgContext); - setLength(msgContext, len+1); - msgContext[len] := info; -end; - -procedure popInfoContext; -begin - setLength(msgContext, length(msgContext)-1); -end; - -function includeFilename(const f: string): int; -var - i: int; -begin - for i := high(filenames) downto low(filenames) do - if filenames[i] = f then begin - result := i; exit - end; - // not found, so add it: - result := length(filenames); - setLength(filenames, result+1); - filenames[result] := f; -end; - -function checkpoint(const info: TLineInfo; const filename: string; - line: int): boolean; -begin - result := (info.line = line) and ( - ChangeFileExt(extractFilename(filenames[info.fileIndex]), '') = filename); -end; - - -{@ignore} -var - checkPoints: array of TLineInfo; -{@emit -var - checkPoints: array of TLineInfo = []; -} - -procedure addCheckpoint(const info: TLineInfo); overload; -var - len: int; -begin - len := length(checkPoints); - setLength(checkPoints, len+1); - checkPoints[len] := info; -end; - -procedure addCheckpoint(const filename: string; line: int); overload; -begin - addCheckpoint(newLineInfo(filename, line, -1)); -end; - -function newLineInfo(const filename: string; line, col: int): TLineInfo; -begin - result.fileIndex := includeFilename(filename); - result.line := int16(line); - result.col := int16(col); -end; - -function ToFilename(const info: TLineInfo): string; -begin - if info.fileIndex = -1 then result := '???' - else result := filenames[info.fileIndex] -end; - -function ToLinenumber(const info: TLineInfo): int; -begin - result := info.line -end; - -function toColumn(const info: TLineInfo): int; -begin - result := info.col -end; - -procedure MessageOut(const s: string); -begin // change only this proc to put it elsewhere - Writeln(output, s); -end; - -function coordToStr(const coord: int): string; -begin - if coord = -1 then result := '???' - else result := toString(coord) -end; - -function MsgKindToString(kind: TMsgKind): string; -begin // later versions may provide translated error messages - result := msgKindToStr[kind]; -end; - -function getMessageStr(msg: TMsgKind; const arg: string): string; -begin - result := format(msgKindToString(msg), [arg]); -end; - -function inCheckpoint(const current: TLineInfo): boolean; -var - i: int; -begin - result := false; - if not (optCheckpoints in gOptions) then exit; // ignore all checkpoints - for i := 0 to high(checkPoints) do begin - if (current.line = int(checkPoints[i].line)) and - (current.fileIndex = int(checkPoints[i].fileIndex)) then begin - MessageOut(Format('$1($2, $3) Checkpoint: ', [toFilename(current), - coordToStr(current.line), - coordToStr(current.col)])); - result := true; - exit - end - end -end; - -procedure handleError(const msg: TMsgKind); -begin - if (msg >= fatalMin) and (msg <= fatalMax) then begin - if optVerbose in gGlobalOptions then assert(false); - halt(1) - end; - if (msg >= errMin) and (msg <= errMax) then begin - inc(gErrorCounter); - if gErrorCounter >= gErrorMax then begin - if optVerbose in gGlobalOptions then assert(false); - halt(1) // one error stops the compiler - end - end -end; - -procedure writeContext; -var - i: int; -begin - for i := 0 to length(msgContext)-1 do begin - MessageOut(Format(posErrorFormat, [toFilename(msgContext[i]), - coordToStr(msgContext[i].line), - coordToStr(msgContext[i].col), - getMessageStr(errInstantiationFrom, '')])); - end; -end; - -procedure rawMessage(const msg: TMsgKind; const arg: string = ''); +//[[[end]]] + +const + fatalMin = errUnknown; + fatalMax = errInternal; + errMin = errUnknown; + errMax = errUser; + warnMin = warnCannotOpenFile; + warnMax = pred(hintSuccess); + hintMin = hintSuccess; + hintMax = high(TMsgKind); + +type + TNoteKind = warnMin..hintMax; + // "notes" are warnings or hints + TNoteKinds = set of TNoteKind; + + TLineInfo = record + // This is designed to be as small as possible, because it is used + // in syntax nodes. We safe space here by using two int16 and an int32 + // on 64 bit and on 32 bit systems this is only 8 bytes. + line, col: int16; + fileIndex: int32; + end; + +function UnknownLineInfo(): TLineInfo; + +var + gNotes: TNoteKinds = [low(TNoteKind)..high(TNoteKind)]; + gErrorCounter: int = 0; // counts the number of errors + gHintCounter: int = 0; + gWarnCounter: int = 0; + gErrorMax: int = 1; // stop after gErrorMax errors + +const // this format is understood by many text editors: it is the same that + // Borland and Freepascal use + PosErrorFormat = '$1($2, $3) Error: $4'; + PosWarningFormat = '$1($2, $3) Warning: $4'; + PosHintFormat = '$1($2, $3) Hint: $4'; + + RawErrorFormat = 'Error: $1'; + RawWarningFormat = 'Warning: $1'; + RawHintFormat = 'Hint: $1'; + +procedure MessageOut(const s: string); + +procedure rawMessage(const msg: TMsgKind; const arg: string = ''); overload; +procedure rawMessage(const msg: TMsgKind; const args: array of string); overload; + +procedure liMessage(const info: TLineInfo; const msg: TMsgKind; + const arg: string = ''); + +procedure InternalError(const info: TLineInfo; const errMsg: string); + overload; +procedure InternalError(const errMsg: string); overload; + +function newLineInfo(const filename: string; line, col: int): TLineInfo; + +function ToFilename(const info: TLineInfo): string; +function toColumn(const info: TLineInfo): int; +function ToLinenumber(const info: TLineInfo): int; + +function MsgKindToString(kind: TMsgKind): string; + +// checkpoints are used for debugging: +function checkpoint(const info: TLineInfo; const filename: string; + line: int): boolean; + +procedure addCheckpoint(const info: TLineInfo); overload; +procedure addCheckpoint(const filename: string; line: int); overload; +function inCheckpoint(const current: TLineInfo): boolean; +// prints the line information if in checkpoint + +procedure pushInfoContext(const info: TLineInfo); +procedure popInfoContext; + +implementation + +function UnknownLineInfo(): TLineInfo; +begin + result.line := int16(-1); + result.col := int16(-1); + result.fileIndex := -1; +end; + +{@ignore} +var + filenames: array of string; + msgContext: array of TLineInfo; +{@emit +var + filenames: array of string = @[]; + msgContext: array of TLineInfo = @[]; +} + +procedure pushInfoContext(const info: TLineInfo); +var + len: int; +begin + len := length(msgContext); + setLength(msgContext, len+1); + msgContext[len] := info; +end; + +procedure popInfoContext; +begin + setLength(msgContext, length(msgContext)-1); +end; + +function includeFilename(const f: string): int; +var + i: int; +begin + for i := high(filenames) downto low(filenames) do + if filenames[i] = f then begin + result := i; exit + end; + // not found, so add it: + result := length(filenames); + setLength(filenames, result+1); + filenames[result] := f; +end; + +function checkpoint(const info: TLineInfo; const filename: string; + line: int): boolean; +begin + result := (int(info.line) = line) and ( + ChangeFileExt(extractFilename(filenames[info.fileIndex]), '') = filename); +end; + + +{@ignore} +var + checkPoints: array of TLineInfo; +{@emit +var + checkPoints: array of TLineInfo = @[]; +} + +procedure addCheckpoint(const info: TLineInfo); overload; +var + len: int; +begin + len := length(checkPoints); + setLength(checkPoints, len+1); + checkPoints[len] := info; +end; + +procedure addCheckpoint(const filename: string; line: int); overload; +begin + addCheckpoint(newLineInfo(filename, line, -1)); +end; + +function newLineInfo(const filename: string; line, col: int): TLineInfo; +begin + result.fileIndex := includeFilename(filename); + result.line := int16(line); + result.col := int16(col); +end; + +function ToFilename(const info: TLineInfo): string; +begin + if info.fileIndex = -1 then result := '???' + else result := filenames[info.fileIndex] +end; + +function ToLinenumber(const info: TLineInfo): int; +begin + result := info.line +end; + +function toColumn(const info: TLineInfo): int; +begin + result := info.col +end; + +procedure MessageOut(const s: string); +begin // change only this proc to put it elsewhere + Writeln(output, s); +end; + +function coordToStr(const coord: int): string; +begin + if coord = -1 then result := '???' + else result := toString(coord) +end; + +function MsgKindToString(kind: TMsgKind): string; +begin // later versions may provide translated error messages + result := msgKindToStr[kind]; +end; + +function getMessageStr(msg: TMsgKind; const arg: string): string; +begin + result := format(msgKindToString(msg), [arg]); +end; + +function inCheckpoint(const current: TLineInfo): boolean; +var + i: int; +begin + result := false; + if not (optCheckpoints in gOptions) then exit; // ignore all checkpoints + for i := 0 to high(checkPoints) do begin + if (current.line = checkPoints[i].line) and + (current.fileIndex = (checkPoints[i].fileIndex)) then begin + MessageOut(Format('$1($2, $3) Checkpoint: ', [toFilename(current), + coordToStr(current.line), + coordToStr(current.col)])); + result := true; + exit + end + end +end; + +procedure handleError(const msg: TMsgKind); +begin + if msg = errInternal then assert(false); // we want a stack trace here + if (msg >= fatalMin) and (msg <= fatalMax) then begin + if gVerbosity >= 3 then assert(false); + halt(1) + end; + if (msg >= errMin) and (msg <= errMax) then begin + inc(gErrorCounter); + if gErrorCounter >= gErrorMax then begin + if gVerbosity >= 3 then assert(false); + halt(1) // one error stops the compiler + end + end +end; + +procedure writeContext; +var + i: int; +begin + for i := 0 to length(msgContext)-1 do begin + MessageOut(Format(posErrorFormat, [toFilename(msgContext[i]), + coordToStr(msgContext[i].line), + coordToStr(msgContext[i].col), + getMessageStr(errInstantiationFrom, '')])); + end; +end; + +procedure rawMessage(const msg: TMsgKind; const args: array of string); var frmt: string; begin @@ -857,51 +864,56 @@ begin end; else assert(false) // cannot happen end; - MessageOut(Format(frmt, [getMessageStr(msg, arg)])); - handleError(msg); -end; - -procedure liMessage(const info: TLineInfo; const msg: TMsgKind; - const arg: string = ''); -var - frmt: string; -begin - case msg of - errMin..errMax: begin - writeContext(); - frmt := posErrorFormat; - end; - warnMin..warnMax: begin - if not (optWarns in gOptions) then exit; - if not (msg in gNotes) then exit; - frmt := posWarningFormat; - inc(gWarnCounter); - end; - hintMin..hintMax: begin - if not (optHints in gOptions) then exit; - if not (msg in gNotes) then exit; - frmt := posHintFormat; - inc(gHintCounter); - end; - else assert(false) // cannot happen - end; - MessageOut(Format(frmt, [toFilename(info), - coordToStr(info.line), - coordToStr(info.col), - getMessageStr(msg, arg)])); + MessageOut(Format(frmt, format(msgKindToString(msg), args))); handleError(msg); end; - -procedure InternalError(const info: TLineInfo; const errMsg: string); + +procedure rawMessage(const msg: TMsgKind; const arg: string = ''); begin - writeContext(); - liMessage(info, errInternal, errMsg); -end; - -procedure InternalError(const errMsg: string); overload; -begin - writeContext(); - rawMessage(errInternal, errMsg); -end; - -end. + rawMessage(msg, [arg]); +end; + +procedure liMessage(const info: TLineInfo; const msg: TMsgKind; + const arg: string = ''); +var + frmt: string; +begin + case msg of + errMin..errMax: begin + writeContext(); + frmt := posErrorFormat; + end; + warnMin..warnMax: begin + if not (optWarns in gOptions) then exit; + if not (msg in gNotes) then exit; + frmt := posWarningFormat; + inc(gWarnCounter); + end; + hintMin..hintMax: begin + if not (optHints in gOptions) then exit; + if not (msg in gNotes) then exit; + frmt := posHintFormat; + inc(gHintCounter); + end; + else assert(false) // cannot happen + end; + MessageOut(Format(frmt, [toFilename(info), + coordToStr(info.line), + coordToStr(info.col), + getMessageStr(msg, arg)])); + handleError(msg); +end; + +procedure InternalError(const info: TLineInfo; const errMsg: string); +begin + writeContext(); + liMessage(info, errInternal, errMsg); +end; + +procedure InternalError(const errMsg: string); overload; +begin + writeContext(); + rawMessage(errInternal, errMsg); +end; + +end. diff --git a/nim/nimconf.pas b/nim/nimconf.pas index 5a4a13702..1a70abdbe 100644 --- a/nim/nimconf.pas +++ b/nim/nimconf.pas @@ -17,11 +17,13 @@ unit nimconf; interface uses - nsystem, nversion, commands, nos, strutils, msgs, platform, condsyms, - scanner, options, idents, wordrecg; + nsystem, llstream, nversion, commands, nos, strutils, msgs, platform, + condsyms, scanner, options, idents, wordrecg; procedure LoadConfig(const project: string); +procedure LoadSpecialConfig(const configfilename: string); + implementation @@ -96,7 +98,7 @@ var condStack: array of bool; {@emit - condStack := []; + condStack := @[]; } procedure doEnd(var L: TLexer; tok: PToken); @@ -276,14 +278,13 @@ begin checkSymbol(L, tok); val := val +{&} tokToStr(tok); confTok(L, tok); // skip symbol - while tok.ident.id = getIdent('&'+'').id do begin + while (tok.ident <> nil) and (tok.ident.id = getIdent('&'+'').id) do begin confTok(L, tok); checkSymbol(L, tok); val := val +{&} tokToStr(tok); confTok(L, tok) end end; - //writeln(stdout, "##" & s & "##" & val & "##") processSwitch(s, val, passPP, info) end; @@ -291,25 +292,49 @@ procedure readConfigFile(const filename: string); var L: TLexer; tok: PToken; + stream: PLLStream; begin new(tok); {@ignore} fillChar(tok^, sizeof(tok^), 0); fillChar(L, sizeof(L), 0); {@emit} - if openLexer(L, filename) = Success then begin + stream := LLStreamOpen(filename, fmRead); + if stream <> nil then begin + openLexer(L, filename, stream); tok.tokType := tkEof; // to avoid a pointless warning confTok(L, tok); // read in the first token while tok.tokType <> tkEof do parseAssignment(L, tok); if length(condStack) > 0 then lexMessage(L, errTokenExpected, '@end'); - closeLexer(L) + closeLexer(L); + if gVerbosity >= 1 then rawMessage(hintConf, filename); end end; // ------------------------------------------------------------------------ +function getConfigPath(const filename: string): string; +begin + // try local configuration file: + result := joinPath(getConfigDir(), filename); + if not ExistsFile(result) then begin + // try standard configuration file (installation did not distribute files + // the UNIX way) + result := joinPath([getPrefixDir(), 'config', filename]); + if not ExistsFile(result) then begin + result := '/etc/' +{&} filename + end + end +end; + +procedure LoadSpecialConfig(const configfilename: string); +begin + if not (optSkipConfigFile in gGlobalOptions) then + readConfigFile(getConfigPath(configfilename)); +end; + procedure LoadConfig(const project: string); var conffile: string; @@ -319,12 +344,9 @@ begin // choose default libpath: libpath := joinPath(getPrefixDir(), 'lib'); // read default config file: - if not (optSkipConfigFile in gGlobalOptions) then begin - readConfigFile(joinPath([getPrefixDir(), 'config', 'nimrod.cfg'])); - readConfigFile(joinPath([getPrefixDir(), 'config', 'doctempl.cfg'])); - end; + LoadSpecialConfig('nimrod.cfg'); // read project config file: - if not (optSkipProjConfigFile in gGlobalOptions) then begin + if not (optSkipProjConfigFile in gGlobalOptions) and (project <> '') then begin conffile := changeFileExt(project, 'cfg'); if existsFile(conffile) then readConfigFile(conffile) diff --git a/nim/nimrod.pas b/nim/nimrod.pas index 5d3785af4..d197a3448 100644 --- a/nim/nimrod.pas +++ b/nim/nimrod.pas @@ -16,7 +16,7 @@ program nimrod; {@emit} uses - nsystem, + nsystem, ntime, charsets, sysutils, commands, scanner, condsyms, options, msgs, nversion, nimconf, ropes, extccomp, strutils, nos, platform, main, parseopt; @@ -54,10 +54,17 @@ begin end end; +{@ignore} +type + TTime = int; +{@emit} + procedure HandleCmdLine; var command, filename: string; + start: TTime; begin + {@emit start := getTime(); } if paramCount() = 0 then writeCommandLineUsage() else begin @@ -65,19 +72,26 @@ begin command := ''; filename := ''; ProcessCmdLine(passCmd1, command, filename); - if filename <> '' then begin - if gCmd = cmdInterpret then DefineSymbol('interpreting'); - nimconf.LoadConfig(filename); // load the right config file - // now process command line arguments again, because some options in the - // command line can overwite the config file's settings - extccomp.initVars(); - command := ''; - filename := ''; - ProcessCmdLine(passCmd2, command, filename); - end; + if filename <> '' then options.projectPath := extractDir(filename); + nimconf.LoadConfig(filename); // load the right config file + // now process command line arguments again, because some options in the + // command line can overwite the config file's settings + extccomp.initVars(); + + command := ''; + filename := ''; + ProcessCmdLine(passCmd2, command, filename); MainCommand(command, filename); - if (gCmd <> cmdInterpret) and (msgs.gErrorCounter = 0) then + {@emit + if gVerbosity >= 2 then echo(GC_getStatistics()); } + if (gCmd <> cmdInterpret) and (msgs.gErrorCounter = 0) then begin + {@ignore} rawMessage(hintSuccess); + {@emit + rawMessage(hintSuccessX, [toString(gLinesCompiled), + toString(getTime() - start)]); + } + end; if optRun in gGlobalOptions then execExternalProgram(changeFileExt(filename, '') +{&} ' ' +{&} arguments) end diff --git a/nim/nimsets.pas b/nim/nimsets.pas index 04ec943e7..7fa3dbc12 100644 --- a/nim/nimsets.pas +++ b/nim/nimsets.pas @@ -142,7 +142,7 @@ var begin elemType := settype.sons[0]; first := firstOrd(elemType); - result := newNode(nkCurly); + result := newNodeI(nkCurly, info); result.typ := settype; result.info := info; @@ -157,7 +157,7 @@ begin if a = b then // a single element: addSon(result, newIntTypeNode(nkIntLit, a + first, elemType)) else begin - n := newNode(nkRange); + n := newNodeI(nkRange, info); n.typ := elemType; addSon(n, newIntTypeNode(nkIntLit, a + first, elemType)); addSon(n, newIntTypeNode(nkIntLit, b + first, elemType)); diff --git a/nim/nos.pas b/nim/nos.pas index b4c77681b..002803b53 100644 --- a/nim/nos.pas +++ b/nim/nos.pas @@ -10,8 +10,6 @@ unit nos; // This module provides Nimrod's os module in Pascal // Note: Only implement what is really needed here! -// This is not portable! It only works on Windows and Linux! But -// it does not matter since this is only needed for bootstraping. interface @@ -45,7 +43,7 @@ const sep = dirsep; // alternative name extsep = '.'; -function executeProcess(const cmd: string): int; +function executeShellCommand(const cmd: string): int; // like exec, but gets a command function FileNewer(const a, b: string): Boolean; @@ -67,6 +65,9 @@ function extractFilename(const f: string): string; function getApplicationDir(): string; function getApplicationFilename(): string; +function getCurrentDir: string; +function GetConfigDir(): string; + procedure SplitFilename(const filename: string; out name, extension: string); @@ -74,7 +75,7 @@ function ExistsFile(const filename: string): Boolean; function AppendFileExt(const filename, ext: string): string; function ChangeFileExt(const filename, ext: string): string; -procedure createDir(dir: string); +procedure createDir(const dir: string); function expandFilename(filename: string): string; function UnixToNativePath(const path: string): string; @@ -83,6 +84,20 @@ function sameFile(const path1, path2: string): boolean; implementation +function GetConfigDir(): string; +begin +{$ifdef windows} + result := getEnv('APPDATA') + '\'; +{$else} + result := getEnv('HOME') + '/.config/'; +{$endif} +end; + +function getCurrentDir: string; +begin + result := sysutils.GetCurrentDir(); +end; + function UnixToNativePath(const path: string): string; begin if dirSep <> '/' then @@ -102,9 +117,14 @@ begin expandFilename(UnixToNativePath(path2))) = 0; end; -procedure createDir(dir: string); +procedure createDir(const dir: string); +var + i: int; begin - sysutils.CreateDir(Dir); + for i := 1 to length(dir) do begin + if dir[i] in [sep, altsep] then sysutils.createDir(ncopy(dir, 1, i-1)); + end; + sysutils.createDir(dir); end; function searchExtPos(const s: string): int; @@ -157,7 +177,7 @@ begin extPos := searchExtPos(filename); if extPos > 0 then begin name := ncopy(filename, 1, extPos-1); - extension := ncopy(filename, extPos+1); + extension := ncopy(filename, extPos); end else begin name := filename; @@ -405,7 +425,7 @@ end; {$ifdef windows} -function ExecuteProcess(const cmd: string): int; +function executeShellCommand(const cmd: string): int; var SI: TStartupInfo; ProcInfo: TProcessInformation; @@ -437,14 +457,14 @@ end; {$else} {$ifdef windows} -function executeProcess(const cmd: string): int; +function executeShellCommand(const cmd: string): int; begin result := dos.Exec(cmd, '') end; //C:\Eigenes\compiler\MinGW\bin; {$else} // fpc has a portable function for this -function executeProcess(const cmd: string): int; +function executeShellCommand(const cmd: string): int; begin result := shell(cmd); end; diff --git a/nim/nsystem.pas b/nim/nsystem.pas index 9f3adfc7d..340477461 100644 --- a/nim/nsystem.pas +++ b/nim/nsystem.pas @@ -155,6 +155,7 @@ function leU(a, b: biggestInt): bool; function toU8(a: biggestInt): byte; function toU32(a: biggestInt): int32; function ze64(a: byte): biggestInt; +function ze(a: byte): int; {@emit} function alloc(size: int): Pointer; @@ -173,9 +174,15 @@ type function OpenFile(out f: tTextFile; const filename: string; mode: TFileMode = fmRead): Boolean; overload; +function endofFile(var f: tBinaryFile): boolean; overload; +function endofFile(var f: textFile): boolean; overload; + function readChar(var f: tTextFile): char; -function readLine(var f: tTextFile): string; -procedure nimWrite(var f: tTextFile; const str: string); +function readLine(var f: tTextFile): string; overload; +function readLine(var f: tBinaryFile): string; overload; +function readLine(var f: textFile): string; overload; + +procedure nimWrite(var f: tTextFile; const str: string); overload; procedure nimCloseFile(var f: tTextFile); overload; // binary file handling: @@ -197,6 +204,8 @@ procedure setFilePos(var f: tBinaryFile; pos: int64); function readFile(const filename: string): string; +procedure nimWrite(var f: tBinaryFile; const str: string); overload; + implementation @@ -279,6 +288,11 @@ function ze64(a: byte): biggestInt; begin result := a end; + +function ze(a: byte): int; +begin + result := a +end; {@emit} procedure addChar(var s: string; c: Char); @@ -400,7 +414,7 @@ end; function readChar(var f: tTextFile): char; begin - Readln(f.sysFile, result); + Read(f.sysFile, result); end; procedure nimWrite(var f: tTextFile; const str: string); @@ -413,6 +427,16 @@ begin Readln(f.sysFile, result); end; +function endofFile(var f: tBinaryFile): boolean; +begin + result := eof(f) +end; + +function endofFile(var f: textFile): boolean; +begin + result := eof(f) +end; + procedure nimCloseFile(var f: tTextFile); begin closeFile(f.sysFile); @@ -457,6 +481,35 @@ begin BlockRead(f, buffer^, len, result) end; +procedure nimWrite(var f: tBinaryFile; const str: string); overload; +begin + writeBuffer(f, addr(str[1]), length(str)); +end; + +function readLine(var f: tBinaryFile): string; overload; +var + c: char; +begin + result := ''; + while readBuffer(f, addr(c), 1) = 1 do begin + case c of + #13: begin + readBuffer(f, addr(c), 1); // skip #10 + break; + end; + #10: break; + else begin end + end; + addChar(result, c); + end +end; + +function readLine(var f: textFile): string; overload; +begin + result := ''; + readln(f, result); +end; + function readBuffer(var f: tBinaryFile): string; overload; const bufSize = 4096; diff --git a/nim/nversion.pas b/nim/nversion.pas index 4958353f8..51390a073 100644 --- a/nim/nversion.pas +++ b/nim/nversion.pas @@ -18,31 +18,22 @@ interface uses strutils; -// the Pascal version number gets a little star ('*'), the Nimrod version -// does not! This helps distinguishing the different builds. -{@ignore} -const - VersionStar = '*'+''; -{@emit -const - VersionStar = ''; -} - const MaxSetElements = 1 shl 16; // (2^16) to support unicode character sets? defaultAsmMarkerSymbol = '!'; //[[[cog //from koch import NIMROD_VERSION - //cog.outl("VersionAsString = '%s'+VersionStar;" % NIMROD_VERSION) - //ver = NIMROD_VERSION.split('.') + //from string import split + //cog.outl("VersionAsString = '%s';" % NIMROD_VERSION) + //ver = split(NIMROD_VERSION, '.') //cog.outl('VersionMajor = %s;' % ver[0]) //cog.outl('VersionMinor = %s;' % ver[1]) //cog.outl('VersionPatch = %s;' % ver[2]) //]]] - VersionAsString = '0.6.0'+VersionStar; + VersionAsString = '0.7.0'; VersionMajor = 0; - VersionMinor = 6; + VersionMinor = 7; VersionPatch = 0; //[[[[end]]]] diff --git a/nim/options.pas b/nim/options.pas index 93b56c330..9a9eaae36 100644 --- a/nim/options.pas +++ b/nim/options.pas @@ -18,7 +18,8 @@ uses type // please make sure we have under 32 options // (improves code efficiency a lot!) - TOption = (optNone, + TOption = ( // **keep binary compatible** + optNone, optObjCheck, optFieldCheck, optRangeCheck, optBoundsCheck, optOverflowCheck, optNilCheck, optAssert, optLineDir, @@ -29,28 +30,23 @@ type optLineTrace, // line tracing support (includes stack tracing) optEndb, // embedded debugger optByRef, // use pass by ref for records (for interfacing with C) - optCheckpoints // check for checkpoints (used for debugging) + optCheckpoints, // check for checkpoints (used for debugging) + optProfiler // profiler turned on ); TOptions = set of TOption; TGlobalOption = (gloptNone, optForceFullMake, optBoehmGC, optRefcGC, optDeadCodeElim, optListCmd, optCompileOnly, optNoLinking, optSafeCode, // only allow safe code - // a new comment line optCDebug, // turn on debugging information - optGenDynLib, - optGenGuiApp, - optVerbose, // be verbose + optGenDynLib, // generate a dynamic library + optGenGuiApp, // generate a GUI application optGenScript, // generate a script file to compile the *.c files optGenMapping, // generate a mapping file optRun, // run the compiled project - optCompileSys, // compile system files - - optMergeOutput, // generate only one C output file + optSymbolFiles, // use symbol files for speeding up compilation optSkipConfigFile, // skip the general config file - optSkipProjConfigFile, // skip the project's config file - optAstCache, - optCFileCache + optSkipProjConfigFile // skip the project's config file ); TGlobalOptions = set of TGlobalOption; @@ -70,7 +66,8 @@ type cmdParse, // parse a single file (for debugging) cmdScan, // scan a single file (for debugging) cmdDebugTrans, // debug a transformation pass - cmdRst2html // convert a reStructuredText file to HTML + cmdRst2html, // convert a reStructuredText file to HTML + cmdInteractive // start interactive session ); TStringSeq = array of string; @@ -83,12 +80,12 @@ const 'optBoundsCheck', 'optOverflowCheck', 'optNilCheck', 'optAssert', 'optLineDir', 'optWarns', 'optHints', 'optOptimizeSpeed', 'optOptimizeSize', 'optStackTrace', 'optLineTrace', 'optEmdb', - 'optByRef', 'optCheckpoints' + 'optByRef', 'optCheckpoints', 'optProfiler' ); var gOptions: TOptions = {@set}[optObjCheck, optFieldCheck, optRangeCheck, optBoundsCheck, optOverflowCheck, - optAssert, optWarns, optHints, optLineDir, + optAssert, optWarns, optHints, optStackTrace, optLineTrace]; gGlobalOptions: TGlobalOptions = {@set}[optRefcGC]; @@ -100,35 +97,40 @@ var gCmd: TCommands = cmdNone; // the command - debugState: int; // a global switch used for better debugging... - // not used for any program logic - + gVerbosity: int; // how verbose the compiler is function FindFile(const f: string): string; const - genSubDir = 'rod_gen'; + genSubDir = 'nimcache'; NimExt = 'nim'; RodExt = 'rod'; HtmlExt = 'html'; + IniExt = 'ini'; + TmplExt = 'tmpl'; + DocConfig = 'nimdoc.cfg'; function completeGeneratedFilePath(const f: string; createSubDir: bool = true): string; function toGeneratedFile(const path, ext: string): string; -// converts "/home/a/mymodule.nim", "rod" to "/home/a/rod_gen/mymodule.rod" +// converts "/home/a/mymodule.nim", "rod" to "/home/a/nimcache/mymodule.rod" function getPrefixDir: string; // gets the application directory +function getFileTrunk(const filename: string): string; + // additional configuration variables: var gConfigVars: PStringTable; libpath: string = ''; + projectPath: string = ''; gKeepComments: boolean = true; // whether the parser needs to keep comments - gImplicitMods: TStringSeq = {@ignore} nil {@emit []}; + gImplicitMods: TStringSeq = {@ignore} nil {@emit @[]}; // modules that are to be implicitly imported +function existsConfigVar(const key: string): bool; function getConfigVar(const key: string): string; procedure setConfigVar(const key, val: string); @@ -140,6 +142,11 @@ function binaryStrSearch(const x: array of string; const y: string): int; implementation +function existsConfigVar(const key: string): bool; +begin + result := hasKey(gConfigVars, key) +end; + function getConfigVar(const key: string): string; begin result := strtabs.get(gConfigVars, key); @@ -173,12 +180,37 @@ begin SplitPath(appdir, result, bin); end; +function getFileTrunk(const filename: string): string; +var + f, e, dir: string; +begin + splitPath(filename, dir, f); + splitFilename(f, result, e); +end; + +function shortenDir(const dir: string): string; +var + prefix: string; +begin + // returns the interesting part of a dir + prefix := getPrefixDir() +{&} dirSep; + if startsWith(dir, prefix) then begin + result := ncopy(dir, length(prefix) + strStart); exit + end; + prefix := getCurrentDir() +{&} dirSep; + if startsWith(dir, prefix) then begin + result := ncopy(dir, length(prefix) + strStart); exit + end; + result := dir +end; + function toGeneratedFile(const path, ext: string): string; var head, tail: string; begin splitPath(path, head, tail); - result := joinPath([head, genSubDir, changeFileExt(tail, ext)]) + result := joinPath([projectPath, genSubDir, shortenDir(head), + changeFileExt(tail, ext)]) end; function completeGeneratedFilePath(const f: string; @@ -187,13 +219,13 @@ var head, tail, subdir: string; begin splitPath(f, head, tail); - subdir := joinPath(head, genSubDir); + subdir := joinPath([projectPath, genSubDir, shortenDir(head)]); if createSubDir then createDir(subdir); result := joinPath(subdir, tail) end; -function FindFile(const f: string): string; +function rawFindFile(const f: string): string; var it: PStrEntry; begin @@ -209,6 +241,13 @@ begin end end; +function FindFile(const f: string): string; +begin + result := rawFindFile(f); + if length(result) = 0 then + result := rawFindFile(toLower(f)); +end; + function binaryStrSearch(const x: array of string; const y: string): int; var a, b, mid, c: int; diff --git a/nim/parsecfg.pas b/nim/parsecfg.pas index 1f049536d..a99da6852 100644 --- a/nim/parsecfg.pas +++ b/nim/parsecfg.pas @@ -9,15 +9,15 @@ unit parsecfg; // A HIGH-PERFORMANCE configuration file parser; -// the Nimrod version of this file will become part -// of the standard library. +// the Nimrod version of this file is part of the +// standard library. interface {$include 'config.inc'} uses - charsets, nsystem, sysutils, hashes, strutils, lexbase; + nsystem, charsets, llstream, sysutils, hashes, strutils, lexbase; type TCfgEventKind = ( @@ -25,7 +25,7 @@ type cfgSectionStart, // a ``[section]`` has been parsed cfgKeyValuePair, // a ``key=value`` pair has been detected cfgOption, // a ``--key=value`` command line option - cfgError // an error ocurred during parsing; msg contains the + cfgError // an error ocurred during parsing; msg contains the // error message ); TCfgEvent = {@ignore} record @@ -36,7 +36,8 @@ type end; {@emit object(NObject) case kind: TCfgEventKind of - cfgSection: (section: string); + cfgEof: (); + cfgSectionStart: (section: string); cfgKeyValuePair, cfgOption: (key, value: string); cfgError: (msg: string); end;} @@ -44,9 +45,9 @@ type tkSymbol, tkEquals, tkColon, tkBracketLe, tkBracketRi, tkDashDash ); - TToken = record // a token + TToken = record // a token kind: TTokKind; // the type of the token - literal: string; // the parsed (string) literal + literal: string; // the parsed (string) literal end; TParserState = (startState, commaState); TCfgParser = object(TBaseLexer) @@ -55,8 +56,8 @@ type filename: string; end; -function Open(var c: TCfgParser; const filename: string): bool; -procedure OpenFromBuffer(var c: TCfgParser; const buf: string); +procedure Open(var c: TCfgParser; const filename: string; + inputStream: PLLStream); procedure Close(var c: TCfgParser); function next(var c: TCfgParser): TCfgEvent; @@ -65,6 +66,8 @@ function getColumn(const c: TCfgParser): int; function getLine(const c: TCfgParser): int; function getFilename(const c: TCfgParser): string; +function errorStr(const c: TCfgParser; const msg: string): string; + implementation const @@ -73,35 +76,23 @@ const // ---------------------------------------------------------------------------- procedure rawGetTok(var c: TCfgParser; var tok: TToken); forward; -function open(var c: TCfgParser; const filename: string): bool; +procedure open(var c: TCfgParser; const filename: string; + inputStream: PLLStream); begin {@ignore} - FillChar(c, sizeof(c), 0); // work around Delphi/fpc bug + FillChar(c, sizeof(c), 0); {@emit} - result := initBaseLexer(c, filename); + openBaseLexer(c, inputStream); c.filename := filename; c.state := startState; c.tok.kind := tkInvalid; c.tok.literal := ''; - if result then rawGetTok(c, c.tok); -end; - -procedure openFromBuffer(var c: TCfgParser; const buf: string); -begin -{@ignore} - FillChar(c, sizeof(c), 0); // work around Delphi/fpc bug -{@emit} - initBaseLexerFromBuffer(c, buf); - c.filename := 'buffer'; - c.state := startState; - c.tok.kind := tkInvalid; - c.tok.literal := ''; rawGetTok(c, c.tok); end; procedure close(var c: TCfgParser); begin - deinitBaseLexer(c); + closeBaseLexer(c); end; function getColumn(const c: TCfgParser): int; @@ -285,7 +276,7 @@ begin repeat case buf[pos] of ' ': Inc(pos); - Tabulator: inc(pos); + Tabulator: inc(pos); '#', ';': while not (buf[pos] in [CR, LF, lexbase.EndOfFile]) do inc(pos); CR, LF: pos := HandleCRLF(c, pos); else break // EndOfFile also leaves the loop @@ -321,7 +312,7 @@ begin Inc(c.bufPos); getString(c, tok, true); end - else + else getSymbol(c, tok); end; '[': begin @@ -343,7 +334,7 @@ end; function errorStr(const c: TCfgParser; const msg: string): string; begin result := format('$1($2, $3) Error: $4', [ - c.filename, toString(getLine(c)), toString(getColumn(c)), + c.filename, toString(getLine(c)), toString(getColumn(c)), msg ]); end; @@ -355,6 +346,20 @@ begin result.key := c.tok.literal; result.value := ''; rawGetTok(c, c.tok); + while c.tok.literal = '.'+'' do begin + addChar(result.key, '.'); + rawGetTok(c, c.tok); + if c.tok.kind = tkSymbol then begin + result.key := result.key +{&} c.tok.literal; + rawGetTok(c, c.tok); + end + else begin + result.kind := cfgError; + result.msg := errorStr(c, 'symbol expected, but found: ' + + c.tok.literal); + break + end + end; if c.tok.kind in [tkEquals, tkColon] then begin rawGetTok(c, c.tok); if c.tok.kind = tkSymbol then begin @@ -362,7 +367,7 @@ begin end else begin result.kind := cfgError; - result.msg := errorStr(c, 'symbol expected, but found: ' + result.msg := errorStr(c, 'symbol expected, but found: ' + c.tok.literal); end; rawGetTok(c, c.tok); @@ -400,10 +405,10 @@ begin if c.tok.kind = tkBracketRi then rawGetTok(c, c.tok) else begin result.kind := cfgError; - result.msg := errorStr(c, ''']'' expected, but found: ' + c.tok.literal); + result.msg := errorStr(c, ''']'' expected, but found: ' + c.tok.literal); end end; - tkInvalid, tkEquals, tkColon: begin + tkInvalid, tkBracketRi, tkEquals, tkColon: begin result.kind := cfgError; result.msg := errorStr(c, 'invalid token: ' + c.tok.literal); rawGetTok(c, c.tok); diff --git a/nim/paslex.pas b/nim/paslex.pas index c7aa6e19a..678f3af1a 100644 --- a/nim/paslex.pas +++ b/nim/paslex.pas @@ -34,15 +34,18 @@ type TPasTokKind = (pxInvalid, pxEof, // keywords: //[[[cog - //keywords = eval(file("data/pas_keyw.yml").read()) + //from string import capitalize + //keywords = eval(open("data/pas_keyw.yml").read()) //idents = "" //strings = "" //i = 1 //for k in keywords: - // idents += "px" + k.capitalize() + ", " - // strings += "'" + k + "', " - // if i % 4 == 0: idents += "\n"; strings += "\n" - // i += 1 + // idents = idents + "px" + capitalize(k) + ", " + // strings = strings + "'" + k + "', " + // if i % 4 == 0: + // idents = idents + "\n" + // strings = strings + "\n" + // i = i + 1 //cog.out(idents) //]]] pxAnd, pxArray, pxAs, pxAsm, @@ -164,7 +167,7 @@ begin case tok.ident.id of //[[[cog //for k in keywords: - // m = k.capitalize() + // m = capitalize(k) // cog.outl("ord(w%s):%s tok.xkind := px%s;" % (m, ' '*(18-len(m)), m)) //]]] ord(wAnd): tok.xkind := pxAnd; diff --git a/nim/pasparse.pas b/nim/pasparse.pas index 357918029..d0353fc86 100644 --- a/nim/pasparse.pas +++ b/nim/pasparse.pas @@ -18,7 +18,7 @@ unit pasparse; interface uses - nsystem, nos, charsets, scanner, paslex, idents, wordrecg, strutils, + nsystem, nos, llstream, charsets, scanner, paslex, idents, wordrecg, strutils, ast, astalgo, msgs, options; type @@ -62,7 +62,7 @@ const ('len', 'length'), ('setlength', 'setlen') ); - nimReplacements: array [1..29] of TReplaceTuple = ( + nimReplacements: array [1..30] of TReplaceTuple = ( ('nimread', 'read'), ('nimwrite', 'write'), ('nimclosefile', 'closeFile'), @@ -88,6 +88,7 @@ const ('leu', '`<=%`'), ('shlu', '`shl`'), ('shru', '`shr`'), + ('assigned', 'not isNil'), ('eintoverflow', 'EOverflow'), ('format', '`%`'), @@ -108,7 +109,8 @@ const function ParseUnit(var p: TPasParser): PNode; -function openPasParser(var p: TPasParser; const filename: string): TResult; +procedure openPasParser(var p: TPasParser; const filename: string; + inputStream: PLLStream); procedure closePasParser(var p: TPasParser); procedure exSymbol(var n: PNode); @@ -117,14 +119,15 @@ procedure fixRecordDef(var n: PNode); implementation -function OpenPasParser(var p: TPasParser; const filename: string): TResult; +procedure OpenPasParser(var p: TPasParser; const filename: string; + inputStream: PLLStream); var i: int; begin {@ignore} FillChar(p, sizeof(p), 0); {@emit} - result := OpenLexer(p.lex, filename); + OpenLexer(p.lex, filename, inputStream); initIdTable(p.repl); for i := low(stdReplacements) to high(stdReplacements) do IdTablePut(p.repl, getIdent(stdReplacements[i][0]), @@ -191,8 +194,7 @@ end; function newNodeP(kind: TNodeKind; const p: TPasParser): PNode; begin - result := newNode(kind); - result.info := getLineInfo(p.lex); + result := newNodeI(kind, getLineInfo(p.lex)); end; function newIntNodeP(kind: TNodeKind; const intVal: BiggestInt; @@ -236,9 +238,10 @@ end; function parseExpr(var p: TPasParser): PNode; forward; function parseStmt(var p: TPasParser): PNode; forward; -function parseTypeDesc(var p: TPasParser): PNode; forward; +function parseTypeDesc(var p: TPasParser; + definition: PNode=nil): PNode; forward; -function parseEmit(var p: TPasParser): PNode; +function parseEmit(var p: TPasParser; definition: PNode): PNode; var a: PNode; begin @@ -258,12 +261,12 @@ begin end end end; - conTypeDesc: result := parseTypeDesc(p); + conTypeDesc: result := parseTypeDesc(p, definition); end; eat(p, pxCurlyDirRi); end; -function parseCommand(var p: TPasParser): PNode; +function parseCommand(var p: TPasParser; definition: PNode=nil): PNode; var a: PNode; begin @@ -294,7 +297,7 @@ begin end end else if p.tok.ident.id = getIdent('emit').id then begin - result := parseEmit(p); + result := parseEmit(p, definition); end else if p.tok.ident.id = getIdent('ignore').id then begin getTok(p); eat(p, pxCurlyDirRi); @@ -304,12 +307,11 @@ begin pxCommand: begin getTok(p); if p.tok.ident.id = getIdent('emit').id then begin - result := parseEmit(p); + result := parseEmit(p, definition); break end else begin - while (p.tok.xkind <> pxCurlyDirRi) - and (p.tok.xkind <> pxEof) do + while (p.tok.xkind <> pxCurlyDirRi) and (p.tok.xkind <> pxEof) do getTok(p); eat(p, pxCurlyDirRi); end; @@ -326,6 +328,10 @@ begin result := newNodeP(nkTupleTy, p); getTok(p); eat(p, pxCurlyDirRi); end + else if p.tok.ident.id = getIdent('acyclic').id then begin + result := newIdentNodeP(p.tok.ident, p); + getTok(p); eat(p, pxCurlyDirRi); + end else begin parMessage(p, errUnknownDirective, pasTokToStr(p.tok)); while true do begin @@ -445,8 +451,7 @@ begin skipCom(p, result); if p.tok.xkind = pxSymbol then begin a := result; - result := newNode(nkQualified); - result.info := a.info; + result := newNodeI(nkQualified, a.info); addSon(result, a); addSon(result, createIdentNodeP(p.tok.ident, p)); getTok(p); @@ -583,8 +588,15 @@ begin end else if p.tok.xkind = pxAt then begin result := newNodeP(nkAddr, p); + a := newIdentNodeP(getIdent(pasTokToStr(p.tok)), p); getTok(p); - addSon(result, primary(p)); + if p.tok.xkind = pxBracketLe then begin + result := newNodeP(nkPrefix, p); + addSon(result, a); + addSon(result, identOrLiteral(p)); + end + else + addSon(result, primary(p)); exit end; result := identOrLiteral(p); @@ -737,8 +749,7 @@ begin getTok(p); skipCom(p, a); b := parseExpr(p); - result := newNode(nkAsgn); - result.info := info; + result := newNodeI(nkAsgn, info); addSon(result, a); addSon(result, b); end @@ -837,7 +848,7 @@ end; function parseStmtList(var p: TPasParser): PNode; begin result := newNodeP(nkStmtList, p); - while true do begin + while true do begin case p.tok.xkind of pxEof: break; pxCurlyDirLe, pxStarDirLe: begin @@ -847,7 +858,7 @@ begin end; addSon(result, parseStmt(p)) end; - if sonsLen(result) = 1 then result := result.sons[0]; + if sonsLen(result) = 1 then result := result.sons[0]; end; procedure parseIfDirAux(var p: TPasParser; result: PNode); @@ -1278,7 +1289,6 @@ begin addSon(e, parseExpr(p)); addSon(result, e); opt(p, pxSemicolon); - if (p.tok.xkind = pxSymbol) and (p.tok.ident.id = getIdent('name').id) then begin e := newNodeP(nkExprColonExpr, p); @@ -1286,7 +1296,9 @@ begin addSon(e, newIdentNodeP(getIdent('importc'), p)); addSon(e, parseExpr(p)); addSon(result, e); - end; + end + else + addSon(result, newIdentNodeP(getIdent('importc'), p)); opt(p, pxSemicolon); end else begin @@ -1453,7 +1465,8 @@ begin end; eat(p, pxParRi); opt(p, pxSemicolon); - skipCom(p, lastSon(c)); + if sonsLen(c) > 0 then skipCom(p, lastSon(c)) + else addSon(c, newNodeP(nkNilLit, p)); addSon(b, c); addSon(result, b); if b.kind = nkElse then break; @@ -1491,8 +1504,7 @@ begin nkPostfix: begin end; // already an export marker nkPragmaExpr: exSymbol(n.sons[0]); nkIdent, nkAccQuoted: begin - a := newNode(nkPostFix); - a.info := n.info; + a := newNodeI(nkPostFix, n.info); addSon(a, newIdentNode(getIdent('*'+''), n.info)); addSon(a, n); n := a @@ -1521,12 +1533,32 @@ begin nkIdentDefs: begin for i := 0 to sonsLen(n)-3 do exSymbol(n.sons[i]) end; + nkNilLit: begin end; //nkIdent: exSymbol(n); else internalError(n.info, 'fixRecordDef(): ' + nodekindtostr[n.kind]); end end; -procedure parseRecordBody(var p: TPasParser; result: PNode); +procedure addPragmaToIdent(var ident: PNode; pragma: PNode); +var + e, pragmasNode: PNode; +begin + if ident.kind <> nkPragmaExpr then begin + pragmasNode := newNodeI(nkPragma, ident.info); + e := newNodeI(nkPragmaExpr, ident.info); + addSon(e, ident); + addSon(e, pragmasNode); + ident := e; + end + else begin + pragmasNode := ident.sons[1]; + if pragmasNode.kind <> nkPragma then + InternalError(ident.info, 'addPragmaToIdent'); + end; + addSon(pragmasNode, pragma); +end; + +procedure parseRecordBody(var p: TPasParser; result, definition: PNode); var a: PNode; begin @@ -1535,11 +1567,32 @@ begin if result.kind <> nkTupleTy then fixRecordDef(a); addSon(result, a); eat(p, pxEnd); + case p.tok.xkind of + pxSymbol: begin + if (p.tok.ident.id = getIdent('acyclic').id) then begin + if definition <> nil then + addPragmaToIdent(definition.sons[0], newIdentNodeP(p.tok.ident, p)) + else + InternalError(result.info, 'anonymous record is not supported'); + getTok(p); + end + else + InternalError(result.info, 'parseRecordBody'); + end; + pxCommand: begin + if definition <> nil then + addPragmaToIdent(definition.sons[0], parseCommand(p)) + else + InternalError(result.info, 'anonymous record is not supported'); + end; + else begin end + end; opt(p, pxSemicolon); - skipCom(p, result); + skipCom(p, result); end; -function parseRecordOrObject(var p: TPasParser; kind: TNodeKind): PNode; +function parseRecordOrObject(var p: TPasParser; kind: TNodeKind; + definition: PNode): PNode; var a: PNode; begin @@ -1554,10 +1607,10 @@ begin eat(p, pxParRi); end else addSon(result, nil); - parseRecordBody(p, result); + parseRecordBody(p, result, definition); end; -function parseTypeDesc(var p: TPasParser): PNode; +function parseTypeDesc(var p: TPasParser; definition: PNode=nil): PNode; var oldcontext: TPasContext; a, r: PNode; @@ -1567,15 +1620,15 @@ begin p.context := conTypeDesc; if p.tok.xkind = pxPacked then getTok(p); case p.tok.xkind of - pxCommand: result := parseCommand(p); + pxCommand: result := parseCommand(p, definition); pxProcedure, pxFunction: result := parseRoutineType(p); pxRecord: begin getTok(p); if p.tok.xkind = pxCommand then begin result := parseCommand(p); - if result.kind <> nkTupleTy then + if result.kind <> nkTupleTy then InternalError(result.info, 'parseTypeDesc'); - parseRecordBody(p, result); + parseRecordBody(p, result, definition); a := lastSon(result); // embed nkRecList directly into nkTupleTy for i := 0 to sonsLen(a)-1 do @@ -1583,15 +1636,18 @@ begin else addSon(result, a.sons[i]); end else begin - result := newNodeP(nkReturnToken, p); - // we use nkReturnToken to signal that this object should be marked as - // final + result := newNodeP(nkObjectTy, p); addSon(result, nil); addSon(result, nil); - parseRecordBody(p, result); + parseRecordBody(p, result, definition); + if definition <> nil then + addPragmaToIdent(definition.sons[0], + newIdentNodeP(getIdent('final'), p)) + else + InternalError(result.info, 'anonymous record is not supported'); end; end; - pxObject: result := parseRecordOrObject(p, nkObjectTy); + pxObject: result := parseRecordOrObject(p, nkObjectTy, definition); pxParLe: result := parseEnum(p); pxArray: begin result := newNodeP(nkBracketExpr, p); @@ -1622,8 +1678,10 @@ begin getTok(p); if p.tok.xkind = pxCommand then result := parseCommand(p) + else if gCmd = cmdBoot then + result := newNodeP(nkRefTy, p) else - result := newNodeP(nkRefTy, p); + result := newNodeP(nkPtrTy, p); addSon(result, parseTypeDesc(p)) end; pxType: begin @@ -1650,28 +1708,15 @@ end; function parseTypeDef(var p: TPasParser): PNode; var - a, e, pragmasNode: PNode; + a: PNode; begin result := newNodeP(nkTypeDef, p); addSon(result, identVis(p)); addSon(result, nil); // generic params if p.tok.xkind = pxEquals then begin getTok(p); skipCom(p, result); - a := parseTypeDesc(p); + a := parseTypeDesc(p, result); addSon(result, a); - if a.kind = nkReturnToken then begin // a `final` object? - a.kind := nkObjectTy; - if result.sons[0].kind <> nkPragmaExpr then begin - e := newNodeP(nkPragmaExpr, p); - pragmasNode := newNodeP(nkPragma, p); - addSon(e, result.sons[0]); - addSon(e, pragmasNode); - result.sons[0] := e; - end - else - pragmasNode := result.sons[1]; - addSon(pragmasNode, newIdentNodeP(getIdent('final'), p)); - end end else addSon(result, nil); diff --git a/nim/platform.pas b/nim/platform.pas index 896d7b4a2..1c021db86 100644 --- a/nim/platform.pas +++ b/nim/platform.pas @@ -12,8 +12,7 @@ unit platform; // and operating systems. // Note: Unfortunately if an OS or CPU is listed here this does not mean that // Nimrod has been tested on this platform or that the RTL has been ported. -// Feel free to test for your exentric platform! (Windows on I386 and Linux -// on I386 have been tested, though.) +// Feel free to test for your exentric platform! interface @@ -24,7 +23,6 @@ uses type TSystemOS = ( - // This enumeration is stored in rod files, so append new OSes at the end! // Also add OS for in initialization section and alias conditionals to // condsyms (end of module). osNone, @@ -39,6 +37,7 @@ type osNetbsd, osFreebsd, osOpenbsd, + osAix, osPalmos, osQnx, osAmiga, @@ -46,7 +45,8 @@ type osNetware, osMacos, osMacosx, - osEcmaScript + osEcmaScript, + osNimrodVM ); type TInfoOSProp = ( @@ -251,6 +251,22 @@ const props: {@set}[ospNeedsPIC, ospPosix]; ), ( + name: 'AIX'; + parDir: '..'; + dllExt: '.so'; + altDirSep: '/'+''; + dllPrefix: 'lib'; + objExt: '.o'; + newLine: #10+''; + pathSep: ':'+''; + dirSep: '/'+''; + scriptExt: '.sh'; + curDir: '.'+''; + exeExt: ''; + extSep: '.'+''; + props: {@set}[ospNeedsPIC, ospPosix]; + ), + ( name: 'PalmOS'; parDir: '..'; dllExt: '.so'; @@ -377,11 +393,26 @@ const exeExt: ''; extSep: '.'+''; props: {@set}[]; + ), + ( + name: 'NimrodVM'; + parDir: '..'; + dllExt: '.so'; + altDirSep: '/'+''; + dllPrefix: 'lib'; + objExt: '.o'; + newLine: #10+''; + pathSep: ':'+''; + dirSep: '/'+''; + scriptExt: '.sh'; + curDir: '.'+''; + exeExt: ''; + extSep: '.'+''; + props: {@set}[]; ) ); type TSystemCPU = ( - // This enumeration is stored in rod files, so append new CPUs at the end! // Also add CPU for in initialization section and alias conditionals to // condsyms (end of module). cpuNone, @@ -395,7 +426,8 @@ type cpuAmd64, cpuMips, cpuArm, - cpuEcmaScript + cpuEcmaScript, + cpuNimrodVM ); type TEndian = (littleEndian, bigEndian); @@ -485,6 +517,13 @@ const endian: bigEndian; floatSize: 64; bit: 32; + ), + ( + name: 'nimrodvm'; + intSize: 32; + endian: bigEndian; + floatSize: 64; + bit: 32; ) ); diff --git a/nim/pnimsyn.pas b/nim/pnimsyn.pas index 27841229e..2cb34e708 100644 --- a/nim/pnimsyn.pas +++ b/nim/pnimsyn.pas @@ -6,7 +6,6 @@ // See the file "copying.txt", included in this // distribution, for details about the copyright. // - unit pnimsyn; // This module implements the parser of the standard Nimrod representation. @@ -21,15 +20,14 @@ unit pnimsyn; interface uses - nsystem, scanner, idents, strutils, ast, msgs; + nsystem, llstream, scanner, idents, strutils, ast, msgs; function ParseFile(const filename: string): PNode; type TParser = record // a TParser object represents a module that // is being parsed - lex: PLexer; // we need a stack of lexers because - // of support for the `include` command + lex: PLexer; // the lexer that is used for parsing tok: PToken; // the current token end; @@ -38,22 +36,26 @@ function ParseModule(var p: TParser): PNode; function parseExpr(var p: TParser): PNode; function parseStmt(var p: TParser): PNode; -function openParser(var p: TParser; const filename: string): TResult; -procedure bufferParser(var p: TParser; const buffer: string); - // the same as `openParser`, but does use a buffer and does not read from - // a file +procedure openParser(var p: TParser; const filename: string; + inputstream: PLLStream); procedure closeParser(var p: TParser); +function parseTopLevelStmt(var p: TParser): PNode; +// implements an iterator. Returns the next top-level statement or nil if end +// of stream. + implementation function ParseFile(const filename: string): PNode; var p: TParser; + f: TBinaryFile; begin - if OpenParser(p, filename) = failure then begin + if not OpenFile(f, filename) then begin rawMessage(errCannotOpenFile, filename); exit end; + OpenParser(p, filename, LLStreamOpen(f)); result := ParseModule(p); CloseParser(p); end; @@ -73,16 +75,17 @@ begin {@emit} end; -procedure bufferParser(var p: TParser; const buffer: string); +procedure getTok(var p: TParser); begin - initParser(p); - bufferLexer(p.lex^, buffer); + rawGetTok(p.lex^, p.tok^); end; -function OpenParser(var p: TParser; const filename: string): TResult; +procedure OpenParser(var p: TParser; const filename: string; + inputStream: PLLStream); begin initParser(p); - result := OpenLexer(p.lex^, filename); + OpenLexer(p.lex^, filename, inputstream); + getTok(p); // read the first token end; procedure CloseParser(var p: TParser); @@ -95,12 +98,6 @@ end; // ---------------- parser helpers -------------------------------------------- -procedure getTok(var p: TParser); -begin - rawGetTok(p.lex^, p.tok^); - //printTok(p.tok); // DEBUG -end; - procedure skipComment(var p: TParser; node: PNode); begin if p.tok.tokType = tkComment then begin @@ -177,8 +174,7 @@ end; function newNodeP(kind: TNodeKind; const p: TParser): PNode; begin - result := newNode(kind); - result.info := getLineInfo(p.lex^); + result := newNodeI(kind, getLineInfo(p.lex^)); end; function newIntNodeP(kind: TNodeKind; const intVal: BiggestInt; @@ -261,22 +257,22 @@ begin getTok(p); eat(p, tkDotDot); if (p.tok.tokType = tkOpr) and (p.tok.ident.s = '$'+'') then begin - s := s + '$'+''; - getTok(p); + addChar(s, '$'); + getTok(p); end; end else if p.tok.tokType = tkDotDot then begin s := s + '..'; getTok(p); if (p.tok.tokType = tkOpr) and (p.tok.ident.s = '$'+'') then begin - s := s + '$'+''; + addChar(s, '$'); getTok(p); end; end; eat(p, tkBracketRi); - s := s + ']'+''; + addChar(s, ']'); if p.tok.tokType = tkEquals then begin - s := s + '='; getTok(p); + addChar(s, '='); getTok(p); end; addSon(result, newIdentNodeP(getIdent(s), p)); end; @@ -485,8 +481,7 @@ begin getTok(p); optInd(p, result); a := result; - result := newNode(nkQualified); - result.info := a.info; + result := newNodeI(nkQualified, a.info); addSon(result, a); addSon(result, parseSymbol(p)); end; @@ -809,8 +804,7 @@ begin getTok(p); optInd(p, result); b := parseExpr(p); - result := newNode(nkAsgn); - result.info := a.info; + result := newNodeI(nkAsgn, a.info); addSon(result, a); addSon(result, b); end @@ -1449,6 +1443,12 @@ begin end end; +function newCommentStmt(var p: TParser): PNode; +begin + result := newNodeP(nkCommentStmt, p); + result.info.line := result.info.line - int16(1); +end; + type TDefParser = function (var p: TParser): PNode; @@ -1475,7 +1475,7 @@ begin tkDed: begin getTok(p); break end; tkEof: break; // BUGFIX tkComment: begin - a := newNodeP(nkCommentStmt, p); + a := newCommentStmt(p); skipComment(p, a); addSon(result, a); end; @@ -1618,7 +1618,7 @@ begin while true do begin case p.tok.tokType of tkSad: getTok(p); - tkCase, tkWhen, tkSymbol, tkAccent: begin + tkCase, tkWhen, tkSymbol, tkAccent, tkNil: begin addSon(result, parseRecordPart(p)); end; tkDed: begin getTok(p); break end; @@ -1636,6 +1636,10 @@ begin result := parseIdentColonEquals(p, true); skipComment(p, result); end; + tkNil: begin + result := newNodeP(nkNilLit, p); + getTok(p); + end; else result := nil end end; @@ -1681,13 +1685,13 @@ begin end else addSon(result, nil); - indAndComment(p, result); // XXX: special extension! + indAndComment(p, result); // special extension! end; function parseVariable(var p: TParser): PNode; begin result := parseIdentColonEquals(p, true); - indAndComment(p, result); // XXX: special extension! + indAndComment(p, result); // special extension! end; function simpleStmt(var p: TParser): PNode; @@ -1703,13 +1707,11 @@ begin tkImport: result := parseImportStmt(p); tkFrom: result := parseFromStmt(p); tkInclude: result := parseIncludeStmt(p); - tkComment: begin - result := newNodeP(nkCommentStmt, p); - end; + tkComment: result := newCommentStmt(p); //tkSad, tkInd, tkDed: assert(false); else result := parseExprStmt(p) end; - skipComment(p, result); + skipComment(p, result); end; function complexOrSimpleStmt(var p: TParser): PNode; @@ -1770,7 +1772,6 @@ end; function parseModule(var p: TParser): PNode; begin result := newNodeP(nkStmtList, p); - getTok(p); // read first token while true do begin case p.tok.tokType of tkSad: getTok(p); @@ -1781,4 +1782,23 @@ begin end end; +function parseTopLevelStmt(var p: TParser): PNode; +begin + result := nil; + while true do begin + case p.tok.tokType of + tkSad: getTok(p); + tkDed, tkInd: begin + parMessage(p, errInvalidIndentation); + break; + end; + tkEof: break; + else begin + result := complexOrSimpleStmt(p); + break + end + end + end +end; + end. diff --git a/nim/pragmas.pas b/nim/pragmas.pas index c3a6c42d2..372d8d4a4 100644 --- a/nim/pragmas.pas +++ b/nim/pragmas.pas @@ -6,9 +6,34 @@ // See the file "copying.txt", included in this // distribution, for details about the copyright. // +unit pragmas; // This module implements semantic checking for pragmas +interface + +{$include 'config.inc'} + +uses + nsystem, nos, platform, condsyms, ast, astalgo, idents, semdata, msgs, + rnimsyn, wordrecg, ropes, options, strutils, lists, extccomp, nmath, + magicsys; + +procedure pragmaProc(c: PContext; s: PSym; n: PNode); +procedure pragmaMacro(c: PContext; s: PSym; n: PNode); +procedure pragmaIterator(c: PContext; s: PSym; n: PNode); +procedure pragmaStmt(c: PContext; s: PSym; n: PNode); +procedure pragmaLambda(c: PContext; s: PSym; n: PNode); +procedure pragmaType(c: PContext; s: PSym; n: PNode); +procedure pragmaField(c: PContext; s: PSym; n: PNode); +procedure pragmaVar(c: PContext; s: PSym; n: PNode); +procedure pragmaConst(c: PContext; s: PSym; n: PNode); +procedure pragmaProcType(c: PContext; s: PSym; n: PNode); + +function pragmaAsm(c: PContext; n: PNode): char; + +implementation + procedure invalidPragma(n: PNode); begin liMessage(n.info, errInvalidPragmaX, renderTree(n, {@set}[renderNoComments])); @@ -25,7 +50,7 @@ begin it := n.sons[i]; if (it.kind = nkExprColonExpr) and (it.sons[0].kind = nkIdent) then begin case whichKeyword(it.sons[0].ident) of - wAsmQuote: begin + wSubsChar: begin if it.sons[1].kind = nkCharLit then result := chr(int(it.sons[1].intVal)) else invalidPragma(it) @@ -51,14 +76,12 @@ procedure MakeExternImport(s: PSym; const extname: string); begin s.loc.r := toRope(extname); Include(s.flags, sfImportc); - Include(s.flags, sfNoStatic); Exclude(s.flags, sfForward); end; procedure MakeExternExport(s: PSym; const extname: string); begin s.loc.r := toRope(extname); - Include(s.flags, sfNoStatic); Include(s.flags, sfExportc); end; @@ -69,7 +92,7 @@ begin result := '' end else begin - n.sons[1] := semConstExpr(c, n.sons[1]); + n.sons[1] := c.semConstExpr(c, n.sons[1]); case n.sons[1].kind of nkStrLit, nkRStrLit, nkTripleStrLit: result := n.sons[1].strVal; else begin @@ -87,7 +110,7 @@ begin result := 0 end else begin - n.sons[1] := semConstExpr(c, n.sons[1]); + n.sons[1] := c.semConstExpr(c, n.sons[1]); case n.sons[1].kind of nkIntLit..nkInt64Lit: result := int(n.sons[1].intVal); else begin @@ -114,7 +137,10 @@ var begin if not (sfSystemModule in c.module.flags) then liMessage(n.info, errMagicOnlyInSystem); - v := expectStrLit(c, n); + if n.kind <> nkExprColonExpr then + liMessage(n.info, errStringLiteralExpected); + if n.sons[1].kind = nkIdent then v := n.sons[1].ident.s + else v := expectStrLit(c, n); Include(s.flags, sfImportc); // magics don't need an implementation, so we // treat them as imported, instead of modifing a lot of working code Include(s.loc.Flags, lfNoDecl); // magics don't need to be declared! @@ -260,6 +286,7 @@ begin wStacktrace: OnOff(c, n, {@set}[optStackTrace]); wLinetrace: OnOff(c, n, {@set}[optLineTrace]); wDebugger: OnOff(c, n, {@set}[optEndb]); + wProfiler: OnOff(c, n, {@set}[optProfiler]); wByRef: OnOff(c, n, {@set}[optByRef]); wDynLib: processDynLib(c, n, nil); // ------------------------------------------------------- @@ -323,16 +350,20 @@ end; procedure processDefine(c: PContext; n: PNode); begin - if (n.kind = nkExprColonExpr) and (n.sons[1].kind = nkIdent) then - DefineSymbol(n.sons[1].ident.s) + if (n.kind = nkExprColonExpr) and (n.sons[1].kind = nkIdent) then begin + DefineSymbol(n.sons[1].ident.s); + liMessage(n.info, warnDeprecated, 'define'); + end else invalidPragma(n) end; procedure processUndef(c: PContext; n: PNode); begin - if (n.kind = nkExprColonExpr) and (n.sons[1].kind = nkIdent) then - UndefSymbol(n.sons[1].ident.s) + if (n.kind = nkExprColonExpr) and (n.sons[1].kind = nkIdent) then begin + UndefSymbol(n.sons[1].ident.s); + liMessage(n.info, warnDeprecated, 'undef'); + end else invalidPragma(n) end; @@ -366,9 +397,8 @@ begin case feature of linkNormal: extccomp.addFileToLink(found); linkSys: begin - if not (optCompileSys in gGlobalOptions) then - extccomp.addFileToLink(joinPath(libpath, - completeCFilePath(found, false))); + extccomp.addFileToLink(joinPath(libpath, + completeCFilePath(found, false))); end else internalError(n.info, 'processCommonLink'); end @@ -423,6 +453,7 @@ begin makeExternImport(sym, getOptionalStr(c, it, sym.name.s)); end; wAlign: begin + if sym.typ = nil then invalidPragma(it); sym.typ.align := expectIntLit(c, it); if not IsPowerOfTwo(sym.typ.align) and (sym.typ.align <> 0) then liMessage(it.info, errPowerOfTwoExpected); @@ -434,8 +465,17 @@ begin end; wVolatile: begin noVal(it); Include(sym.flags, sfVolatile); end; wRegister: begin noVal(it); include(sym.flags, sfRegister); end; + wThreadVar: begin noVal(it); include(sym.flags, sfThreadVar); end; wMagic: processMagic(c, it, sym); - wNostatic: begin noVal(it); include(sym.flags, sfNoStatic); end; + wCompileTime: begin + noVal(it); + include(sym.flags, sfCompileTime); + include(sym.loc.Flags, lfNoDecl); + end; + wMerge: begin + noval(it); + include(sym.flags, sfMerge); + end; wHeader: begin lib := getLib(c, libHeader, expectStrLit(c, it)); addToLib(lib, sym); @@ -453,7 +493,7 @@ begin makeExternExport(sym, sym.name.s); include(sym.flags, sfCompilerProc); include(sym.flags, sfUsed); // suppress all those stupid warnings - StrTableAdd(magicsys.compilerprocs, sym); + registerCompilerProc(sym); end; wCppMethod: begin makeExternImport(sym, getOptionalStr(c, it, sym.name.s)); @@ -465,12 +505,19 @@ begin end; wVarargs: begin noVal(it); + if sym.typ = nil then invalidPragma(it); include(sym.typ.flags, tfVarargs); end; wFinal: begin noVal(it); + if sym.typ = nil then invalidPragma(it); include(sym.typ.flags, tfFinal); end; + wAcyclic: begin + noVal(it); + if sym.typ = nil then invalidPragma(it); + include(sym.typ.flags, tfAcyclic); + end; wTypeCheck: begin noVal(it); include(sym.flags, sfTypeCheck); @@ -507,11 +554,12 @@ begin wChecks, wObjChecks, wFieldChecks, wRangechecks, wBoundchecks, wOverflowchecks, wNilchecks, wAssertions, wWarnings, wHints, wLinedir, wStacktrace, - wLinetrace, wOptimization, wByRef, wCallConv, wDebugger: + wLinetrace, wOptimization, wByRef, wCallConv, wDebugger, wProfiler: processOption(c, it); // calling conventions (boring...): firstCallConv..lastCallConv: begin assert(sym <> nil); + if sym.typ = nil then invalidPragma(it); sym.typ.callConv := wordToCallConv(k) end else invalidPragma(it); @@ -538,15 +586,15 @@ end; procedure pragmaProc(c: PContext; s: PSym; n: PNode); begin pragma(c, s, n, {@set}[FirstCallConv..LastCallConv, - wImportc, wExportc, wNostatic, wNodecl, wMagic, wNosideEffect, - wNoreturn, wDynLib, wHeader, wReturnsNew, wCompilerProc, wPure, - wCppMethod, wDeprecated, wVarargs]); + wImportc, wExportc, wNodecl, wMagic, wNosideEffect, + wNoreturn, wDynLib, wHeader, wCompilerProc, wPure, + wCppMethod, wDeprecated, wVarargs, wCompileTime, wMerge]); end; procedure pragmaMacro(c: PContext; s: PSym; n: PNode); begin pragma(c, s, n, {@set}[FirstCallConv..LastCallConv, - wImportc, wExportc, wNostatic, wNodecl, wMagic, wNosideEffect, + wImportc, wExportc, wNodecl, wMagic, wNosideEffect, wCompilerProc, wDeprecated, wTypeCheck]); end; @@ -570,13 +618,13 @@ end; procedure pragmaLambda(c: PContext; s: PSym; n: PNode); begin pragma(c, s, n, {@set}[FirstCallConv..LastCallConv, - wImportc, wExportc, wNostatic, wNodecl, wNosideEffect, - wNoreturn, wDynLib, wHeader, wReturnsNew, wPure, wDeprecated]); + wImportc, wExportc, wNodecl, wNosideEffect, + wNoreturn, wDynLib, wHeader, wPure, wDeprecated]); end; procedure pragmaType(c: PContext; s: PSym; n: PNode); begin - pragma(c, s, n, {@set}[wImportc, wExportc, wDeprecated, wMagic, + pragma(c, s, n, {@set}[wImportc, wExportc, wDeprecated, wMagic, wAcyclic, wNodecl, wPure, wHeader, wCompilerProc, wFinal]); end; @@ -587,9 +635,9 @@ end; procedure pragmaVar(c: PContext; s: PSym; n: PNode); begin - pragma(c, s, n, {@set}[wImportc, wExportc, wVolatile, wRegister, - wNodecl, wMagic, wNostatic, wHeader, - wDeprecated, wCompilerProc, wDynLib]); + pragma(c, s, n, {@set}[wImportc, wExportc, wVolatile, wRegister, wThreadVar, + wNodecl, wMagic, wHeader, wDeprecated, wCompilerProc, + wDynLib]); end; procedure pragmaConst(c: PContext; s: PSym; n: PNode); @@ -602,3 +650,5 @@ procedure pragmaProcType(c: PContext; s: PSym; n: PNode); begin pragma(c, s, n, [FirstCallConv..LastCallConv, wVarargs]); end; + +end. diff --git a/nim/procfind.pas b/nim/procfind.pas index f7a78c8b9..9c4786e53 100644 --- a/nim/procfind.pas +++ b/nim/procfind.pas @@ -6,10 +6,24 @@ // See the file "copying.txt", included in this // distribution, for details about the copyright. // +unit procfind; // This module implements the searching for procs and iterators. // This is needed for proper handling of forward declarations. +interface + +{$include 'config.inc'} + +uses + nsystem, ast, astalgo, msgs, semdata, types; + +function SearchForProc(c: PContext; fn: PSym; tos: int): PSym; +// Searchs for the fn in the symbol table. If the parameter lists are exactly +// the same the sym in the symbol table is returned, else nil. + +implementation + function equalGenericParams(procA, procB: PNode): Boolean; var a, b: PSym; @@ -21,8 +35,10 @@ begin if sonsLen(procA) <> sonsLen(procB) then exit; for i := 0 to sonsLen(procA)-1 do begin - assert(procA.sons[i].kind = nkSym); - assert(procB.sons[i].kind = nkSym); + if procA.sons[i].kind <> nkSym then + InternalError(procA.info, 'equalGenericParams'); + if procB.sons[i].kind <> nkSym then + InternalError(procB.info, 'equalGenericParams'); a := procA.sons[i].sym; b := procB.sons[i].sym; if (a.name.id <> b.name.id) or not sameType(a.typ, b.typ) then exit; @@ -31,8 +47,6 @@ begin end; function SearchForProc(c: PContext; fn: PSym; tos: int): PSym; -// Searchs for the fn in the symbol table. If the parameter lists are exactly -// the same the sym in the symbol table is returned, else nil. var it: TIdentIter; begin @@ -54,3 +68,5 @@ begin result := NextIdentIter(it, c.tab.stack[tos]) end end; + +end. diff --git a/nim/rnimsyn.pas b/nim/rnimsyn.pas index b4ba928fb..6b8e3b3cb 100644 --- a/nim/rnimsyn.pas +++ b/nim/rnimsyn.pas @@ -71,9 +71,9 @@ begin g.comStack := nil; g.tokens := nil; {@emit - g.comStack := [];} + g.comStack := @[];} {@emit - g.tokens := [];} + g.tokens := @[];} g.indent := 0; g.lineLen := 0; g.pos := 0; @@ -1183,6 +1183,7 @@ begin gcoms(g); indentNL(g); gcommaAux(g, n, g.indent, 1); + gcoms(g); // BUGFIX: comment for the last enum field dedent(g); end; nkEnumFieldDef: begin diff --git a/nim/rodgen.pas b/nim/rodgen.pas deleted file mode 100644 index 8ef71dcb3..000000000 --- a/nim/rodgen.pas +++ /dev/null @@ -1,441 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2008 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -unit rodgen; - -// This module is responsible for loading and storing of rod -// files. -{ - Reading and writing binary files are really hard to debug. Therefore we use - a text-based format. It consists of: - - - a header - - a section that contains the lengths of the other sections - - a ident section that contains all PIdents - - an AST section that contains the module's AST - - The resulting file sizes are currently almost as small as the source files - (about 10%-30% increase). - - Long comments have the format: @<jump_info>#comment - Short comments: #comment -} - -interface - -{$include 'config.inc'} - -uses - sysutils, nsystem, nos, options, strutils, nversion, ast, astalgo, msgs, - platform, ropes, idents; - -type - TRodReaderFlag = (mrSkipComments, mrSkipProcBodies); - TRodReaderFlags = set of TRodReaderFlag; - -const - FileVersion = '04'; // modify this if the rod-format changes! - -procedure generateRod(module: PNode; const filename: string); -function readRod(const filename: string; const flags: TRodReaderFlags): PNode; - - -implementation - -// special characters: -// \ # ? ! $ @ #128..#255 - -type - TIntObj = object(NObject) - intVal: int; - end; - PIntObj = ^TIntObj; - - TRodGen = record - identTab: TTable; // maps PIdent to PIntObj - idents: PRope; - end; - -procedure toBase62Aux(var str: string; x: BiggestInt); -const - chars: string = - '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'; -var - v, rem: biggestInt; - d: char; -begin - v := x; - rem := v mod 62; - if (rem < 0) then begin - str := str + '-'; - v := -(v div 62); - rem := -rem; - end - else - v := v div 62; - d := chars[int(rem)+strStart]; - if (v <> 0) then toBase62Aux(str, v); - addChar(str, d); -end; - -function toBase62(x: BiggestInt): PRope; -var - res: string; -begin - res := ''; - toBase62Aux(res, x); - result := toRope(res); -end; - -function fromBase62i(const s: string; index: int; out x: int): int; -var - i: int; - sign: int; -begin - i := index; - sign := -1; - if s[i] = '-' then begin - inc(i); - sign := 1 - end; - x := 0; - while i <= length(s)+strStart-1 do begin - case s[i] of - '0'..'9': x := x * 62 - (ord(s[i]) - ord('0')); - 'a'..'z': x := x * 62 - (ord(s[i]) - ord('a') + 10); - 'A'..'Z': x := x * 62 - (ord(s[i]) - ord('A') + 36); - else break; - end; - inc(i) - end; - x := x * sign; - result := i -end; - -function fromBase62b(const s: string; index: int; out x: BiggestInt): int; -var - i: int; - sign: biggestInt; -begin - i := index; - sign := -1; - if s[i] = '-' then begin - inc(i); - sign := 1 - end; - x := 0; - while i <= length(s)+strStart-1 do begin - case s[i] of - '0'..'9': x := x * 62 - (ord(s[i]) - ord('0')); - 'a'..'z': x := x * 62 - (ord(s[i]) - ord('a') + 10); - 'A'..'Z': x := x * 62 - (ord(s[i]) - ord('A') + 36); - else break; - end; - inc(i) - end; - x := x * sign; - result := i -end; - -function encode(const s: string): PRope; -var - i: int; - res: string; -begin - res := ''; - for i := strStart to length(s)+strStart-1 do begin - case s[i] of - '\', '?', '!', '@', '$', #128..#255, #0..#31: - res := res +{&} '\' +{&} toHex(ord(s[i]), 2) - else - addChar(res, s[i]) - end - end; - result := toRope(res); -end; - -function encodeIdent(var g: TRodGen; ident: PIdent): PRope; -var - n: PIntObj; -begin - n := PIntObj(TableGet(g.identTab, ident)); - if n = nil then begin - new(n); - {@ignore} - fillChar(n^, sizeof(n^), 0); - {@emit} - n.intVal := ropeLen(g.idents); - TablePut(g.identTab, ident, n); - - app(g.idents, encode(ident.s)); - app(g.idents, '$'+''); - end; - result := toBase62(n.intVal) -end; - -function encodeNode(var g: TRodGen; const fInfo: TLineInfo; n: PNode): PRope; -var - i, len: int; - com: PRope; -begin - if n = nil then begin // nil nodes have to be stored too! - result := toRope(#255+''); exit - end; - result := nil; - if n.comment <> snil then begin - com := encode(n.comment); - if ropeLen(com) >= 128 then - appf(result, '@$1$2', [toBase62(ropeLen(com)), com]) - else - result := com - // do not emit comments to the string table as this would only increase - // file size, because comments are likely to be unique! - end; - // Line information takes easily 50% or more of the filesize! Therefore we - // omit line information if it is the same as the father's line information: - if (finfo.line <> int(n.info.line)) then - appf(result, '?$1,$2', [toBase62(n.info.col), - toBase62(n.info.line)]) - else if (finfo.col <> int(n.info.col)) then - appf(result, '?$1', [toBase62(n.info.col)]); - // No need to output the file index, as this is the serialization of one - // file. - if n.flags <> {@set}[] then - appf(result, '$$$1', [toBase62({@cast}int(n.flags))]); - case n.kind of - nkCharLit..nkInt64Lit: - appf(result, '!$1', [toBase62(n.intVal)]); - nkFloatLit..nkFloat64Lit: - appf(result, '!$1', [toRopeF(n.floatVal)]); - nkStrLit..nkTripleStrLit: - appf(result, '!$1', [encode(n.strVal)]); - nkSym: assert(false); - nkIdent: - appf(result, '!$1', [encodeIdent(g, n.ident)]); - else begin - for i := 0 to sonsLen(n)-1 do - app(result, encodeNode(g, n.info, n.sons[i])); - end - end; - len := ropeLen(result); - result := ropef('$1$2$3', [toBase62(ord(n.kind)), toBase62(len), result]); -end; - -procedure generateRod(module: PNode; const filename: string); -var - g: TRodGen; - ast: PRope; - info: TLineInfo; -begin - initTable(g.identTab); - g.idents := nil; - info := newLineInfo(changeFileExt(filename, '.nim'), -1, -1); - ast := encodeNode(g, info, module); - - writeRope(ropef('AA02 $1 $2,$3 $4 $5', - [toRope(FileVersion), - toBase62(ropeLen(g.idents)), toBase62(ropeLen(ast)), - g.idents, ast]), filename); -end; - -// ----------------------- reader --------------------------------------------- - -type - TRodReader = record - s: string; // buffer of the whole Mo2 file - pos: int; // current position - identOff: int; // offset of start of first PIdent - identLen: int; // length of ident part - astOff: int; // offset of AST part - astLen: int; // length of AST part - flags: TRodReaderFlags; - end; - -procedure initRodReader(out r: TRodReader; const filename: string; - const flags: TRodReaderFlags); -var - i: int; - version: string; -begin - r.flags := flags; - r.pos := -1; // indicates an error - r.s := readFile(filename) {@ignore} + #0 {@emit}; - r.identOff := 0; - r.astOff := 0; - r.identLen := 0; - r.astLen := 0; - - // read header: - i := strStart; - if (r.s[i] = 'A') and (r.s[i+1] = 'A') - and (r.s[i+2] = '0') and (r.s[i+3] = '2') and (r.s[i+4] = ' ') then begin - // check version: - inc(i, 5); - version := ''; - while (r.s[i] <> ' ') and (r.s[i] <> #0) do begin - addChar(version, r.s[i]); - inc(i); - end; - if r.s[i] = ' ' then inc(i); - if version = FileVersion then begin - i := fromBase62i(r.s, i, r.identLen); - if r.s[i] = ',' then inc(i); - i := fromBase62i(r.s, i, r.astLen); - if r.s[i] = ' ' then inc(i); - r.identOff := i; - r.astOff := i+r.identLen+1; - assert(r.s[r.astOff-1] = ' '); - r.pos := r.astOff; // everything seems fine - end - end -end; - -procedure hexChar(c: char; var xi: int); -begin - case c of - '0'..'9': xi := (xi shl 4) or (ord(c) - ord('0')); - 'a'..'f': xi := (xi shl 4) or (ord(c) - ord('a') + 10); - 'A'..'F': xi := (xi shl 4) or (ord(c) - ord('A') + 10); - else begin end - end -end; - -function decode(const s: string; index: int; var d: string): int; -var - i, xi: int; -begin - i := index; - while true do begin - case s[i] of - '?', '$', '@', '!', #128..#255, #0: break; - '\': begin - inc(i, 3); xi := 0; - hexChar(s[i-2], xi); - hexChar(s[i-1], xi); - addChar(d, chr(xi)); - end; - else begin - addChar(d, s[i]); - inc(i); - end - end - end; - result := i; -end; - -function readNode(var r: TRodReader; const fatherInfo: TLineInfo; - skip: bool): PNode; -var - i, len, x, endpos: int; - kind: TNodeKind; - fl: string; -begin - result := nil; - i := r.pos; - if r.s[i] = #255 then begin - inc(r.pos); exit // nil node - end; - i := fromBase62i(r.s, i, x); - kind := TNodeKind(x); - assert((kind >= low(TNodeKind)) and (kind <= high(TNodeKind))); - inc(i); // skip kind - i := fromBase62i(r.s, i, len); - endpos := i+len-1; - if skip then - inc(i, len) - else begin - result := newNode(kind); - result.info := fatherInfo; - // comment: - if r.s[i] = '#' then begin - result.comment := ''; - i := decode(r.s, i, result.comment); - if mrSkipComments in r.flags then result.comment := snil; - end - else if r.s[i] = '@' then begin - inc(i); - i := fromBase62i(r.s, i, x); - if mrSkipComments in r.flags then - inc(i, x) - else begin - result.comment := ''; - i := decode(r.s, i, result.comment) - end - end; - // info: - if r.s[i] = '?' then begin - inc(i); - i := fromBase62i(r.s, i, x); - result.info.col := x; - if r.s[i] = ',' then begin - inc(i); - i := fromBase62i(r.s, i, x); - result.info.line := x - end - end; - // base: - if r.s[i] = '$' then begin - inc(i); - i := fromBase62i(r.s, i, x); - result.flags := {@cast}TNodeFlags(x); - end; - // atom: - if r.s[i] = '!' then begin - inc(i); - case kind of - nkCharLit..nkInt64Lit: - i := fromBase62b(r.s, i, result.intVal); - nkFloatLit..nkFloat64Lit: begin - fl := ''; - i := decode(r.s, i, fl); - result.floatVal := parseFloat(fl); - end; - nkStrLit..nkTripleStrLit: - i := decode(r.s, i, result.strVal); - nkSym: assert(false); - nkIdent: begin - i := fromBase62i(r.s, i, x); - fl := ''; - {@discard} decode(r.s, r.identOff+x, fl); - result.ident := getIdent(fl) - end - else assert(false); - end - end - else if r.s[i] >= #128 then begin - case kind of - nkCharLit..nkInt64Lit, nkFloatLit..nkFloat64Lit, - nkStrLit..nkTripleStrLit, nkSym, nkIdent: assert(false); - else begin end; - end; - r.pos := i; - // H3YYY - // 01234 - while r.pos <= endpos do - addSon(result, readNode(r, result.info, false)); - i := r.pos; - end - else assert(r.s[i] = #0); - end; - r.pos := i; -end; - -function readRod(const filename: string; const flags: TRodReaderFlags): PNode; -var - r: TRodReader; - info: TLineInfo; -begin - result := nil; - initRodReader(r, filename, flags); - info := newLineInfo(changeFileExt(filename, '.nim'), -1, -1); - if r.pos > 0 then - result := readNode(r, info, false); -end; - -end. diff --git a/nim/ropes.pas b/nim/ropes.pas index 0e4b4981b..e82f1e96d 100644 --- a/nim/ropes.pas +++ b/nim/ropes.pas @@ -14,7 +14,7 @@ unit ropes; efficiently; especially concatenation is done in O(1) instead of O(N). Ropes make use a lazy evaluation: They are essentially concatenation trees that are only flattened when converting to a native Nimrod - string or when written to disk. The empty string is represented by a + string or when written to disk. The empty string is represented with a nil pointer. A little picture makes everything clear: @@ -57,10 +57,6 @@ unit ropes; To cache them they are inserted in another tree, a splay tree for best performance. But for the caching tree we use the leafs' left and right pointers. - - Experiments show that for bootstrapping the whole compiler needs - ~1 MB less space because of this optimization. For bigger programs - this is likely to increase even further. } interface @@ -71,7 +67,7 @@ uses nsystem, msgs, strutils, platform, hashes, crc; const - CacheLeafs = True; + CacheLeafs = true; countCacheMisses = False; // see what our little optimization gives type @@ -85,7 +81,7 @@ type left, right: PRope; len: int; data: string; // != nil if a leaf - end; + end {@acyclic}; // the empty rope is represented by nil to safe space TRopeSeq = array of PRope; @@ -157,7 +153,7 @@ begin if hits+misses <> 0 then result := 'Misses: ' +{&} ToString(misses) +{&} ' total: ' +{&} toString(hits+misses) +{&} - ' quot: ' +{&} toStringF(misses / (hits+misses)) + ' quot: ' +{&} toStringF(toFloat(misses) / toFloat(hits+misses)) else result := '' end; @@ -376,7 +372,7 @@ procedure InitStack(var stack: TRopeSeq); begin {@ignore} setLength(stack, 0); - {@emit stack := [];} + {@emit stack := @[];} end; procedure push(var stack: TRopeSeq; r: PRope); @@ -439,6 +435,8 @@ begin if head <> nil then newWriteRopeRec(f, head); nimCloseFile(f); end + else + rawMessage(errCannotOpenFile, filename); end; procedure recRopeToStr(var result: string; var resultLen: int; p: PRope); @@ -519,7 +517,9 @@ begin start := i; while (i <= len + StrStart - 1) do if (frmt[i] <> '$') then inc(i) else break; - if i-1 >= start then app(result, ncopy(frmt, start, i-1)); + if i-1 >= start then begin + app(result, ncopy(frmt, start, i-1)); + end end; assert(RopeInvariant(result)); end; @@ -588,7 +588,7 @@ function newCrcFromRopeAux(r: PRope; startVal: TCrc32): TCrc32; var stack: TRopeSeq; it: PRope; - i: int; + L, i: int; begin initStack(stack); push(stack, r); @@ -600,8 +600,12 @@ begin it := it.left; end; assert(it.data <> snil); - for i := strStart to length(it.data)+strStart-1 do + i := strStart; + L := length(it.data)+strStart; + while i < L do begin result := updateCrc32(it.data[i], result); + inc(i); + end end end; @@ -616,7 +620,7 @@ var c: TCrc32; begin c := crcFromFile(filename); - if int(c) <> crcFromRope(r) then begin + if c <> crcFromRope(r) then begin writeRope(r, filename); result := true end diff --git a/nim/rst.pas b/nim/rst.pas index 54958aff2..b5e5846b1 100644 --- a/nim/rst.pas +++ b/nim/rst.pas @@ -8,7 +8,7 @@ // unit rst; -// This module implements a *reStructuredText* parser. Currently, only a small +// This module implements a *reStructuredText* parser. Currently, only a // subset is provided. Later, there will be additions. interface @@ -126,7 +126,7 @@ type // the document or the section level: int; // valid for some node kinds sons: TRstNodeSeq; // the node's sons - end; + end {@acyclic}; function rstParse(const text: string; // the text to be parsed @@ -360,7 +360,7 @@ begin {@ignore} fillChar(result^, sizeof(result^), 0); {@emit - result.sons := []; + result.sons := @[]; } result.kind := kind; end; @@ -407,9 +407,9 @@ begin fillChar(result^, sizeof(result^), 0); {@emit} {@emit - result.subs := [];} + result.subs := @[];} {@emit - result.refs := [];} + result.refs := @[];} end; function tokInfo(const p: TRstParser; const tok: TToken): TLineInfo; @@ -456,9 +456,9 @@ begin p.indentStack := nil; pushInd(p, 0); {@emit - p.indentStack := [0];} + p.indentStack := @[0];} {@emit - p.tok := [];} + p.tok := @[];} p.idx := 0; p.filename := ''; p.hasToc := false; @@ -1535,9 +1535,9 @@ begin cols := nil; row := nil; {@emit - cols := [];} + cols := @[];} {@emit - row := [];} + row := @[];} a := nil; c := p.tok[p.idx].symbol[strStart]; while true do begin @@ -1873,13 +1873,6 @@ type TDirFlags = set of TDirFlag; TSectionParser = function (var p: TRstParser): PRstNode; -{@emit -function assigned(contentParser: TSectionParser): bool; -begin - result := contentParser <> nil; -end; -} - function parseDirective(var p: TRstParser; flags: TDirFlags; contentParser: TSectionParser): PRstNode; var diff --git a/nim/scanner.pas b/nim/scanner.pas index b9a61f95d..98bb54c07 100644 --- a/nim/scanner.pas +++ b/nim/scanner.pas @@ -24,7 +24,7 @@ interface uses charsets, nsystem, sysutils, hashes, options, msgs, strutils, platform, idents, - lexbase, wordrecg; + lexbase, llstream, wordrecg; const MaxLineLength = 80; // lines longer than this lead to a warning @@ -40,15 +40,18 @@ type tkSymbol, // keywords: //[[[cog - //keywords = (file("data/keywords.txt").read()).split() + //from string import split, capitalize + //keywords = split(open("data/keywords.txt").read()) //idents = "" //strings = "" //i = 1 //for k in keywords: - // idents += "tk" + k.capitalize() + ", " - // strings += "'" + k + "', " - // if i % 4 == 0: idents += "\n"; strings += "\n" - // i += 1 + // idents = idents + "tk" + capitalize(k) + ", " + // strings = strings + "'" + k + "', " + // if i % 4 == 0: + // idents = idents + "\n" + // strings = strings + "\n" + // i = i + 1 //cog.out(idents) //]]] tkAddr, tkAnd, tkAs, tkAsm, @@ -156,11 +159,14 @@ type // needs so much look-ahead end; +var + gLinesCompiled: int; // all lines that have been compiled + procedure pushInd(var L: TLexer; indent: int); function isKeyword(kind: TTokType): boolean; -function openLexer(out lex: TLexer; const filename: string): TResult; -procedure bufferLexer(out lex: TLexer; const buf: string); +procedure openLexer(out lex: TLexer; const filename: string; + inputstream: PLLStream); procedure rawGetTok(var L: TLexer; var tok: TToken); // reads in the next token into tok and skips it @@ -194,8 +200,10 @@ var begin len := length(L.indentStack); setLength(L.indentStack, len+1); - assert(indent > L.indentStack[len-1]); - L.indentstack[len] := indent; + if (indent > L.indentStack[len-1]) then + L.indentstack[len] := indent + else + InternalError('pushInd'); //writeln('push indent ', indent); end; @@ -222,7 +230,7 @@ begin else if (tok.ident <> nil) then result := tok.ident.s else begin - assert(false); + InternalError('tokToStr'); result := '' end end @@ -251,40 +259,25 @@ begin L.ident := dummyIdent; // this prevents many bugs! end; -function openLexer(out lex: TLexer; const filename: string): TResult; +procedure openLexer(out lex: TLexer; const filename: string; + inputstream: PLLStream); begin {@ignore} - FillChar(lex, sizeof(lex), 0); // work around Delphi/fpc bug + FillChar(lex, sizeof(lex), 0); {@emit} - if initBaseLexer(lex, filename) then - result := Success - else - result := Failure; + openBaseLexer(lex, inputstream); {@ignore} setLength(lex.indentStack, 1); lex.indentStack[0] := 0; -{@emit lex.indentStack := [0]; } +{@emit lex.indentStack := @[0]; } lex.filename := filename; lex.indentAhead := -1; end; -procedure bufferLexer(out lex: TLexer; const buf: string); -begin -{@ignore} - FillChar(lex, sizeof(lex), 0); // work around Delphi/fpc bug -{@emit} - initBaseLexerFromBuffer(lex, buf); -{@ignore} - setLength(lex.indentStack, 1); - lex.indentStack[0] := 0; -{@emit lex.indentStack := [0]; } - lex.filename := 'buffer'; - lex.indentAhead := -1; -end; - procedure closeLexer(var lex: TLexer); begin - deinitBaseLexer(lex); + inc(gLinesCompiled, lex.LineNumber); + closeBaseLexer(lex); end; function getColumn(const L: TLexer): int; @@ -493,7 +486,7 @@ begin end end end; - else assert(false); + else InternalError(getLineInfo(L), 'getNumber'); end; // now look at the optional type suffix: case result.tokType of @@ -505,7 +498,7 @@ begin // XXX: Test this on big endian machine! tkFloat64Lit: result.fNumber := ({@cast}PFloat64(addr(xi)))^; - else assert(false); + else InternalError(getLineInfo(L), 'getNumber'); end end else if isFloatLiteral(result.literal) diff --git a/nim/sem.pas b/nim/sem.pas index d57af7be6..59bf29be5 100644 --- a/nim/sem.pas +++ b/nim/sem.pas @@ -8,7 +8,7 @@ // unit sem; -// This module implements the semantic checking. +// This module implements the semantic checking pass. interface @@ -17,206 +17,20 @@ interface uses sysutils, nsystem, charsets, strutils, lists, options, scanner, ast, astalgo, trees, treetab, wordrecg, - ropes, msgs, platform, nos, condsyms, idents, rnimsyn, types, - extccomp, nmath, magicsys, nversion, nimsets, pnimsyn, ntime, backends; + ropes, msgs, nos, condsyms, idents, rnimsyn, types, platform, + nmath, magicsys, pnimsyn, nversion, nimsets, + semdata, evals, semfold, importer, procfind, lookups, rodread, + pragmas, passes; + +//var +// point: array [0..3] of int; -const - genPrefix = '::'; // prefix for generated names - -type - TOptionEntry = object(lists.TListEntry) - // entries to put on a stack for pragma parsing - options: TOptions; - defaultCC: TCallingConvention; - dynlib: PLib; - Notes: TNoteKinds; - end; - POptionEntry = ^TOptionEntry; - - TProcCon = record // procedure context; also used for top-level - // statements - owner: PSym; // the symbol this context belongs to - resultSym: PSym; // the result symbol (if we are in a proc) - nestedLoopCounter: int; // whether we are in a loop or not - nestedBlockCounter: int; // whether we are in a block or not - end; - PProcCon = ^TProcCon; - - PTransCon = ^TTransCon; - TTransCon = record // part of TContext; stackable - mapping: TIdNodeTable; // mapping from symbols to nodes - owner: PSym; // current owner - forStmt: PNode; // current for stmt - next: PTransCon; - params: TNodeSeq; // parameters passed to the proc - end; - - PContext = ^TContext; - TContext = object(NObject) // a context represents a module - module: PSym; // the module sym belonging to the context - tab: TSymTab; // each module has its own symbol table - AmbigiousSymbols: TStrTable; // contains all ambigious symbols (we cannot - // store this info in the syms themselves!) - generics: PNode; // a list of the things to compile; list of - // nkExprEqExpr nodes which contain the generic - // symbol and the instantiated symbol - converters: TSymSeq; // sequence of converters - optionStack: TLinkedList; - libs: TLinkedList; // all libs used by this module - b: PBackend; - p: PProcCon; // procedure context - transCon: PTransCon; // top of a TransCon stack - lastException: PNode; // last exception - importModule: function (const filename: string; backend: PBackend): PSym; - includeFile: function (const filename: string): PNode; - end; - -function newContext(const nimfile: string): PContext; -function newProcCon(owner: PSym): PProcCon; - -function semModule(c: PContext; n: PNode): PNode; - // Does the semantic pass for node n. The new node is returned and - // n shall not be used after this call! - -procedure importAllSymbols(c: PContext; fromMod: PSym); +function semPass(): TPass; implementation -function newTransCon(): PTransCon; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - initIdNodeTable(result.mapping); -{@emit result.params := [];} -end; - -procedure pushTransCon(c: PContext; t: PTransCon); -begin - t.next := c.transCon; - c.transCon := t; -end; - -procedure popTransCon(c: PContext); -begin - assert(c.transCon <> nil); - c.transCon := c.transCon.next; -end; - -function lastOptionEntry(c: PContext): POptionEntry; -begin - result := POptionEntry(c.optionStack.tail); -end; - -function newProcCon(owner: PSym): PProcCon; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.owner := owner; -end; - -function newOptionEntry(): POptionEntry; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.options := gOptions; - result.defaultCC := ccDefault; - result.dynlib := nil; - result.notes := gNotes; -end; - -function newContext(const nimfile: string): PContext; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - InitSymTab(result.tab); - initStrTable(result.AmbigiousSymbols); - initLinkedList(result.optionStack); - initLinkedList(result.libs); - append(result.optionStack, newOptionEntry()); - result.module := nil; - result.generics := newNode(nkStmtList); -{@emit result.converters := [];} -end; - -procedure addConverter(c: PContext; conv: PSym); -var - i, L: int; -begin - L := length(c.converters); - for i := 0 to L-1 do - if c.converters[i].id = conv.id then exit; - setLength(c.converters, L+1); - c.converters[L] := conv; -end; - -// -------------------- embedded debugger ------------------------------------ - -procedure embeddedDbg(c: PContext; n: PNode); -begin - if optVerbose in gGlobalOptions then liMessage(n.info, hintProcessing); - //{@discard} inCheckpoint(n.info) -end; - -// --------------------------------------------------------------------------- - -function newLib(kind: TLibKind): PLib; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.kind := kind; - initObjectSet(result.syms) -end; - -procedure addToLib(lib: PLib; sym: PSym); -begin - ObjectSetIncl(lib.syms, sym); - assert(sym.annex = nil); - sym.annex := lib -end; - function semp(c: PContext; n: PNode): PNode; forward; -var - gOwners: array of PSym; // owner stack (used for initializing the - // owner field of syms) - // the documentation comment always gets - // assigned to the current owner - // BUGFIX: global array is needed! -{@emit gOwners := []; } - -function getCurrOwner(c: PContext): PSym; -begin - result := gOwners[high(gOwners)]; -end; - -procedure PushOwner(c: PContext; owner: PSym); -var - len: int; -begin - len := length(gOwners); - setLength(gOwners, len+1); - gOwners[len] := owner; -end; - -procedure PopOwner(c: PContext); -var - len: int; -begin - len := length(gOwners); - assert(len > 0); - setLength(gOwners, len - 1); -end; - function considerAcc(n: PNode): PIdent; var x: PNode; @@ -235,57 +49,16 @@ end; function newSymS(const kind: TSymKind; n: PNode; c: PContext): PSym; begin - result := newSym(kind, considerAcc(n), getCurrOwner(c)); + result := newSym(kind, considerAcc(n), getCurrOwner()); result.info := n.info; end; -function newTypeS(const kind: TTypeKind; c: PContext): PType; -begin - result := newType(kind, getCurrOwner(c)) -end; - -procedure fillTypeS(dest: PType; const kind: TTypeKind; c: PContext); -begin - dest.kind := kind; - dest.owner := getCurrOwner(c); - dest.size := -1; -end; - -function makeRangeType(c: PContext; first, last: biggestInt): PType; -var - n: PNode; -begin - n := newNode(nkRange); - addSon(n, newIntNode(nkIntLit, first)); - addSon(n, newIntNode(nkIntLit, last)); - result := newTypeS(tyRange, c); - result.n := n; - addSon(result, getSysType(tyInt)); // basetype of range -end; - -function makePtrType(c: PContext; baseType: PType): PType; -begin - assert(baseType <> nil); - result := newTypeS(tyPtr, c); - addSon(result, baseType); -end; - -function makeVarType(c: PContext; baseType: PType): PType; -begin - assert(baseType <> nil); - result := newTypeS(tyVar, c); - addSon(result, baseType); -end; - -{$include 'lookup.pas'} - function semIdentVis(c: PContext; kind: TSymKind; n: PNode; const allowed: TSymFlags): PSym; forward; // identifier with visability function semIdentWithPragma(c: PContext; kind: TSymKind; n: PNode; const allowed: TSymFlags): PSym; forward; -function semStmt(c: PContext; n: PNode): PNode; forward; function semStmtScope(c: PContext; n: PNode): PNode; forward; type @@ -298,24 +71,49 @@ function semExprWithType(c: PContext; n: PNode; flags: TExprFlags = {@set}[]): PNode; forward; function semLambda(c: PContext; n: PNode): PNode; forward; function semTypeNode(c: PContext; n: PNode; prev: PType): PType; forward; +function semStmt(c: PContext; n: PNode): PNode; forward; -function semConstExpr(c: PContext; n: PNode): PNode; forward; - // evaluates the const - -function getConstExpr(c: PContext; n: PNode): PNode; forward; - // evaluates the constant expression or returns nil if it is no constant - // expression - -function eval(c: PContext; n: PNode): PNode; forward; -// eval never returns nil! This simplifies the code a lot and -// makes it faster too. +function semConstExpr(c: PContext; n: PNode): PNode; +var + e: PNode; +begin + e := semExprWithType(c, n); + if e = nil then begin + liMessage(n.info, errConstExprExpected); + result := nil; exit + end; + result := getConstExpr(c.module, e); + if result = nil then begin + //writeln(output, renderTree(n)); + liMessage(n.info, errConstExprExpected); + end +end; +function semMacroExpr(c: PContext; n: PNode; sym: PSym): PNode; +var + p: PEvalContext; + s: PStackFrame; +begin + p := newEvalContext(c.module, ''); + s := newStackFrame(); + s.call := n; + setLength(s.params, 2); + s.params[0] := newNodeIT(nkNilLit, n.info, sym.typ.sons[0]); + s.params[1] := n; + pushStackFrame(p, s); + {@discard} eval(p, sym.ast.sons[codePos]); + result := s.params[0]; + popStackFrame(p); + if cyclicTree(result) then liMessage(n.info, errCyclicTree); + result := semStmt(c, result); + // now, that was easy ... + // and we get more flexibility than in any other programming language +end; {$include 'semtempl.pas'} -{$include 'instgen.pas'} +{$include 'seminst.pas'} {$include 'sigmatch.pas'} -{$include 'pragmas.pas'} procedure CheckBool(t: PNode); begin @@ -323,26 +121,6 @@ begin liMessage(t.Info, errExprMustBeBool); end; -procedure illFormedAst(n: PNode); -begin - liMessage(n.info, errIllFormedAstX, renderTree(n, {@set}[renderNoComments])); -end; - -function getSon(n: PNode; indx: int): PNode; -begin - if (n <> nil) and (indx < sonsLen(n)) then result := n.sons[indx] - else begin illFormedAst(n); result := nil end; -end; - -procedure checkSonsLen(n: PNode; len: int); -begin - if (n = nil) or (sonsLen(n) <> len) then illFormedAst(n); -end; - -procedure checkMinSonsLen(n: PNode; len: int); -begin - if (n = nil) or (sonsLen(n) < len) then illFormedAst(n); -end; procedure typeMismatch(n: PNode; formal, actual: PType); begin @@ -353,10 +131,7 @@ end; {$include 'semtypes.pas'} {$include 'semexprs.pas'} -{$include 'transf.pas'} {$include 'semstmts.pas'} -{$include 'semfold.pas'} -{$include 'eval.pas'} function semp(c: PContext; n: PNode): PNode; begin @@ -367,32 +142,80 @@ procedure addCodeForGenerics(c: PContext; n: PNode); var i: int; prc: PSym; + it: PNode; begin for i := 0 to sonsLen(c.generics)-1 do begin - assert(c.generics.sons[i].sons[1].kind = nkSym); - prc := c.generics.sons[i].sons[1].sym; - if (prc.kind in [skProc, skConverter]) and (prc.magic = mNone) then begin + it := c.generics.sons[i].sons[1]; + if it.kind <> nkSym then InternalError('addCodeForGenerics'); + prc := it.sym; + if (prc.kind in [skProc, skConverter]) and (prc.magic = mNone) then addSon(n, prc.ast); - end - end + end; end; -function semModule(c: PContext; n: PNode): PNode; +function myOpen(module: PSym; const filename: string): PPassContext; +var + c: PContext; begin - assert(c.p = nil); + c := newContext(module, filename); + if (c.p <> nil) then InternalError(module.info, 'sem.myOpen'); + c.semConstExpr := semConstExpr; c.p := newProcCon(nil); - pushOwner(c, c.module); - result := semStmtScope(c, n); - if eAfterModule in c.b.eventMask then begin - addCodeForGenerics(c, result); - result := transform(c, result); - c.b.afterModuleEvent(c.b, result); + pushOwner(c.module); + openScope(c.tab); // scope for imported symbols + SymTabAdd(c.tab, module); // a module knows itself + if sfSystemModule in module.flags then begin + magicsys.SystemModule := module; // set global variable! + InitSystem(c.tab); // currently does nothing + end + else begin + SymTabAdd(c.tab, magicsys.SystemModule); // import the "System" identifier + importAllSymbols(c, magicsys.SystemModule); end; - popOwner(c); + openScope(c.tab); // scope for the module's symbols + result := c +end; + +function myOpenCached(module: PSym; const filename: string; + rd: PRodReader): PPassContext; +var + c: PContext; +begin + c := PContext(myOpen(module, filename)); + c.fromCache := true; + result := c +end; + +function myProcess(context: PPassContext; n: PNode): PNode; +var + c: PContext; +begin + result := nil; + c := PContext(context); + result := semStmt(c, n); +end; + +function myClose(context: PPassContext; n: PNode): PNode; +var + c: PContext; +begin + c := PContext(context); + closeScope(c.tab); // close module's scope + rawCloseScope(c.tab); // imported symbols; don't check for unused ones! + if n = nil then result := newNode(nkStmtList) + else result := n; + addCodeForGenerics(c, result); + popOwner(); c.p := nil; end; -initialization - new(emptyNode); - emptyNode.kind := nkEmpty; +function semPass(): TPass; +begin + initPass(result); + result.open := myOpen; + result.openCached := myOpenCached; + result.close := myClose; + result.process := myProcess; +end; + end. diff --git a/nim/semexprs.pas b/nim/semexprs.pas index 699998a94..26e63c845 100644 --- a/nim/semexprs.pas +++ b/nim/semexprs.pas @@ -19,7 +19,8 @@ var d: PNode; begin result := semExpr(c, n, flags); - if result.typ = nil then + if result = nil then InternalError('semExprWithType'); + if (result.typ = nil) then liMessage(n.info, errExprXHasNoType, renderTree(result, {@set}[renderNoComments])); if result.typ.kind = tyVar then begin @@ -175,6 +176,7 @@ begin while (b <> nil) and (b.id <> a.id) do b := b.sons[0]; if b = nil then liMessage(n.info, errXcanNeverBeOfThisSubtype, typeToString(a)); + n.typ := getSysType(tyBool); end else liMessage(n.info, errIsExpectsTwoArguments); @@ -266,13 +268,11 @@ var typ: PType; i: int; begin - result := newNode(nkBracket); - result.info := n.info; + result := newNodeI(nkBracket, n.info); result.typ := newTypeS(tyArrayConstr, c); addSon(result.typ, nil); // index type if sonsLen(n) = 0 then - // empty array - addSon(result.typ, nil) // needs an empty basetype! + addSon(result.typ, newTypeS(tyEmpty, c)) // needs an empty basetype! else begin addSon(result, semExprWithType(c, n.sons[0])); typ := skipVar(result.sons[0].typ); @@ -282,13 +282,13 @@ begin end; addSon(result.typ, typ) end; - result.typ.sons[0] := makeRangeType(c, 0, sonsLen(result)-1); + result.typ.sons[0] := makeRangeType(c, 0, sonsLen(result)-1, n.info); end; const ConstAbstractTypes = {@set}[tyNil, tyChar, tyInt..tyInt64, tyFloat..tyFloat128, - tyArrayConstr, tyTuple, tyEmptySet, tySet]; + tyArrayConstr, tyTuple, tySet]; procedure fixAbstractType(c: PContext; n: PNode); var @@ -304,17 +304,15 @@ begin it.sons[1] := semArrayConstr(c, it.sons[1]); if skipVarGeneric(it.typ).kind = tyOpenArray then begin s := skipVarGeneric(it.sons[1].typ); - if (s.kind = tyArrayConstr) and (s.sons[1] = nil) then begin - s := copyType(s, getCurrOwner(c)); - s.id := getID(); + if (s.kind = tyArrayConstr) and (s.sons[1].kind = tyEmpty) then begin + s := copyType(s, getCurrOwner(), false); skipVarGeneric(s).sons[1] := elemType(skipVarGeneric(it.typ)); it.sons[1].typ := s; end end else if skipVarGeneric(it.sons[1].typ).kind in [tyNil, tyArrayConstr, - tyTuple, tyEmptySet, tySet] then begin + tyTuple, tySet] then begin s := skipVarGeneric(it.typ); - if s.kind = tyEmptySet then InternalError(it.info, 'fixAbstractType'); changeType(it.sons[1], s); n.sons[i] := it.sons[1]; end @@ -323,7 +321,7 @@ begin // an implicitely constructed array (passed to an open array): n.sons[i] := semArrayConstr(c, it); end; - else if (it.typ = nil) or (it.typ.kind = tyEmptySet) then + else if (it.typ = nil) then InternalError(it.info, 'fixAbstractType: ' + renderTree(it)); end end @@ -357,8 +355,9 @@ begin end; nkHiddenStdConv, nkHiddenSubConv, nkConv: begin // Object and tuple conversions are still addressable, so we skip them - if skipPtrsGeneric(n.sons[1].typ).kind in [tyOpenArray, - tyTuple, tyObject] then + //if skipPtrsGeneric(n.sons[1].typ).kind in [tyOpenArray, + // tyTuple, tyObject] then + if skipPtrsGeneric(n.typ).kind in [tyOpenArray, tyTuple, tyObject] then result := isAssignable(n.sons[1]) end; nkHiddenDeref, nkDerefExpr: result := true; @@ -377,7 +376,9 @@ begin else begin result := newNodeIT(nkHiddenAddr, n.info, makeVarType(c, n.typ)); addSon(result, n); - if not isAssignable(n) then liMessage(n.info, errVarForOutParamNeeded); + if not isAssignable(n) then begin + liMessage(n.info, errVarForOutParamNeeded); + end end end; @@ -414,10 +415,11 @@ end; procedure analyseIfAddressTakenInCall(c: PContext; n: PNode); const - FakeVarParams = {@set}[mNew, mNewFinalize, mInc, mDec, mIncl, + FakeVarParams = {@set}[mNew, mNewFinalize, mInc, ast.mDec, mIncl, mExcl, mSetLengthStr, mSetLengthSeq, mAppendStrCh, mAppendStrStr, mSwap, - mAppendSeqElem, mAppendSeqSeq]; + mAppendSeqElem, mAppendSeqSeq, + mNewSeq]; var i: int; t: PType; @@ -430,29 +432,6 @@ begin if (i < sonsLen(t)) and (skipGeneric(t.sons[i]).kind = tyVar) then n.sons[i] := analyseIfAddressTaken(c, n.sons[i]); end; -(* -function lastPassOverArg(c: PContext; n: PNode; fakeVar: bool): PNode; -// this pass does various things: -// - it checks whether an address has been taken (needed for the ECMAScript -// code generator) -// - it changes the type of the argument (if it is not a concrete type) -begin - -end; - -procedure lastPassOverCall(c: PContext; n: PNode); -var - i: int; - fakeVar: bool; -begin - checkMinSonsLen(n, 1); - t := n.sons[0].typ; - fakeVar := (n.sons[0].kind = nkSym) - and (n.sons[0].sym.magic in FakeVarParams); - for i := 1 to sonsLen(n)-1 do begin - n.sons[i] := lastPassOverArg(c, n); - end -end;*) function semIndirectOp(c: PContext; n: PNode): PNode; var @@ -500,6 +479,7 @@ begin end else begin result := overloadedCallOpr(c, n); + if result = nil then result := semDirectCall(c, n); if result = nil then liMessage(n.info, errExprCannotBeCalled); end; fixAbstractType(c, result); @@ -508,6 +488,7 @@ end; function semDirectOp(c: PContext; n: PNode): PNode; begin + // this seems to be a hotspot in the compiler! semOpAux(c, n); result := semDirectCall(c, n); if result = nil then begin @@ -564,7 +545,7 @@ var ident: PIdent; begin case n.kind of - nkIdent: result := SymtabGet(c.Tab, n.ident); + nkIdent: result := SymtabGet(c.Tab, n.ident); // no need for stub loading nkDotExpr, nkQualified: begin checkSonsLen(n, 2); result := nil; @@ -615,6 +596,7 @@ begin end; function semMagic(c: PContext; n: PNode; s: PSym): PNode; +// this is a hotspot in the compiler! begin result := n; case s.magic of // magics that need special treatment @@ -632,7 +614,7 @@ begin result.typ := n.sons[1].typ; end; mInc: result := semIncSucc(c, setMs(n, s), 'inc'); - mDec: result := semIncSucc(c, setMs(n, s), 'dec'); + ast.mDec: result := semIncSucc(c, setMs(n, s), 'dec'); mOrd: result := semOrd(c, setMs(n, s)); else result := semDirectOp(c, n); end; @@ -683,8 +665,7 @@ begin end; function lookupInRecordAndBuildCheck(c: PContext; n, r: PNode; - field: PIdent; - var check: PNode): PSym; + field: PIdent; var check: PNode): PSym; // transform in a node that contains the runtime check for the // field, if it is in a case-part... var @@ -856,10 +837,10 @@ begin // allow things like "".replace(...) // --> replace("", ...) f := SymTabGet(c.tab, i); + if (f <> nil) and (f.kind = skStub) then loadStub(f); if (f <> nil) and (f.kind in [skProc, skIterator]) then begin - result := newNode(nkDotCall); + result := newNodeI(nkDotCall, n.info); // This special node kind is to merge with the call handler in `semExpr`. - result.info := n.info; addSon(result, newIdentNode(i, n.info)); addSon(result, copyTree(n.sons[0])); end @@ -961,7 +942,7 @@ begin nkElseExpr: begin checkSonsLen(it, 1); it.sons[0] := semExprWithType(c, it.sons[0]); - assert(typ <> nil); + if (typ = nil) then InternalError(it.info, 'semIfExpr'); it.sons[0] := fitNode(c, typ, it.sons[0]); end; else illFormedAst(n); @@ -976,10 +957,10 @@ var i: int; m: PNode; begin - result := newNode(nkCurly); - result.info := n.info; - if sonsLen(n) = 0 then - result.typ := newTypeS(tyEmptySet, c) + result := newNodeI(nkCurly, n.info); + result.typ := newTypeS(tySet, c); + if sonsLen(n) = 0 then + addSon(result.typ, newTypeS(tyEmpty, c)) else begin // only semantic checking for all elements, later type checking: typ := nil; @@ -996,20 +977,17 @@ begin if typ = nil then typ := skipVar(n.sons[i].typ) end end; - - result.typ := newTypeS(tySet, c); if not isOrdinalType(typ) then begin liMessage(n.info, errOrdinalTypeExpected); exit end; if lengthOrd(typ) > MaxSetElements then - typ := makeRangeType(c, 0, MaxSetElements-1); + typ := makeRangeType(c, 0, MaxSetElements-1, n.info); addSon(result.typ, typ); for i := 0 to sonsLen(n)-1 do begin if n.sons[i].kind = nkRange then begin - m := newNode(nkRange); - m.info := n.sons[i].info; + m := newNodeI(nkRange, n.sons[i].info); addSon(m, fitNode(c, typ, n.sons[i].sons[0])); addSon(m, fitNode(c, typ, n.sons[i].sons[1])); end @@ -1037,7 +1015,7 @@ begin for i := 0 to len-1 do begin if result = paTupleFields then begin if (n.sons[i].kind <> nkExprColonExpr) - or (n.sons[i].sons[0].kind <> nkIdent) then begin + or not (n.sons[i].sons[0].kind in [nkSym, nkIdent]) then begin liMessage(n.sons[i].info, errNamedExprExpected); result := paNone; exit end @@ -1060,16 +1038,18 @@ var id: PIdent; f: PSym; begin - result := newNode(nkPar); - result.info := n.info; + result := newNodeI(nkPar, n.info); typ := newTypeS(tyTuple, c); - typ.n := newNode(nkRecList); // nkIdentDefs + typ.n := newNodeI(nkRecList, n.info); // nkIdentDefs IntSetInit(ids); for i := 0 to sonsLen(n)-1 do begin if (n.sons[i].kind <> nkExprColonExpr) - or (n.sons[i].sons[0].kind <> nkIdent) then + or not (n.sons[i].sons[0].kind in [nkSym, nkIdent]) then illFormedAst(n.sons[i]); - id := n.sons[i].sons[0].ident; + if n.sons[i].sons[0].kind = nkIdent then + id := n.sons[i].sons[0].ident + else + id := n.sons[i].sons[0].sym.name; if IntSetContainsOrIncl(ids, id.id) then liMessage(n.sons[i].info, errFieldInitTwice, id.s); n.sons[i].sons[1] := semExprWithType(c, n.sons[i].sons[1]); @@ -1141,28 +1121,26 @@ begin result := semFieldAccess(c, n, flags); end; -function semMacroExpr(c: PContext; n: PNode; sym: PSym): PNode; forward; - function semExpr(c: PContext; n: PNode; flags: TExprFlags = {@set}[]): PNode; var s: PSym; begin result := n; if n = nil then exit; + if nfSem in n.flags then exit; case n.kind of // atoms: nkIdent: begin - // lookup the symbol: - s := SymtabGet(c.Tab, n.ident); - if s <> nil then result := semSym(c, n, s, flags) - else liMessage(n.info, errUndeclaredIdentifier, n.ident.s); + s := lookUp(c, n); + result := semSym(c, n, s, flags); end; nkSym: begin s := n.sym; include(s.flags, sfUsed); if (s.kind = skType) and not (efAllowType in flags) then liMessage(n.info, errATypeHasNoValue); - if s.magic <> mNone then + if (s.magic <> mNone) and + (s.kind in [skProc, skIterator, skConverter]) then liMessage(n.info, errInvalidContextForBuiltinX, s.name.s); end; nkEmpty, nkNone: begin end; @@ -1304,5 +1282,6 @@ begin renderTree(n, {@set}[renderNoComments])); result := nil end - end + end; + include(result.flags, nfSem); end; diff --git a/nim/semfold.pas b/nim/semfold.pas index 00d84f836..9c27c3a16 100644 --- a/nim/semfold.pas +++ b/nim/semfold.pas @@ -6,10 +6,37 @@ // See the file "copying.txt", included in this // distribution, for details about the copyright. // +unit semfold; // this module folds constants; used by semantic checking phase // and evaluation phase +interface + +{$include 'config.inc'} + +uses + sysutils, nsystem, charsets, strutils, + lists, options, ast, astalgo, trees, treetab, nimsets, ntime, nversion, + platform, nmath, msgs, nos, condsyms, idents, rnimsyn, types; + +function getConstExpr(module: PSym; n: PNode): PNode; + // evaluates the constant expression or returns nil if it is no constant + // expression + +function evalOp(m: TMagic; n, a, b: PNode): PNode; +function leValueConv(a, b: PNode): Boolean; + +function newIntNodeT(const intVal: BiggestInt; n: PNode): PNode; +function newFloatNodeT(const floatVal: BiggestFloat; n: PNode): PNode; +function newStrNodeT(const strVal: string; n: PNode): PNode; +function getInt(a: PNode): biggestInt; +function getFloat(a: PNode): biggestFloat; +function getStr(a: PNode): string; +function getStrOrChar(a: PNode): string; + +implementation + function newIntNodeT(const intVal: BiggestInt; n: PNode): PNode; begin if skipVarGenericRange(n.typ).kind = tyChar then @@ -194,14 +221,22 @@ begin result := nimsets.symdiffSets(a, b); result.info := n.info; end; - mInSet: result := newIntNodeT(Ord(inSet(a, b)), n); mConStrStr: result := newStrNodeT(getStrOrChar(a)+{&}getStrOrChar(b), n); - mRepr: result := newStrNodeT(renderTree(a, {@set}[renderNoComments]), n); + mInSet: result := newIntNodeT(Ord(inSet(a, b)), n); + mRepr: begin + // BUGFIX: we cannot eval mRepr here. But this means that it is not + // available for interpretation. I don't know how to fix this. + //result := newStrNodeT(renderTree(a, {@set}[renderNoComments]), n); + end; mIntToStr, mInt64ToStr, mBoolToStr, mCharToStr: result := newStrNodeT(toString(getOrdValue(a)), n); mFloatToStr: result := newStrNodeT(toStringF(getFloat(a)), n); mCStrToStr: result := newStrNodeT(getStrOrChar(a), n); mStrToStr: result := a; + mArrToSeq: begin + result := copyTree(a); + result.typ := n.typ; + end; mExit, mInc, ast.mDec, mAssert, mSwap, mAppendStrCh, mAppendStrStr, mAppendSeqElem, mAppendSeqSeq, mSetLengthStr, mSetLengthSeq, mNLen..mNError: begin end; @@ -209,7 +244,7 @@ begin end end; -function getConstIfExpr(c: PContext; n: PNode): PNode; +function getConstIfExpr(c: PSym; n: PNode): PNode; var i: int; it, e: PNode; @@ -236,7 +271,7 @@ begin end end; -function partialAndExpr(c: PContext; n: PNode): PNode; +function partialAndExpr(c: PSym; n: PNode): PNode; // partial evaluation var a, b: PNode; @@ -245,19 +280,17 @@ begin a := getConstExpr(c, n.sons[1]); b := getConstExpr(c, n.sons[2]); if a <> nil then begin - assert(a.kind in [nkIntLit..nkInt64Lit]); - if a.intVal = 0 then result := a + if getInt(a) = 0 then result := a else if b <> nil then result := b else result := n.sons[2] end else if b <> nil then begin - assert(b.kind in [nkIntLit..nkInt64Lit]); - if b.intVal = 0 then result := b + if getInt(b) = 0 then result := b else result := n.sons[1] end end; -function partialOrExpr(c: PContext; n: PNode): PNode; +function partialOrExpr(c: PSym; n: PNode): PNode; // partial evaluation var a, b: PNode; @@ -266,14 +299,12 @@ begin a := getConstExpr(c, n.sons[1]); b := getConstExpr(c, n.sons[2]); if a <> nil then begin - assert(a.kind in [nkIntLit..nkInt64Lit]); - if a.intVal <> 0 then result := a + if getInt(a) <> 0 then result := a else if b <> nil then result := b else result := n.sons[2] end else if b <> nil then begin - assert(b.kind in [nkIntLit..nkInt64Lit]); - if b.intVal <> 0 then result := b + if getInt(b) <> 0 then result := b else result := n.sons[1] end end; @@ -298,7 +329,7 @@ begin end end; -function getConstExpr(c: PContext; n: PNode): PNode; +function getConstExpr(module: PSym; n: PNode): PNode; var s: PSym; a, b: PNode; @@ -312,6 +343,8 @@ begin result := newIntNodeT(s.position, n) else if (s.kind = skConst) then begin case s.magic of + mIsMainModule: + result := newIntNodeT(ord(sfMainModule in module.flags), n); mCompileDate: result := newStrNodeT(ntime.getDateStr(), n); mCompileTime: result := newStrNodeT(ntime.getClockStr(), n); mNimrodVersion: result := newStrNodeT(VersionAsString, n); @@ -327,7 +360,7 @@ begin end end; nkCharLit..nkNilLit: result := copyNode(n); - nkIfExpr: result := getConstIfExpr(c, n); + nkIfExpr: result := getConstIfExpr(module, n); nkCall: begin if (n.sons[0].kind <> nkSym) then exit; s := n.sons[0].sym; @@ -356,10 +389,10 @@ begin result := newIntNodeT(lastOrd(skipVarGeneric(n.sons[1].typ)), n); end; else begin - a := getConstExpr(c, n.sons[1]); + a := getConstExpr(module, n.sons[1]); if a = nil then exit; if sonsLen(n) > 2 then begin - b := getConstExpr(c, n.sons[2]); + b := getConstExpr(module, n.sons[2]); if b = nil then exit end else b := nil; @@ -372,7 +405,7 @@ begin end end; nkAddr: begin - a := getConstExpr(c, n.sons[0]); + a := getConstExpr(module, n.sons[0]); if a <> nil then begin result := n; n.sons[0] := a @@ -381,16 +414,16 @@ begin nkBracket: begin result := copyTree(n); for i := 0 to sonsLen(n)-1 do begin - a := getConstExpr(c, n.sons[i]); + a := getConstExpr(module, n.sons[i]); if a = nil then begin result := nil; exit end; result.sons[i] := a; end; include(result.flags, nfAllConst); end; nkRange: begin - a := getConstExpr(c, n.sons[0]); + a := getConstExpr(module, n.sons[0]); if a = nil then exit; - b := getConstExpr(c, n.sons[1]); + b := getConstExpr(module, n.sons[1]); if b = nil then exit; result := copyNode(n); addSon(result, a); @@ -399,7 +432,7 @@ begin nkCurly: begin result := copyTree(n); for i := 0 to sonsLen(n)-1 do begin - a := getConstExpr(c, n.sons[i]); + a := getConstExpr(module, n.sons[i]); if a = nil then begin result := nil; exit end; result.sons[i] := a; end; @@ -409,14 +442,14 @@ begin result := copyTree(n); if (sonsLen(n) > 0) and (n.sons[0].kind = nkExprColonExpr) then begin for i := 0 to sonsLen(n)-1 do begin - a := getConstExpr(c, n.sons[i].sons[1]); + a := getConstExpr(module, n.sons[i].sons[1]); if a = nil then begin result := nil; exit end; result.sons[i].sons[1] := a; end end else begin for i := 0 to sonsLen(n)-1 do begin - a := getConstExpr(c, n.sons[i]); + a := getConstExpr(module, n.sons[i]); if a = nil then begin result := nil; exit end; result.sons[i] := a; end @@ -424,7 +457,7 @@ begin include(result.flags, nfAllConst); end; nkChckRangeF, nkChckRange64, nkChckRange: begin - a := getConstExpr(c, n.sons[0]); + a := getConstExpr(module, n.sons[0]); if a = nil then exit; if leValueConv(n.sons[1], a) and leValueConv(a, n.sons[2]) then begin result := a; // a <= x and x <= b @@ -436,13 +469,13 @@ begin [typeToString(n.sons[0].typ), typeToString(n.typ)])); end; nkStringToCString, nkCStringToString: begin - a := getConstExpr(c, n.sons[0]); + a := getConstExpr(module, n.sons[0]); if a = nil then exit; result := a; result.typ := n.typ; end; nkHiddenStdConv, nkHiddenSubConv, nkConv, nkCast: begin - a := getConstExpr(c, n.sons[1]); + a := getConstExpr(module, n.sons[1]); if a = nil then exit; case skipRange(n.typ).kind of tyInt..tyInt64: begin @@ -478,18 +511,4 @@ begin end end; -function semConstExpr(c: PContext; n: PNode): PNode; -var - e: PNode; -begin - e := semExprWithType(c, n); - if e = nil then begin - liMessage(n.info, errConstExprExpected); - result := nil; exit - end; - result := getConstExpr(c, e); - if result = nil then begin - //writeln(output, renderTree(n)); - liMessage(n.info, errConstExprExpected); - end -end; +end. diff --git a/nim/semstmts.pas b/nim/semstmts.pas index 4d8372a19..7d6403db4 100644 --- a/nim/semstmts.pas +++ b/nim/semstmts.pas @@ -9,6 +9,11 @@ // this module does the semantic checking of statements +function isTopLevel(c: PContext): bool; +begin + result := c.tab.tos <= 2 +end; + function semWhen(c: PContext; n: PNode): PNode; var i: int; @@ -23,7 +28,7 @@ begin checkSonsLen(it, 2); e := semConstExpr(c, it.sons[0]); checkBool(e); - assert(e.kind = nkIntLit); + if (e.kind <> nkIntLit) then InternalError(n.info, 'semWhen'); if (e.intVal <> 0) and (result = nil) then result := semStmt(c, it.sons[1]); // do not open a new scope! end; @@ -35,7 +40,11 @@ begin else illFormedAst(n) end end; - if result = nil then result := newNode(nkNilLit); + if result = nil then result := newNodeI(nkNilLit, n.info); + // The ``when`` statement implements the mechanism for platform dependant + // code. Thus we try to ensure here consistent ID distribution after the + // ``when`` statement. + IDsynchronizationPoint(200); end; function semIf(c: PContext; n: PNode): PNode; @@ -81,19 +90,15 @@ begin if n.sons[0] <> nil then begin if n.sons[0].kind = nkIdent then begin // lookup the symbol: - s := SymtabGet(c.Tab, n.sons[0].ident); - if s <> nil then begin - if (s.kind = skLabel) and (s.owner.id = c.p.owner.id) then begin - x := newSymNode(s); - x.info := n.info; - include(s.flags, sfUsed); - n.sons[0] := x - end - else - liMessage(n.info, errInvalidControlFlowX, s.name.s) + s := lookUp(c, n.sons[0]); + if (s.kind = skLabel) and (s.owner.id = c.p.owner.id) then begin + x := newSymNode(s); + x.info := n.info; + include(s.flags, sfUsed); + n.sons[0] := x end else - liMessage(n.info, errUndeclaredIdentifier, n.sons[0].ident.s); + liMessage(n.info, errInvalidControlFlowX, s.name.s) end else illFormedAst(n) end @@ -155,8 +160,10 @@ begin sub := ncopy(str, b+1, c-1); if sub <> '' then begin e := SymtabGet(con.tab, getIdent(sub)); - if e <> nil then + if e <> nil then begin + if e.kind = skStub then loadStub(e); addSon(result, newSymNode(e)) + end else addSon(result, newStrNode(nkStrLit, sub)); end; @@ -314,8 +321,7 @@ begin // check for type compatibility: restype := c.p.owner.typ.sons[0]; if (restype <> nil) then begin - a := newNode(nkAsgn); - a.info := n.sons[0].info; + a := newNodeI(nkAsgn, n.sons[0].info); n.sons[0] := fitNode(c, restype, n.sons[0]); // optimize away ``return result``, because it would be transferred @@ -325,7 +331,7 @@ begin n.sons[0] := nil; end else begin - assert(c.p.resultSym <> nil); + if (c.p.resultSym = nil) then InternalError(n.info, 'semReturn'); addSon(a, semExprWithType(c, newSymNode(c.p.resultSym))); addSon(a, n.sons[0]); n.sons[0] := a; @@ -350,7 +356,7 @@ begin restype := c.p.owner.typ.sons[0]; if (restype <> nil) then begin n.sons[0] := fitNode(c, restype, n.sons[0]); - assert(n.sons[0].typ <> nil); + if (n.sons[0].typ = nil) then InternalError(n.info, 'semYield'); end else liMessage(n.info, errCannotReturnExpr); @@ -388,8 +394,9 @@ begin typ := nil; if a.sons[len-1] <> nil then begin def := semExprWithType(c, a.sons[len-1]); + // BUGFIX: ``fitNode`` is needed here! // check type compability between def.typ and typ: - if (typ <> nil) then def := fitRemoveHiddenConv(c, typ, def) + if (typ <> nil) then def := fitNode(c, typ, def) else typ := def.typ; end else @@ -405,8 +412,7 @@ begin if v.flags * [sfStar, sfMinus] <> {@set}[] then include(v.flags, sfInInterface); addInterfaceDecl(c, v); - b := newNode(nkIdentDefs); - b.info := a.info; + b := newNodeI(nkIdentDefs, a.info); addSon(b, newSymNode(v)); addSon(b, nil); // no type description addSon(b, copyTree(def)); @@ -449,8 +455,7 @@ begin if v.flags * [sfStar, sfMinus] <> {@set}[] then include(v.flags, sfInInterface); addInterfaceDecl(c, v); - b := newNode(nkConstDef); - b.info := a.info; + b := newNodeI(nkConstDef, a.info); addSon(b, newSymNode(v)); addSon(b, nil); // no type description addSon(b, copyTree(def)); @@ -548,7 +553,7 @@ begin if typ.kind = tyRef then typ := typ.sons[0]; if (typ.kind <> tyObject) then liMessage(a.sons[j].info, errExprCannotBeRaised); - a.sons[j] := newNode(nkType); + a.sons[j] := newNodeI(nkType, a.sons[j].info); a.sons[j].typ := typ; if IntSetContainsOrIncl(check, typ.id) then liMessage(a.sons[j].info, errExceptionAlreadyHandled); @@ -566,7 +571,8 @@ var i: int; s: PSym; begin - assert(n.kind = nkGenericParams); + if n.kind <> nkGenericParams then + InternalError(n.info, 'semGenericParamList'); for i := 0 to sonsLen(n)-1 do begin if n.sons[i].kind = nkDefaultTypeParam then begin internalError(n.sons[i].info, 'semGenericParamList() to implement'); @@ -583,6 +589,21 @@ begin end end; +procedure addGenericParamListToScope(c: PContext; n: PNode); +var + i: int; + s: PSym; +begin + if n.kind <> nkGenericParams then + InternalError(n.info, 'addGenericParamListToScope'); + for i := 0 to sonsLen(n)-1 do begin + if n.sons[i].kind <> nkSym then + InternalError(n.sons[i].info, 'addGenericParamListToScope'); + s := n.sons[i].sym; + addDecl(c, s); + end +end; + function resolveGenericParams(c: PContext; n: PNode): PNode; begin result := n; @@ -630,35 +651,60 @@ begin s := a.sons[0].sym; if (s.magic = mNone) and (a.sons[2] = nil) then liMessage(a.info, errTypeXNeedsImplementation, s.name.s); + if s.magic <> mNone then processMagicType(c, s); if a.sons[1] <> nil then begin // we have a generic type declaration here, so we don't process the // type's body: openScope(c.tab); - pushOwner(c, s); + pushOwner(s); s.typ.kind := tyGeneric; semGenericParamList(c, a.sons[1]); // process the type body for symbol lookup of generic params // we can use the same algorithm as for template parameters: a.sons[2] := resolveTemplateParams(c, a.sons[2]); s.ast := a; - assert(s.typ.containerID = 0); + if s.typ.containerID <> 0 then + InternalError(a.info, 'semTypeSection: containerID'); s.typ.containerID := getID(); - popOwner(c); + popOwner(); closeScope(c.tab); end - else begin + else if a.sons[2] <> nil then begin // process the type's body: - pushOwner(c, s); + pushOwner(s); t := semTypeNode(c, a.sons[2], s.typ); - if (t <> s.typ) then internalError(a.info, 'semTypeSection()'); + if (t <> s.typ) and (s.typ <> nil) then + internalError(a.info, 'semTypeSection()'); s.typ := t; s.ast := a; - popOwner(c); - // compute the type's size and check for illegal recursions: - if computeSize(s.typ) < 0 then - liMessage(s.info, errIllegalRecursionInTypeX, s.name.s); + popOwner(); + if (tfAcyclic in t.flags) and (t.kind <> tyObject) then + liMessage(s.info, errInvalidPragmaX, 'acyclic'); end; end; + // unfortunately we need another pass over the section for checking of + // illegal recursions and type aliases: + for i := 0 to sonsLen(n)-1 do begin + a := n.sons[i]; + if a.kind = nkCommentStmt then continue; + if (a.sons[0].kind <> nkSym) then IllFormedAst(a); + s := a.sons[0].sym; + // compute the type's size and check for illegal recursions: + if a.sons[1] = nil then begin + if (a.sons[2] <> nil) + and (a.sons[2].kind in [nkSym, nkIdent, nkAccQuoted]) then begin + // type aliases are hard: + //MessageOut('for type ' + typeToString(s.typ)); + t := semTypeNode(c, a.sons[2], nil); + if t.kind in [tyObject, tyEnum] then begin + assignType(s.typ, t); + s.typ.id := t.id; // same id + end + end; + if computeSize(s.typ) < 0 then + liMessage(s.info, errIllegalRecursionInTypeX, s.name.s); + end + end end; procedure semParamList(c: PContext; n: PNode; s: PSym); @@ -691,7 +737,7 @@ begin include(s.flags, sfGlobal); if sfStar in s.flags then include(s.flags, sfInInterface); s.ast := n; - pushOwner(c, s); + pushOwner(s); if n.sons[genericParamsPos] <> nil then begin // we have a generic type declaration here, so we don't process the // type's body: @@ -721,24 +767,23 @@ begin else liMessage(n.info, errIteratorNeedsImplementation); closeScope(c.tab); - popOwner(c); + popOwner(); c.p := oldP; // add it here, so that recursive iterators are impossible: addInterfaceOverloadableSymAt(c, s, c.tab.tos-1); //writeln(renderTree(n.sons[codePos], {@set}[renderIds])); end; -{$include 'procfind.pas'} - procedure addResult(c: PContext; t: PType; const info: TLineInfo); var s: PSym; begin if t <> nil then begin - s := newSym(skVar, getIdent('result'), getCurrOwner(c)); + s := newSym(skVar, getIdent('result'), getCurrOwner()); s.info := info; s.typ := t; Include(s.flags, sfResult); + Include(s.flags, sfUsed); addDecl(c, s); c.p.resultSym := s; end @@ -756,16 +801,16 @@ var begin result := n; checkSonsLen(n, codePos+1); - s := newSym(skProc, getIdent(genPrefix + 'anonymous'), getCurrOwner(c)); + s := newSym(skProc, getIdent(':anonymous'), getCurrOwner()); s.info := n.info; oldP := c.p; // restore later s.ast := n; n.sons[namePos] := newSymNode(s); - pushOwner(c, s); + pushOwner(s); openScope(c.tab); - assert(n.sons[genericParamsPos] = nil); + if (n.sons[genericParamsPos] <> nil) then InternalError(n.info, 'semLambda'); // process parameters: if n.sons[paramsPos] <> nil then begin semParamList(c, n.sons[ParamsPos], s); @@ -790,13 +835,10 @@ begin n.sons[codePos] := semStmtScope(c, n.sons[codePos]); addResultNode(c, n); end - else begin + else liMessage(n.info, errImplOfXexpected, s.name.s); - if not (sfImportc in s.flags) then - Include(s.flags, sfForward); - end; closeScope(c.tab); // close scope for parameters - popOwner(c); + popOwner(); c.p := oldP; // restore end; @@ -818,7 +860,7 @@ begin if sfStar in s.flags then include(s.flags, sfInInterface); s.ast := n; - pushOwner(c, s); + pushOwner(s); openScope(c.tab); if n.sons[genericParamsPos] <> nil then semGenericParamList(c, n.sons[genericParamsPos]); @@ -855,21 +897,24 @@ begin if not (sfForward in proto.flags) then liMessage(n.info, errAttemptToRedefineX, proto.name.s); exclude(proto.flags, sfForward); + closeScope(c.tab); // close scope with wrong parameter symbols + openScope(c.tab); // open scope for old (correct) parameter symbols + if proto.ast.sons[genericParamsPos] <> nil then + addGenericParamListToScope(c, proto.ast.sons[genericParamsPos]); + addParams(c, proto.typ.n); proto.info := s.info; // more accurate line information - s.typ.callConv := proto.typ.callConv; - s.typ.flags := proto.typ.flags; - - proto.typ := s.typ; + s.typ := proto.typ; s := proto; - proto.ast := n; // needed for code generation - assert(n.sons[namePos].kind = nkSym); + n.sons[genericParamsPos] := proto.ast.sons[genericParamsPos]; + n.sons[paramsPos] := proto.ast.sons[paramsPos]; + if (n.sons[namePos].kind <> nkSym) then InternalError(n.info, 'semProcAux'); n.sons[namePos].sym := proto; - popOwner(c); - pushOwner(c, s); + proto.ast := n; // needed for code generation + popOwner(); + pushOwner(s); end; s.options := gOptions; - //writeln(s.name.s, ' ', ropeToStr(optionsToStr(s.options))); if n.sons[codePos] <> nil then begin if sfImportc in s.flags then liMessage(n.sons[codePos].info, errImportedProcCannotHaveImpl); @@ -881,7 +926,7 @@ begin end else begin n.sons[codePos] := resolveGenericParams(c, n.sons[codePos]); - end + end; end else begin if proto <> nil then @@ -889,7 +934,7 @@ begin if not (sfImportc in s.flags) then Include(s.flags, sfForward); end; closeScope(c.tab); // close scope for parameters - popOwner(c); + popOwner(); c.p := oldP; // restore end; @@ -898,11 +943,6 @@ begin result := semProcAux(c, n, skProc); end; -function isTopLevel(c: PContext): bool; -begin - result := c.tab.tos <= 2 -end; - function semConverterDef(c: PContext; n: PNode): PNode; var t: PType; @@ -938,7 +978,31 @@ begin liMessage(n.info, errXRequiresOneArgument, 'macro'); end; -{$include 'importer.pas'} +function evalInclude(c: PContext; n: PNode): PNode; +var + i: int; + x: PNode; + f, name, ext: string; +begin + result := newNodeI(nkStmtList, n.info); + addSon(result, n); // the rodwriter needs include information! + for i := 0 to sonsLen(n)-1 do begin + f := getModuleFile(n.sons[i]); + SplitFilename(f, name, ext); + if cmpIgnoreCase(ext, '.'+TmplExt) = 0 then + x := gIncludeTmplFile(f) + else + x := gIncludeFile(f); + x := semStmt(c, x); + addSon(result, x); + end; +end; + +function semCommand(c: PContext; n: PNode): PNode; +begin + result := semExpr(c, n); + if result.typ <> nil then liMessage(n.info, errDiscardValue); +end; function SemStmt(c: PContext; n: PNode): PNode; const @@ -950,13 +1014,11 @@ var begin result := n; if n = nil then exit; - embeddedDbg(c, n); + if nfSem in n.flags then exit; case n.kind of nkAsgn: result := semAsgn(c, n); - nkCall, nkInfix, nkPrefix, nkPostfix, nkCommand: begin - result := semExpr(c, n); - if result.typ <> nil then liMessage(n.info, errDiscardValue); - end; + nkCall, nkInfix, nkPrefix, nkPostfix, nkCommand: + result := semCommand(c, n); nkEmpty, nkCommentStmt, nkNilLit: begin end; nkBlockStmt: result := semBlock(c, n); nkStmtList: begin @@ -969,24 +1031,25 @@ begin nkPragma, nkCommentStmt, nkNilLit, nkEmpty: begin end; else liMessage(n.sons[j].info, errStmtInvalidAfterReturn); end - end; - end; + end + end end; nkRaiseStmt: result := semRaise(c, n); - nkVarSection: result := SemVar(c, n); - nkConstSection: result := SemConst(c, n); + nkVarSection: result := semVar(c, n); + nkConstSection: result := semConst(c, n); nkTypeSection: result := SemTypeSection(c, n); nkIfStmt: result := SemIf(c, n); nkWhenStmt: result := semWhen(c, n); nkDiscardStmt: result := semDiscard(c, n); nkWhileStmt: result := semWhile(c, n); nkTryStmt: result := semTry(c, n); - nkBreakStmt, nkContinueStmt: result := semBreakOrContinue(c, n); + nkBreakStmt, nkContinueStmt: + result := semBreakOrContinue(c, n); nkForStmt: result := semFor(c, n); nkCaseStmt: result := semCase(c, n); nkReturnStmt: result := semReturn(c, n); nkAsmStmt: result := semAsm(c, n); - nkYieldStmt: result := SemYield(c, n); + nkYieldStmt: result := semYield(c, n); nkPragma: pragmaStmt(c, c.p.owner, n); nkIteratorDef: result := semIterator(c, n); nkProcDef: result := semProc(c, n); @@ -1011,6 +1074,7 @@ begin else liMessage(n.info, errStmtExpected); end; if result = nil then InternalError(n.info, 'SemStmt: result = nil'); + include(result.flags, nfSem); end; function semStmtScope(c: PContext; n: PNode): PNode; diff --git a/nim/semtempl.pas b/nim/semtempl.pas index b861949c9..c07a7bd13 100644 --- a/nim/semtempl.pas +++ b/nim/semtempl.pas @@ -83,7 +83,7 @@ begin liMessage(n.info, errTemplateInstantiationTooNested); // replace each param by the corresponding node: r := sym.ast.sons[paramsPos].sons[0]; - assert(r.kind = nkIdent); + if (r.kind <> nkIdent) then InternalError(r.info, 'evalTemplate'); result := evalTemplateAux(c, sym.ast.sons[codePos], n, sym); if r.ident.id = ord(wExpr) then result := semExpr(c, result) else result := semStmt(c, result); @@ -172,7 +172,7 @@ begin s := semIdentVis(c, skTemplate, n.sons[0], {@set}[]); if sfStar in s.flags then include(s.flags, sfInInterface); // check parameter list: - pushOwner(c, s); + pushOwner(s); openScope(c.tab); params := n.sons[paramsPos]; counter := 0; @@ -191,6 +191,7 @@ begin end; end; params.sons[0] := semTemplateParamKind(c, params, params.sons[0]); + n.sons[namePos] := newSymNode(s); // check that no pragmas exist: if n.sons[pragmasPos] <> nil then @@ -205,7 +206,7 @@ begin // only parameters are resolved, no type checking is performed closeScope(c.tab); - popOwner(c); + popOwner(); s.ast := n; result := n; diff --git a/nim/semtypes.pas b/nim/semtypes.pas index e0a3f59b9..00cb019f8 100644 --- a/nim/semtypes.pas +++ b/nim/semtypes.pas @@ -17,12 +17,11 @@ end; function newOrPrevType(kind: TTypeKind; prev: PType; c: PContext): PType; begin - assert((prev = nil) or (prev.Kind = tyForward)); if prev = nil then result := newTypeS(kind, c) else begin result := prev; - result.kind := kind + if result.kind = tyForward then result.kind := kind end end; @@ -37,7 +36,7 @@ begin counter := 0; base := nil; result := newOrPrevType(tyEnum, prev, c); - result.n := newNode(nkEnumTy); + result.n := newNodeI(nkEnumTy, n.info); checkMinSonsLen(n, 1); if n.sons[0] <> nil then begin base := semTypeNode(c, n.sons[0].sons[0], nil); @@ -69,6 +68,7 @@ begin e.position := int(counter); if (result.sym <> nil) and (sfInInterface in result.sym.flags) then begin include(e.flags, sfUsed); // BUGFIX + include(e.flags, sfInInterface); // BUGFIX StrTableAdd(c.module.tab, e); // BUGFIX end; addSon(result.n, newSymNode(e)); @@ -142,11 +142,12 @@ function semRangeAux(c: PContext; n: PNode; prev: PType): PType; var a, b: PNode; begin - assert(n.kind = nkRange); + if (n.kind <> nkRange) then InternalError(n.info, 'semRangeAux'); checkSonsLen(n, 2); result := newOrPrevType(tyRange, prev, c); - result.n := copyTree(n); - result.n := newNode(nkRange); + result.n := newNodeI(nkRange, n.info); + if (n.sons[0] = nil) or (n.sons[1] = nil) then + liMessage(n.Info, errRangeIsEmpty); a := semConstExpr(c, n.sons[0]); b := semConstExpr(c, n.sons[1]); if not sameType(a.typ, b.typ) then @@ -278,12 +279,13 @@ var elem: PType; inst: PNode; begin - if (s.typ = nil) or (s.typ.kind <> tyGeneric) then + if (s.typ = nil) or (s.typ.kind <> tyGeneric) then liMessage(n.info, errCannotInstantiateX, s.name.s); - result := newOrPrevType(tyGenericInst, prev, c); - result.containerID := s.typ.containerID; + result := newOrPrevType(tyGenericInst, prev, c); // new ID... + result.containerID := s.typ.containerID; // ... but the same containerID result.sym := s; - assert(s.typ.containerID <> 0); + if (s.typ.containerID = 0) then + InternalError(n.info, 'semGeneric'); for i := 1 to sonsLen(n)-1 do begin elem := semTypeNode(c, n.sons[i], nil); if elem.kind = tyGenericParam then result.kind := tyGeneric; @@ -355,8 +357,10 @@ var begin for i := 1 to branchIndex-1 do for j := 0 to sonsLen(t.sons[i])-2 do - if overlap(t.sons[i].sons[j], ex) then + if overlap(t.sons[i].sons[j], ex) then begin + //MessageOut(renderTree(t)); liMessage(ex.info, errDuplicateCaseLabel); + end end; procedure semBranchExpr(c: PContext; t: PNode; var ex: PNode); @@ -380,8 +384,10 @@ begin checkSonsLen(b, 2); semBranchExpr(c, t, b.sons[0]); semBranchExpr(c, t, b.sons[1]); - if emptyRange(b.sons[0], b.sons[1]) then + if emptyRange(b.sons[0], b.sons[1]) then begin + //MessageOut(renderTree(t)); liMessage(b.info, errRangeIsEmpty); + end; covered := covered + getOrdValue(b.sons[1]) - getOrdValue(b.sons[0]) + 1; end else begin @@ -444,8 +450,7 @@ begin addSon(father, a); end; -procedure semRecordNodeAux(c: PContext; n: PNode; - var check: TIntSet; +procedure semRecordNodeAux(c: PContext; n: PNode; var check: TIntSet; var pos: int; father: PNode; rectype: PSym); var i, len: int; @@ -465,7 +470,8 @@ begin checkSonsLen(it, 2); e := semConstExpr(c, it.sons[0]); checkBool(e); - assert(e.kind = nkIntLit); + if (e.kind <> nkIntLit) then + InternalError(e.info, 'semRecordNodeAux'); if (e.intVal <> 0) and (branch = nil) then branch := it.sons[1] end; @@ -482,6 +488,10 @@ begin nkRecCase: begin semRecordCase(c, n, check, pos, father, rectype); end; + nkNilLit: begin + if father.kind <> nkRecList then + addSon(father, newNodeI(nkRecList, n.info)); + end; nkRecList: begin // attempt to keep the nesting at a sane level: if father.kind = nkRecList then a := father @@ -495,8 +505,10 @@ begin nkIdentDefs: begin checkMinSonsLen(n, 3); len := sonsLen(n); - if (father.kind <> nkRecList) and (len >= 4) then a := newNode(nkRecList) - else a := nil; + if (father.kind <> nkRecList) and (len >= 4) then + a := newNodeI(nkRecList, n.info) + else + a := nil; if n.sons[len-1] <> nil then liMessage(n.sons[len-1].info, errInitHereNotAllowed); if n.sons[len-2] = nil then @@ -531,7 +543,8 @@ var begin case n.kind of nkRecCase: begin - assert(n.sons[0].kind = nkSym); + if (n.sons[0].kind <> nkSym) then + InternalError(n.info, 'addInheritedFieldsAux'); addInheritedFieldsAux(c, check, pos, n.sons[0]); for i := 1 to sonsLen(n)-1 do begin case n.sons[i].kind of @@ -589,9 +602,9 @@ begin else InternalError(n.info, 'semObjectNode'); addSon(result, base); - result.n := newNode(nkRecList); + result.n := newNodeI(nkRecList, n.info); semRecordNodeAux(c, n.sons[2], check, pos, result.n, result.sym); - if (tfFinal in result.flags) and (base <> nil) then + if (base <> nil) and (tfFinal in base.flags) then liMessage(n.sons[1].info, errInheritanceOnlyWithNonFinalObjects); end; @@ -606,14 +619,14 @@ begin checkMinSonsLen(n, 1); result := newOrPrevType(tyProc, prev, c); result.callConv := lastOptionEntry(c).defaultCC; - result.n := newNode(nkFormalParams); + result.n := newNodeI(nkFormalParams, n.info); if n.sons[0] = nil then begin addSon(result, nil); // return type - addSon(result.n, newNode(nkType)); // BUGFIX: nkType-Node must be present! + addSon(result.n, newNodeI(nkType, n.info)); // BUGFIX: nkType must exist! end else begin addSon(result, semTypeNode(c, n.sons[0], nil)); // return type - res := newNode(nkType); + res := newNodeI(nkType, n.info); res.typ := result.sons[0]; addSon(result.n, res); end; @@ -655,13 +668,45 @@ begin end end; +function semStmtListType(c: PContext; n: PNode; prev: PType): PType; +var + len, i: int; +begin + checkMinSonsLen(n, 1); + len := sonsLen(n); + for i := 0 to len-2 do begin + n.sons[i] := semStmt(c, n.sons[i]); + end; + if len > 0 then begin + result := semTypeNode(c, n.sons[len-1], prev); + n.typ := result; + n.sons[len-1].typ := result + end + else + result := nil; +end; + +function semBlockType(c: PContext; n: PNode; prev: PType): PType; +begin + Inc(c.p.nestedBlockCounter); + checkSonsLen(n, 2); + openScope(c.tab); + if n.sons[0] <> nil then begin + addDecl(c, newSymS(skLabel, n.sons[0], c)) + end; + result := semStmtListType(c, n.sons[1], prev); + n.sons[1].typ := result; + n.typ := result; + closeScope(c.tab); + Dec(c.p.nestedBlockCounter); +end; + function semTypeNode(c: PContext; n: PNode; prev: PType): PType; var s: PSym; begin result := nil; if n = nil then exit; - embeddedDbg(c, n); case n.kind of nkTypeOfExpr: begin result := semExprWithType(c, n, {@set}[efAllowType]).typ; @@ -686,6 +731,7 @@ begin result := s.typ else begin assignType(prev, s.typ); + prev.id := s.typ.id; result := prev; end end; @@ -717,7 +763,56 @@ begin end; nkEnumTy: result := semEnum(c, n, prev); nkType: result := n.typ; + nkStmtListType: result := semStmtListType(c, n, prev); + nkBlockType: result := semBlockType(c, n, prev); else liMessage(n.info, errTypeExpected); //internalError(n.info, 'semTypeNode(' +{&} nodeKindToStr[n.kind] +{&} ')'); end end; + +procedure setMagicType(m: PSym; kind: TTypeKind; size: int); +begin + m.typ.kind := kind; + m.typ.align := size; + m.typ.size := size; + //m.typ.sym := nil; +end; + +procedure processMagicType(c: PContext; m: PSym); +begin + case m.magic of + mInt: setMagicType(m, tyInt, intSize); + mInt8: setMagicType(m, tyInt8, 1); + mInt16: setMagicType(m, tyInt16, 2); + mInt32: setMagicType(m, tyInt32, 4); + mInt64: setMagicType(m, tyInt64, 8); + mFloat: setMagicType(m, tyFloat, floatSize); + mFloat32: setMagicType(m, tyFloat32, 4); + mFloat64: setMagicType(m, tyFloat64, 8); + mBool: setMagicType(m, tyBool, 1); + mChar: setMagicType(m, tyChar, 1); + mString: begin + setMagicType(m, tyString, ptrSize); + addSon(m.typ, getSysType(tyChar)); + end; + mCstring: begin + setMagicType(m, tyCString, ptrSize); + addSon(m.typ, getSysType(tyChar)); + end; + mPointer: setMagicType(m, tyPointer, ptrSize); + mAnyEnum: setMagicType(m, tyAnyEnum, 1); + mEmptySet: begin + setMagicType(m, tySet, 1); + addSon(m.typ, newTypeS(tyEmpty, c)); + end; + mIntSetBaseType: begin + setMagicType(m, tyRange, intSize); + //intSetBaseType := m.typ; + exit + end; + mNil: setMagicType(m, tyNil, ptrSize); + mArray, mOpenArray, mRange, mSet, mSeq: exit; + else liMessage(m.info, errTypeExpected); + end; + //registerSysType(m.typ); +end; diff --git a/nim/sigmatch.pas b/nim/sigmatch.pas index 6257d5178..96001ed90 100644 --- a/nim/sigmatch.pas +++ b/nim/sigmatch.pas @@ -15,6 +15,7 @@ type TCandidate = record exactMatches: int; subtypeMatches: int; + intConvMatches: int; // conversions to int are not as expensive convMatches: int; genericMatches: int; state: TCandidateState; @@ -25,7 +26,8 @@ type baseTypeMatch: bool; // needed for conversions from T to openarray[T] // for example end; - TTypeRelation = (isNone, isConvertible, isSubtype, isGeneric, isEqual); + TTypeRelation = (isNone, isConvertible, isIntConv, isSubtype, + isGeneric, isEqual); // order is important! procedure initCandidate(out c: TCandidate; callee: PType); @@ -33,6 +35,7 @@ begin c.exactMatches := 0; c.subtypeMatches := 0; c.convMatches := 0; + c.intConvMatches := 0; c.genericMatches := 0; c.state := csEmpty; c.callee := callee; @@ -51,6 +54,8 @@ begin if result <> 0 then exit; result := a.subtypeMatches - b.subtypeMatches; if result <> 0 then exit; + result := a.intConvMatches - b.intConvMatches; + if result <> 0 then exit; result := a.convMatches - b.convMatches; end; @@ -59,6 +64,7 @@ begin Writeln(output, 'exact matches: ' + toString(c.exactMatches)); Writeln(output, 'subtype matches: ' + toString(c.subtypeMatches)); Writeln(output, 'conv matches: ' + toString(c.convMatches)); + Writeln(output, 'intconv matches: ' + toString(c.intConvMatches)); Writeln(output, 'generic matches: ' + toString(c.genericMatches)); end; @@ -77,7 +83,7 @@ begin result := result +{&} typeToString(n.sons[i].typ); if i <> sonsLen(n)-1 then result := result + ', '; end; - result := result + ')'; + addChar(result, ')'); candidates := ''; sym := initOverloadIter(o, c, n.sons[0]); while sym <> nil do begin @@ -101,8 +107,8 @@ begin addSon(result, t.sons[0]); // XXX: t.owner is wrong for ID! addSon(result, t.sons[1]); // XXX: semantic checking for the type? end; - tyEmptySet, tyNil: result := nil; // what should it be? - else result := t + tyNil: result := nil; // what should it be? + else result := t // Note: empty is valid here end end; @@ -116,7 +122,26 @@ begin k := skipRange(a).kind; if k = f.kind then result := isSubtype - else if (k >= min) and (k <= max) or (k = tyInt) then + else if (f.kind = tyInt) and (k in [tyInt..tyInt32]) then + result := isIntConv + else if (k >= min) and (k <= max) then + result := isConvertible + else + result := isNone + end +end; + +function handleFloatRange(f, a: PType): TTypeRelation; +var + k: TTypeKind; +begin + if a.kind = f.kind then + result := isEqual + else begin + k := skipRange(a).kind; + if k = f.kind then + result := isSubtype + else if (k >= tyFloat) and (k <= tyFloat128) then result := isConvertible else result := isNone @@ -201,14 +226,14 @@ begin // is a subtype of f? result := isConvertible // a convertible to f end; tyInt: result := handleRange(f, a, tyInt8, tyInt32); - tyInt8: result := handleRange(f, a, tyInt, tyInt64); - tyInt16: result := handleRange(f, a, tyInt, tyInt64); - tyInt32: result := handleRange(f, a, tyInt, tyInt64); + tyInt8: result := handleRange(f, a, tyInt8, tyInt8); + tyInt16: result := handleRange(f, a, tyInt8, tyInt16); + tyInt32: result := handleRange(f, a, tyInt, tyInt32); tyInt64: result := handleRange(f, a, tyInt, tyInt64); - tyFloat: result := handleRange(f, a, tyFloat, tyFloat128); - tyFloat32: result := handleRange(f, a, tyFloat, tyFloat128); - tyFloat64: result := handleRange(f, a, tyFloat, tyFloat128); - tyFloat128: result := handleRange(f, a, tyFloat, tyFloat128); + tyFloat: result := handleFloatRange(f, a); + tyFloat32: result := handleFloatRange(f, a); + tyFloat64: result := handleFloatRange(f, a); + tyFloat128: result := handleFloatRange(f, a); tyVar: begin if (a.kind = f.kind) then @@ -226,13 +251,14 @@ begin // is a subtype of f? end; tyArrayConstr: begin result := typeRel(mapping, f.sons[1], a.sons[1]); - if result < isGeneric then result := isNone + if result < isGeneric then + result := isNone else begin if (result <> isGeneric) and (lengthOrd(f) <> lengthOrd(a)) then result := isNone else if f.sons[0].kind in GenericTypes then result := minRel(result, typeRel(mapping, f.sons[0], a.sons[0])); - end; + end end; else begin end end @@ -244,16 +270,24 @@ begin // is a subtype of f? if result < isGeneric then result := isNone end; tyArrayConstr: begin - if (a.sons[1] = nil) then + if (f.sons[0].kind <> tyGenericParam) and + (a.sons[1].kind = tyEmpty) then result := isSubtype // [] is allowed here else if typeRel(mapping, base(f), a.sons[1]) >= isGeneric then result := isSubtype; end; - tyArray: - if typeRel(mapping, base(f), a.sons[1]) >= isGeneric then - result := isConvertible; + tyArray: begin + if (f.sons[0].kind <> tyGenericParam) and + (a.sons[1].kind = tyEmpty) then + result := isSubtype + else if typeRel(mapping, base(f), a.sons[1]) >= isGeneric then + result := isConvertible + end; tySequence: begin - if typeRel(mapping, base(f), a.sons[0]) >= isGeneric then + if (f.sons[0].kind <> tyGenericParam) and + (a.sons[0].kind = tyEmpty) then + result := isConvertible + else if typeRel(mapping, base(f), a.sons[0]) >= isGeneric then result := isConvertible; end else begin end @@ -262,21 +296,20 @@ begin // is a subtype of f? tySequence: begin case a.Kind of tyNil: result := isSubtype; - tyArrayConstr: begin - if (a.sons[1] = nil) then // [] is allowed here - result := isConvertible - else if typeRel(mapping, f.sons[0], a.sons[1]) >= isGeneric then - result := isConvertible - end; tySequence: begin - result := typeRel(mapping, f.sons[0], a.sons[0]); - if result < isGeneric then result := isNone + if (f.sons[0].kind <> tyGenericParam) and + (a.sons[0].kind = tyEmpty) then + result := isSubtype + else begin + result := typeRel(mapping, f.sons[0], a.sons[0]); + if result < isGeneric then result := isNone + end end; else begin end end end; tyForward: InternalError('forward type in typeRel()'); - tyNil, tyEmptySet: begin + tyNil: begin if a.kind = f.kind then result := isEqual end; tyTuple: begin @@ -289,15 +322,14 @@ begin // is a subtype of f? end end; tySet: begin - case a.kind of - tyEmptySet: begin - result := isSubtype; - end; - tySet: begin - result := typeRel(mapping, base(f), base(a)); + if a.kind = tySet then begin + if (f.sons[0].kind <> tyGenericParam) and + (a.sons[0].kind = tyEmpty) then + result := isSubtype + else begin + result := typeRel(mapping, f.sons[0], a.sons[0]); if result <= isConvertible then result := isNone // BUGFIX! - end; - else begin end + end end end; tyPtr: begin @@ -338,7 +370,7 @@ begin // is a subtype of f? // allow ``f.son`` as subtype of ``a.son``! result := isConvertible; end - else if m < isGeneric then begin + else if m < isSubtype then begin result := isNone; exit end else result := minRel(m, result) @@ -393,6 +425,9 @@ begin // is a subtype of f? end end; + tyEmpty: begin + if a.kind = tyEmpty then result := isEqual; + end; tyAnyEnum: begin case a.kind of tyRange: result := typeRel(mapping, f, base(a)); @@ -445,6 +480,8 @@ begin // is a subtype of f? end end end + else if a.kind = tyEmpty then + result := isGeneric else begin result := typeRel(mapping, x, a); // check if it fits end @@ -520,6 +557,10 @@ begin inc(m.convMatches); result := implicitConv(nkHiddenStdConv, f, copyTree(arg), m, c); end; + isIntConv: begin + inc(m.intConvMatches); + result := implicitConv(nkHiddenStdConv, f, copyTree(arg), m, c); + end; isSubtype: begin inc(m.subtypeMatches); result := implicitConv(nkHiddenSubConv, f, copyTree(arg), m, c); @@ -587,9 +628,8 @@ begin f := 1; a := 1; m.state := csMatch; // until proven otherwise - m.call := newNode(nkCall); + m.call := newNodeI(nkCall, n.info); m.call.typ := base(m.callee); // may be nil - m.call.info := n.info; formalLen := sonsLen(m.callee.n); addSon(m.call, copyTree(n.sons[0])); IntSetInit(marker); diff --git a/nim/strtabs.pas b/nim/strtabs.pas index 1df147f08..295c46faa 100644 --- a/nim/strtabs.pas +++ b/nim/strtabs.pas @@ -79,12 +79,11 @@ begin new(result); result.mode := mode; result.counter := 0; -{@emit - result.data := []; } - setLength(result.data, startSize); {@ignore} + setLength(result.data, startSize); fillChar(result.data[0], length(result.data)*sizeof(result.data[0]), 0); -{@emit} +{@emit + newSeq(result.data, startSize); } i := 0; while i < high(keyValuePairs) do begin put(result, keyValuePairs[i], keyValuePairs[i+1]); @@ -184,11 +183,12 @@ var n: TKeyValuePairSeq; i: int; begin +{@ignore} n := emptySeq; setLength(n, length(t.data) * growthFactor); -{@ignore} fillChar(n[0], length(n)*sizeof(n[0]), 0); -{@emit} +{@emit + newSeq(n, length(t.data) * growthFactor); } for i := 0 to high(t.data) do if not isNil(t.data[i].key) then RawInsert(t, n, t.data[i].key, t.data[i].val); diff --git a/nim/strutils.pas b/nim/strutils.pas index d70fdd8c3..3d8f0424b 100644 --- a/nim/strutils.pas +++ b/nim/strutils.pas @@ -639,6 +639,28 @@ begin inc(code); end; end; + + if (s[code] = 'N') or (s[code] = 'n') then begin + inc(code); + if (s[code] = 'A') or (s[code] = 'a') then begin + inc(code); + if (s[code] = 'N') or (s[code] = 'n') then begin + if code = length(s) then begin result:= NaN; exit end; + end + end; + raise EInvalidValue.create('invalid float: ' + s) + end; + if (s[code] = 'I') or (s[code] = 'i') then begin + inc(code); + if (s[code] = 'N') or (s[code] = 'n') then begin + inc(code); + if (s[code] = 'F') or (s[code] = 'f') then begin + if code = length(s) then begin result:= Inf*sign; exit end; + end + end; + raise EInvalidValue.create('invalid float: ' + s) + end; + while (code <= Length(s)) and (s[code] in ['0'..'9']) do begin { Read int part } flags := flags or 1; @@ -662,7 +684,7 @@ begin end; { Again, read int and fractional part } if flags = 0 then - raise EInvalidValue.create(''); + raise EInvalidValue.create('invalid float: ' + s); { Exponent ? } if (length(s) >= code) and (upcase(s[code]) = 'E') then begin inc(code); @@ -692,7 +714,7 @@ begin result := result / hd; { Not all characters are read ? } if checkEnd and (length(s) >= code) then - raise EInvalidValue.create(''); + raise EInvalidValue.create('invalid float: ' + s); { evaluate sign } result := result * sign; end; diff --git a/nim/transf.pas b/nim/transf.pas index 97ad31540..fb59eeef2 100644 --- a/nim/transf.pas +++ b/nim/transf.pas @@ -6,29 +6,81 @@ // See the file "copying.txt", included in this // distribution, for details about the copyright. // +unit transf; // This module implements the transformator. It transforms the syntax tree // to ease the work of the code generators. Does some transformations: // // * inlines iterators -// * looks up constants +// * inlines constants +// * performes contant folding -// ------------ helpers ----------------------------------------------------- +interface -var - gTmpId: int; +{$include 'config.inc'} + +uses + sysutils, nsystem, charsets, strutils, + lists, options, ast, astalgo, trees, treetab, + msgs, nos, idents, rnimsyn, types, passes, semfold; + +const + genPrefix = ':tmp'; // prefix for generated names + +function transfPass(): TPass; + +implementation + +type + PTransCon = ^TTransCon; + TTransCon = record // part of TContext; stackable + mapping: TIdNodeTable; // mapping from symbols to nodes + owner: PSym; // current owner + forStmt: PNode; // current for stmt + next: PTransCon; // for stacking + end; + + TTransfContext = object(passes.TPassContext) + module: PSym; + transCon: PTransCon; // top of a TransCon stack + end; + PTransf = ^TTransfContext; -function newTemp(c: PContext; typ: PType; const info: TLineInfo): PSym; +function newTransCon(): PTransCon; begin - inc(gTmpId); - result := newSym(skTemp, getIdent(genPrefix +{&} ToString(gTmpId)), - c.transCon.owner); + new(result); +{@ignore} + fillChar(result^, sizeof(result^), 0); +{@emit} + initIdNodeTable(result.mapping); +end; + +procedure pushTransCon(c: PTransf; t: PTransCon); +begin + t.next := c.transCon; + c.transCon := t; +end; + +procedure popTransCon(c: PTransf); +begin + if (c.transCon = nil) then InternalError('popTransCon'); + c.transCon := c.transCon.next; +end; + +// ------------ helpers ----------------------------------------------------- + +function newTemp(c: PTransf; typ: PType; const info: TLineInfo): PSym; +begin + result := newSym(skTemp, getIdent(genPrefix), getCurrOwner()); result.info := info; result.typ := skipGeneric(typ); + include(result.flags, sfFromGeneric); end; // -------------------------------------------------------------------------- +function transform(c: PTransf; n: PNode): PNode; forward; + (* Transforming iterators into non-inlined versions is pretty hard, but @@ -79,17 +131,14 @@ More efficient, but not implementable: label1: inc(c.i) *) - -function transform(c: PContext; n: PNode): PNode; forward; - -function newAsgnStmt(c: PContext; le, ri: PNode): PNode; +function newAsgnStmt(c: PTransf; le, ri: PNode): PNode; begin result := newNodeI(nkAsgn, ri.info); addSon(result, le); addSon(result, ri); end; -function transformSym(c: PContext; n: PNode): PNode; +function transformSym(c: PTransf; n: PNode): PNode; var tc: PTransCon; begin @@ -107,7 +156,7 @@ begin case n.sym.kind of skConst, skEnumField: begin // BUGFIX: skEnumField was missing if not (skipGeneric(n.sym.typ).kind in ConstantDataTypes) then begin - result := getConstExpr(c, n); + result := getConstExpr(c.module, n); if result = nil then InternalError(n.info, 'transformSym: const'); end end @@ -115,7 +164,7 @@ begin end end; -procedure transformContinueAux(c: PContext; n: PNode; labl: PSym; +procedure transformContinueAux(c: PTransf; n: PNode; labl: PSym; var counter: int); var i: int; @@ -135,7 +184,7 @@ begin end end; -function transformContinue(c: PContext; n: PNode): PNode; +function transformContinue(c: PTransf; n: PNode): PNode; // we transform the continue statement into a block statement var i, counter: int; @@ -146,9 +195,8 @@ begin for i := 0 to sonsLen(n)-1 do result.sons[i] := transform(c, n.sons[i]); counter := 0; - inc(gTmpId); - labl := newSym(skLabel, getIdent(genPrefix +{&} ToString(gTmpId)), - getCurrOwner(c)); + labl := newSym(skLabel, nil, getCurrOwner()); + labl.name := getIdent(genPrefix +{&} ToString(labl.id)); labl.info := result.info; transformContinueAux(c, result, labl, counter); if counter > 0 then begin @@ -170,7 +218,7 @@ begin end end; -function transformYield(c: PContext; n: PNode): PNode; +function transformYield(c: PTransf; n: PNode): PNode; var e: PNode; i: int; @@ -198,7 +246,7 @@ begin addSon(result, transform(c, lastSon(c.transCon.forStmt))); end; -function inlineIter(c: PContext; n: PNode): PNode; +function inlineIter(c: PTransf; n: PNode): PNode; var i: int; it: PNode; @@ -219,9 +267,11 @@ begin if (it.kind <> nkIdentDefs) or (it.sons[0].kind <> nkSym) then InternalError(it.info, 'inlineIter'); newVar := copySym(it.sons[0].sym); - newVar.owner := getCurrOwner(c); - IdNodeTablePut(c.transCon.mapping, it.sons[0].sym, - newSymNode(newVar)); + include(newVar.flags, sfFromGeneric); + // fixes a strange bug for rodgen: + //include(it.sons[0].sym.flags, sfFromGeneric); + newVar.owner := getCurrOwner(); + IdNodeTablePut(c.transCon.mapping, it.sons[0].sym, newSymNode(newVar)); it.sons[0] := newSymNode(newVar); it.sons[2] := transform(c, it.sons[2]); end @@ -245,7 +295,7 @@ begin addSon(father, vpart); end; -function transformAddrDeref(c: PContext; n: PNode; a, b: TNodeKind): PNode; +function transformAddrDeref(c: PTransf; n: PNode; a, b: TNodeKind): PNode; var m: PNode; begin @@ -281,7 +331,7 @@ begin result := n; end; -function transformConv(c: PContext; n: PNode): PNode; +function transformConv(c: PTransf; n: PNode): PNode; var source, dest: PType; diff: int; @@ -370,7 +420,7 @@ begin end; end; -function transformFor(c: PContext; n: PNode): PNode; +function transformFor(c: PTransf; n: PNode): PNode; // generate access statements for the parameters (unless they are constant) // put mapping from formal parameters to actual parameters var @@ -379,7 +429,7 @@ var newC: PTransCon; temp, formal: PSym; begin - assert(n.kind = nkForStmt); + if (n.kind <> nkForStmt) then InternalError(n.info, 'transformFor'); result := newNodeI(nkStmtList, n.info); len := sonsLen(n); n.sons[len-1] := transformContinue(c, n.sons[len-1]); @@ -388,15 +438,16 @@ begin addSon(result, v); newC := newTransCon(); call := n.sons[len-2]; - assert(call.kind = nkCall); - assert(call.sons[0].kind = nkSym); + if (call.kind <> nkCall) or (call.sons[0].kind <> nkSym) then + InternalError(call.info, 'transformFor'); newC.owner := call.sons[0].sym; newC.forStmt := n; - assert(newC.owner.kind = skIterator); + if (newC.owner.kind <> skIterator) then + InternalError(call.info, 'transformFor'); // generate access statements for the parameters (unless they are constant) pushTransCon(c, newC); for i := 1 to sonsLen(call)-1 do begin - e := getConstExpr(c, call.sons[i]); + e := getConstExpr(c.module, call.sons[i]); formal := skipGeneric(newC.owner.typ).n.sons[i].sym; if e <> nil then IdNodeTablePut(newC.mapping, formal, e) @@ -414,7 +465,9 @@ begin end end; body := newC.owner.ast.sons[codePos]; + pushInfoContext(n.info); addSon(result, inlineIter(c, body)); + popInfoContext(); popTransCon(c); end; @@ -427,7 +480,7 @@ begin result := mNone end; -procedure gatherVars(c: PContext; n: PNode; var marked: TIntSet; +procedure gatherVars(c: PTransf; n: PNode; var marked: TIntSet; owner: PSym; container: PNode); // gather used vars for closure generation var @@ -542,7 +595,7 @@ begin result.typ := y.typ; end; -function transformLambda(c: PContext; n: PNode): PNode; +function transformLambda(c: PTransf; n: PNode): PNode; var marked: TIntSet; closure: PNode; @@ -553,7 +606,8 @@ var begin result := n; IntSetInit(marked); - assert(n.sons[namePos].kind = nkSym); + if (n.sons[namePos].kind <> nkSym) then + InternalError(n.info, 'transformLambda'); s := n.sons[namePos].sym; closure := newNodeI(nkRecList, n.sons[codePos].info); gatherVars(c, n.sons[codePos], marked, s, closure); @@ -582,7 +636,7 @@ begin // the outer routine! end; -function transformCase(c: PContext; n: PNode): PNode; +function transformCase(c: PTransf; n: PNode): PNode; // removes `elif` branches of a case stmt var len, i, j: int; @@ -593,7 +647,8 @@ begin if n.sons[i].kind = nkElse then dec(i); if n.sons[i].kind = nkElifBranch then begin while n.sons[i].kind = nkElifBranch do dec(i); - assert(n.sons[i].kind = nkOfBranch); + if (n.sons[i].kind <> nkOfBranch) then + InternalError(n.sons[i].info, 'transformCase'); ifs := newNodeI(nkIfStmt, n.sons[i+1].info); for j := i+1 to len-1 do addSon(ifs, n.sons[j]); setLength(n.sons, i+2); @@ -603,7 +658,7 @@ begin for j := 0 to sonsLen(n)-1 do result.sons[j] := transform(c, n.sons[j]); end; -function transformArrayAccess(c: PContext; n: PNode): PNode; +function transformArrayAccess(c: PTransf; n: PNode): PNode; var i: int; begin @@ -614,16 +669,85 @@ begin result.sons[i] := transform(c, result.sons[i]); end; -function transform(c: PContext; n: PNode): PNode; +function getMergeOp(n: PNode): PSym; +begin + result := nil; + case n.kind of + nkCall, nkHiddenCallConv, nkCommand, nkInfix, nkPrefix, nkPostfix: begin + if (n.sons[0].Kind = nkSym) and (n.sons[0].sym.kind = skProc) + and (sfMerge in n.sons[0].sym.flags) then + result := n.sons[0].sym; + end + else begin end + end +end; + +procedure flattenTreeAux(d, a: PNode; op: PSym); +var + i: int; + op2: PSym; +begin + op2 := getMergeOp(a); + if (op2 <> nil) and ((op2.id = op.id) + or (op.magic <> mNone) and (op2.magic = op.magic)) then + for i := 1 to sonsLen(a)-1 do + flattenTreeAux(d, a.sons[i], op) + else + // a is a "leaf", so add it: + addSon(d, copyTree(a)) +end; + +function flattenTree(root: PNode): PNode; +var + op: PSym; +begin + op := getMergeOp(root); + if op <> nil then begin + result := copyNode(root); + addSon(result, copyTree(root.sons[0])); + flattenTreeAux(result, root, op) + end + else + result := root +end; + +function transformCall(c: PTransf; n: PNode): PNode; +var + i, j: int; + m, a: PNode; + op: PSym; +begin + result := flattenTree(n); + for i := 0 to sonsLen(result)-1 do + result.sons[i] := transform(c, result.sons[i]); + op := getMergeOp(result); + if (op <> nil) and (op.magic <> mNone) and (sonsLen(result) >= 3) then begin + m := result; + result := newNodeIT(nkCall, m.info, m.typ); + addSon(result, copyTree(m.sons[0])); + j := 1; + while j < sonsLen(m) do begin + a := m.sons[j]; + inc(j); + if isConstExpr(a) then + while (j < sonsLen(m)) and isConstExpr(m.sons[j]) do begin + a := evalOp(op.magic, m, a, m.sons[j]); + inc(j) + end; + addSon(result, a); + end; + if sonsLen(result) = 2 then + result := result.sons[1]; + end; +end; + +function transform(c: PTransf; n: PNode): PNode; var i: int; cnst: PNode; begin result := n; if n = nil then exit; - //result := getConstExpr(c, n); // try to evaluate the expressions - //if result <> nil then exit; - //result := n; // reset the result node case n.kind of nkSym: begin result := transformSym(c, n); @@ -636,28 +760,60 @@ begin nkLambda: result := transformLambda(c, n); nkForStmt: result := transformFor(c, n); nkCaseStmt: result := transformCase(c, n); - nkProcDef, nkIteratorDef: begin + nkProcDef, nkIteratorDef, nkMacroDef: begin if n.sons[genericParamsPos] = nil then n.sons[codePos] := transform(c, n.sons[codePos]); end; nkWhileStmt: begin - assert(sonsLen(n) = 2); + if (sonsLen(n) <> 2) then InternalError(n.info, 'transform'); n.sons[0] := transform(c, n.sons[0]); n.sons[1] := transformContinue(c, n.sons[1]); end; + nkCall, nkHiddenCallConv, nkCommand, nkInfix, nkPrefix, nkPostfix: + result := transformCall(c, result); nkAddr, nkHiddenAddr: result := transformAddrDeref(c, n, nkDerefExpr, nkHiddenDeref); nkDerefExpr, nkHiddenDeref: result := transformAddrDeref(c, n, nkAddr, nkHiddenAddr); nkHiddenStdConv, nkHiddenSubConv, nkConv: result := transformConv(c, n); - nkCommentStmt, nkTemplateDef, nkMacroDef: exit; + nkCommentStmt, nkTemplateDef: exit; nkConstSection: exit; // do not replace ``const c = 3`` with ``const 3 = 3`` else begin for i := 0 to sonsLen(n)-1 do result.sons[i] := transform(c, n.sons[i]); end end; - cnst := getConstExpr(c, result); + cnst := getConstExpr(c.module, result); if cnst <> nil then result := cnst; // do not miss an optimization end; + +function processTransf(context: PPassContext; n: PNode): PNode; +var + c: PTransf; +begin + c := PTransf(context); + result := transform(c, n); +end; + +function openTransf(module: PSym; const filename: string): PPassContext; +var + n: PTransf; +begin + new(n); +{@ignore} + fillChar(n^, sizeof(n^), 0); +{@emit} + n.module := module; + result := n; +end; + +function transfPass(): TPass; +begin + initPass(result); + result.open := openTransf; + result.process := processTransf; + result.close := processTransf; // we need to process generics too! +end; + +end. diff --git a/nim/trees.pas b/nim/trees.pas index a50b8f6cb..d271bfae8 100644 --- a/nim/trees.pas +++ b/nim/trees.pas @@ -70,7 +70,7 @@ function cyclicTree(n: PNode): boolean; var s: PNode; begin - s := newNode(nkEmpty); + s := newNodeI(nkEmpty, n.info); result := cyclicTreeAux(n, s); end; @@ -113,8 +113,8 @@ begin end else if (a <> nil) and (b <> nil) and (a.kind = b.kind) then begin if a.flags <> b.flags then exit; - if a.info.line <> int(b.info.line) then exit; - if a.info.col <> int(b.info.col) then exit; + if a.info.line <> b.info.line then exit; + if a.info.col <> b.info.col then exit; //if a.info.fileIndex <> b.info.fileIndex then exit; case a.kind of nkSym: // don't go nuts here: same symbol as string is enough: @@ -147,7 +147,7 @@ begin if not (op.kind in [nkCall, nkGenericCall, nkHiddenCallConv]) then result := nil else begin - assert(sonsLen(op) > 0); + if (sonsLen(op) <= 0) then InternalError(op.info, 'getOpSym'); case op.sons[0].Kind of nkSym, nkQualified: result := op.sons[0].sym; else result := nil @@ -160,8 +160,7 @@ begin case op.kind of nkCall, nkHiddenCallConv: begin case op.sons[0].Kind of - nkSym, nkQualified: begin - assert(op.sons[0].sym <> nil); // BUGFIX + nkSym: begin result := op.sons[0].sym.magic; end; else result := mNone @@ -183,7 +182,8 @@ end; function isConstExpr(n: PNode): Boolean; begin result := (n.kind in [nkCharLit..nkInt64Lit, nkStrLit..nkTripleStrLit, - nkFloatLit..nkFloat64Lit]) or (nfAllConst in n.flags) + nkFloatLit..nkFloat64Lit, nkNilLit]) + or (nfAllConst in n.flags) end; procedure flattenTreeAux(d, a: PNode; op: TMagic); diff --git a/nim/treetab.pas b/nim/treetab.pas index 5a9dbdb2a..dbd7b5276 100644 --- a/nim/treetab.pas +++ b/nim/treetab.pas @@ -17,8 +17,10 @@ interface uses nsystem, hashes, ast, astalgo, types; -function NodeTableGet(const t: TNodeTable; key: PNode): PNode; -procedure NodeTablePut(var t: TNodeTable; key, val: PNode); +function NodeTableGet(const t: TNodeTable; key: PNode): int; +procedure NodeTablePut(var t: TNodeTable; key: PNode; val: int); + +function NodeTableTestOrSet(var t: TNodeTable; key: PNode; val: int): int; implementation @@ -29,7 +31,7 @@ begin result := 0; if n = nil then exit; result := ord(n.kind); - case n.kind of + case n.kind of nkEmpty, nkNilLit, nkType: begin end; nkIdent: result := concHash(result, n.ident.h); nkSym: result := concHash(result, n.sym.name.h); @@ -44,7 +46,7 @@ begin nkStrLit..nkTripleStrLit: result := concHash(result, GetHashStr(n.strVal)); else begin - for i := 0 to sonsLen(n)-1 do + for i := 0 to sonsLen(n)-1 do result := concHash(result, hashTree(n.sons[i])); end end @@ -95,17 +97,17 @@ begin result := -1 end; -function NodeTableGet(const t: TNodeTable; key: PNode): PNode; +function NodeTableGet(const t: TNodeTable; key: PNode): int; var index: int; begin index := NodeTableRawGet(t, hashTree(key), key); if index >= 0 then result := t.data[index].val - else result := nil + else result := low(int) end; procedure NodeTableRawInsert(var data: TNodePairSeq; k: THash; - key, val: PNode); + key: PNode; val: int); var h: THash; begin @@ -117,7 +119,7 @@ begin data[h].val := val; end; -procedure NodeTablePut(var t: TNodeTable; key, val: PNode); +procedure NodeTablePut(var t: TNodeTable; key: PNode; val: int); var index, i: int; n: TNodePairSeq; @@ -131,10 +133,44 @@ begin end else begin if mustRehash(length(t.data), t.counter) then begin + {@ignore} setLength(n, length(t.data) * growthFactor); + fillChar(n[0], length(n)*sizeof(n[0]), 0); + {@emit + newSeq(n, length(t.data) * growthFactor); } + for i := 0 to high(t.data) do + if t.data[i].key <> nil then + NodeTableRawInsert(n, t.data[i].h, t.data[i].key, t.data[i].val); + {@ignore} + t.data := n; + {@emit + swap(t.data, n); + } + end; + NodeTableRawInsert(t.data, k, key, val); + inc(t.counter) + end; +end; + +function NodeTableTestOrSet(var t: TNodeTable; key: PNode; val: int): int; +var + index, i: int; + n: TNodePairSeq; + k: THash; +begin + k := hashTree(key); + index := NodeTableRawGet(t, k, key); + if index >= 0 then begin + assert(t.data[index].key <> nil); + result := t.data[index].val + end + else begin + if mustRehash(length(t.data), t.counter) then begin {@ignore} + setLength(n, length(t.data) * growthFactor); fillChar(n[0], length(n)*sizeof(n[0]), 0); - {@emit} + {@emit + newSeq(n, length(t.data) * growthFactor); } for i := 0 to high(t.data) do if t.data[i].key <> nil then NodeTableRawInsert(n, t.data[i].h, t.data[i].key, t.data[i].val); @@ -145,6 +181,7 @@ begin } end; NodeTableRawInsert(t.data, k, key, val); + result := val; inc(t.counter) end; end; diff --git a/nim/types.pas b/nim/types.pas index c63913baa..bc42f2169 100644 --- a/nim/types.pas +++ b/nim/types.pas @@ -77,8 +77,10 @@ function skipPtrsGeneric(t: PType): PType; function elemType(t: PType): PType; function containsObject(t: PType): bool; + function containsGarbageCollectedRef(typ: PType): Boolean; function containsHiddenPointer(typ: PType): Boolean; +function canFormAcycle(typ: PType): boolean; function isCompatibleToCString(a: PType): bool; @@ -100,6 +102,19 @@ function inheritanceDiff(a, b: PType): int; function InvalidGenericInst(f: PType): bool; // for debugging + +type + TTypeFieldResult = ( + frNone, // type has no object type field + frHeader, // type has an object type field only in the header + frEmbedded // type has an object type field somewhere embedded + ); + +function analyseObjectWithTypeField(t: PType): TTypeFieldResult; +// this does a complex analysis whether a call to ``objectInit`` needs to be +// made or intializing of the type field suffices or if there is no type field +// at all in this type. + implementation function InvalidGenericInst(f: PType): bool; @@ -392,6 +407,54 @@ begin result := searchTypeFor(t, isObjectPredicate); end; +function isObjectWithTypeFieldPredicate(t: PType): bool; +begin + result := (t.kind = tyObject) and (t.sons[0] = nil) + and not (sfPure in t.sym.flags) + and not (tfFinal in t.flags); +end; + +function analyseObjectWithTypeFieldAux(t: PType; + var marker: TIntSet): TTypeFieldResult; +var + res: TTypeFieldResult; + i: int; +begin + result := frNone; + if t = nil then exit; + case t.kind of + tyObject: begin + if (t.n <> nil) then + if searchTypeNodeForAux(t.n, isObjectWithTypeFieldPredicate, marker) then begin + result := frEmbedded; exit + end; + for i := 0 to sonsLen(t)-1 do begin + res := analyseObjectWithTypeFieldAux(t.sons[i], marker); + if res = frEmbedded then begin result := frEmbedded; exit end; + if res = frHeader then result := frHeader; + end; + if result = frNone then + if isObjectWithTypeFieldPredicate(t) then result := frHeader + end; + tyGenericInst: result := analyseObjectWithTypeFieldAux(lastSon(t), marker); + tyArray, tyArrayConstr, tyTuple: begin + for i := 0 to sonsLen(t)-1 do begin + res := analyseObjectWithTypeFieldAux(t.sons[i], marker); + if res <> frNone then begin result := frEmbedded; exit end; + end + end + else begin end + end +end; + +function analyseObjectWithTypeField(t: PType): TTypeFieldResult; +var + marker: TIntSet; +begin + IntSetInit(marker); + result := analyseObjectWithTypeFieldAux(t, marker); +end; + function isGBCRef(t: PType): bool; begin result := t.kind in [tyRef, tySequence, tyString]; @@ -416,6 +479,61 @@ begin result := searchTypeFor(typ, isHiddenPointer); end; +function canFormAcycleAux(var marker: TIntSet; t: PType; + startId: int): bool; forward; + +function canFormAcycleNode(var marker: TIntSet; n: PNode; startId: int): bool; +var + i: int; +begin + result := false; + if n <> nil then begin + result := canFormAcycleAux(marker, n.typ, startId); + if not result then + case n.kind of + nkNone..nkNilLit: begin end; + else begin + for i := 0 to sonsLen(n)-1 do begin + result := canFormAcycleNode(marker, n.sons[i], startId); + if result then exit + end + end + end + end +end; + +function canFormAcycleAux(var marker: TIntSet; t: PType; startId: int): bool; +var + i: int; +begin + result := false; + if t = nil then exit; + if tfAcyclic in t.flags then exit; + case skipGeneric(t).kind of + tyTuple, tyObject, tyRef, tySequence, tyArray, tyArrayConstr, + tyOpenArray: begin + if not IntSetContainsOrIncl(marker, t.id) then begin + for i := 0 to sonsLen(t)-1 do begin + result := canFormAcycleAux(marker, t.sons[i], startId); + if result then exit + end; + if t.n <> nil then result := canFormAcycleNode(marker, t.n, startId) + end + else + result := t.id = startId; + end + else begin end + end +end; + +function canFormAcycle(typ: PType): boolean; +var + marker: TIntSet; +begin + IntSetInit(marker); + result := canFormAcycleAux(marker, typ, typ.id); +end; + function mutateTypeAux(var marker: TIntSet; t: PType; iter: TTypeMutator; closure: PObject): PType; forward; @@ -476,7 +594,7 @@ end; function TypeToString(typ: PType; prefer: TPreferedDesc = preferName): string; const typeToStr: array [TTypeKind] of string = ( - 'None', 'bool', 'Char', '{}', 'Array Constructor [$1]', 'nil', + 'None', 'bool', 'Char', 'empty', 'Array Constructor [$1]', 'nil', 'Generic', 'GenericInst', 'GenericParam', 'enum', 'anyenum', 'array[$1, $2]', 'object', 'tuple', 'set[$1]', 'range[$1]', @@ -770,12 +888,16 @@ var i: int; a, b: PType; begin + if x = y then begin result := true; exit end; a := skipGeneric(x); b := skipGeneric(y); assert(a <> nil); assert(b <> nil); if a.kind <> b.kind then begin result := false; exit end; case a.Kind of + tyEmpty, tyChar, tyBool, tyNil, tyPointer, tyString, tyCString, + tyInt..tyFloat128: + result := true; tyEnum, tyForward, tyObject: result := (a.id = b.id); tyTuple: @@ -802,17 +924,10 @@ begin and SameValue(a.n.sons[0], b.n.sons[0]) and SameValue(a.n.sons[1], b.n.sons[1]) end; - tyChar, tyBool, tyNil, tyPointer, tyString, tyCString, tyInt..tyFloat128: - result := true; - else begin - InternalError('sameType(' +{&} typeKindToStr[a.kind] +{&} ', ' - +{&} typeKindToStr[b.kind] +{&} ')'); - result := false - end + tyNone, tyAnyEnum: result := false; end end; - function align(address, alignment: biggestInt): biggestInt; begin result := address + (alignment-1) and not (alignment-1); diff --git a/nim/wordrecg.pas b/nim/wordrecg.pas index 2849c1d05..309b2f7c1 100644 --- a/nim/wordrecg.pas +++ b/nim/wordrecg.pas @@ -25,15 +25,18 @@ type TSpecialWord = (wInvalid, // these are mapped to Nimrod keywords: //[[[cog - //keywords = (file("data/keywords.txt").read()).split() + //from string import split, capitalize + //keywords = split(open("data/keywords.txt").read()) //idents = "" //strings = "" //i = 1 //for k in keywords: - // idents += "w" + k.capitalize() + ", " - // strings += "'" + k + "', " - // if i % 4 == 0: idents += "\n"; strings += "\n" - // i += 1 + // idents = idents + "w" + capitalize(k) + ", " + // strings = strings + "'" + k + "', " + // if i % 4 == 0: + // idents = idents + "\n" + // strings = strings + "\n" + // i = i + 1 //cog.out(idents) //]]] wAddr, wAnd, wAs, wAsm, @@ -57,34 +60,34 @@ type wColon, wEquals, wDot, wDotDot, wHat, wStar, wMinus, // pragmas and command line options: - wMagic, wTypeCheck, wFinal, wPostfix, + wMagic, wTypeCheck, wFinal, wProfiler, wObjChecks, wImportc, wExportc, wAlign, wNodecl, wPure, wVolatile, wRegister, wNostatic, wHeader, wNosideeffect, wNoreturn, - wLib, wDynlib, wReturnsnew, wCompilerproc, wCppmethod, wFatal, + wMerge, wLib, wDynlib, wCompilerproc, wCppmethod, wFatal, wError, wWarning, wHint, wLine, wPush, wPop, wDefine, wUndef, wLinedir, wStacktrace, wLinetrace, wPragma, wLink, wCompile, wLinksys, wFixupsystem, wDeprecated, wVarargs, wByref, wCallconv, wBreakpoint, wDebugger, wNimcall, wStdcall, - wCdecl, wSafecall, wSyscall, wInline, wFastcall, wClosure, + wCdecl, wSafecall, wSyscall, wInline, wNoInline, wFastcall, wClosure, wNoconv, wOn, wOff, wChecks, wRangechecks, wBoundchecks, wOverflowchecks, wNilchecks, wAssertions, wWarnings, wW, wHints, wOptimization, wSpeed, wSize, wNone, wPath, wP, wD, wU, wDebuginfo, wCompileonly, wNolinking, wForcebuild, - wF, wDeadelim, wSafecode, wSyntaxcheck, wY, + wF, wDeadelim, wSafecode, wCompileTime, wGc, wRefc, wBoehm, wA, wOpt, wO, wApp, wConsole, wGui, wPassc, wT, wPassl, wL, wListcmd, wGendoc, wGenmapping, wOs, wCpu, wGenerate, wG, wC, wCpp, - wYaml, wRun, wR, wVerbose, wV, wHelp, - wH, wCompilesys, wFieldChecks, wX, wVersion, wAdvanced, wMergeoutput, + wYaml, wRun, wR, wVerbosity, wV, wHelp, + wH, wSymbolFiles, wFieldChecks, wX, wVersion, wAdvanced, wSkipcfg, wSkipProjCfg, wCc, wGenscript, wCheckPoint, wCheckPoints, wMaxErr, wExpr, wStmt, wTypeDesc, - wAsmQuote, wAstCache, wCFileCache, wIndex, + wSubsChar, wAstCache, wAcyclic, wIndex, // commands: wCompileToC, wCompileToCpp, wCompileToEcmaScript, wPretty, wDoc, wPas, wGenDepend, wListDef, wCheck, wParse, wScan, wBoot, wDebugTrans, - wRst2html, + wRst2html, wI, // special for the preprocessor of configuration files: wWrite, wPutEnv, wPrependEnv, wAppendEnv, // additional Pascal keywords: @@ -131,34 +134,33 @@ const ':'+'', '='+'', '.'+'', '..', '^'+'', '*'+'', '-'+'', // pragmas and command line options: - 'magic', 'typecheck', 'final', 'postfix', + 'magic', 'typecheck', 'final', 'profiler', 'objchecks', 'importc', 'exportc', 'align', 'nodecl', 'pure', 'volatile', 'register', 'nostatic', 'header', 'nosideeffect', 'noreturn', - 'lib', 'dynlib', 'returnsnew', 'compilerproc', 'cppmethod', 'fatal', + 'merge', 'lib', 'dynlib', 'compilerproc', 'cppmethod', 'fatal', 'error', 'warning', 'hint', 'line', 'push', 'pop', 'define', 'undef', 'linedir', 'stacktrace', 'linetrace', 'pragma', 'link', 'compile', 'linksys', 'fixupsystem', 'deprecated', 'varargs', 'byref', 'callconv', 'breakpoint', 'debugger', 'nimcall', 'stdcall', - 'cdecl', 'safecall', 'syscall', 'inline', 'fastcall', 'closure', + 'cdecl', 'safecall', 'syscall', 'inline', 'noinline', 'fastcall', 'closure', 'noconv', 'on', 'off', 'checks', 'rangechecks', 'boundchecks', 'overflowchecks', 'nilchecks', 'assertions', 'warnings', 'w'+'', 'hints', 'optimization', 'speed', 'size', 'none', 'path', 'p'+'', 'd'+'', 'u'+'', 'debuginfo', 'compileonly', 'nolinking', 'forcebuild', - 'f'+'', 'deadelim', 'safecode', 'syntaxcheck', 'y'+'', + 'f'+'', 'deadelim', 'safecode', 'compiletime', 'gc', 'refc', 'boehm', 'a'+'', 'opt', 'o'+'', 'app', 'console', 'gui', 'passc', 't'+'', 'passl', 'l'+'', 'listcmd', 'gendoc', 'genmapping', 'os', 'cpu', 'generate', 'g'+'', 'c'+'', 'cpp', - 'yaml', 'run', 'r'+'', 'verbose', 'v'+'', 'help', - 'h'+'', 'compilesys', 'fieldchecks', 'x'+'', 'version', 'advanced', - 'mergeoutput', + 'yaml', 'run', 'r'+'', 'verbosity', 'v'+'', 'help', + 'h'+'', 'symbolfiles', 'fieldchecks', 'x'+'', 'version', 'advanced', 'skipcfg', 'skipprojcfg', 'cc', 'genscript', 'checkpoint', 'checkpoints', 'maxerr', 'expr', 'stmt', 'typedesc', - 'asmquote', 'astcache', 'cfilecache', 'index', + 'subschar', 'astcache', 'acyclic', 'index', // commands: 'compiletoc', 'compiletocpp', 'compiletoecmascript', 'pretty', 'doc', 'pas', 'gendepend', 'listdef', 'check', 'parse', - 'scan', 'boot', 'debugtrans', 'rst2html', + 'scan', 'boot', 'debugtrans', 'rst2html', 'i'+'', // special for the preprocessor of configuration files: 'write', 'putenv', 'prependenv', 'appendenv', |