diff options
Diffstat (limited to 'nim')
86 files changed, 0 insertions, 49387 deletions
diff --git a/nim/ast.pas b/nim/ast.pas deleted file mode 100755 index 0079d755c..000000000 --- a/nim/ast.pas +++ /dev/null @@ -1,1436 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit ast; - -// abstract syntax tree + symbol table - -interface - -{$include 'config.inc'} - -uses - nsystem, charsets, msgs, nhashes, - nversion, options, strutils, crc, ropes, idents, lists; - -const - ImportTablePos = 0; - ModuleTablePos = 1; - -type - TCallingConvention = ( - ccDefault, // proc has no explicit calling convention - ccStdCall, // procedure is stdcall - ccCDecl, // cdecl - ccSafeCall, // safecall - ccSysCall, // system call - ccInline, // proc should be inlined - ccNoInline, // proc should not be inlined - ccFastCall, // fastcall (pass parameters in registers) - ccClosure, // proc has a closure - ccNoConvention // needed for generating proper C procs sometimes - ); - -const - CallingConvToStr: array [TCallingConvention] of string = ( - '', 'stdcall', 'cdecl', 'safecall', 'syscall', 'inline', 'noinline', - 'fastcall', 'closure', 'noconv'); - -(*[[[cog -def toEnum(name, elems, prefixlen=0): - body = "" - strs = "" - prefix = "" - counter = 0 - for e in elems: - if counter % 4 == 0: prefix = "\n " - else: prefix = "" - body = body + prefix + e + ', ' - strs = strs + prefix + "'%s', " % e[prefixlen:] - counter = counter + 1 - - return ("type\n T%s = (%s);\n T%ss = set of T%s;\n" - % (name, body[:-2], name, name), - "const\n %sToStr: array [T%s] of string = (%s);\n" - % (name, name, strs[:-2])) - -enums = eval(open("data/ast.yml").read()) -for key, val in enums.items(): - (a, b) = toEnum(key, val) - cog.out(a) - cog.out(b) -]]]*) -type - TNodeKind = ( - nkNone, nkEmpty, nkIdent, nkSym, - nkType, nkCharLit, nkIntLit, nkInt8Lit, - nkInt16Lit, nkInt32Lit, nkInt64Lit, nkFloatLit, - nkFloat32Lit, nkFloat64Lit, nkStrLit, nkRStrLit, - nkTripleStrLit, nkMetaNode, nkNilLit, nkDotCall, - nkCommand, nkCall, nkCallStrLit, nkExprEqExpr, - nkExprColonExpr, nkIdentDefs, nkVarTuple, nkInfix, - nkPrefix, nkPostfix, nkPar, nkCurly, - nkBracket, nkBracketExpr, nkPragmaExpr, nkRange, - nkDotExpr, nkCheckedFieldExpr, nkDerefExpr, nkIfExpr, - nkElifExpr, nkElseExpr, nkLambda, nkAccQuoted, - nkTableConstr, nkBind, nkSymChoice, nkHiddenStdConv, - nkHiddenSubConv, nkHiddenCallConv, nkConv, nkCast, - nkAddr, nkHiddenAddr, nkHiddenDeref, nkObjDownConv, - nkObjUpConv, nkChckRangeF, nkChckRange64, nkChckRange, - nkStringToCString, nkCStringToString, nkPassAsOpenArray, nkAsgn, - nkFastAsgn, nkGenericParams, nkFormalParams, nkOfInherit, - nkModule, nkProcDef, nkMethodDef, nkConverterDef, - nkMacroDef, nkTemplateDef, nkIteratorDef, nkOfBranch, - nkElifBranch, nkExceptBranch, nkElse, nkMacroStmt, - nkAsmStmt, nkPragma, nkIfStmt, nkWhenStmt, - nkForStmt, nkWhileStmt, nkCaseStmt, nkVarSection, - nkConstSection, nkConstDef, nkTypeSection, nkTypeDef, - nkYieldStmt, nkTryStmt, nkFinally, nkRaiseStmt, - nkReturnStmt, nkBreakStmt, nkContinueStmt, nkBlockStmt, - nkDiscardStmt, nkStmtList, nkImportStmt, nkFromStmt, - nkIncludeStmt, nkCommentStmt, nkStmtListExpr, nkBlockExpr, - nkStmtListType, nkBlockType, nkTypeOfExpr, nkObjectTy, - nkTupleTy, nkRecList, nkRecCase, nkRecWhen, - nkRefTy, nkPtrTy, nkVarTy, nkDistinctTy, - nkProcTy, nkEnumTy, nkEnumFieldDef, nkReturnToken); - TNodeKinds = set of TNodeKind; -const - NodeKindToStr: array [TNodeKind] of string = ( - 'nkNone', 'nkEmpty', 'nkIdent', 'nkSym', - 'nkType', 'nkCharLit', 'nkIntLit', 'nkInt8Lit', - 'nkInt16Lit', 'nkInt32Lit', 'nkInt64Lit', 'nkFloatLit', - 'nkFloat32Lit', 'nkFloat64Lit', 'nkStrLit', 'nkRStrLit', - 'nkTripleStrLit', 'nkMetaNode', 'nkNilLit', 'nkDotCall', - 'nkCommand', 'nkCall', 'nkCallStrLit', 'nkExprEqExpr', - 'nkExprColonExpr', 'nkIdentDefs', 'nkVarTuple', 'nkInfix', - 'nkPrefix', 'nkPostfix', 'nkPar', 'nkCurly', - 'nkBracket', 'nkBracketExpr', 'nkPragmaExpr', 'nkRange', - 'nkDotExpr', 'nkCheckedFieldExpr', 'nkDerefExpr', 'nkIfExpr', - 'nkElifExpr', 'nkElseExpr', 'nkLambda', 'nkAccQuoted', - 'nkTableConstr', 'nkBind', 'nkSymChoice', 'nkHiddenStdConv', - 'nkHiddenSubConv', 'nkHiddenCallConv', 'nkConv', 'nkCast', - 'nkAddr', 'nkHiddenAddr', 'nkHiddenDeref', 'nkObjDownConv', - 'nkObjUpConv', 'nkChckRangeF', 'nkChckRange64', 'nkChckRange', - 'nkStringToCString', 'nkCStringToString', 'nkPassAsOpenArray', 'nkAsgn', - 'nkFastAsgn', 'nkGenericParams', 'nkFormalParams', 'nkOfInherit', - 'nkModule', 'nkProcDef', 'nkMethodDef', 'nkConverterDef', - 'nkMacroDef', 'nkTemplateDef', 'nkIteratorDef', 'nkOfBranch', - 'nkElifBranch', 'nkExceptBranch', 'nkElse', 'nkMacroStmt', - 'nkAsmStmt', 'nkPragma', 'nkIfStmt', 'nkWhenStmt', - 'nkForStmt', 'nkWhileStmt', 'nkCaseStmt', 'nkVarSection', - 'nkConstSection', 'nkConstDef', 'nkTypeSection', 'nkTypeDef', - 'nkYieldStmt', 'nkTryStmt', 'nkFinally', 'nkRaiseStmt', - 'nkReturnStmt', 'nkBreakStmt', 'nkContinueStmt', 'nkBlockStmt', - 'nkDiscardStmt', 'nkStmtList', 'nkImportStmt', 'nkFromStmt', - 'nkIncludeStmt', 'nkCommentStmt', 'nkStmtListExpr', 'nkBlockExpr', - 'nkStmtListType', 'nkBlockType', 'nkTypeOfExpr', 'nkObjectTy', - 'nkTupleTy', 'nkRecList', 'nkRecCase', 'nkRecWhen', - 'nkRefTy', 'nkPtrTy', 'nkVarTy', 'nkDistinctTy', - 'nkProcTy', 'nkEnumTy', 'nkEnumFieldDef', 'nkReturnToken'); -type - TSymFlag = ( - sfUsed, sfStar, sfMinus, sfInInterface, - sfFromGeneric, sfGlobal, sfForward, sfImportc, - sfExportc, sfVolatile, sfRegister, sfPure, - sfResult, sfNoSideEffect, sfSideEffect, sfMainModule, - sfSystemModule, sfNoReturn, sfAddrTaken, sfCompilerProc, - sfProcvar, sfDiscriminant, sfDeprecated, sfInClosure, - sfTypeCheck, sfCompileTime, sfThreadVar, sfMerge, - sfDeadCodeElim, sfBorrow); - TSymFlags = set of TSymFlag; -const - SymFlagToStr: array [TSymFlag] of string = ( - 'sfUsed', 'sfStar', 'sfMinus', 'sfInInterface', - 'sfFromGeneric', 'sfGlobal', 'sfForward', 'sfImportc', - 'sfExportc', 'sfVolatile', 'sfRegister', 'sfPure', - 'sfResult', 'sfNoSideEffect', 'sfSideEffect', 'sfMainModule', - 'sfSystemModule', 'sfNoReturn', 'sfAddrTaken', 'sfCompilerProc', - 'sfProcvar', 'sfDiscriminant', 'sfDeprecated', 'sfInClosure', - 'sfTypeCheck', 'sfCompileTime', 'sfThreadVar', 'sfMerge', - 'sfDeadCodeElim', 'sfBorrow'); -type - TTypeKind = ( - tyNone, tyBool, tyChar, tyEmpty, - tyArrayConstr, tyNil, tyExpr, tyStmt, - tyTypeDesc, tyGenericInvokation, tyGenericBody, tyGenericInst, - tyGenericParam, tyDistinct, tyEnum, tyOrdinal, - tyArray, tyObject, tyTuple, tySet, - tyRange, tyPtr, tyRef, tyVar, - tySequence, tyProc, tyPointer, tyOpenArray, - tyString, tyCString, tyForward, tyInt, - tyInt8, tyInt16, tyInt32, tyInt64, - tyFloat, tyFloat32, tyFloat64, tyFloat128); - TTypeKinds = set of TTypeKind; -const - TypeKindToStr: array [TTypeKind] of string = ( - 'tyNone', 'tyBool', 'tyChar', 'tyEmpty', - 'tyArrayConstr', 'tyNil', 'tyExpr', 'tyStmt', - 'tyTypeDesc', 'tyGenericInvokation', 'tyGenericBody', 'tyGenericInst', - 'tyGenericParam', 'tyDistinct', 'tyEnum', 'tyOrdinal', - 'tyArray', 'tyObject', 'tyTuple', 'tySet', - 'tyRange', 'tyPtr', 'tyRef', 'tyVar', - 'tySequence', 'tyProc', 'tyPointer', 'tyOpenArray', - 'tyString', 'tyCString', 'tyForward', 'tyInt', - 'tyInt8', 'tyInt16', 'tyInt32', 'tyInt64', - 'tyFloat', 'tyFloat32', 'tyFloat64', 'tyFloat128'); -type - TNodeFlag = ( - nfNone, nfBase2, nfBase8, nfBase16, - nfAllConst, nfTransf, nfSem); - TNodeFlags = set of TNodeFlag; -const - NodeFlagToStr: array [TNodeFlag] of string = ( - 'nfNone', 'nfBase2', 'nfBase8', 'nfBase16', - 'nfAllConst', 'nfTransf', 'nfSem'); -type - TTypeFlag = ( - tfVarargs, tfNoSideEffect, tfFinal, tfAcyclic, - tfEnumHasWholes); - TTypeFlags = set of TTypeFlag; -const - TypeFlagToStr: array [TTypeFlag] of string = ( - 'tfVarargs', 'tfNoSideEffect', 'tfFinal', 'tfAcyclic', - 'tfEnumHasWholes'); -type - TSymKind = ( - skUnknown, skConditional, skDynLib, skParam, - skGenericParam, skTemp, skType, skConst, - skVar, skProc, skMethod, skIterator, - skConverter, skMacro, skTemplate, skField, - skEnumField, skForVar, skModule, skLabel, - skStub); - TSymKinds = set of TSymKind; -const - SymKindToStr: array [TSymKind] of string = ( - 'skUnknown', 'skConditional', 'skDynLib', 'skParam', - 'skGenericParam', 'skTemp', 'skType', 'skConst', - 'skVar', 'skProc', 'skMethod', 'skIterator', - 'skConverter', 'skMacro', 'skTemplate', 'skField', - 'skEnumField', 'skForVar', 'skModule', 'skLabel', - 'skStub'); -{[[[end]]]} - -type - // symbols that require compiler magic: - TMagic = ( - //[[[cog - //magics = eval(open("data/magic.yml").read()) - //for i in range(0, len(magics)-1): - // cog.out("m" + magics[i] + ", ") - // if (i+1) % 6 == 0: cog.outl("") - //cog.outl("m" + magics[-1]) - //]]] - mNone, mDefined, mDefinedInScope, mLow, mHigh, mSizeOf, - mIs, mEcho, mSucc, mPred, mInc, mDec, - mOrd, mNew, mNewFinalize, mNewSeq, mLengthOpenArray, mLengthStr, - mLengthArray, mLengthSeq, mIncl, mExcl, mCard, mChr, - mGCref, mGCunref, mAddI, mSubI, mMulI, mDivI, - mModI, mAddI64, mSubI64, mMulI64, mDivI64, mModI64, - mShrI, mShlI, mBitandI, mBitorI, mBitxorI, mMinI, - mMaxI, mShrI64, mShlI64, mBitandI64, mBitorI64, mBitxorI64, - mMinI64, mMaxI64, mAddF64, mSubF64, mMulF64, mDivF64, - mMinF64, mMaxF64, mAddU, mSubU, mMulU, mDivU, - mModU, mAddU64, mSubU64, mMulU64, mDivU64, mModU64, - mEqI, mLeI, mLtI, mEqI64, mLeI64, mLtI64, - mEqF64, mLeF64, mLtF64, mLeU, mLtU, mLeU64, - mLtU64, mEqEnum, mLeEnum, mLtEnum, mEqCh, mLeCh, - mLtCh, mEqB, mLeB, mLtB, mEqRef, mEqProc, - mEqUntracedRef, mLePtr, mLtPtr, mEqCString, mXor, mUnaryMinusI, - mUnaryMinusI64, mAbsI, mAbsI64, mNot, mUnaryPlusI, mBitnotI, - mUnaryPlusI64, mBitnotI64, mUnaryPlusF64, mUnaryMinusF64, mAbsF64, mZe8ToI, - mZe8ToI64, mZe16ToI, mZe16ToI64, mZe32ToI64, mZeIToI64, mToU8, - mToU16, mToU32, mToFloat, mToBiggestFloat, mToInt, mToBiggestInt, - mCharToStr, mBoolToStr, mIntToStr, mInt64ToStr, mFloatToStr, mCStrToStr, - mStrToStr, mEnumToStr, mAnd, mOr, mEqStr, mLeStr, - mLtStr, mEqSet, mLeSet, mLtSet, mMulSet, mPlusSet, - mMinusSet, mSymDiffSet, mConStrStr, mConArrArr, mConArrT, mConTArr, - mConTT, mSlice, mAppendStrCh, mAppendStrStr, mAppendSeqElem, mInRange, - mInSet, mRepr, mExit, mSetLengthStr, mSetLengthSeq, mAssert, - mSwap, mIsNil, mArrToSeq, mCopyStr, mCopyStrLast, mNewString, - mArray, mOpenArray, mRange, mSet, mSeq, mOrdinal, - mInt, mInt8, mInt16, mInt32, mInt64, mFloat, - mFloat32, mFloat64, mBool, mChar, mString, mCstring, - mPointer, mEmptySet, mIntSetBaseType, mNil, mExpr, mStmt, - mTypeDesc, mIsMainModule, mCompileDate, mCompileTime, mNimrodVersion, mNimrodMajor, - mNimrodMinor, mNimrodPatch, mCpuEndian, mHostOS, mHostCPU, mNaN, - mInf, mNegInf, mNLen, mNChild, mNSetChild, mNAdd, - mNAddMultiple, mNDel, mNKind, mNIntVal, mNFloatVal, mNSymbol, - mNIdent, mNGetType, mNStrVal, mNSetIntVal, mNSetFloatVal, mNSetSymbol, - mNSetIdent, mNSetType, mNSetStrVal, mNNewNimNode, mNCopyNimNode, mNCopyNimTree, - mStrToIdent, mIdentToStr, mEqIdent, mEqNimrodNode, mNHint, mNWarning, - mNError - //[[[end]]] - ); - -type - PNode = ^TNode; - PNodePtr = ^{@ptr}PNode; - TNodeSeq = array of PNode; - - PType = ^TType; - PSym = ^TSym; - - TNode = {@ignore} record - typ: PType; - strVal: string; - comment: string; - sons: TNodeSeq; // else! - info: TLineInfo; - flags: TNodeFlags; - case Kind: TNodeKind of - nkCharLit, nkIntLit, nkInt8Lit, nkInt16Lit, nkInt32Lit, nkInt64Lit: - (intVal: biggestInt); - nkFloatLit, nkFloat32Lit, nkFloat64Lit: - (floatVal: biggestFloat); - nkSym: (sym: PSym); - nkIdent: (ident: PIdent); - nkMetaNode: (nodePtr: PNodePtr); - end; - {@emit - record // on a 32bit machine, this takes 32 bytes - typ: PType; - comment: string; - info: TLineInfo; - flags: TNodeFlags; - case Kind: TNodeKind of - nkCharLit..nkInt64Lit: - (intVal: biggestInt); - nkFloatLit..nkFloat64Lit: - (floatVal: biggestFloat); - nkStrLit..nkTripleStrLit: - (strVal: string); - nkSym: (sym: PSym); - nkIdent: (ident: PIdent); - nkMetaNode: (nodePtr: PNodePtr); - else (sons: TNodeSeq); - end acyclic; } - - TSymSeq = array of PSym; - TStrTable = object // a table[PIdent] of PSym - counter: int; - data: TSymSeq; - end; - -// -------------- backend information ------------------------------- - - TLocKind = ( - locNone, // no location - locTemp, // temporary location - locLocalVar, // location is a local variable - locGlobalVar, // location is a global variable - locParam, // location is a parameter - locField, // location is a record field - locArrayElem, // location is an array element - locExpr, // "location" is really an expression - locProc, // location is a proc (an address of a procedure) - locData, // location is a constant - locCall, // location is a call expression - locOther // location is something other - ); - - TLocFlag = ( - lfIndirect, // backend introduced a pointer - lfParamCopy, // backend introduced a parameter copy (LLVM) - lfNoDeepCopy, // no need for a deep copy - lfNoDecl, // do not declare it in C - lfDynamicLib, // link symbol to dynamic library - lfExportLib, // export symbol for dynamic library generation - lfHeader // include header file for symbol - ); - - TStorageLoc = ( - OnUnknown, // location is unknown (stack, heap or static) - OnStack, // location is on hardware stack - OnHeap // location is on heap or global (reference counting needed) - ); - - TLocFlags = set of TLocFlag; - TLoc = record - k: TLocKind; // kind of location - s: TStorageLoc; - flags: TLocFlags; // location's flags - t: PType; // type of location - r: PRope; // rope value of location (code generators) - a: int; // location's "address", i.e. slot for temporaries - end; - -// ---------------- end of backend information ------------------------------ - TLibKind = (libHeader, libDynamic); - TLib = object(lists.TListEntry) // also misused for headers! - kind: TLibKind; - generated: bool; - // needed for the backends: - name: PRope; - path: string; - end; - PLib = ^TLib; - - TSym = object(TIdObj) // symbols are identical iff they have the same - // id! - kind: TSymKind; - magic: TMagic; - typ: PType; - name: PIdent; - info: TLineInfo; - owner: PSym; - flags: TSymFlags; - tab: TStrTable; // interface table for modules - ast: PNode; // syntax tree of proc, iterator, etc.: - // the whole proc including header; this is used - // for easy generation of proper error messages - // for variant record fields the discriminant - // expression - options: TOptions; - position: int; // used for many different things: - // for enum fields its position; - // for fields its offset - // for parameters its position - // for a conditional: - // 1 iff the symbol is defined, else 0 - // (or not in symbol table) - offset: int; // offset of record field - loc: TLoc; - annex: PLib; // additional fields (seldom used, so we use a - // reference to another object to safe space) - end; - - TTypeSeq = array of PType; - TType = object(TIdObj) // types are identical iff they have the - // same id; there may be multiple copies of a type - // in memory! - kind: TTypeKind; // kind of type - sons: TTypeSeq; // base types, etc. - n: PNode; // node for types: - // for range types a nkRange node - // for record types a nkRecord node - // for enum types a list of symbols - // else: unused - flags: TTypeFlags; // flags of the type - callConv: TCallingConvention; // for procs - owner: PSym; // the 'owner' of the type - sym: PSym; // types have the sym associated with them - // it is used for converting types to strings - size: BiggestInt; // the size of the type in bytes - // -1 means that the size is unkwown - align: int; // the type's alignment requirements - containerID: int; // used for type checking of generics - loc: TLoc; - end; - - TPair = record - key, val: PObject; - end; - TPairSeq = array of TPair; - - TTable = record // the same as table[PObject] of PObject - counter: int; - data: TPairSeq; - end; - - TIdPair = record - key: PIdObj; - val: PObject; - end; - TIdPairSeq = array of TIdPair; - - TIdTable = record // the same as table[PIdent] of PObject - counter: int; - data: TIdPairSeq; - end; - - TIdNodePair = record - key: PIdObj; - val: PNode; - end; - TIdNodePairSeq = array of TIdNodePair; - - TIdNodeTable = record // the same as table[PIdObj] of PNode - counter: int; - data: TIdNodePairSeq; - end; - - TNodePair = record - h: THash; // because it is expensive to compute! - key: PNode; - val: int; - end; - TNodePairSeq = array of TNodePair; - - TNodeTable = record // the same as table[PNode] of int; - // nodes are compared by structure! - counter: int; - data: TNodePairSeq; - end; - - TObjectSeq = array of PObject; - - TObjectSet = record - counter: int; - data: TObjectSeq; - end; - -const - OverloadableSyms = {@set}[skProc, skMethod, skIterator, skConverter, - skModule]; - -const // "MagicToStr" array: - MagicToStr: array [TMagic] of string = ( - //[[[cog - //for i in range(0, len(magics)-1): - // cog.out("'%s', " % magics[i]) - // if (i+1) % 6 == 0: cog.outl("") - //cog.outl("'%s'" % magics[-1]) - //]]] - 'None', 'Defined', 'DefinedInScope', 'Low', 'High', 'SizeOf', - 'Is', 'Echo', 'Succ', 'Pred', 'Inc', 'Dec', - 'Ord', 'New', 'NewFinalize', 'NewSeq', 'LengthOpenArray', 'LengthStr', - 'LengthArray', 'LengthSeq', 'Incl', 'Excl', 'Card', 'Chr', - 'GCref', 'GCunref', 'AddI', 'SubI', 'MulI', 'DivI', - 'ModI', 'AddI64', 'SubI64', 'MulI64', 'DivI64', 'ModI64', - 'ShrI', 'ShlI', 'BitandI', 'BitorI', 'BitxorI', 'MinI', - 'MaxI', 'ShrI64', 'ShlI64', 'BitandI64', 'BitorI64', 'BitxorI64', - 'MinI64', 'MaxI64', 'AddF64', 'SubF64', 'MulF64', 'DivF64', - 'MinF64', 'MaxF64', 'AddU', 'SubU', 'MulU', 'DivU', - 'ModU', 'AddU64', 'SubU64', 'MulU64', 'DivU64', 'ModU64', - 'EqI', 'LeI', 'LtI', 'EqI64', 'LeI64', 'LtI64', - 'EqF64', 'LeF64', 'LtF64', 'LeU', 'LtU', 'LeU64', - 'LtU64', 'EqEnum', 'LeEnum', 'LtEnum', 'EqCh', 'LeCh', - 'LtCh', 'EqB', 'LeB', 'LtB', 'EqRef', 'EqProc', - 'EqUntracedRef', 'LePtr', 'LtPtr', 'EqCString', 'Xor', 'UnaryMinusI', - 'UnaryMinusI64', 'AbsI', 'AbsI64', 'Not', 'UnaryPlusI', 'BitnotI', - 'UnaryPlusI64', 'BitnotI64', 'UnaryPlusF64', 'UnaryMinusF64', 'AbsF64', 'Ze8ToI', - 'Ze8ToI64', 'Ze16ToI', 'Ze16ToI64', 'Ze32ToI64', 'ZeIToI64', 'ToU8', - 'ToU16', 'ToU32', 'ToFloat', 'ToBiggestFloat', 'ToInt', 'ToBiggestInt', - 'CharToStr', 'BoolToStr', 'IntToStr', 'Int64ToStr', 'FloatToStr', 'CStrToStr', - 'StrToStr', 'EnumToStr', 'And', 'Or', 'EqStr', 'LeStr', - 'LtStr', 'EqSet', 'LeSet', 'LtSet', 'MulSet', 'PlusSet', - 'MinusSet', 'SymDiffSet', 'ConStrStr', 'ConArrArr', 'ConArrT', 'ConTArr', - 'ConTT', 'Slice', 'AppendStrCh', 'AppendStrStr', 'AppendSeqElem', 'InRange', - 'InSet', 'Repr', 'Exit', 'SetLengthStr', 'SetLengthSeq', 'Assert', - 'Swap', 'IsNil', 'ArrToSeq', 'CopyStr', 'CopyStrLast', 'NewString', - 'Array', 'OpenArray', 'Range', 'Set', 'Seq', 'Ordinal', - 'Int', 'Int8', 'Int16', 'Int32', 'Int64', 'Float', - 'Float32', 'Float64', 'Bool', 'Char', 'String', 'Cstring', - 'Pointer', 'EmptySet', 'IntSetBaseType', 'Nil', 'Expr', 'Stmt', - 'TypeDesc', 'IsMainModule', 'CompileDate', 'CompileTime', 'NimrodVersion', 'NimrodMajor', - 'NimrodMinor', 'NimrodPatch', 'CpuEndian', 'HostOS', 'HostCPU', 'NaN', - 'Inf', 'NegInf', 'NLen', 'NChild', 'NSetChild', 'NAdd', - 'NAddMultiple', 'NDel', 'NKind', 'NIntVal', 'NFloatVal', 'NSymbol', - 'NIdent', 'NGetType', 'NStrVal', 'NSetIntVal', 'NSetFloatVal', 'NSetSymbol', - 'NSetIdent', 'NSetType', 'NSetStrVal', 'NNewNimNode', 'NCopyNimNode', 'NCopyNimTree', - 'StrToIdent', 'IdentToStr', 'EqIdent', 'EqNimrodNode', 'NHint', 'NWarning', - 'NError' - //[[[end]]] - ); - -const - GenericTypes: TTypeKinds = {@set}[ - tyGenericInvokation, - tyGenericBody, - tyGenericParam - ]; - - StructuralEquivTypes: TTypeKinds = {@set}[ - tyArrayConstr, tyNil, tyTuple, - tyArray, - tySet, - tyRange, - tyPtr, tyRef, - tyVar, - tySequence, - tyProc, tyOpenArray - ]; - - ConcreteTypes: TTypeKinds = {@set}[ - // types of the expr that may occur in:: - // var x = expr - tyBool, tyChar, tyEnum, tyArray, tyObject, tySet, tyTuple, - tyRange, tyPtr, tyRef, tyVar, tySequence, tyProc, - tyPointer, tyOpenArray, - tyString, tyCString, - tyInt..tyInt64, - tyFloat..tyFloat128 - ]; - ConstantDataTypes: TTypeKinds = {@set}[tyArray, tySet, tyTuple]; - ExportableSymKinds = {@set}[skVar, skConst, skProc, skMethod, skType, - skIterator, skMacro, skTemplate, skConverter, - skStub]; - PersistentNodeFlags: TNodeFlags = {@set}[ - nfBase2, nfBase8, nfBase16, nfAllConst]; - namePos = 0; - genericParamsPos = 1; - paramsPos = 2; - pragmasPos = 3; - codePos = 4; - resultPos = 5; - dispatcherPos = 6; - -var - gId: int; - -function getID: int; -procedure setID(id: int); -procedure IDsynchronizationPoint(idRange: int); - -// creator procs: -function NewSym(symKind: TSymKind; Name: PIdent; owner: PSym): PSym; - -function NewType(kind: TTypeKind; owner: PSym): PType; overload; - -function newNode(kind: TNodeKind): PNode; -function newIntNode(kind: TNodeKind; const intVal: BiggestInt): PNode; -function newIntTypeNode(kind: TNodeKind; const intVal: BiggestInt; - typ: PType): PNode; -function newFloatNode(kind: TNodeKind; const floatVal: BiggestFloat): PNode; -function newStrNode(kind: TNodeKind; const strVal: string): PNode; -function newIdentNode(ident: PIdent; const info: TLineInfo): PNode; -function newSymNode(sym: PSym): PNode; -function newNodeI(kind: TNodeKind; const info: TLineInfo): PNode; -function newNodeIT(kind: TNodeKind; const info: TLineInfo; typ: PType): PNode; - -procedure initStrTable(out x: TStrTable); -procedure initTable(out x: TTable); -procedure initIdTable(out x: TIdTable); -procedure initObjectSet(out x: TObjectSet); -procedure initIdNodeTable(out x: TIdNodeTable); -procedure initNodeTable(out x: TNodeTable); - -// copy procs: -function copyType(t: PType; owner: PSym; keepId: bool): PType; -function copySym(s: PSym; keepId: bool = false): PSym; -procedure assignType(dest, src: PType); - -procedure copyStrTable(out dest: TStrTable; const src: TStrTable); -procedure copyTable(out dest: TTable; const src: TTable); -procedure copyObjectSet(out dest: TObjectSet; const src: TObjectSet); -procedure copyIdTable(var dest: TIdTable; const src: TIdTable); - -function sonsLen(n: PNode): int; overload; -function sonsLen(n: PType): int; overload; - -function lastSon(n: PNode): PNode; overload; -function lastSon(n: PType): PType; overload; -procedure newSons(father: PNode; len: int); overload; -procedure newSons(father: PType; len: int); overload; - -procedure addSon(father, son: PNode); overload; -procedure addSon(father, son: PType); overload; - -procedure addSonIfNotNil(father, n: PNode); -procedure delSon(father: PNode; idx: int); -function hasSonWith(n: PNode; kind: TNodeKind): boolean; -function hasSubnodeWith(n: PNode; kind: TNodeKind): boolean; -procedure replaceSons(n: PNode; oldKind, newKind: TNodeKind); -function sonsNotNil(n: PNode): bool; // for assertions - -function copyNode(src: PNode): PNode; -// does not copy its sons! - -function copyTree(src: PNode): PNode; -// does copy its sons! - -procedure discardSons(father: PNode); - -const // for all kind of hash tables: - GrowthFactor = 2; // must be power of 2, > 0 - StartSize = 8; // must be power of 2, > 0 - -function SameValue(a, b: PNode): Boolean; // a, b are literals -function leValue(a, b: PNode): Boolean; // a <= b? a, b are literals - -function ValueToString(a: PNode): string; - -// ------------- efficient integer sets ------------------------------------- -{@ignore} -type - TBitScalar = int32; // FPC produces wrong code for ``int`` -{@emit -type - TBitScalar = int; } - -const - InitIntSetSize = 8; // must be a power of two! - TrunkShift = 9; - BitsPerTrunk = 1 shl TrunkShift; - // needs to be a power of 2 and divisible by 64 - TrunkMask = BitsPerTrunk-1; - IntsPerTrunk = BitsPerTrunk div (sizeof(TBitScalar)*8); - IntShift = 5+ord(sizeof(TBitScalar)=8); // 5 or 6, depending on int width - IntMask = 1 shl IntShift -1; - -type - PTrunk = ^TTrunk; - TTrunk = record - next: PTrunk; // all nodes are connected with this pointer - key: int; // start address at bit 0 - bits: array [0..IntsPerTrunk-1] of TBitScalar; // a bit vector - end; - TTrunkSeq = array of PTrunk; - TIntSet = record - counter, max: int; - head: PTrunk; - data: TTrunkSeq; - end; - -function IntSetContains(const s: TIntSet; key: int): bool; -procedure IntSetIncl(var s: TIntSet; key: int); -procedure IntSetExcl(var s: TIntSet; key: int); -procedure IntSetInit(var s: TIntSet); - -function IntSetContainsOrIncl(var s: TIntSet; key: int): bool; - - -const - debugIds = false; - -procedure registerID(id: PIdObj); - -implementation - -var - usedIds: TIntSet; - -procedure registerID(id: PIdObj); -begin - if debugIDs then - if (id.id = -1) or IntSetContainsOrIncl(usedIds, id.id) then - InternalError('ID already used: ' + toString(id.id)); -end; - -function getID: int; -begin - result := gId; - inc(gId) -end; - -procedure setId(id: int); -begin - gId := max(gId, id+1); -end; - -procedure IDsynchronizationPoint(idRange: int); -begin - gId := (gId div IdRange +1) * IdRange + 1; -end; - -function leValue(a, b: PNode): Boolean; // a <= b? -begin - result := false; - case a.kind of - nkCharLit..nkInt64Lit: - if b.kind in [nkCharLit..nkInt64Lit] then - result := a.intVal <= b.intVal; - nkFloatLit..nkFloat64Lit: - if b.kind in [nkFloatLit..nkFloat64Lit] then - result := a.floatVal <= b.floatVal; - nkStrLit..nkTripleStrLit: begin - if b.kind in [nkStrLit..nkTripleStrLit] then - result := a.strVal <= b.strVal; - end - else InternalError(a.info, 'leValue'); - end -end; - -function SameValue(a, b: PNode): Boolean; -begin - result := false; - case a.kind of - nkCharLit..nkInt64Lit: - if b.kind in [nkCharLit..nkInt64Lit] then - result := a.intVal = b.intVal; - nkFloatLit..nkFloat64Lit: - if b.kind in [nkFloatLit..nkFloat64Lit] then - result := a.floatVal = b.floatVal; - nkStrLit..nkTripleStrLit: begin - if b.kind in [nkStrLit..nkTripleStrLit] then - result := a.strVal = b.strVal; - end - else InternalError(a.info, 'SameValue'); - end -end; - -function ValueToString(a: PNode): string; -begin - case a.kind of - nkCharLit..nkInt64Lit: - result := ToString(a.intVal); - nkFloatLit, nkFloat32Lit, nkFloat64Lit: - result := toStringF(a.floatVal); - nkStrLit..nkTripleStrLit: - result := a.strVal; - else begin - InternalError(a.info, 'valueToString'); - result := '' - end - end -end; - -procedure copyStrTable(out dest: TStrTable; const src: TStrTable); -var - i: int; -begin - dest.counter := src.counter; -{@emit - if isNil(src.data) then exit; -} - setLength(dest.data, length(src.data)); - for i := 0 to high(src.data) do - dest.data[i] := src.data[i]; -end; - -procedure copyIdTable(var dest: TIdTable; const src: TIdTable); -var - i: int; -begin - dest.counter := src.counter; -{@emit - if isNil(src.data) then exit; -} -{@ignore} - setLength(dest.data, length(src.data)); -{@emit - newSeq(dest.data, length(src.data)); } - for i := 0 to high(src.data) do - dest.data[i] := src.data[i]; -end; - -procedure copyTable(out dest: TTable; const src: TTable); -var - i: int; -begin - dest.counter := src.counter; -{@emit - if isNil(src.data) then exit; -} - setLength(dest.data, length(src.data)); - for i := 0 to high(src.data) do - dest.data[i] := src.data[i]; -end; - -procedure copyObjectSet(out dest: TObjectSet; const src: TObjectSet); -var - i: int; -begin - dest.counter := src.counter; -{@emit - if isNil(src.data) then exit; -} - setLength(dest.data, length(src.data)); - for i := 0 to high(src.data) do - dest.data[i] := src.data[i]; -end; - -procedure discardSons(father: PNode); -begin - father.sons := nil; -end; - -function newNode(kind: TNodeKind): PNode; -begin - new(result); -{@ignore} - FillChar(result^, sizeof(result^), 0); -{@emit} - result.kind := kind; - //result.info := UnknownLineInfo(); inlined: - result.info.fileIndex := int32(-1); - result.info.col := int16(-1); - result.info.line := int16(-1); -end; - -function newIntNode(kind: TNodeKind; const intVal: BiggestInt): PNode; -begin - result := newNode(kind); - result.intVal := intVal -end; - -function newIntTypeNode(kind: TNodeKind; const intVal: BiggestInt; - typ: PType): PNode; -begin - result := newIntNode(kind, intVal); - result.typ := typ; -end; - -function newFloatNode(kind: TNodeKind; const floatVal: BiggestFloat): PNode; -begin - result := newNode(kind); - result.floatVal := floatVal -end; - -function newStrNode(kind: TNodeKind; const strVal: string): PNode; -begin - result := newNode(kind); - result.strVal := strVal -end; - -function newIdentNode(ident: PIdent; const info: TLineInfo): PNode; -begin - result := newNode(nkIdent); - result.ident := ident; - result.info := info; -end; - -function newSymNode(sym: PSym): PNode; -begin - result := newNode(nkSym); - result.sym := sym; - result.typ := sym.typ; - result.info := sym.info; -end; - -function newNodeI(kind: TNodeKind; const info: TLineInfo): PNode; -begin - result := newNode(kind); - result.info := info; -end; - -function newNodeIT(kind: TNodeKind; const info: TLineInfo; typ: PType): PNode; -begin - result := newNode(kind); - result.info := info; - result.typ := typ; -end; - -function NewType(kind: TTypeKind; owner: PSym): PType; overload; -begin - new(result); -{@ignore} - FillChar(result^, sizeof(result^), 0); -{@emit} - result.kind := kind; - result.owner := owner; - result.size := -1; - result.align := 2; // default alignment - result.id := getID(); - if debugIds then RegisterId(result); - //if result.id < 2000 then - // MessageOut(typeKindToStr[kind] +{&} ' has id: ' +{&} toString(result.id)); -end; - -procedure assignType(dest, src: PType); -var - i: int; -begin - dest.kind := src.kind; - dest.flags := src.flags; - dest.callConv := src.callConv; - dest.n := src.n; - dest.size := src.size; - dest.align := src.align; - dest.containerID := src.containerID; - newSons(dest, sonsLen(src)); - for i := 0 to sonsLen(src)-1 do - dest.sons[i] := src.sons[i]; -end; - -function copyType(t: PType; owner: PSym; keepId: bool): PType; -begin - result := newType(t.Kind, owner); - assignType(result, t); - if keepId then result.id := t.id - else begin - result.id := getID(); - if debugIds then RegisterId(result); - end; - result.sym := t.sym; - // backend-info should not be copied -end; - -function copySym(s: PSym; keepId: bool = false): PSym; -begin - result := newSym(s.kind, s.name, s.owner); - result.ast := nil; // BUGFIX; was: s.ast which made problems - result.info := s.info; - result.typ := s.typ; - if keepId then result.id := s.id - else begin - result.id := getID(); - if debugIds then RegisterId(result); - end; - result.flags := s.flags; - result.magic := s.magic; - copyStrTable(result.tab, s.tab); - result.options := s.options; - result.position := s.position; - result.loc := s.loc; - result.annex := s.annex; // BUGFIX -end; - -function NewSym(symKind: TSymKind; Name: PIdent; owner: PSym): PSym; -// generates a symbol and initializes the hash field too -begin - new(result); -{@ignore} - FillChar(result^, sizeof(result^), 0); -{@emit} - result.Name := Name; - result.Kind := symKind; - result.flags := {@set}[]; - result.info := UnknownLineInfo(); - result.options := gOptions; - result.owner := owner; - result.offset := -1; - result.id := getID(); - if debugIds then RegisterId(result); - //if result.id < 2000 then - // MessageOut(name.s +{&} ' has id: ' +{&} toString(result.id)); -end; - -procedure initStrTable(out x: TStrTable); -begin - x.counter := 0; -{@emit - newSeq(x.data, startSize); } -{@ignore} - setLength(x.data, startSize); - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initTable(out x: TTable); -begin - x.counter := 0; -{@emit - newSeq(x.data, startSize); } -{@ignore} - setLength(x.data, startSize); - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initIdTable(out x: TIdTable); -begin - x.counter := 0; -{@emit - newSeq(x.data, startSize); } -{@ignore} - setLength(x.data, startSize); - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initObjectSet(out x: TObjectSet); -begin - x.counter := 0; -{@emit - newSeq(x.data, startSize); } -{@ignore} - setLength(x.data, startSize); - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initIdNodeTable(out x: TIdNodeTable); -begin - x.counter := 0; -{@emit - newSeq(x.data, startSize); } -{@ignore} - setLength(x.data, startSize); - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -procedure initNodeTable(out x: TNodeTable); -begin - x.counter := 0; -{@emit - newSeq(x.data, startSize); } -{@ignore} - setLength(x.data, startSize); - fillChar(x.data[0], length(x.data)*sizeof(x.data[0]), 0); -{@emit} -end; - -function sonsLen(n: PType): int; -begin -{@ignore} - result := length(n.sons); -{@emit - if isNil(n.sons) then result := 0 - else result := length(n.sons); } -end; - -procedure newSons(father: PType; len: int); -var - i, L: int; -begin -{@emit - if isNil(father.sons) then father.sons := @[]; } - L := length(father.sons); - setLength(father.sons, L + len); -{@ignore} - for i := L to L+len-1 do father.sons[i] := nil // needed for FPC -{@emit} -end; - -procedure addSon(father, son: PType); -var - L: int; -begin -{@ignore} - L := length(father.sons); - setLength(father.sons, L+1); - father.sons[L] := son; -{@emit - if isNil(father.sons) then father.sons := @[]; } -{@emit add(father.sons, son); } - assert((father.kind <> tyGenericInvokation) or (son.kind <> tyGenericInst)); -end; - -function sonsLen(n: PNode): int; -begin -{@ignore} - result := length(n.sons); -{@emit - if isNil(n.sons) then result := 0 - else result := length(n.sons); } -end; - -procedure newSons(father: PNode; len: int); -var - i, L: int; -begin -{@emit - if isNil(father.sons) then father.sons := @[]; } - L := length(father.sons); - setLength(father.sons, L + len); -{@ignore} - for i := L to L+len-1 do father.sons[i] := nil // needed for FPC -{@emit} -end; - -procedure addSon(father, son: PNode); -var - L: int; -begin -{@ignore} - L := length(father.sons); - setLength(father.sons, L+1); - father.sons[L] := son; -{@emit - if isNil(father.sons) then father.sons := @[]; } -{@emit add(father.sons, son); } -end; - -procedure delSon(father: PNode; idx: int); -var - len, i: int; -begin -{@emit - if isNil(father.sons) then exit; } - len := sonsLen(father); - for i := idx to len-2 do - father.sons[i] := father.sons[i+1]; - setLength(father.sons, len-1); -end; - -function copyNode(src: PNode): PNode; -// does not copy its sons! -begin - if src = nil then begin result := nil; exit end; - result := newNode(src.kind); - result.info := src.info; - result.typ := src.typ; - result.flags := src.flags * PersistentNodeFlags; - case src.Kind of - nkCharLit..nkInt64Lit: - result.intVal := src.intVal; - nkFloatLit, nkFloat32Lit, nkFloat64Lit: - result.floatVal := src.floatVal; - nkSym: - result.sym := src.sym; - nkIdent: - result.ident := src.ident; - nkStrLit..nkTripleStrLit: - result.strVal := src.strVal; - nkMetaNode: - result.nodePtr := src.nodePtr; - else begin end; - end; -end; - -function copyTree(src: PNode): PNode; -// copy a whole syntax tree; performs deep copying -var - i: int; -begin - if src = nil then begin result := nil; exit end; - result := newNode(src.kind); - result.info := src.info; - result.typ := src.typ; - result.flags := src.flags * PersistentNodeFlags; - case src.Kind of - nkCharLit..nkInt64Lit: - result.intVal := src.intVal; - nkFloatLit, nkFloat32Lit, nkFloat64Lit: - result.floatVal := src.floatVal; - nkSym: - result.sym := src.sym; - nkIdent: - result.ident := src.ident; - nkStrLit..nkTripleStrLit: - result.strVal := src.strVal; - nkMetaNode: - result.nodePtr := src.nodePtr; - else begin - result.sons := nil; - newSons(result, sonsLen(src)); - for i := 0 to sonsLen(src)-1 do - result.sons[i] := copyTree(src.sons[i]); - end; - end -end; - -function lastSon(n: PNode): PNode; -begin - result := n.sons[sonsLen(n)-1]; -end; - -function lastSon(n: PType): PType; -begin - result := n.sons[sonsLen(n)-1]; -end; - -function hasSonWith(n: PNode; kind: TNodeKind): boolean; -var - i: int; -begin - for i := 0 to sonsLen(n)-1 do begin - if (n.sons[i] <> nil) and (n.sons[i].kind = kind) then begin - result := true; exit - end - end; - result := false -end; - -function hasSubnodeWith(n: PNode; kind: TNodeKind): boolean; -var - i: int; -begin - case n.kind of - nkEmpty..nkNilLit: result := n.kind = kind; - else begin - for i := 0 to sonsLen(n)-1 do begin - if (n.sons[i] <> nil) and (n.sons[i].kind = kind) - or hasSubnodeWith(n.sons[i], kind) then begin - result := true; exit - end - end; - result := false - end - end -end; - -procedure replaceSons(n: PNode; oldKind, newKind: TNodeKind); -var - i: int; -begin - for i := 0 to sonsLen(n)-1 do - if n.sons[i].kind = oldKind then n.sons[i].kind := newKind -end; - -function sonsNotNil(n: PNode): bool; -var - i: int; -begin - for i := 0 to sonsLen(n)-1 do - if n.sons[i] = nil then begin result := false; exit end; - result := true -end; - -procedure addSonIfNotNil(father, n: PNode); -begin - if n <> nil then addSon(father, n) -end; - -// ---------------- efficient integer sets ---------------------------------- -// Same algorithm as the one the GC uses - -function mustRehash(len, counter: int): bool; -begin - assert(len > counter); - result := (len * 2 < counter * 3) or (len-counter < 4); -end; - -function nextTry(h, maxHash: THash): THash; -begin - result := ((5*h) + 1) and maxHash; - // For any initial h in range(maxHash), repeating that maxHash times - // generates each int in range(maxHash) exactly once (see any text on - // random-number generation for proof). -end; - -procedure IntSetInit(var s: TIntSet); -begin -{@ignore} - fillChar(s, sizeof(s), 0); -{@emit} -{@ignore} - setLength(s.data, InitIntSetSize); - fillChar(s.data[0], length(s.data)*sizeof(s.data[0]), 0); -{@emit - newSeq(s.data, InitIntSetSize); } - s.max := InitIntSetSize-1; - s.counter := 0; - s.head := nil -end; - -function IntSetGet(const t: TIntSet; key: int): PTrunk; -var - h: int; -begin - h := key and t.max; - while t.data[h] <> nil do begin - if t.data[h].key = key then begin - result := t.data[h]; exit - end; - h := nextTry(h, t.max) - end; - result := nil -end; - -procedure IntSetRawInsert(const t: TIntSet; var data: TTrunkSeq; desc: PTrunk); -var - h: int; -begin - h := desc.key and t.max; - while data[h] <> nil do begin - assert(data[h] <> desc); - h := nextTry(h, t.max) - end; - assert(data[h] = nil); - data[h] := desc -end; - -procedure IntSetEnlarge(var t: TIntSet); -var - n: TTrunkSeq; - i, oldMax: int; -begin - oldMax := t.max; - t.max := ((t.max+1)*2)-1; -{@ignore} - setLength(n, t.max + 1); - fillChar(n[0], length(n)*sizeof(n[0]), 0); -{@emit - newSeq(n, t.max+1); } - for i := 0 to oldmax do - if t.data[i] <> nil then - IntSetRawInsert(t, n, t.data[i]); -{@ignore} - t.data := n; -{@emit - swap(t.data, n); } -end; - -function IntSetPut(var t: TIntSet; key: int): PTrunk; -var - h: int; -begin - h := key and t.max; - while t.data[h] <> nil do begin - if t.data[h].key = key then begin - result := t.data[h]; exit - end; - h := nextTry(h, t.max) - end; - - if mustRehash(t.max+1, t.counter) then IntSetEnlarge(t); - inc(t.counter); - h := key and t.max; - while t.data[h] <> nil do h := nextTry(h, t.max); - assert(t.data[h] = nil); - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.next := t.head; - result.key := key; - t.head := result; - t.data[h] := result; -end; - -// ---------- slightly higher level procs ---------------------------------- - -function IntSetContains(const s: TIntSet; key: int): bool; -var - u: TBitScalar; - t: PTrunk; -begin - t := IntSetGet(s, shru(key, TrunkShift)); - if t <> nil then begin - u := key and TrunkMask; - result := (t.bits[shru(u, IntShift)] and shlu(1, u and IntMask)) <> 0 - end - else - result := false -end; - -procedure IntSetIncl(var s: TIntSet; key: int); -var - u: TBitScalar; - t: PTrunk; -begin - t := IntSetPut(s, shru(key, TrunkShift)); - u := key and TrunkMask; - t.bits[shru(u, IntShift)] := t.bits[shru(u, IntShift)] - or shlu(1, u and IntMask); -end; - -procedure IntSetExcl(var s: TIntSet; key: int); -var - u: TBitScalar; - t: PTrunk; -begin - t := IntSetGet(s, shru(key, TrunkShift)); - if t <> nil then begin - u := key and TrunkMask; - t.bits[shru(u, IntShift)] := t.bits[shru(u, IntShift)] - and not shlu(1, u and IntMask); - end -end; - -function IntSetContainsOrIncl(var s: TIntSet; key: int): bool; -var - u: TBitScalar; - t: PTrunk; -begin - t := IntSetGet(s, shru(key, TrunkShift)); - if t <> nil then begin - u := key and TrunkMask; - result := (t.bits[shru(u, IntShift)] and shlu(1, u and IntMask)) <> 0; - if not result then - t.bits[shru(u, IntShift)] := t.bits[shru(u, IntShift)] - or shlu(1, u and IntMask); - end - else begin - IntSetIncl(s, key); - result := false - end -end; -(* -procedure IntSetDebug(const s: TIntSet); -var - it: PTrunk; - i, j: int; -begin - it := s.head; - while it <> nil do begin - for i := 0 to high(it.bits) do - for j := 0 to BitsPerInt-1 do begin - if (it.bits[j] and (1 shl j)) <> 0 then - MessageOut('Contains key: ' + toString(it.key + i * BitsPerInt + j)); - end; - it := it.next - end -end;*) - -initialization - if debugIDs then IntSetInit(usedIds); -end. diff --git a/nim/astalgo.pas b/nim/astalgo.pas deleted file mode 100755 index 7c1f3ec0b..000000000 --- a/nim/astalgo.pas +++ /dev/null @@ -1,1294 +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 astalgo; - -// Algorithms for the abstract syntax tree: hash tables, lists -// and sets of nodes are supported. Efficiency is important as -// the data structures here are used in the whole compiler. - -interface - -{$include 'config.inc'} - -uses - nsystem, ast, nhashes, charsets, strutils, options, msgs, ropes, idents; - -function hashNode(p: PObject): THash; - -function treeToYaml(n: PNode; indent: int = 0; maxRecDepth: int = -1): PRope; -// Convert a tree into its YAML representation; this is used by the -// YAML code generator and it is invaluable for debugging purposes. -// If maxRecDepht <> -1 then it won't print the whole graph. - -function typeToYaml(n: PType; indent: int = 0; maxRecDepth: int = -1): PRope; -function symToYaml(n: PSym; indent: int = 0; maxRecDepth: int = -1): PRope; -function optionsToStr(flags: TOptions): PRope; -function lineInfoToStr(const info: TLineInfo): PRope; - -// ----------------------- node sets: --------------------------------------- - -function ObjectSetContains(const t: TObjectSet; obj: PObject): Boolean; -// returns true whether n is in t - -procedure ObjectSetIncl(var t: TObjectSet; obj: PObject); -// include an element n in the table t - -function ObjectSetContainsOrIncl(var t: TObjectSet; obj: PObject): Boolean; - -// more are not needed ... - -// ----------------------- (key, val)-Hashtables ---------------------------- - -procedure TablePut(var t: TTable; key, val: PObject); -function TableGet(const t: TTable; key: PObject): PObject; - -type - TCmpProc = function (key, closure: PObject): Boolean; - // should return true if found -function TableSearch(const t: TTable; key, closure: PObject; - comparator: TCmpProc): PObject; -// return val as soon as comparator returns true; if this never happens, -// nil is returned - -// ----------------------- str table ----------------------------------------- - -function StrTableContains(const t: TStrTable; n: PSym): Boolean; -procedure StrTableAdd(var t: TStrTable; n: PSym); -function StrTableGet(const t: TStrTable; name: PIdent): PSym; -function StrTableIncl(var t: TStrTable; n: PSym): Boolean; -// returns true if n is already in the string table - -// the iterator scheme: -type - TTabIter = record // consider all fields here private - h: THash; // current hash - end; - -function InitTabIter(out ti: TTabIter; const tab: TStrTable): PSym; -function NextIter(var ti: TTabIter; const tab: TStrTable): PSym; -// usage: -// var i: TTabIter; s: PSym; -// s := InitTabIter(i, table); -// while s <> nil do begin -// ... -// s := NextIter(i, table); -// end; - - -type - TIdentIter = record // iterator over all syms with the same identifier - h: THash; // current hash - name: PIdent; - end; - -function InitIdentIter(out ti: TIdentIter; const tab: TStrTable; - s: PIdent): PSym; -function NextIdentIter(var ti: TIdentIter; const tab: TStrTable): PSym; - -// -------------- symbol table ---------------------------------------------- - -// Each TParser object (which represents a module being compiled) has its own -// symbol table. A symbol table is organized as a stack of str tables. The -// stack represents the different scopes. -// Stack pointer: -// 0 imported symbols from other modules -// 1 module level -// 2 proc level -// 3 nested statements -// ... -// - -type - TSymTab = record - tos: Natural; // top of stack - stack: array of TStrTable; - end; - -procedure InitSymTab(out tab: TSymTab); -procedure DeinitSymTab(var tab: TSymTab); - -function SymTabGet(const tab: TSymTab; s: PIdent): PSym; -function SymTabLocalGet(const tab: TSymTab; s: PIdent): PSym; - -procedure SymTabAdd(var tab: TSymTab; e: PSym); -procedure SymTabAddAt(var tab: TSymTab; e: PSym; at: Natural); - -function SymTabAddUnique(var tab: TSymTab; e: PSym): TResult; -function SymTabAddUniqueAt(var tab: TSymTab; e: PSym; at: Natural): TResult; -procedure OpenScope(var tab: TSymTab); -procedure RawCloseScope(var tab: TSymTab); // the real "closeScope" adds some -// checks in parsobj - - -// these are for debugging only: -procedure debug(n: PSym); overload; -procedure debug(n: PType); overload; -procedure debug(n: PNode); overload; - -// --------------------------- ident tables ---------------------------------- - -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; -// checks if `t` contains the `key` (compared by the pointer value, not only -// `key`'s id) - -function IdNodeTableGet(const t: TIdNodeTable; key: PIdObj): PNode; -procedure IdNodeTablePut(var t: TIdNodeTable; key: PIdObj; val: PNode); - -procedure writeIdNodeTable(const t: TIdNodeTable); - -// --------------------------------------------------------------------------- -function getSymFromList(list: PNode; ident: PIdent; start: int = 0): PSym; -function lookupInRecord(n: PNode; field: PIdent): PSym; - -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; -var - i: int; -begin - result := nil; - case n.kind of - nkRecList: begin - for i := 0 to sonsLen(n)-1 do begin - result := lookupInRecord(n.sons[i], field); - if result <> nil then exit - end - end; - nkRecCase: begin - if (n.sons[0].kind <> nkSym) then InternalError(n.info, 'lookupInRecord'); - result := lookupInRecord(n.sons[0], field); - if result <> nil then exit; - for i := 1 to sonsLen(n)-1 do begin - case n.sons[i].kind of - nkOfBranch, nkElse: begin - result := lookupInRecord(lastSon(n.sons[i]), field); - if result <> nil then exit; - end; - else internalError(n.info, 'lookupInRecord(record case branch)'); - end - end - end; - nkSym: begin - if n.sym.name.id = field.id then result := n.sym; - end; - else internalError(n.info, 'lookupInRecord()'); - end; -end; - -function getModule(s: PSym): PSym; -begin - result := s; - assert((result.kind = skModule) or (result.owner <> result)); - while (result <> nil) and (result.kind <> skModule) do result := result.owner; -end; - -function getSymFromList(list: PNode; ident: PIdent; start: int = 0): PSym; -var - i: int; -begin - for i := start to sonsLen(list)-1 do begin - if list.sons[i].kind <> nkSym then - InternalError(list.info, 'getSymFromList'); - result := list.sons[i].sym; - if result.name.id = ident.id then exit - end; - result := nil -end; - -// ---------------------- helpers -------------------------------------------- - -function hashNode(p: PObject): THash; -begin - result := hashPtr({@cast}pointer(p)) -end; - -function mustRehash(len, counter: int): bool; -begin - assert(len > counter); - result := (len * 2 < counter * 3) or (len-counter < 4); -end; - -// --------------------------------------------------------------------------- - -// convert a node to a string; this is used for YAML code generation and -// debugging: - -function spaces(x: int): PRope; // returns x spaces -begin - result := toRope(repeatChar(x)) -end; - -function toYamlChar(c: Char): string; -begin - case c of - #0..#31, #128..#255: result := '\u' + strutils.toHex(ord(c), 4); - '''', '"', '\': result := '\' + c; - else result := c + '' - end; -end; - -function makeYamlString(const s: string): PRope; -// We have to split long strings into many ropes. Otherwise -// this could trigger InternalError(111). See the ropes module for -// further information. -const - MaxLineLength = 64; -var - i: int; - res: string; -begin - result := nil; - res := '"' + ''; - for i := strStart to length(s)+strStart-1 do begin - if (i-strStart+1) mod MaxLineLength = 0 then begin - addChar(res, '"'); - add(res, nl); - app(result, toRope(res)); - res := '"'+''; // reset - end; - add(res, toYamlChar(s[i])); - end; - addChar(res, '"'); - app(result, toRope(res)); -end; - -function symFlagsToStr(flags: TSymFlags): PRope; -var - x: TSymFlag; -begin - if flags = [] then - result := toRope('[]') - else begin - result := nil; - for x := low(TSymFlag) to high(TSymFlag) do - if x in flags then begin - if result <> nil then app(result, ', '); - app(result, makeYamlString(symFlagToStr[x])); - end; - result := con('['+'', con(result, ']'+'')) - end -end; - -function optionsToStr(flags: TOptions): PRope; -var - x: TOption; -begin - if flags = [] then - result := toRope('[]') - else begin - result := nil; - for x := low(TOption) to high(TOption) do - if x in flags then begin - if result <> nil then app(result, ', '); - app(result, makeYamlString(optionToStr[x])); - end; - result := con('['+'', con(result, ']'+'')) - end -end; - -function typeFlagsToStr(flags: TTypeFlags): PRope; -var - x: TTypeFlag; -begin - if flags = [] then - result := toRope('[]') - else begin - result := nil; - for x := low(TTypeFlag) to high(TTypeFlag) do - if x in flags then begin - if result <> nil then app(result, ', '); - app(result, makeYamlString(typeFlagToStr[x])); - end; - result := con('['+'', con(result, ']'+'')) - end -end; - -function lineInfoToStr(const info: TLineInfo): PRope; -begin - result := ropef('[$1, $2, $3]', [makeYamlString(toFilename(info)), - toRope(toLinenumber(info)), toRope(toColumn(info))]); -end; - -function treeToYamlAux(n: PNode; var marker: TIntSet; - indent: int; maxRecDepth: int): PRope; -forward; - -function symToYamlAux(n: PSym; var marker: TIntSet; - indent: int; maxRecDepth: int): PRope; forward; -function typeToYamlAux(n: PType; var marker: TIntSet; - indent: int; maxRecDepth: int): PRope; forward; - -function strTableToYaml(const n: TStrTable; var marker: TIntSet; - indent: int; maxRecDepth: int): PRope; -var - istr: PRope; - mycount, i: int; -begin - istr := spaces(indent+2); - result := toRope('['+''); - mycount := 0; - for i := 0 to high(n.data) do - if n.data[i] <> nil then begin - if mycount > 0 then app(result, ','+''); - appf(result, '$n$1$2', - [istr, symToYamlAux(n.data[i], marker, indent+2, maxRecDepth-1)]); - inc(mycount) - end; - if mycount > 0 then appf(result, '$n$1', [spaces(indent)]); - app(result, ']'+''); - assert(mycount = n.counter); -end; - -function ropeConstr(indent: int; const c: array of PRope): PRope; -// array of (name, value) pairs -var - istr: PRope; - i: int; -begin - istr := spaces(indent+2); - result := toRope('{'+''); - i := 0; - while i <= high(c) do begin - if i > 0 then app(result, ','+''); - appf(result, '$n$1"$2": $3', [istr, c[i], c[i+1]]); - inc(i, 2) - end; - appf(result, '$n$1}', [spaces(indent)]); -end; - -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 IntSetContainsOrIncl(marker, n.id) then - result := ropef('"$1 @$2"', [ - toRope(n.name.s), - toRope(strutils.toHex({@cast}TAddress(n), sizeof(n)*2))]) - else begin - ast := treeToYamlAux(n.ast, marker, indent+2, maxRecDepth-1); - result := ropeConstr(indent, [ - toRope('kind'), makeYamlString(symKindToStr[n.kind]), - toRope('name'), makeYamlString(n.name.s), - toRope('typ'), typeToYamlAux(n.typ, marker, indent+2, maxRecDepth-1), - toRope('info'), lineInfoToStr(n.info), - toRope('flags'), symFlagsToStr(n.flags), - toRope('magic'), makeYamlString(MagicToStr[n.magic]), - toRope('ast'), ast, - toRope('options'), optionsToStr(n.options), - toRope('position'), toRope(n.position) - ]); - end - // YYY: backend info? -end; - -function typeToYamlAux(n: PType; var marker: TIntSet; - indent: int; maxRecDepth: int): PRope; -var - i: int; -begin - if n = nil then - result := toRope('null') - else if intSetContainsOrIncl(marker, n.id) then - result := ropef('"$1 @$2"', [ - toRope(typeKindToStr[n.kind]), - toRope(strutils.toHex({@cast}TAddress(n), sizeof(n)*2))]) - else begin - if sonsLen(n) > 0 then begin - result := toRope('['+''); - for i := 0 to sonsLen(n)-1 do begin - if i > 0 then app(result, ','+''); - appf(result, '$n$1$2', - [spaces(indent+4), - typeToYamlAux(n.sons[i], marker, indent + 4, maxRecDepth-1)]); - end; - appf(result, '$n$1]', [spaces(indent+2)]); - end - else - result := toRope('null'); - result := ropeConstr(indent, [ - toRope('kind'), makeYamlString(typeKindToStr[n.kind]), - toRope('sym'), symToYamlAux(n.sym, marker, indent+2, maxRecDepth-1), - toRope('n'+''), treeToYamlAux(n.n, marker, indent+2, maxRecDepth-1), - toRope('flags'), typeFlagsToStr(n.flags), - toRope('callconv'), makeYamlString(CallingConvToStr[n.callConv]), - toRope('size'), toRope(n.size), - toRope('align'), toRope(n.align), - toRope('sons'), result - ]); - end -end; - -function treeToYamlAux(n: PNode; var marker: TIntSet; indent: int; - maxRecDepth: int): PRope; -var - istr: PRope; - i: int; -begin - if n = nil then - result := toRope('null') - else begin - istr := spaces(indent+2); - result := ropef('{$n$1"kind": $2', - [istr, makeYamlString(nodeKindToStr[n.kind])]); - if maxRecDepth <> 0 then begin - appf(result, ',$n$1"info": $2', - [istr, lineInfoToStr(n.info)]); - case n.kind of - nkCharLit..nkInt64Lit: - appf(result, ',$n$1"intVal": $2', [istr, toRope(n.intVal)]); - nkFloatLit, nkFloat32Lit, nkFloat64Lit: - appf(result, ',$n$1"floatVal": $2', [istr, toRopeF(n.floatVal)]); - nkStrLit..nkTripleStrLit: - appf(result, ',$n$1"strVal": $2', [istr, makeYamlString(n.strVal)]); - nkSym: - appf(result, ',$n$1"sym": $2', - [istr, symToYamlAux(n.sym, marker, indent+2, maxRecDepth)]); - - nkIdent: begin - if n.ident <> nil then - appf(result, ',$n$1"ident": $2', - [istr, makeYamlString(n.ident.s)]) - else - appf(result, ',$n$1"ident": null', [istr]) - end - else begin - if sonsLen(n) > 0 then begin - appf(result, ',$n$1"sons": [', [istr]); - for i := 0 to sonsLen(n)-1 do begin - if i > 0 then app(result, ','+''); - appf(result, '$n$1$2', - [spaces(indent+4), - treeToYamlAux(n.sons[i], marker, indent + 4, maxRecDepth-1)]); - end; - appf(result, '$n$1]', [istr]); - end - end - end; - appf(result, ',$n$1"typ": $2', - [istr, typeToYamlAux(n.typ, marker, indent+2, maxRecDepth)]); - end; - appf(result, '$n$1}', [spaces(indent)]); - end -end; - -function treeToYaml(n: PNode; indent: int = 0; maxRecDepth: int = -1): PRope; -var - marker: TIntSet; -begin - IntSetInit(marker); - result := treeToYamlAux(n, marker, indent, maxRecDepth) -end; - -function typeToYaml(n: PType; indent: int = 0; maxRecDepth: int = -1): PRope; -var - marker: TIntSet; -begin - IntSetInit(marker); - result := typeToYamlAux(n, marker, indent, maxRecDepth) -end; - -function symToYaml(n: PSym; indent: int = 0; maxRecDepth: int = -1): PRope; -var - marker: TIntSet; -begin - IntSetInit(marker); - result := symToYamlAux(n, marker, indent, maxRecDepth) -end; - -// these are for debugging only: -function debugType(n: PType): PRope; -var - i: int; -begin - if n = nil then - result := toRope('null') - else begin - result := toRope(typeKindToStr[n.kind]); - if n.sym <> nil then begin - app(result, ' '+''); - app(result, n.sym.name.s); - end; - if (n.kind <> tyString) and (sonsLen(n) > 0) then begin - app(result, '('+''); - for i := 0 to sonsLen(n)-1 do begin - if i > 0 then app(result, ', '); - if n.sons[i] = nil then app(result, 'null') - else app(result, debugType(n.sons[i])); - // app(result, typeKindToStr[n.sons[i].kind]); - end; - app(result, ')'+''); - end - end -end; - -function debugTree(n: PNode; indent: int; maxRecDepth: int): PRope; -var - istr: PRope; - i: int; -begin - if n = nil then - result := toRope('null') - else begin - istr := spaces(indent+2); - result := ropef('{$n$1"kind": $2', - [istr, makeYamlString(nodeKindToStr[n.kind])]); - if maxRecDepth <> 0 then begin - case n.kind of - nkCharLit..nkInt64Lit: - appf(result, ',$n$1"intVal": $2', [istr, toRope(n.intVal)]); - nkFloatLit, nkFloat32Lit, nkFloat64Lit: - appf(result, ',$n$1"floatVal": $2', - [istr, toRopeF(n.floatVal)]); - nkStrLit..nkTripleStrLit: - appf(result, ',$n$1"strVal": $2', - [istr, makeYamlString(n.strVal)]); - nkSym: - appf(result, ',$n$1"sym": $2_$3', - [istr, toRope(n.sym.name.s), toRope(n.sym.id)]); - - nkIdent: begin - if n.ident <> nil then - appf(result, ',$n$1"ident": $2', - [istr, makeYamlString(n.ident.s)]) - else - appf(result, ',$n$1"ident": null', [istr]) - end - else begin - if sonsLen(n) > 0 then begin - appf(result, ',$n$1"sons": [', [istr]); - for i := 0 to sonsLen(n)-1 do begin - if i > 0 then app(result, ','+''); - appf(result, '$n$1$2', - [spaces(indent+4), - debugTree(n.sons[i], indent + 4, maxRecDepth-1)]); - end; - appf(result, '$n$1]', [istr]); - end - end - end; - end; - appf(result, '$n$1}', [spaces(indent)]); - end -end; - -procedure debug(n: PSym); overload; -begin - writeln(output, ropeToStr(ropef('$1_$2', [toRope(n.name.s), toRope(n.id)]))); -end; - -procedure debug(n: PType); overload; -begin - writeln(output, ropeToStr(debugType(n))); -end; - -procedure debug(n: PNode); overload; -begin - writeln(output, ropeToStr(debugTree(n, 0, 100))); -end; - -// -------------------- node sets -------------------------------------------- - -{@ignore} -const - EmptySeq = nil; -{@emit -const - EmptySeq = @[]; -} - -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; - -function objectSetContains(const t: TObjectSet; obj: PObject): Boolean; -// returns true whether n is in t -var - h: THash; -begin - h := hashNode(obj) and high(t.data); // start with real hash value - while t.data[h] <> nil do begin - if (t.data[h] = obj) then begin - result := true; exit - end; - h := nextTry(h, high(t.data)) - end; - result := false -end; - -procedure objectSetRawInsert(var data: TObjectSeq; obj: PObject); -var - h: THash; -begin - h := HashNode(obj) and high(data); - while data[h] <> nil do begin - assert(data[h] <> obj); - h := nextTry(h, high(data)) - end; - assert(data[h] = nil); - data[h] := obj; -end; - -procedure objectSetEnlarge(var t: TObjectSet); -var - n: TObjectSeq; - i: int; -begin -{@ignore} - n := emptySeq; - 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] <> nil then objectSetRawInsert(n, t.data[i]); -{@ignore} - t.data := n; -{@emit - swap(t.data, n); -} -end; - -procedure objectSetIncl(var t: TObjectSet; obj: PObject); -begin - if mustRehash(length(t.data), t.counter) then objectSetEnlarge(t); - objectSetRawInsert(t.data, obj); - inc(t.counter); -end; - -function objectSetContainsOrIncl(var t: TObjectSet; obj: PObject): Boolean; -// returns true if obj is already in the string table: -var - h: THash; - it: PObject; -begin - h := HashNode(obj) and high(t.data); - repeat - it := t.data[h]; - if it = nil then break; - if it = obj then begin - result := true; exit // found it - end; - h := nextTry(h, high(t.data)) - until false; - if mustRehash(length(t.data), t.counter) then begin - objectSetEnlarge(t); - objectSetRawInsert(t.data, obj); - end - else begin - assert(t.data[h] = nil); - t.data[h] := obj; - end; - inc(t.counter); - result := false -end; - -// --------------------------- node tables ----------------------------------- - -function TableRawGet(const t: TTable; key: PObject): int; -var - h: THash; -begin - h := hashNode(key) and high(t.data); // start with real hash value - while t.data[h].key <> nil do begin - if (t.data[h].key = key) then begin - result := h; exit - end; - h := nextTry(h, high(t.data)) - end; - result := -1 -end; - -function TableSearch(const t: TTable; key, closure: PObject; - comparator: TCmpProc): PObject; -var - h: THash; -begin - h := hashNode(key) and high(t.data); // start with real hash value - while t.data[h].key <> nil do begin - if (t.data[h].key = key) then - if comparator(t.data[h].val, closure) then begin // BUGFIX 1 - result := t.data[h].val; exit - end; - h := nextTry(h, high(t.data)) - end; - result := nil -end; - -function TableGet(const t: TTable; key: PObject): PObject; -var - index: int; -begin - index := TableRawGet(t, key); - if index >= 0 then result := t.data[index].val - else result := nil -end; - -procedure TableRawInsert(var data: TPairSeq; key, val: PObject); -var - h: THash; -begin - h := HashNode(key) and high(data); - while data[h].key <> nil do begin - assert(data[h].key <> key); - h := nextTry(h, high(data)) - end; - assert(data[h].key = nil); - data[h].key := key; - data[h].val := val; -end; - -procedure TableEnlarge(var t: TTable); -var - n: TPairSeq; - i: int; -begin -{@ignore} - n := emptySeq; - 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 - TableRawInsert(n, t.data[i].key, t.data[i].val); -{@ignore} - t.data := n; -{@emit - swap(t.data, n); -} -end; - -procedure TablePut(var t: TTable; key, val: PObject); -var - index: int; -begin - index := TableRawGet(t, key); - if index >= 0 then - t.data[index].val := val - else begin - if mustRehash(length(t.data), t.counter) then TableEnlarge(t); - TableRawInsert(t.data, key, val); - inc(t.counter) - end; -end; - -// ----------------------- string tables ------------------------------------ - -function StrTableContains(const t: TStrTable; n: PSym): Boolean; -var - h: THash; -begin - h := n.name.h and high(t.data); // start with real hash value - while t.data[h] <> nil do begin - if (t.data[h] = n) then begin - result := true; exit - end; - h := nextTry(h, high(t.data)) - end; - result := false -end; - -procedure StrTableRawInsert(var data: TSymSeq; n: PSym); -var - h: THash; -begin - h := n.name.h and high(data); - while data[h] <> nil do begin - if data[h] = n then - InternalError(n.info, 'StrTableRawInsert: ' + n.name.s); - h := nextTry(h, high(data)) - end; - assert(data[h] = nil); - data[h] := n; -end; - -procedure StrTableEnlarge(var t: TStrTable); -var - n: TSymSeq; - i: int; -begin -{@ignore} - n := emptySeq; - 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] <> nil then StrTableRawInsert(n, t.data[i]); -{@ignore} - t.data := n; -{@emit - swap(t.data, n); -} -end; - -procedure StrTableAdd(var t: TStrTable; n: PSym); -begin - if mustRehash(length(t.data), t.counter) then StrTableEnlarge(t); - StrTableRawInsert(t.data, n); - inc(t.counter); -end; - -function StrTableIncl(var t: TStrTable; n: PSym): Boolean; -// returns true if n is already in the string table: -var - h: THash; - it: PSym; -begin - h := n.name.h and high(t.data); - repeat - it := t.data[h]; - if it = nil then break; - if it.name.id = n.name.id then begin - result := true; exit // found it - end; - h := nextTry(h, high(t.data)) - until false; - if mustRehash(length(t.data), t.counter) then begin - StrTableEnlarge(t); - StrTableRawInsert(t.data, n); - end - else begin - assert(t.data[h] = nil); - t.data[h] := n; - end; - inc(t.counter); - result := false -end; - -function StrTableGet(const t: TStrTable; name: PIdent): PSym; -var - h: THash; -begin - h := name.h and high(t.data); - repeat - result := t.data[h]; - if result = nil then break; - if result.name.id = name.id then - break; - h := nextTry(h, high(t.data)) - until false; -end; - -// iterators: - -function InitIdentIter(out ti: TIdentIter; const tab: TStrTable; - s: PIdent): PSym; -begin - ti.h := s.h; - ti.name := s; - if tab.Counter = 0 then result := nil - else result := NextIdentIter(ti, tab) -end; - -function NextIdentIter(var ti: TIdentIter; const tab: TStrTable): PSym; -var - h, start: THash; -begin - h := ti.h and high(tab.data); - start := h; - result := tab.data[h]; - while (result <> nil) do begin - if result.Name.id = ti.name.id then break; - h := nextTry(h, high(tab.data)); - if h = start then begin - result := nil; - break - end; - result := tab.data[h] - end; - ti.h := nextTry(h, high(tab.data)) -end; - -function InitTabIter(out ti: TTabIter; const tab: TStrTable): PSym; -begin - ti.h := 0; // we start by zero ... - if tab.counter = 0 then result := nil // FIX 1: removed endless loop - else result := NextIter(ti, tab) -end; - -function NextIter(var ti: TTabIter; const tab: TStrTable): PSym; -begin - result := nil; - while (ti.h <= high(tab.data)) do begin - result := tab.data[ti.h]; - Inc(ti.h); // ... and increment by one always - if result <> nil then break - end; -end; - -// ------------------- symbol table ------------------------------------------ - -procedure InitSymTab(out tab: TSymTab); -begin - tab.tos := 0; - tab.stack := EmptySeq; -end; - -procedure DeinitSymTab(var tab: TSymTab); -begin - tab.stack := nil; -end; - -function SymTabLocalGet(const tab: TSymTab; s: PIdent): PSym; -begin - result := StrTableGet(tab.stack[tab.tos-1], s) -end; - -function SymTabGet(const tab: TSymTab; s: PIdent): PSym; -var - i: int; -begin - for i := tab.tos-1 downto 0 do begin - result := StrTableGet(tab.stack[i], s); - if result <> nil then exit - end; - result := nil -end; - -procedure SymTabAddAt(var tab: TSymTab; e: PSym; at: Natural); -begin - StrTableAdd(tab.stack[at], e); -end; - -procedure SymTabAdd(var tab: TSymTab; e: PSym); -begin - StrTableAdd(tab.stack[tab.tos-1], e) -end; - -function SymTabAddUniqueAt(var tab: TSymTab; e: PSym; at: Natural): TResult; -begin - if StrTableGet(tab.stack[at], e.name) <> nil then begin - result := Failure; - end - else begin - StrTableAdd(tab.stack[at], e); - result := Success - end -end; - -function SymTabAddUnique(var tab: TSymTab; e: PSym): TResult; -begin - result := SymTabAddUniqueAt(tab, e, tab.tos-1) -end; - -procedure OpenScope(var tab: TSymTab); -begin - if tab.tos >= length(tab.stack) then - SetLength(tab.stack, tab.tos + 1); - initStrTable(tab.stack[tab.tos]); - Inc(tab.tos) -end; - -procedure RawCloseScope(var tab: TSymTab); -begin - Dec(tab.tos); - //tab.stack[tab.tos] := nil; -end; - -// --------------------------- ident tables ---------------------------------- - -function hasEmptySlot(const data: TIdPairSeq): bool; -var - h: THash; -begin - for h := 0 to high(data) do - if data[h].key = nil then begin result := true; exit end; - result := false -end; - -function IdTableRawGet(const t: TIdTable; key: int): int; -var - h: THash; -begin - 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) then begin - result := h; exit - end; - h := nextTry(h, high(t.data)) - end; - result := -1 -end; - -function IdTableHasObjectAsKey(const t: TIdTable; key: PIdObj): bool; -var - index: int; -begin - index := IdTableRawGet(t, key.id); - if index >= 0 then result := t.data[index].key = key - else result := false -end; - -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 -end; - -procedure IdTableRawInsert(var data: TIdPairSeq; - key: PIdObj; val: PObject); -var - h: THash; -begin - h := key.id and high(data); - while data[h].key <> nil do begin - assert(data[h].key.id <> key.id); - h := nextTry(h, high(data)) - end; - assert(data[h].key = nil); - data[h].key := key; - data[h].val := val; -end; - -procedure IdTablePut(var t: TIdTable; key: PIdObj; val: PObject); -var - index, i: int; - n: TIdPairSeq; -begin - 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 - {@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 - IdTableRawInsert(n, t.data[i].key, t.data[i].val); - assert(hasEmptySlot(n)); - {@ignore} - t.data := n; - {@emit - swap(t.data, n); - } - end; - IdTableRawInsert(t.data, key, val); - inc(t.counter) - end; -end; - - -procedure writeIdNodeTable(const t: TIdNodeTable); -var - h: THash; -begin -{@ignore} - write('{'+''); - for h := 0 to high(t.data) do - if t.data[h].key <> nil then begin - write(t.data[h].key.id : 5); - end; - writeln('}'+''); -{@emit} -end; - -function IdNodeTableRawGet(const t: TIdNodeTable; key: PIdObj): int; -var - h: THash; -begin - h := key.id 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 - result := h; exit - end; - h := nextTry(h, high(t.data)) - end; - result := -1 -end; - -function IdNodeTableGet(const t: TIdNodeTable; key: PIdObj): PNode; -var - index: int; -begin - index := IdNodeTableRawGet(t, key); - if index >= 0 then result := t.data[index].val - else result := nil -end; - -procedure IdNodeTableRawInsert(var data: TIdNodePairSeq; - key: PIdObj; val: PNode); -var - h: THash; -begin - h := key.id and high(data); - while data[h].key <> nil do begin - assert(data[h].key.id <> key.id); - h := nextTry(h, high(data)) - end; - assert(data[h].key = nil); - data[h].key := key; - data[h].val := val; -end; - -procedure IdNodeTablePut(var t: TIdNodeTable; key: PIdObj; val: PNode); -var - index, i: int; - n: TIdNodePairSeq; -begin - index := IdNodeTableRawGet(t, key); - 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 - {@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 - IdNodeTableRawInsert(n, t.data[i].key, t.data[i].val); - {@ignore} - t.data := n; - {@emit - swap(t.data, n); - } - end; - IdNodeTableRawInsert(t.data, key, val); - inc(t.counter) - end; -end; - -// ------------- int-to-int-mapping ------------------------------------------ - -procedure initIITable(out x: TIITable); -var - i: int; -begin - x.counter := 0; -{@ignore} - setLength(x.data, startSize); -{@emit - newSeq(x.data, startSize); } - for i := 0 to startSize-1 do x.data[i].key := InvalidKey; -end; - -function IITableRawGet(const t: TIITable; key: int): int; -var - h: THash; -begin - 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, high(t.data)) - end; - result := -1 -end; - -function IITableGet(const t: TIITable; key: int): int; -var - index: int; -begin - index := IITableRawGet(t, key); - if index >= 0 then result := t.data[index].val - else result := InvalidKey -end; - -procedure IITableRawInsert(var data: TIIPairSeq; - key, val: int); -var - h: THash; -begin - h := key and high(data); - while data[h].key <> InvalidKey do begin - assert(data[h].key <> key); - h := nextTry(h, high(data)) - end; - assert(data[h].key = InvalidKey); - data[h].key := key; - data[h].val := val; -end; - -procedure IITablePut(var t: TIITable; key, val: int); -var - index, i: int; - n: TIIPairSeq; -begin - index := IITableRawGet(t, key); - if index >= 0 then begin - assert(t.data[index].key <> InvalidKey); - t.data[index].val := val - end - else begin - 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/bitsets.pas b/nim/bitsets.pas deleted file mode 100755 index 78c6d1f36..000000000 --- a/nim/bitsets.pas +++ /dev/null @@ -1,123 +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 bitsets; - -// this unit handles Nimrod sets; it implements bit sets -// the code here should be reused in the Nimrod standard library - -interface - -{$include 'config.inc'} - -{@ignore} -uses - nsystem; -{@emit} - -type - TBitSet = array of Byte; // we use byte here to avoid issues with - // cross-compiling; uint would be more efficient - // however - -const - ElemSize = sizeof(Byte) * 8; - -procedure BitSetInit(out b: TBitSet; len: int); -procedure BitSetUnion(var x: TBitSet; const y: TBitSet); -procedure BitSetDiff(var x: TBitSet; const y: TBitSet); -procedure BitSetSymDiff(var x: TBitSet; const y: TBitSet); -procedure BitSetIntersect(var x: TBitSet; const y: TBitSet); -procedure BitSetIncl(var x: TBitSet; const elem: BiggestInt); -procedure BitSetExcl(var x: TBitSet; const elem: BiggestInt); - -function BitSetIn(const x: TBitSet; const e: BiggestInt): Boolean; -function BitSetEquals(const x, y: TBitSet): Boolean; -function BitSetContains(const x, y: TBitSet): Boolean; - -implementation - -function BitSetIn(const x: TBitSet; const e: BiggestInt): Boolean; -begin - 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)] := 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)] := x[int(elem div ElemSize)] and - not toU8(int(1 shl (elem mod ElemSize))) -end; - -procedure BitSetInit(out b: TBitSet; len: int); -begin -{@ignore} - setLength(b, len); - fillChar(b[0], length(b)*sizeof(b[0]), 0); -{@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] := 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] := 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] := 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] := x[i] and y[i] -end; - -function BitSetEquals(const x, y: TBitSet): Boolean; -var - i: int; -begin - for i := 0 to high(x) do - if x[i] <> y[i] then begin - result := false; exit; - end; - result := true -end; - -function BitSetContains(const x, y: TBitSet): Boolean; -var - i: int; -begin - for i := 0 to high(x) do - if (x[i] and not y[i]) <> byte(0) then begin - result := false; exit; - end; - result := true -end; - -end. diff --git a/nim/ccgexprs.pas b/nim/ccgexprs.pas deleted file mode 100755 index a5789487a..000000000 --- a/nim/ccgexprs.pas +++ /dev/null @@ -1,2318 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -// -------------------------- constant expressions ------------------------ - -function intLiteral(i: biggestInt): PRope; -begin - if (i > low(int32)) and (i <= high(int32)) then - result := toRope(i) - else if i = low(int32) then - // Nimrod has the same bug for the same reasons :-) - result := toRope('(-2147483647 -1)') - else if i > low(int64) then - result := ropef('IL64($1)', [toRope(i)]) - else - result := toRope('(IL64(-9223372036854775807) - IL64(1))') -end; - -function int32Literal(i: Int): PRope; -begin - if i = int(low(int32)) then - // Nimrod has the same bug for the same reasons :-) - result := toRope('(-2147483647 -1)') - else - result := toRope(i) -end; - -function genHexLiteral(v: PNode): PRope; -// hex literals are unsigned in C -// so we don't generate hex literals any longer. -begin - if not (v.kind in [nkIntLit..nkInt64Lit]) then - internalError(v.info, 'genHexLiteral'); - result := intLiteral(v.intVal) -end; - -function getStrLit(m: BModule; const s: string): PRope; -begin - useMagic(m, 'TGenericSeq'); - result := con('TMP', toRope(getID())); - appf(m.s[cfsData], 'STRING_LITERAL($1, $2, $3);$n', - [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 - nkCharLit..nkInt64Lit: begin - case skipTypes(ty, abstractVarRange).kind of - tyChar, tyInt64, tyNil: result := intLiteral(v.intVal); - tyInt8: - result := ropef('((NI8) $1)', [intLiteral(biggestInt(int8(v.intVal)))]); - tyInt16: - result := ropef('((NI16) $1)', [intLiteral(biggestInt(int16(v.intVal)))]); - tyInt32: - result := ropef('((NI32) $1)', [intLiteral(biggestInt(int32(v.intVal)))]); - tyInt: begin - if (v.intVal >= low(int32)) and (v.intVal <= high(int32)) then - result := int32Literal(int32(v.intVal)) - else - result := intLiteral(v.intVal); - end; - tyBool: begin - if v.intVal <> 0 then result := toRope('NIM_TRUE') - else result := toRope('NIM_FALSE'); - end; - else - result := ropef('(($1) $2)', [getTypeDesc(p.module, - skipTypes(ty, abstractVarRange)), intLiteral(v.intVal)]) - end - end; - nkNilLit: - result := toRope('0'+''); - nkStrLit..nkTripleStrLit: begin - if skipTypes(ty, abstractVarRange).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; - nkFloatLit..nkFloat64Lit: begin - f := v.floatVal; - if f <> f then // NAN - result := toRope('NAN') - else if f = 0.0 then - result := toRopeF(f) - else if f = 0.5 * f then - if f > 0.0 then result := toRope('INF') - else result := toRope('-INF') - else - result := toRopeF(f); - end - else begin - InternalError(v.info, 'genLiteral(' +{&} nodeKindToStr[v.kind] +{&} ')'); - result := nil - end - end -end; - -function genLiteral(p: BProc; v: PNode): PRope; overload; -begin - result := genLiteral(p, v, v.typ) -end; - -function bitSetToWord(const s: TBitSet; size: int): BiggestInt; -var - j: int; -begin - result := 0; - if CPU[platform.hostCPU].endian = CPU[targetCPU].endian then begin - for j := 0 to size-1 do - if j < length(s) then - result := result or shlu(Ze64(s[j]), j * 8) - end - else begin - for j := 0 to size-1 do - if j < length(s) then - result := result or shlu(Ze64(s[j]), (Size-1-j) * 8) - end -end; - -function genRawSetData(const cs: TBitSet; size: int): PRope; -var - frmt: TFormatStr; - i: int; -begin - if size > 8 then begin - result := toRope('{' + tnl); - for i := 0 to size-1 do begin - if i < size-1 then begin // not last iteration? - if (i + 1) mod 8 = 0 then frmt := '0x$1,$n' - else frmt := '0x$1, ' - end - else frmt := '0x$1}$n'; - appf(result, frmt, [toRope(toHex(Ze64(cs[i]), 2))]) - end - end - else - 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, id: int; -begin - size := int(getSize(n.typ)); - toBitSet(n, cs); - if size > 8 then begin - 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) -end; - -// --------------------------- assignment generator ----------------------- - -function getStorageLoc(n: PNode): TStorageLoc; -begin - case n.kind of - nkSym: begin - case n.sym.kind of - skParam, skForVar, skTemp: result := OnStack; - skVar: begin - if sfGlobal in n.sym.flags then result := OnHeap - else result := OnStack - end; - else result := OnUnknown; - end - end; - //nkHiddenAddr, nkAddr: - nkDerefExpr, nkHiddenDeref: - case n.sons[0].typ.kind of - tyVar: result := OnUnknown; - tyPtr: result := OnStack; - tyRef: result := OnHeap; - else InternalError(n.info, 'getStorageLoc'); - end; - nkBracketExpr, nkDotExpr, nkObjDownConv, nkObjUpConv: - result := getStorageLoc(n.sons[0]); - else result := OnUnknown; - end -end; - -function rdLoc(const a: TLoc): PRope; // 'read' location (deref if indirect) -begin - result := a.r; - if lfIndirect in a.flags then result := ropef('(*$1)', [result]) -end; - -function addrLoc(const a: TLoc): PRope; -begin - result := a.r; - if not (lfIndirect in a.flags) then result := con('&'+'', result) -end; - -function rdCharLoc(const a: TLoc): PRope; -// read a location that may need a char-cast: -begin - result := rdLoc(a); - if skipTypes(a.t, abstractRange).kind = tyChar then - result := ropef('((NU8)($1))', [result]) -end; - -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 - // 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'); - appf(p.s[cpsStmts], 'unsureAsgnRef((void**) $1, $2);$n', - [addrLoc(dest), rdLoc(src)]) - end -end; - -procedure genAssignment(p: BProc; const dest, src: TLoc; - flags: TAssignmentFlags); overload; - // This function replaces all other methods for generating - // the assignment operation in C. -var - ty: PType; -begin; - ty := skipTypes(dest.t, abstractVarRange); - case ty.kind of - tyRef: - genRefAssign(p, dest, src, flags); - tySequence: begin - if not (needToCopy in flags) then - genRefAssign(p, dest, src, flags) - else begin - useMagic(p.module, 'genericSeqAssign'); // BUGFIX - appf(p.s[cpsStmts], 'genericSeqAssign($1, $2, $3);$n', - [addrLoc(dest), rdLoc(src), genTypeInfo(p.module, dest.t)]) - end - end; - tyString: begin - if not (needToCopy in flags) then - 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, 'asgnRefNoCycle'); - useMagic(p.module, 'copyString'); // BUGFIX - appf(p.s[cpsStmts], 'asgnRefNoCycle((void**) $1, copyString($2));$n', - [addrLoc(dest), rdLoc(src)]) - end - else begin - useMagic(p.module, 'unsureAsgnRef'); - useMagic(p.module, 'copyString'); // BUGFIX - appf(p.s[cpsStmts], - 'unsureAsgnRef((void**) $1, copyString($2));$n', - [addrLoc(dest), rdLoc(src)]) - end - end - end; - - tyTuple: - if needsComplexAssignment(dest.t) then begin - useMagic(p.module, 'genericAssign'); - appf(p.s[cpsStmts], - 'genericAssign((void*)$1, (void*)$2, $3);$n', - [addrLoc(dest), addrLoc(src), genTypeInfo(p.module, dest.t)]) - end - else - appf(p.s[cpsStmts], '$1 = $2;$n', [rdLoc(dest), rdLoc(src)]); - tyArray, tyArrayConstr: - if needsComplexAssignment(dest.t) then begin - useMagic(p.module, 'genericAssign'); - appf(p.s[cpsStmts], - 'genericAssign((void*)$1, (void*)$2, $3);$n', - [addrLoc(dest), addrLoc(src), genTypeInfo(p.module, dest.t)]) - end - else - appf(p.s[cpsStmts], - 'memcpy((void*)$1, (NIM_CONST void*)$2, sizeof($1));$n', - [rdLoc(dest), rdLoc(src)]); - tyObject: - // XXX: check for subtyping? - if needsComplexAssignment(dest.t) then begin - useMagic(p.module, 'genericAssign'); - appf(p.s[cpsStmts], - 'genericAssign((void*)$1, (void*)$2, $3);$n', - [addrLoc(dest), addrLoc(src), genTypeInfo(p.module, dest.t)]) - end - else - appf(p.s[cpsStmts], '$1 = $2;$n', [rdLoc(dest), rdLoc(src)]); - tyOpenArray: begin - // open arrays are always on the stack - really? What if a sequence is - // passed to an open array? - if needsComplexAssignment(dest.t) then begin - useMagic(p.module, 'genericAssignOpenArray'); - appf(p.s[cpsStmts],// XXX: is this correct for arrays? - 'genericAssignOpenArray((void*)$1, (void*)$2, $1Len0, $3);$n', - [addrLoc(dest), addrLoc(src), genTypeInfo(p.module, dest.t)]) - end - else - appf(p.s[cpsStmts], - 'memcpy((void*)$1, (NIM_CONST void*)$2, sizeof($1[0])*$1Len0);$n', - [rdLoc(dest), rdLoc(src)]); - end; - tySet: - if mapType(ty) = ctArray then - appf(p.s[cpsStmts], 'memcpy((void*)$1, (NIM_CONST void*)$2, $3);$n', - [rdLoc(dest), rdLoc(src), toRope(getSize(dest.t))]) - else - appf(p.s[cpsStmts], '$1 = $2;$n', - [rdLoc(dest), rdLoc(src)]); - tyPtr, tyPointer, tyChar, tyBool, tyProc, tyEnum, - tyCString, tyInt..tyFloat128, tyRange: - appf(p.s[cpsStmts], '$1 = $2;$n', [rdLoc(dest), rdLoc(src)]); - else - InternalError('genAssignment(' + typeKindToStr[ty.kind] + ')') - end -end; - -// ------------------------------ expressions ----------------------------- - -procedure expr(p: BProc; e: PNode; var d: TLoc); forward; - -procedure initLocExpr(p: BProc; e: PNode; var result: TLoc); -begin - 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 getTemp(p, typ, d) -end; - -procedure putLocIntoDest(p: BProc; var d: TLoc; const s: TLoc); -begin - if d.k <> locNone then // need to generate an assignment here - if lfNoDeepCopy in d.flags then - genAssignment(p, d, s, {@set}[]) - else - genAssignment(p, d, s, {@set}[needToCopy]) - else - d := s // ``d`` is free, so fill it with ``s`` -end; - -procedure putIntoDest(p: BProc; var d: TLoc; t: PType; r: PRope); -var - a: TLoc; -begin - if d.k <> locNone then begin // need to generate an assignment here - initLoc(a, locExpr, getUniqueType(t), OnUnknown); - a.r := r; - if lfNoDeepCopy in d.flags then - genAssignment(p, d, a, {@set}[]) - else - genAssignment(p, d, a, {@set}[needToCopy]) - end - else begin // we cannot call initLoc() here as that would overwrite - // the flags field! - d.k := locExpr; - d.t := getUniqueType(t); - d.r := r; - d.a := -1 - end -end; - -procedure binaryStmt(p: BProc; e: PNode; var d: TLoc; - const magic, frmt: string); -var - a, b: TLoc; -begin - if (d.k <> locNone) then InternalError(e.info, 'binaryStmt'); - if magic <> '' then useMagic(p.module, magic); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - appf(p.s[cpsStmts], frmt, [rdLoc(a), rdLoc(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)]); -end; - -procedure binaryStmtChar(p: BProc; e: PNode; var d: TLoc; - const magic, frmt: string); -var - a, b: TLoc; -begin - if (d.k <> locNone) then InternalError(e.info, 'binaryStmtChar'); - if magic <> '' then useMagic(p.module, magic); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - appf(p.s[cpsStmts], frmt, [rdCharLoc(a), rdCharLoc(b)]); -end; - -procedure binaryExpr(p: BProc; e: PNode; var d: TLoc; - const magic, frmt: string); -var - a, b: TLoc; -begin - if magic <> '' then useMagic(p.module, magic); - assert(e.sons[1].typ <> nil); - assert(e.sons[2].typ <> nil); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - putIntoDest(p, d, e.typ, ropef(frmt, [rdLoc(a), rdLoc(b)])); -end; - -procedure binaryExprChar(p: BProc; e: PNode; var d: TLoc; - const magic, frmt: string); -var - a, b: TLoc; -begin - if magic <> '' then useMagic(p.module, magic); - assert(e.sons[1].typ <> nil); - assert(e.sons[2].typ <> nil); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - putIntoDest(p, d, e.typ, ropef(frmt, [rdCharLoc(a), rdCharLoc(b)])); -end; - -procedure unaryExpr(p: BProc; e: PNode; var d: TLoc; - const magic, frmt: string); -var - a: TLoc; -begin - if magic <> '' then useMagic(p.module, magic); - InitLocExpr(p, e.sons[1], a); - putIntoDest(p, d, e.typ, ropef(frmt, [rdLoc(a)])); -end; - -procedure unaryExprChar(p: BProc; e: PNode; var d: TLoc; - const magic, frmt: string); -var - a: TLoc; -begin - if magic <> '' then useMagic(p.module, magic); - InitLocExpr(p, e.sons[1], a); - putIntoDest(p, d, e.typ, ropef(frmt, [rdCharLoc(a)])); -end; - -procedure binaryArithOverflow(p: BProc; e: PNode; var d: TLoc; m: TMagic); -const - prc: array [mAddi..mModi64] of string = ( - 'addInt', 'subInt', 'mulInt', 'divInt', 'modInt', - 'addInt64', 'subInt64', 'mulInt64', 'divInt64', 'modInt64' - ); - opr: array [mAddi..mModi64] of string = ( - '+'+'', '-'+'', '*'+'', '/'+'', '%'+'', - '+'+'', '-'+'', '*'+'', '/'+'', '%'+'' - ); -var - a, b: TLoc; - t: PType; -begin - assert(e.sons[1].typ <> nil); - assert(e.sons[2].typ <> nil); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - t := skipTypes(e.typ, abstractRange); - if getSize(t) >= platform.IntSize then begin - if optOverflowCheck in p.options then begin - useMagic(p.module, prc[m]); - putIntoDest(p, d, e.typ, ropef('$1($2, $3)', - [toRope(prc[m]), rdLoc(a), rdLoc(b)])); - end - else - putIntoDest(p, d, e.typ, ropef('(NI$4)($2 $1 $3)', - [toRope(opr[m]), rdLoc(a), rdLoc(b), toRope(getSize(t)*8)])); - end - else begin - if optOverflowCheck in p.options then begin - useMagic(p.module, 'raiseOverflow'); - if (m = mModI) or (m = mDivI) then begin - useMagic(p.module, 'raiseDivByZero'); - appf(p.s[cpsStmts], 'if (!$1) raiseDivByZero();$n', [rdLoc(b)]); - end; - a.r := ropef('((NI)($2) $1 (NI)($3))', - [toRope(opr[m]), 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(t)), intLiteral(lastOrd(t))]); - d.t := e.typ; - d.r := ropef('(NI$1)($2)', [toRope(getSize(t)*8), rdLoc(d)]); - end - else - putIntoDest(p, d, e.typ, ropef('(NI$4)($2 $1 $3)', - [toRope(opr[m]), rdLoc(a), rdLoc(b), toRope(getSize(t)*8)])); - end -end; - -procedure unaryArithOverflow(p: BProc; e: PNode; var d: TLoc; m: TMagic); -const - opr: array [mUnaryMinusI..mAbsI64] of string = ( - '((NI$2)-($1))', // UnaryMinusI - '-($1)', // UnaryMinusI64 - '(NI$2)abs($1)', // AbsI - '($1 > 0? ($1) : -($1))' // AbsI64 - ); -var - a: TLoc; - t: PType; -begin - assert(e.sons[1].typ <> nil); - InitLocExpr(p, e.sons[1], a); - t := skipTypes(e.typ, abstractRange); - if optOverflowCheck in p.options then begin - useMagic(p.module, 'raiseOverflow'); - appf(p.s[cpsStmts], 'if ($1 == $2) raiseOverflow();$n', - [rdLoc(a), intLiteral(firstOrd(t))]); - end; - putIntoDest(p, d, e.typ, ropef(opr[m], [rdLoc(a), toRope(getSize(t)*8)])); -end; - -procedure binaryArith(p: BProc; e: PNode; var d: TLoc; op: TMagic); -const - binArithTab: array [mShrI..mXor] of string = ( - '(NI$3)((NU$3)($1) >> (NU$3)($2))', // ShrI - '(NI$3)((NU$3)($1) << (NU$3)($2))', // ShlI - '(NI$3)($1 & $2)', // BitandI - '(NI$3)($1 | $2)', // BitorI - '(NI$3)($1 ^ $2)', // BitxorI - '(($1 <= $2) ? $1 : $2)', // MinI - '(($1 >= $2) ? $1 : $2)', // MaxI - '(NI64)((NU64)($1) >> (NU64)($2))', // ShrI64 - '(NI64)((NU64)($1) << (NU64)($2))', // ShlI64 - '($1 & $2)', // BitandI64 - '($1 | $2)', // BitorI64 - '($1 ^ $2)', // BitxorI64 - '(($1 <= $2) ? $1 : $2)', // MinI64 - '(($1 >= $2) ? $1 : $2)', // MaxI64 - - '($1 + $2)', // AddF64 - '($1 - $2)', // SubF64 - '($1 * $2)', // MulF64 - '($1 / $2)', // DivF64 - '(($1 <= $2) ? $1 : $2)', // MinF64 - '(($1 >= $2) ? $1 : $2)', // MaxF64 - - '(NI$3)((NU$3)($1) + (NU$3)($2))', // AddU - '(NI$3)((NU$3)($1) - (NU$3)($2))', // SubU - '(NI$3)((NU$3)($1) * (NU$3)($2))', // MulU - '(NI$3)((NU$3)($1) / (NU$3)($2))', // DivU - '(NI$3)((NU$3)($1) % (NU$3)($2))', // ModU - '(NI64)((NU64)($1) + (NU64)($2))', // AddU64 - '(NI64)((NU64)($1) - (NU64)($2))', // SubU64 - '(NI64)((NU64)($1) * (NU64)($2))', // MulU64 - '(NI64)((NU64)($1) / (NU64)($2))', // DivU64 - '(NI64)((NU64)($1) % (NU64)($2))', // ModU64 - - '($1 == $2)', // EqI - '($1 <= $2)', // LeI - '($1 < $2)', // LtI - '($1 == $2)', // EqI64 - '($1 <= $2)', // LeI64 - '($1 < $2)', // LtI64 - '($1 == $2)', // EqF64 - '($1 <= $2)', // LeF64 - '($1 < $2)', // LtF64 - - '((NU$3)($1) <= (NU$3)($2))', // LeU - '((NU$3)($1) < (NU$3)($2))', // LtU - '((NU64)($1) <= (NU64)($2))', // LeU64 - '((NU64)($1) < (NU64)($2))', // LtU64 - - '($1 == $2)', // EqEnum - '($1 <= $2)', // LeEnum - '($1 < $2)', // LtEnum - '((NU8)($1) == (NU8)($2))', // EqCh - '((NU8)($1) <= (NU8)($2))', // LeCh - '((NU8)($1) < (NU8)($2))', // LtCh - '($1 == $2)', // EqB - '($1 <= $2)', // LeB - '($1 < $2)', // LtB - - '($1 == $2)', // EqRef - '($1 == $2)', // EqProc - '($1 == $2)', // EqPtr - '($1 <= $2)', // LePtr - '($1 < $2)', // LtPtr - '($1 == $2)', // EqCString - - '($1 != $2)' // Xor - ); -var - a, b: TLoc; - s: biggestInt; -begin - assert(e.sons[1].typ <> nil); - assert(e.sons[2].typ <> nil); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - // BUGFIX: cannot use result-type here, as it may be a boolean - s := max(getSize(a.t), getSize(b.t))*8; - putIntoDest(p, d, e.typ, ropef(binArithTab[op], - [rdLoc(a), rdLoc(b), toRope(s)])); -end; - -procedure unaryArith(p: BProc; e: PNode; var d: TLoc; op: TMagic); -const - unArithTab: array [mNot..mToBiggestInt] of string = ( - '!($1)', // Not - '$1', // UnaryPlusI - '(NI$2)((NU$2) ~($1))', // BitnotI - '$1', // UnaryPlusI64 - '~($1)', // BitnotI64 - '$1', // UnaryPlusF64 - '-($1)', // UnaryMinusF64 - '($1 > 0? ($1) : -($1))', // AbsF64; BUGFIX: fabs() makes problems - // for Tiny C, so we don't use it - '((NI)(NU)(NU8)($1))', // mZe8ToI - '((NI64)(NU64)(NU8)($1))', // mZe8ToI64 - '((NI)(NU)(NU16)($1))', // mZe16ToI - '((NI64)(NU64)(NU16)($1))', // mZe16ToI64 - '((NI64)(NU64)(NU32)($1))', // mZe32ToI64 - '((NI64)(NU64)(NU)($1))', // mZeIToI64 - - '((NI8)(NU8)(NU)($1))', // ToU8 - '((NI16)(NU16)(NU)($1))', // ToU16 - '((NI32)(NU32)(NU64)($1))', // ToU32 - - '((double) ($1))', // ToFloat - '((double) ($1))', // ToBiggestFloat - 'float64ToInt32($1)', // ToInt XXX: this is not correct! - 'float64ToInt64($1)' // ToBiggestInt - ); -var - a: TLoc; - t: PType; -begin - assert(e.sons[1].typ <> nil); - InitLocExpr(p, e.sons[1], a); - t := skipTypes(e.typ, abstractRange); - putIntoDest(p, d, e.typ, ropef(unArithTab[op], - [rdLoc(a), toRope(getSize(t)*8)])); -end; - -procedure genDeref(p: BProc; e: PNode; var d: TLoc); -var - a: TLoc; -begin - if mapType(e.sons[0].typ) = ctArray then - expr(p, e.sons[0], d) - else begin - initLocExpr(p, e.sons[0], a); - case skipTypes(a.t, abstractInst).kind of - tyRef: d.s := OnHeap; - tyVar: d.s := OnUnknown; - tyPtr: d.s := OnUnknown; // BUGFIX! - else InternalError(e.info, 'genDeref ' + typekindToStr[a.t.kind]); - end; - putIntoDest(p, d, a.t.sons[0], ropef('(*$1)', [rdLoc(a)])); - end -end; - -procedure genAddr(p: BProc; e: PNode; var d: TLoc); -var - a: TLoc; -begin - if mapType(e.sons[0].typ) = ctArray then - expr(p, e.sons[0], d) - else begin - InitLocExpr(p, e.sons[0], a); - putIntoDest(p, d, e.typ, addrLoc(a)); - end -end; - -function genRecordFieldAux(p: BProc; e: PNode; var d, a: TLoc): PType; -begin - 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 - result := getUniqueType(a.t); -end; - -procedure genRecordField(p: BProc; e: PNode; var d: TLoc); -var - a: TLoc; - f, field: PSym; - ty: PType; - r: PRope; -begin - ty := genRecordFieldAux(p, e, d, a); - r := rdLoc(a); - f := e.sons[1].sym; - field := nil; - while ty <> nil do begin - if not (ty.kind in [tyTuple, tyObject]) then - InternalError(e.info, 'genRecordField'); - field := lookupInRecord(ty.n, f.name); - if field <> nil then break; - if gCmd <> cmdCompileToCpp then app(r, '.Sup'); - ty := GetUniqueType(ty.sons[0]); - end; - if field = nil then InternalError(e.info, 'genRecordField'); - if field.loc.r = nil then InternalError(e.info, 'genRecordField'); - appf(r, '.$1', [field.loc.r]); - putIntoDest(p, d, field.typ, r); -end; - -procedure genTupleElem(p: BProc; e: PNode; var d: TLoc); -var - a: TLoc; - field: PSym; - ty: PType; - r: PRope; - i: int; -begin - initLocExpr(p, e.sons[0], a); - if d.k = locNone then d.s := a.s; - {@discard} getTypeDesc(p.module, a.t); // fill the record's fields.loc - ty := getUniqueType(a.t); - r := rdLoc(a); - case e.sons[1].kind of - nkIntLit..nkInt64Lit: i := int(e.sons[1].intVal); - else internalError(e.info, 'genTupleElem'); - end; - if ty.n <> nil then begin - field := ty.n.sons[i].sym; - if field = nil then InternalError(e.info, 'genTupleElem'); - if field.loc.r = nil then InternalError(e.info, 'genTupleElem'); - appf(r, '.$1', [field.loc.r]); - end - else - appf(r, '.Field$1', [toRope(i)]); - putIntoDest(p, d, ty.sons[i], r); -end; - -procedure genInExprAux(p: BProc; e: PNode; var a, b, d: TLoc); forward; - -procedure genCheckedRecordField(p: BProc; e: PNode; var d: TLoc); -var - a, u, v, test: TLoc; - f, field, op: PSym; - ty: PType; - 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; - field := nil; - while ty <> nil do begin - assert(ty.kind in [tyTuple, tyObject]); - field := lookupInRecord(ty.n, f.name); - if field <> nil then break; - if gCmd <> cmdCompileToCpp then app(r, '.Sup'); - ty := getUniqueType(ty.sons[0]) - end; - if field = nil then InternalError(e.info, 'genCheckedRecordField'); - if field.loc.r = nil then InternalError(e.info, 'genCheckedRecordField'); - // generate the checks: - for i := 1 to sonsLen(e)-1 do begin - it := e.sons[i]; - assert(it.kind = nkCall); - assert(it.sons[0].kind = nkSym); - op := it.sons[0].sym; - if op.magic = mNot then it := it.sons[1]; - assert(it.sons[2].kind = nkSym); - 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(((NimStringDesc*) &$2));$n', - [rdLoc(test), strLit]) - else - appf(p.s[cpsStmts], - 'if (!($1)) raiseFieldError(((NimStringDesc*) &$2));$n', - [rdLoc(test), strLit]) - end; - appf(r, '.$1', [field.loc.r]); - putIntoDest(p, d, field.typ, r); - end - else - genRecordField(p, e.sons[0], d) -end; - -procedure genArrayElem(p: BProc; e: PNode; var d: TLoc); -var - a, b: TLoc; - ty: PType; - first: PRope; -begin - initLocExpr(p, e.sons[0], a); - initLocExpr(p, e.sons[1], b); - ty := skipTypes(skipTypes(a.t, abstractVarRange), abstractPtrs); - first := intLiteral(firstOrd(ty)); - // emit range check: - if (optBoundsCheck in p.options) then begin - if not isConstExpr(e.sons[1]) then begin - // semantic pass has already checked for const index expressions - useMagic(p.module, 'raiseIndexError'); - if firstOrd(ty) = 0 then begin - if (firstOrd(b.t) < firstOrd(ty)) or (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; - end; - if d.k = locNone then d.s := a.s; - putIntoDest(p, d, elemType(skipTypes(ty, abstractVar)), ropef('$1[($2)-$3]', - [rdLoc(a), rdCharLoc(b), first])); -end; - -procedure genCStringElem(p: BProc; e: PNode; var d: TLoc); -var - a, b: TLoc; - ty: PType; -begin - initLocExpr(p, e.sons[0], a); - initLocExpr(p, e.sons[1], b); - ty := skipTypes(a.t, abstractVarRange); - if d.k = locNone then d.s := a.s; - putIntoDest(p, d, elemType(skipTypes(ty, abstractVar)), ropef('$1[$2]', - [rdLoc(a), rdCharLoc(b)])); -end; - -procedure genOpenArrayElem(p: BProc; e: PNode; var d: TLoc); -var - a, b: TLoc; -begin - initLocExpr(p, e.sons[0], a); - initLocExpr(p, e.sons[1], b); - // emit range check: - if (optBoundsCheck in p.options) then begin - useMagic(p.module, 'raiseIndexError'); - appf(p.s[cpsStmts], - 'if ((NU)($1) >= (NU)($2Len0)) raiseIndexError();$n', [rdLoc(b), rdLoc(a)]) - // BUGFIX: ``>=`` and not ``>``! - end; - if d.k = locNone then d.s := a.s; - putIntoDest(p, d, elemType(skipTypes(a.t, abstractVar)), ropef('$1[$2]', - [rdLoc(a), rdCharLoc(b)])); -end; - -procedure genSeqElem(p: BPRoc; e: PNode; var d: TLoc); -var - a, b: TLoc; - ty: PType; -begin - initLocExpr(p, e.sons[0], a); - initLocExpr(p, e.sons[1], b); - ty := skipTypes(a.t, abstractVarRange); - if ty.kind in [tyRef, tyPtr] then - ty := skipTypes(ty.sons[0], abstractVarRange); - // emit range check: - 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->Sup.len)) raiseIndexError();$n', - [rdLoc(b), rdLoc(a)]) - else - appf(p.s[cpsStmts], - 'if ((NU)($1) >= (NU)($2->Sup.len)) raiseIndexError();$n', - [rdLoc(b), rdLoc(a)]) - end; - if d.k = locNone then d.s := OnHeap; - if skipTypes(a.t, abstractVar).kind in [tyRef, tyPtr] then - a.r := ropef('(*$1)', [a.r]); - putIntoDest(p, d, elemType(skipTypes(a.t, abstractVar)), - ropef('$1->data[$2]', [rdLoc(a), rdCharLoc(b)])); -end; - -procedure genAndOr(p: BProc; e: PNode; var d: TLoc; m: TMagic); -// how to generate code? -// 'expr1 and expr2' becomes: -// result = expr1 -// fjmp result, end -// result = expr2 -// end: -// ... (result computed) -// BUGFIX: -// a = b or a -// used to generate: -// a = b -// if a: goto end -// a = a -// end: -// now it generates: -// tmp = b -// if tmp: goto end -// tmp = a -// end: -// a = tmp -var - L: TLabel; - tmp: TLoc; -begin - getTemp(p, e.typ, tmp); // force it into a temp! - expr(p, e.sons[1], tmp); - L := getLabel(p); - if m = mOr then - appf(p.s[cpsStmts], 'if ($1) goto $2;$n', [rdLoc(tmp), L]) - else // mAnd: - appf(p.s[cpsStmts], 'if (!($1)) goto $2;$n', [rdLoc(tmp), L]); - expr(p, e.sons[2], tmp); - fixLabel(p, L); - if d.k = locNone then - d := tmp - else - genAssignment(p, d, tmp, {@set}[]); // no need for deep copying -end; - -procedure genIfExpr(p: BProc; n: PNode; var d: TLoc); -(* - if (!expr1) goto L1; - thenPart - goto LEnd - L1: - if (!expr2) goto L2; - thenPart2 - goto LEnd - L2: - elsePart - Lend: -*) -var - i: int; - it: PNode; - a, tmp: TLoc; - Lend, Lelse: TLabel; -begin - 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 - initLocExpr(p, it.sons[0], a); - Lelse := getLabel(p); - appf(p.s[cpsStmts], 'if (!$1) goto $2;$n', [rdLoc(a), Lelse]); - expr(p, it.sons[1], tmp); - appf(p.s[cpsStmts], 'goto $1;$n', [Lend]); - fixLabel(p, Lelse); - end; - nkElseExpr: begin - expr(p, it.sons[0], tmp); - end; - else internalError(n.info, 'genIfExpr()'); - end - end; - fixLabel(p, Lend); - if d.k = locNone then - d := tmp - else - genAssignment(p, d, tmp, {@set}[]); // no need for deep copying -end; - -procedure genEcho(p: BProc; n: PNode); -var - i: int; - a: TLoc; -begin - useMagic(p.module, 'rawEcho'); - useMagic(p.module, 'rawEchoNL'); - for i := 1 to sonsLen(n)-1 do begin - initLocExpr(p, n.sons[i], a); - appf(p.s[cpsStmts], 'rawEcho($1);$n', [rdLoc(a)]); - end; - app(p.s[cpsStmts], 'rawEchoNL();' + tnl); -end; - -procedure genCall(p: BProc; t: PNode; var d: TLoc); -var - param: PSym; - invalidRetType: bool; - typ: PType; - pl: PRope; // parameter list - op, list, a: TLoc; - len, i: int; -begin - // this is a hotspot in the compiler - initLocExpr(p, t.sons[0], op); - pl := con(op.r, '('+''); - //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); - for i := 1 to len-1 do begin - 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)) - else app(pl, rdLoc(a)); - end - else - 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 - // XXX (detected by pegs module 64bit): p(result, result) is not - // correct here. Thus we always allocate a temporary: - if d.k = locNone then getTemp(p, typ.sons[0], d); - app(pl, addrLoc(d)); - end; - app(pl, ')'+''); - if (typ.sons[0] <> nil) and not invalidRetType then begin - if d.k = locNone then getTemp(p, typ.sons[0], d); - assert(d.t <> nil); - // generate an assignment to d: - initLoc(list, locCall, nil, OnUnknown); - list.r := pl; - genAssignment(p, d, list, {@set}[]) // no need for deep copying - end - else begin - app(p.s[cpsStmts], pl); - app(p.s[cpsStmts], ';' + tnl) - end -end; - -procedure genStrConcat(p: BProc; e: PNode; var d: TLoc); -// <Nimrod code> -// s = 'hallo ' & name & ' how do you feel?' & 'z' -// -// <generated C code> -// { -// string tmp0; -// ... -// tmp0 = rawNewString(6 + 17 + 1 + s2->len); -// // we cannot generate s = rawNewString(...) here, because -// // ``s`` may be used on the right side of the expression -// appendString(tmp0, strlit_1); -// appendString(tmp0, name); -// appendString(tmp0, strlit_2); -// appendChar(tmp0, 'z'); -// asgn(s, tmp0); -// } -var - a, tmp: TLoc; - appends, lens: PRope; - L, i: int; -begin - useMagic(p.module, 'rawNewString'); - getTemp(p, e.typ, tmp); - L := 0; - appends := nil; - lens := nil; - for i := 0 to sonsLen(e)-2 do begin - // compute the length expression: - initLocExpr(p, e.sons[i+1], a); - if skipTypes(e.sons[i+1].Typ, abstractVarRange).kind = tyChar then begin - Inc(L); - useMagic(p.module, 'appendChar'); - appf(appends, 'appendChar($1, $2);$n', [tmp.r, rdLoc(a)]) - end - else 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->Sup.len + ', [rdLoc(a)]); - useMagic(p.module, 'appendString'); - appf(appends, 'appendString($1, $2);$n', [tmp.r, rdLoc(a)]) - end - end; - appf(p.s[cpsStmts], '$1 = rawNewString($2$3);$n', - [tmp.r, lens, toRope(L)]); - app(p.s[cpsStmts], appends); - if d.k = locNone then - d := tmp - else - genAssignment(p, d, tmp, {@set}[]); // no need for deep copying -end; - -procedure genStrAppend(p: BProc; e: PNode; var d: TLoc); -// <Nimrod code> -// s &= 'hallo ' & name & ' how do you feel?' & 'z' -// // BUG: what if s is on the left side too? -// <generated C code> -// { -// s = resizeString(s, 6 + 17 + 1 + name->len); -// appendString(s, strlit_1); -// appendString(s, name); -// appendString(s, strlit_2); -// appendChar(s, 'z'); -// } -var - a, dest: TLoc; - L, i: int; - appends, lens: PRope; -begin - assert(d.k = locNone); - useMagic(p.module, 'resizeString'); - L := 0; - appends := nil; - lens := nil; - initLocExpr(p, e.sons[1], dest); - for i := 0 to sonsLen(e)-3 do begin - // compute the length expression: - initLocExpr(p, e.sons[i+2], a); - if skipTypes(e.sons[i+2].Typ, abstractVarRange).kind = tyChar then begin - Inc(L); - useMagic(p.module, 'appendChar'); - appf(appends, 'appendChar($1, $2);$n', - [rdLoc(dest), rdLoc(a)]) - end - else 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->Sup.len + ', [rdLoc(a)]); - useMagic(p.module, 'appendString'); - appf(appends, 'appendString($1, $2);$n', - [rdLoc(dest), rdLoc(a)]) - end - end; - appf(p.s[cpsStmts], '$1 = resizeString($1, $2$3);$n', - [rdLoc(dest), lens, toRope(L)]); - app(p.s[cpsStmts], appends); -end; - -procedure genSeqElemAppend(p: BProc; e: PNode; var d: TLoc); -// seq &= 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'); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - appf(p.s[cpsStmts], - '$1 = ($2) incrSeq(&($1)->Sup, sizeof($3));$n', - [rdLoc(a), getTypeDesc(p.module, skipTypes(e.sons[1].typ, abstractVar)), - getTypeDesc(p.module, skipTypes(e.sons[2].Typ, abstractVar))]); - 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 := skipTypes(s.sons[0], abstractInst); - 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); -var - a, b: TLoc; - reftype, bt: PType; -begin - useMagic(p.module, 'newObj'); - refType := skipTypes(e.sons[1].typ, abstractVarRange); - 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, skipTypes(reftype.sons[0], abstractRange))]); - genAssignment(p, a, b, {@set}[]); - // set the object type: - bt := skipTypes(refType.sons[0], abstractRange); - 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 := skipTypes(e.sons[1].typ, abstractVarRange); - 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; x: PNode; typ: PType; var d: TLoc); overload; -var - a: TLoc; - dest, t: PType; - r, nilcheck: PRope; -begin - initLocExpr(p, x, a); - dest := skipTypes(typ, abstractPtrs); - useMagic(p.module, 'isObj'); - r := rdLoc(a); - nilCheck := nil; - t := skipTypes(a.t, abstractInst); - while t.kind in [tyVar, tyPtr, tyRef] do begin - if t.kind <> tyVar then nilCheck := r; - r := ropef('(*$1)', [r]); - t := skipTypes(t.sons[0], abstractInst) - end; - if gCmd <> cmdCompileToCpp then - while (t.kind = tyObject) and (t.sons[0] <> nil) do begin - app(r, '.Sup'); - t := skipTypes(t.sons[0], abstractInst) - 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, getSysType(tyBool), r); -end; - -procedure genIs(p: BProc; n: PNode; var d: TLoc); overload; -begin - genIs(p, n.sons[1], n.sons[2].typ, d); -end; - -procedure genNewFinalize(p: BProc; e: PNode); -var - a, b, f: TLoc; - refType, bt: PType; - ti: PRope; - oldModule: BModule; -begin - useMagic(p.module, 'newObj'); - refType := skipTypes(e.sons[1].typ, abstractVarRange); - InitLocExpr(p, e.sons[1], a); - - // This is a little hack: - // XXX this is also a bug, if the finalizer expression produces side-effects - oldModule := p.module; - p.module := gNimDat; - InitLocExpr(p, e.sons[2], f); - p.module := oldModule; - - initLoc(b, locExpr, a.t, OnHeap); - ti := genTypeInfo(p.module, refType); - - appf(gNimDat.s[cfsTypeInit3], '$1->finalizer = (void*)$2;$n', [ - ti, rdLoc(f)]); - b.r := ropef('($1) newObj($2, sizeof($3))', - [getTypeDesc(p.module, refType), ti, - getTypeDesc(p.module, skipTypes(reftype.sons[0], abstractRange))]); - genAssignment(p, a, b, {@set}[]); - // set the object type: - bt := skipTypes(refType.sons[0], abstractRange); - genObjectInit(p, bt, a, false); -end; - -procedure genRepr(p: BProc; e: PNode; var d: TLoc); -var - a: TLoc; - t: PType; -begin - InitLocExpr(p, e.sons[1], a); - t := skipTypes(e.sons[1].typ, abstractVarRange); - case t.kind of - tyInt..tyInt64: begin - UseMagic(p.module, 'reprInt'); - putIntoDest(p, d, e.typ, ropef('reprInt($1)', [rdLoc(a)])) - end; - tyFloat..tyFloat128: begin - UseMagic(p.module, 'reprFloat'); - putIntoDest(p, d, e.typ, ropef('reprFloat($1)', [rdLoc(a)])) - end; - tyBool: begin - UseMagic(p.module, 'reprBool'); - putIntoDest(p, d, e.typ, ropef('reprBool($1)', [rdLoc(a)])) - end; - tyChar: begin - UseMagic(p.module, 'reprChar'); - putIntoDest(p, d, e.typ, ropef('reprChar($1)', [rdLoc(a)])) - end; - tyEnum, tyOrdinal: begin - UseMagic(p.module, 'reprEnum'); - putIntoDest(p, d, e.typ, - ropef('reprEnum($1, $2)', [rdLoc(a), genTypeInfo(p.module, t)])) - end; - tyString: begin - UseMagic(p.module, 'reprStr'); - putIntoDest(p, d, e.typ, ropef('reprStr($1)', [rdLoc(a)])) - end; - tySet: begin - useMagic(p.module, 'reprSet'); - putIntoDest(p, d, e.typ, ropef('reprSet($1, $2)', - [rdLoc(a), genTypeInfo(p.module, t)])) - end; - tyOpenArray: begin - useMagic(p.module, 'reprOpenArray'); - case a.t.kind of - tyOpenArray: - putIntoDest(p, d, e.typ, ropef('$1, $1Len0', [rdLoc(a)])); - tyString, tySequence: - 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))])); - else InternalError(e.sons[0].info, 'genRepr()') - end; - putIntoDest(p, d, e.typ, ropef('reprOpenArray($1, $2)', - [rdLoc(d), genTypeInfo(p.module, elemType(t))])) - end; - tyCString, tyArray, tyArrayConstr, - tyRef, tyPtr, tyPointer, tyNil, tySequence: begin - useMagic(p.module, 'reprAny'); - putIntoDest(p, d, e.typ, ropef('reprAny($1, $2)', - [rdLoc(a), genTypeInfo(p.module, t)])) - end - else begin - useMagic(p.module, 'reprAny'); - putIntoDest(p, d, e.typ, ropef('reprAny($1, $2)', - [addrLoc(a), genTypeInfo(p.module, t)])) - end - end; -end; - -procedure genDollar(p: BProc; n: PNode; var d: TLoc; const magic, frmt: string); -var - a: TLoc; -begin - InitLocExpr(p, n.sons[1], a); - UseMagic(p.module, magic); - 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); -var - typ: PType; -begin - typ := skipTypes(e.sons[1].Typ, abstractPtrs); - case typ.kind of - tyOpenArray: begin - while e.sons[1].kind = nkPassAsOpenArray do - e.sons[1] := e.sons[1].sons[0]; - if op = mHigh then - unaryExpr(p, e, d, '', '($1Len0-1)') - else - 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->Sup.len-1)') - else - unaryExpr(p, e, d, '', '$1->Sup.len'); - tyArray, tyArrayConstr: begin - // YYY: length(sideeffect) is optimized away incorrectly? - if op = mHigh then - putIntoDest(p, d, e.typ, toRope(lastOrd(Typ))) - else - putIntoDest(p, d, e.typ, toRope(lengthOrd(typ))) - end - else - InternalError(e.info, 'genArrayLen()') - end -end; - -procedure genSetLengthSeq(p: BProc; e: PNode; var d: TLoc); -var - a, b: TLoc; - t: PType; -begin - assert(d.k = locNone); - useMagic(p.module, 'setLengthSeq'); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - t := skipTypes(e.sons[1].typ, abstractVar); - appf(p.s[cpsStmts], - '$1 = ($3) setLengthSeq(&($1)->Sup, sizeof($4), $2);$n', - [rdLoc(a), rdLoc(b), getTypeDesc(p.module, t), - getTypeDesc(p.module, t.sons[0])]); -end; - -procedure genSetLengthStr(p: BProc; e: PNode; var d: TLoc); -begin - binaryStmt(p, e, d, 'setLengthStr', '$1 = setLengthStr($1, $2);$n') -end; - -procedure genSwap(p: BProc; e: PNode; var d: TLoc); - // swap(a, b) --> - // temp = a - // a = b - // b = temp -var - a, b, tmp: TLoc; -begin - getTemp(p, skipTypes(e.sons[1].typ, abstractVar), 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}[]); -end; - -// -------------------- set operations ------------------------------------ - -function rdSetElemLoc(const a: TLoc; setType: PType): PRope; -// read a location of an set element; it may need a substraction operation -// before the set operation -begin - result := rdCharLoc(a); - assert(setType.kind = tySet); - if (firstOrd(setType) <> 0) then - result := ropef('($1-$2)', [result, toRope(firstOrd(setType))]) -end; - -function fewCmps(s: PNode): bool; -// this function estimates whether it is better to emit code -// for constructing the set or generating a bunch of comparisons directly -begin - if s.kind <> nkCurly then InternalError(s.info, 'fewCmps'); - if (getSize(s.typ) <= platform.intSize) and (nfAllConst in s.flags) then - result := false // it is better to emit the set generation code - else if elemType(s.typ).Kind in [tyInt, tyInt16..tyInt64] then - result := true // better not emit the set if int is basetype! - else - result := sonsLen(s) <= 8 // 8 seems to be a good value -end; - -procedure binaryExprIn(p: BProc; e: PNode; var a, b, d: TLoc; - const frmt: string); -begin - putIntoDest(p, d, e.typ, ropef(frmt, [rdLoc(a), rdSetElemLoc(b, a.t)])); -end; - -procedure genInExprAux(p: BProc; e: PNode; var a, b, d: TLoc); -begin - case int(getSize(skipTypes(e.sons[1].typ, abstractVar))) of - 1: binaryExprIn(p, e, a, b, d, '(($1 &(1<<(($2)&7)))!=0)'); - 2: binaryExprIn(p, e, a, b, d, '(($1 &(1<<(($2)&15)))!=0)'); - 4: binaryExprIn(p, e, a, b, d, '(($1 &(1<<(($2)&31)))!=0)'); - 8: binaryExprIn(p, e, a, b, d, '(($1 &(IL64(1)<<(($2)&IL64(63))))!=0)'); - else binaryExprIn(p, e, a, b, d, '(($1[$2/8] &(1<<($2%8)))!=0)'); - end -end; - -procedure binaryStmtInExcl(p: BProc; e: PNode; var d: TLoc; const frmt: string); -var - a, b: TLoc; -begin - assert(d.k = locNone); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - appf(p.s[cpsStmts], frmt, [rdLoc(a), rdSetElemLoc(b, a.t)]); -end; - -procedure genInOp(p: BProc; e: PNode; var d: TLoc); -var - a, b, x, y: TLoc; - len, i: int; -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 - initLocExpr(p, e.sons[2], a); - initLoc(b, locExpr, e.typ, OnUnknown); - b.r := toRope('('+''); - len := sonsLen(e.sons[1]); - for i := 0 to len-1 do begin - if e.sons[1].sons[i].Kind = nkRange then begin - InitLocExpr(p, e.sons[1].sons[i].sons[0], x); - InitLocExpr(p, e.sons[1].sons[i].sons[1], y); - appf(b.r, '$1 >= $2 && $1 <= $3', - [rdCharLoc(a), rdCharLoc(x), rdCharLoc(y)]) - end - else begin - InitLocExpr(p, e.sons[1].sons[i], x); - appf(b.r, '$1 == $2', [rdCharLoc(a), rdCharLoc(x)]) - end; - if i < len - 1 then app(b.r, ' || ') - end; - app(b.r, ')'+''); - putIntoDest(p, d, e.typ, b.r); - end - else begin - assert(e.sons[1].typ <> nil); - assert(e.sons[2].typ <> nil); - InitLocExpr(p, e.sons[1], a); - InitLocExpr(p, e.sons[2], b); - genInExprAux(p, e, a, b, d); - end -end; - -procedure genSetOp(p: BProc; e: PNode; var d: TLoc; op: TMagic); -const - lookupOpr: array [mLeSet..mSymDiffSet] of string = ( - 'for ($1 = 0; $1 < $2; $1++) { $n' + - ' $3 = (($4[$1] & ~ $5[$1]) == 0);$n' + - ' if (!$3) break;}$n', - 'for ($1 = 0; $1 < $2; $1++) { $n' + - ' $3 = (($4[$1] & ~ $5[$1]) == 0);$n' + - ' if (!$3) break;}$n' + - 'if ($3) $3 = (memcmp($4, $5, $2) != 0);$n', - '&'+'', '|'+'', '& ~', '^'+''); -var - size: int; - setType: PType; - a, b, i: TLoc; - ts: string; -begin - setType := skipTypes(e.sons[1].Typ, abstractVar); - size := int(getSize(setType)); - case size of - 1, 2, 4, 8: begin - case op of - mIncl: begin - ts := 'NI' + toString(size*8); - binaryStmtInExcl(p, e, d, - '$1 |=(1<<((' +{&} ts +{&} ')($2)%(sizeof(' +{&} ts +{&} - ')*8)));$n'); - end; - mExcl: begin - ts := 'NI' + toString(size*8); - binaryStmtInExcl(p, e, d, - '$1 &= ~(1 << ((' +{&} ts +{&} ')($2) % (sizeof(' +{&} ts +{&} - ')*8)));$n'); - end; - mCard: begin - if size <= 4 then - unaryExprChar(p, e, d, 'countBits32', 'countBits32($1)') - else - unaryExprChar(p, e, d, 'countBits64', 'countBits64($1)'); - end; - mLtSet: binaryExprChar(p, e, d, '', '(($1 & ~ $2 ==0)&&($1 != $2))'); - mLeSet: binaryExprChar(p, e, d, '', '(($1 & ~ $2)==0)'); - mEqSet: binaryExpr(p, e, d, '', '($1 == $2)'); - mMulSet: binaryExpr(p, e, d, '', '($1 & $2)'); - mPlusSet: binaryExpr(p, e, d, '', '($1 | $2)'); - mMinusSet: binaryExpr(p, e, d, '', '($1 & ~ $2)'); - mSymDiffSet: binaryExpr(p, e, d, '', '($1 ^ $2)'); - mInSet: genInOp(p, e, d); - else internalError(e.info, 'genSetOp()') - end - end - else begin - case op of - mIncl: binaryStmtInExcl(p, e, d, '$1[$2/8] |=(1<<($2%8));$n'); - mExcl: binaryStmtInExcl(p, e, d, '$1[$2/8] &= ~(1<<($2%8));$n'); - mCard: unaryExprChar(p, e, d, 'cardSet', - 'cardSet($1, ' + ToString(size) + ')'); - mLtSet, mLeSet: begin - 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)]); - end; - mEqSet: - binaryExprChar(p, e, d, '', - '(memcmp($1, $2, ' + ToString(size) + ')==0)'); - mMulSet, mPlusSet, mMinusSet, mSymDiffSet: begin - // we inline the simple for loop for better code generation: - 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), - rdLoc(d), rdLoc(a), rdLoc(b), toRope(lookupOpr[op])]); - end; - mInSet: genInOp(p, e, d); - else internalError(e.info, 'genSetOp') - end - end - end -end; - -// --------------------- end of set operations ---------------------------- - -procedure genOrd(p: BProc; e: PNode; var d: TLoc); -begin - unaryExprChar(p, e, d, '', '$1'); -end; - -procedure genCast(p: BProc; e: PNode; var d: TLoc); -const - ValueTypes = {@set}[tyTuple, tyObject, tyArray, tyOpenArray, tyArrayConstr]; -// we use whatever C gives us. Except if we have a value-type, we -// need to go through its address: -var - a: TLoc; -begin - InitLocExpr(p, e.sons[1], a); - if (skipTypes(e.typ, abstractRange).kind in ValueTypes) - and not (lfIndirect in a.flags) then - putIntoDest(p, d, e.typ, ropef('(*($1*) ($2))', - [getTypeDesc(p.module, e.typ), addrLoc(a)])) - else - putIntoDest(p, d, e.typ, ropef('(($1) ($2))', - [getTypeDesc(p.module, e.typ), rdCharLoc(a)])); -end; - -procedure genRangeChck(p: BProc; n: PNode; var d: TLoc; const magic: string); -var - a: TLoc; - dest: PType; -begin - dest := skipTypes(n.typ, abstractVar); - if not (optRangeCheck in p.options) then begin - InitLocExpr(p, n.sons[0], a); - putIntoDest(p, d, n.typ, ropef('(($1) ($2))', - [getTypeDesc(p.module, dest), rdCharLoc(a)])); - end - else begin - InitLocExpr(p, n.sons[0], a); - useMagic(p.module, magic); - putIntoDest(p, d, dest, - ropef('(($1)$5($2, $3, $4))', - [getTypeDesc(p.module, dest), - rdCharLoc(a), genLiteral(p, n.sons[1], dest), - genLiteral(p, n.sons[2], dest), - toRope(magic)])); - end -end; - -procedure genConv(p: BProc; e: PNode; var d: TLoc); -begin - genCast(p, e, d) -end; - -procedure passToOpenArray(p: BProc; n: PNode; var d: TLoc); -var - a: TLoc; - dest: PType; -begin - while n.sons[0].kind = nkPassAsOpenArray do - n.sons[0] := n.sons[0].sons[0]; // BUGFIX - dest := skipTypes(n.typ, abstractVar); - case skipTypes(n.sons[0].typ, abstractVar).kind of - tyOpenArray: begin - initLocExpr(p, n.sons[0], a); - putIntoDest(p, d, dest, ropef('$1, $1Len0', [rdLoc(a)])); - end; - tyString, tySequence: begin - initLocExpr(p, n.sons[0], a); - putIntoDest(p, d, dest, ropef('$1->data, $1->Sup.len', [rdLoc(a)])); - end; - tyArray, tyArrayConstr: begin - initLocExpr(p, n.sons[0], a); - putIntoDest(p, d, dest, ropef('$1, $2', - [rdLoc(a), toRope(lengthOrd(a.t))])); - end - else InternalError(n.sons[0].info, 'passToOpenArray: ' + typeToString(a.t)) - end -end; - -procedure convStrToCStr(p: BProc; n: PNode; var d: TLoc); -var - a: TLoc; -begin - initLocExpr(p, n.sons[0], a); - putIntoDest(p, d, skipTypes(n.typ, abstractVar), - ropef('$1->data', [rdLoc(a)])); -end; - -procedure convCStrToStr(p: BProc; n: PNode; var d: TLoc); -var - a: TLoc; -begin - useMagic(p.module, 'cstrToNimstr'); - initLocExpr(p, n.sons[0], a); - putIntoDest(p, d, skipTypes(n.typ, abstractVar), - ropef('cstrToNimstr($1)', [rdLoc(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(skipTypes(t.typ, abstractInst)), 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(skipTypes(t.typ, abstractInst)), 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(skipTypes(t.sons[1].typ, abstractInst)), 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 - line, filen: PRope; -begin - case op of - mOr, mAnd: genAndOr(p, e, d, op); - mNot..mToBiggestInt: unaryArith(p, e, d, op); - mUnaryMinusI..mAbsI64: unaryArithOverflow(p, e, d, op); - mShrI..mXor: binaryArith(p, e, d, op); - mAddi..mModi64: binaryArithOverflow(p, e, d, op); - mRepr: genRepr(p, e, d); - mSwap: genSwap(p, e, d); - mPred: begin // XXX: range checking? - if not (optOverflowCheck in p.Options) then - binaryExpr(p, e, d, '', '$1 - $2') - else - binaryExpr(p, e, d, 'subInt', 'subInt($1, $2)') - end; - mSucc: begin // XXX: range checking? - if not (optOverflowCheck in p.Options) then - binaryExpr(p, e, d, '', '$1 + $2') - else - binaryExpr(p, e, d, 'addInt', 'addInt($1, $2)') - end; - mInc: begin - if not (optOverflowCheck in p.Options) then - binaryStmt(p, e, d, '', '$1 += $2;$n') - else if skipTypes(e.sons[1].typ, abstractVar).kind = tyInt64 then - binaryStmt(p, e, d, 'addInt64', '$1 = addInt64($1, $2);$n') - else - binaryStmt(p, e, d, 'addInt', '$1 = addInt($1, $2);$n') - end; - ast.mDec: begin - if not (optOverflowCheck in p.Options) then - binaryStmt(p, e, d, '', '$1 -= $2;$n') - else if skipTypes(e.sons[1].typ, abstractVar).kind = tyInt64 then - binaryStmt(p, e, d, 'subInt64', '$1 = subInt64($1, $2);$n') - else - binaryStmt(p, e, d, 'subInt', '$1 = subInt($1, $2);$n') - end; - mConStrStr: genStrConcat(p, e, d); - mAppendStrCh: binaryStmt(p, e, d, 'addChar', '$1 = addChar($1, $2);$n'); - mAppendStrStr: genStrAppend(p, e, d); - mAppendSeqElem: genSeqElemAppend(p, e, d); - 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'); - mIntToStr: genDollar(p, e, d, 'nimIntToStr', 'nimIntToStr($1)'); - mInt64ToStr: genDollar(p, e, d, 'nimInt64ToStr', 'nimInt64ToStr($1)'); - mBoolToStr: genDollar(p, e, d, 'nimBoolToStr', 'nimBoolToStr($1)'); - mCharToStr: genDollar(p, e, d, 'nimCharToStr', 'nimCharToStr($1)'); - mFloatToStr: genDollar(p, e, d, 'nimFloatToStr', 'nimFloatToStr($1)'); - mCStrToStr: genDollar(p, e, d, 'cstrToNimstr', 'cstrToNimstr($1)'); - mStrToStr: expr(p, e.sons[1], d); - mEnumToStr: genRepr(p, e, d); - mAssert: begin - if (optAssert in p.Options) then begin - useMagic(p.module, 'internalAssert'); - expr(p, e.sons[1], d); - line := toRope(toLinenumber(e.info)); - filen := makeCString(ToFilename(e.info)); - appf(p.s[cpsStmts], 'internalAssert($1, $2, $3);$n', - [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('((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: - genArrayLen(p, e, d, op); - 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); - mNewString, mCopyStr, mCopyStrLast, mExit: genCall(p, e, d); - mEcho: genEcho(p, e); - 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: -// memset(tmp, 0, sizeof(tmp)); inclRange(tmp, a, b); incl(tmp, c); -// incl(tmp, d); incl(tmp, e); inclRange(tmp, f, g); -var - a, b, idx: TLoc; - i: int; - ts: string; -begin - if nfAllConst in e.flags then - putIntoDest(p, d, e.typ, genSetNode(p, e)) - else begin - 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 - 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', - [rdLoc(idx), rdLoc(d), rdSetElemLoc(a, e.typ), - rdSetElemLoc(b, e.typ)]); - end - else begin - initLocExpr(p, e.sons[i], a); - appf(p.s[cpsStmts], '$1[$2/8] |=(1<<($2%8));$n', - [rdLoc(d), rdSetElemLoc(a, e.typ)]); - end - end - end - else begin // small set - ts := 'NI' + toString(getSize(e.typ)*8); - 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 - 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', - [rdLoc(idx), rdLoc(d), rdSetElemLoc(a, e.typ), - rdSetElemLoc(b, e.typ)]); - end - else begin - initLocExpr(p, e.sons[i], a); - appf(p.s[cpsStmts], - '$1 |=(1<<((' +{&} ts +{&} ')($2)%(sizeof(' +{&}ts+{&} - ')*8)));$n', - [rdLoc(d), rdSetElemLoc(a, e.typ)]); - end - end - end - end -end; - -procedure genTupleConstr(p: BProc; n: PNode; var d: TLoc); -var - i: int; - rec: TLoc; - it: PNode; - t: PType; -begin - 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); - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if it.kind = nkExprColonExpr then begin - 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 - else if t.n = nil then begin - initLoc(rec, locExpr, it.typ, d.s); - rec.r := ropef('$1.Field$2', [rdLoc(d), toRope(i)]); - expr(p, it, rec); - end - else begin - initLoc(rec, locExpr, it.typ, d.s); - if (t.n.sons[i].kind <> nkSym) then - InternalError(n.info, 'genTupleConstr: 2'); - rec.r := ropef('$1.$2', [rdLoc(d), mangleRecFieldName(t.n.sons[i].sym, t)]); - expr(p, it, rec); - end - end - end -end; - -procedure genArrayConstr(p: BProc; n: PNode; var d: TLoc); -var - arr: TLoc; - i: int; -begin - 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(skipTypes(n.typ, abstractInst)), d.s); - arr.r := ropef('$1[$2]', [rdLoc(d), intLiteral(i)]); - expr(p, n.sons[i], arr) - end - end -end; - -procedure genComplexConst(p: BProc; sym: PSym; var d: TLoc); -begin - genConstPrototype(p.module, sym); - assert((sym.loc.r <> nil) and (sym.loc.t <> nil)); - putLocIntoDest(p, d, sym.loc) -end; - -procedure genStmtListExpr(p: BProc; n: PNode; var d: TLoc); -var - len, i: int; -begin - len := sonsLen(n); - for i := 0 to len-2 do genStmts(p, n.sons[i]); - if len > 0 then expr(p, n.sons[len-1], d); -end; - -procedure upConv(p: BProc; n: PNode; var d: TLoc); -var - a: TLoc; - dest, t: PType; - r, nilCheck: PRope; -begin - initLocExpr(p, n.sons[0], a); - dest := skipTypes(n.typ, abstractPtrs); - if (optObjCheck in p.options) and not (isPureObject(dest)) then begin - useMagic(p.module, 'chckObj'); - r := rdLoc(a); - nilCheck := nil; - t := skipTypes(a.t, abstractInst); - while t.kind in [tyVar, tyPtr, tyRef] do begin - if t.kind <> tyVar then nilCheck := r; - r := ropef('(*$1)', [r]); - t := skipTypes(t.sons[0], abstractInst) - end; - if gCmd <> cmdCompileToCpp then - while (t.kind = tyObject) and (t.sons[0] <> nil) do begin - app(r, '.Sup'); - t := skipTypes(t.sons[0], abstractInst); - end; - if nilCheck <> nil then - appf(p.s[cpsStmts], 'if ($1) chckObj($2.m_type, $3);$n', - [nilCheck, r, genTypeInfo(p.module, dest)]) - else - appf(p.s[cpsStmts], 'chckObj($1.m_type, $2);$n', - [r, genTypeInfo(p.module, dest)]); - end; - if n.sons[0].typ.kind <> tyObject then - putIntoDest(p, d, n.typ, ropef('(($1) ($2))', - [getTypeDesc(p.module, n.typ), rdLoc(a)])) - else - putIntoDest(p, d, n.typ, ropef('(*($1*) ($2))', - [getTypeDesc(p.module, dest), addrLoc(a)])); -end; - -procedure downConv(p: BProc; n: PNode; var d: TLoc); -var - a: TLoc; - dest, src: PType; - i: int; - r: PRope; -begin - if gCmd = cmdCompileToCpp then - expr(p, n.sons[0], d) // downcast does C++ for us - else begin - dest := skipTypes(n.typ, abstractPtrs); - src := skipTypes(n.sons[0].typ, abstractPtrs); - initLocExpr(p, n.sons[0], a); - r := rdLoc(a); - if skipTypes(n.sons[0].typ, abstractInst).kind in [tyRef, tyPtr, tyVar] - then begin - app(r, '->Sup'); - for i := 2 to abs(inheritanceDiff(dest, src)) do app(r, '.Sup'); - r := con('&'+'', r); - end - else - for i := 1 to abs(inheritanceDiff(dest, src)) do app(r, '.Sup'); - putIntoDest(p, d, n.typ, r); - end -end; - -procedure genBlock(p: BProc; t: PNode; var d: TLoc); forward; - -procedure expr(p: BProc; e: PNode; var d: TLoc); -var - sym: PSym; - ty: PType; -begin - case e.kind of - nkSym: begin - sym := e.sym; - case sym.Kind of - skMethod: begin - if sym.ast.sons[codePos] = nil then begin - // we cannot produce code for the dispatcher yet: - fillProcLoc(sym); - genProcPrototype(p.module, sym); - end - else - genProc(p.module, sym); - putLocIntoDest(p, d, sym.loc); - end; - skProc, skConverter: begin - genProc(p.module, sym); - if ((sym.loc.r = nil) or (sym.loc.t = nil)) then - InternalError(e.info, 'expr: proc not init ' + sym.name.s); - putLocIntoDest(p, d, sym.loc); - end; - skConst: - if isSimpleConst(sym.typ) then - putIntoDest(p, d, e.typ, genLiteral(p, sym.ast, sym.typ)) - else - genComplexConst(p, sym, d); - skEnumField: putIntoDest(p, d, e.typ, toRope(sym.position)); - skVar: begin - if (sfGlobal in sym.flags) then genVarPrototype(p.module, sym); - if ((sym.loc.r = nil) or (sym.loc.t = nil)) then - InternalError(e.info, 'expr: var not init ' + sym.name.s); - putLocIntoDest(p, d, sym.loc); - end; - skForVar, skTemp: begin - if ((sym.loc.r = nil) or (sym.loc.t = nil)) then - InternalError(e.info, 'expr: temp not init ' + sym.name.s); - putLocIntoDest(p, d, sym.loc) - end; - skParam: begin - if ((sym.loc.r = nil) or (sym.loc.t = nil)) then - InternalError(e.info, 'expr: param not init ' + sym.name.s); - putLocIntoDest(p, d, sym.loc) - end - else - InternalError(e.info, 'expr(' +{&} symKindToStr[sym.kind] +{&} - '); unknown symbol') - end - end; - //nkQualified: expr(p, e.sons[1], d); - nkStrLit..nkTripleStrLit, nkIntLit..nkInt64Lit, - nkFloatLit..nkFloat64Lit, nkNilLit, nkCharLit: begin - putIntoDest(p, d, e.typ, genLiteral(p, e)); - end; - nkCall, nkHiddenCallConv, nkInfix, nkPrefix, nkPostfix, nkCommand, - nkCallStrLit: begin - if (e.sons[0].kind = nkSym) and - (e.sons[0].sym.magic <> mNone) then - genMagicExpr(p, e, d, e.sons[0].sym.magic) - else - genCall(p, e, d) - end; - nkCurly: genSetConstr(p, e, d); - nkBracket: - if (skipTypes(e.typ, abstractVarRange).kind = tySequence) then - genSeqConstr(p, e, d) - else - genArrayConstr(p, e, d); - nkPar: - genTupleConstr(p, e, d); - nkCast: genCast(p, e, d); - nkHiddenStdConv, nkHiddenSubConv, nkConv: genConv(p, e, d); - nkHiddenAddr, nkAddr: genAddr(p, e, d); - nkBracketExpr: begin - ty := skipTypes(e.sons[0].typ, abstractVarRange); - if ty.kind in [tyRef, tyPtr] then - ty := skipTypes(ty.sons[0], abstractVarRange); - case ty.kind of - tyArray, tyArrayConstr: genArrayElem(p, e, d); - tyOpenArray: genOpenArrayElem(p, e, d); - tySequence, tyString: genSeqElem(p, e, d); - tyCString: genCStringElem(p, e, d); - tyTuple: genTupleElem(p, e, d); - else InternalError(e.info, - 'expr(nkBracketExpr, ' + typeKindToStr[ty.kind] + ')'); - end - end; - nkDerefExpr, nkHiddenDeref: genDeref(p, e, d); - nkDotExpr: genRecordField(p, e, d); - nkCheckedFieldExpr: genCheckedRecordField(p, e, d); - nkBlockExpr: genBlock(p, e, d); - nkStmtListExpr: genStmtListExpr(p, e, d); - nkIfExpr: genIfExpr(p, e, d); - nkObjDownConv: downConv(p, e, d); - nkObjUpConv: upConv(p, e, d); - nkChckRangeF: genRangeChck(p, e, d, 'chckRangeF'); - nkChckRange64: genRangeChck(p, e, d, 'chckRange64'); - nkChckRange: genRangeChck(p, e, d, 'chckRange'); - nkStringToCString: convStrToCStr(p, e, d); - nkCStringToString: convCStrToStr(p, e, d); - nkPassAsOpenArray: passToOpenArray(p, e, d); - else - InternalError(e.info, 'expr(' +{&} nodeKindToStr[e.kind] +{&} - '); unknown node kind') - end -end; - -// ---------------------- generation of complex constants --------------------- - -function genNamedConstExpr(p: BProc; n: PNode): PRope; -begin - if n.kind = nkExprColonExpr then - result := genConstExpr(p, n.sons[1]) - else - result := genConstExpr(p, n); -end; - -function genConstSimpleList(p: BProc; n: PNode): PRope; -var - len, i: int; -begin - len := sonsLen(n); - result := toRope('{'+''); - for i := 0 to len - 2 do - appf(result, '$1,$n', [genNamedConstExpr(p, n.sons[i])]); - if len > 0 then app(result, genNamedConstExpr(p, n.sons[len-1])); - app(result, '}' + tnl) -end; - -function genConstExpr(p: BProc; n: PNode): PRope; -var - cs: TBitSet; - d: TLoc; -begin - case n.Kind of - nkHiddenStdConv, nkHiddenSubConv: result := genConstExpr(p, n.sons[1]); - nkCurly: begin - toBitSet(n, cs); - result := genRawSetData(cs, int(getSize(n.typ))) - end; - nkBracket, nkPar: begin - // XXX: tySequence! - result := genConstSimpleList(p, n); - end - else begin - // result := genLiteral(p, n) - initLocExpr(p, n, d); - result := rdLoc(d) - end - end -end; diff --git a/nim/ccgstmts.pas b/nim/ccgstmts.pas deleted file mode 100755 index d31f0e5bd..000000000 --- a/nim/ccgstmts.pas +++ /dev/null @@ -1,989 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -const - RangeExpandLimit = 256; // do not generate ranges - // over 'RangeExpandLimit' elements - -procedure genLineDir(p: BProc; t: PNode); -var - line: int; -begin - line := toLinenumber(t.info); // BUGFIX - if line < 0 then line := 0; // negative numbers are not allowed in #line - if optLineDir in p.Options then - appff(p.s[cpsStmts], - '#line $2 "$1"$n', - '; line $2 "$1"$n', - [toRope(toFilename(t.info)), toRope(line)]); - if ([optStackTrace, optEndb] * p.Options = [optStackTrace, optEndb]) and - ((p.prc = nil) or not (sfPure in p.prc.flags)) then begin - useMagic(p.module, 'endb'); // new: endb support - appff(p.s[cpsStmts], 'endb($1);$n', - 'call void @endb(%NI $1)$n', - [toRope(line)]) - end - else if ([optLineTrace, optStackTrace] * p.Options = - [optLineTrace, optStackTrace]) and ((p.prc = nil) or - not (sfPure in p.prc.flags)) then begin - inc(p.labels); - appff(p.s[cpsStmts], 'F.line = $1;$n', - '%LOC$2 = getelementptr %TF %F, %NI 2$n' + - 'store %NI $1, %NI* %LOC$2$n', - [toRope(line), toRope(p.labels)]) - end -end; - -procedure finishTryStmt(p: BProc; howMany: int); -var - i: int; -begin - for i := 1 to howMany do begin - inc(p.labels, 3); - appff(p.s[cpsStmts], 'excHandler = excHandler->prev;$n', - '%LOC$1 = load %TSafePoint** @excHandler$n' + - '%LOC$2 = getelementptr %TSafePoint* %LOC$1, %NI 0$n' + - '%LOC$3 = load %TSafePoint** %LOC$2$n' + - 'store %TSafePoint* %LOC$3, %TSafePoint** @excHandler$n', - [toRope(p.labels), toRope(p.labels-1), toRope(p.labels-2)]); - end -end; - -procedure genReturnStmt(p: BProc; t: PNode); -begin - p.beforeRetNeeded := true; - genLineDir(p, t); - if (t.sons[0] <> nil) then genStmts(p, t.sons[0]); - finishTryStmt(p, p.nestedTryStmts); - appff(p.s[cpsStmts], 'goto BeforeRet;$n', 'br label %BeforeRet$n', []) -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 (skipTypes(v.typ, abstractVarRange).Kind in [tyArray, - tyArrayConstr, tySet, tyTuple, tyObject]) then begin - if gCmd = cmdCompileToLLVM then - appf(p.s[cpsStmts], 'store $2 0, $2* $1$n', - [addrLoc(v.loc), getTypeDesc(p.module, v.loc.t)]) - else - appf(p.s[cpsStmts], '$1 = 0;$n', [rdLoc(v.loc)]) - end - else begin - if gCmd = cmdCompileToLLVM then begin - app(p.module.s[cfsProcHeaders], - 'declare void @llvm.memset.i32(i8*, i8, i32, i32)' + tnl); - inc(p.labels, 2); - appf(p.s[cpsStmts], - '%LOC$3 = getelementptr $2* null, %NI 1$n' + - '%LOC$4 = cast $2* %LOC$3 to i32$n' + - 'call void @llvm.memset.i32(i8* $1, i8 0, i32 %LOC$4, i32 0)$n', - [addrLoc(v.loc), getTypeDesc(p.module, v.loc.t), - toRope(p.labels), toRope(p.labels-1)]) - end - else - appf(p.s[cpsStmts], 'memset((void*)$1, 0, sizeof($2));$n', - [addrLoc(v.loc), rdLoc(v.loc)]) - end -end; - -procedure genVarTuple(p: BProc; n: PNode); -var - i, L: int; - v: PSym; - tup, field: TLoc; - t: PType; -begin - if n.kind <> nkVarTuple then InternalError(n.info, 'genVarTuple'); - L := sonsLen(n); - genLineDir(p, n); - initLocExpr(p, n.sons[L-1], tup); - t := tup.t; - for i := 0 to L-3 do begin - v := n.sons[i].sym; - if sfGlobal in v.flags then - assignGlobalVar(p, v) - else begin - assignLocalVar(p, v); - initVariable(p, v) - end; - // generate assignment: - initLoc(field, locExpr, t.sons[i], tup.s); - if t.n = nil then begin - field.r := ropef('$1.Field$2', [rdLoc(tup), toRope(i)]); - end - else begin - if (t.n.sons[i].kind <> nkSym) then - InternalError(n.info, 'genVarTuple'); - field.r := ropef('$1.$2', [rdLoc(tup), - mangleRecFieldName(t.n.sons[i].sym, t)]); - end; - putLocIntoDest(p, v.loc, field); - genObjectInit(p, v.typ, v.loc, true); - end -end; - -procedure genVarStmt(p: BProc; n: 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; - if a.kind = nkIdentDefs then begin - assert(a.sons[0].kind = nkSym); - v := a.sons[0].sym; - if sfGlobal in v.flags then - assignGlobalVar(p, v) - else begin - assignLocalVar(p, v); - initVariable(p, v) // XXX: this is not required if a.sons[2] != nil, - // unless it is a GC'ed pointer - end; - // generate assignment: - if a.sons[2] <> nil then begin - genLineDir(p, a); - expr(p, a.sons[2], v.loc); - end; - genObjectInit(p, v.typ, v.loc, true); // correct position - end - else - genVarTuple(p, a); - end -end; - -procedure genConstStmt(p: BProc; t: PNode); -var - c: PSym; - i: int; -begin - for i := 0 to sonsLen(t)-1 do begin - if t.sons[i].kind = nkCommentStmt then continue; - if t.sons[i].kind <> nkConstDef then InternalError(t.info, 'genConstStmt'); - c := t.sons[i].sons[0].sym; - // This can happen for forward consts: - if (c.ast <> nil) and (c.typ.kind in ConstantDataTypes) and - not (lfNoDecl in c.loc.flags) then begin - // generate the data: - fillLoc(c.loc, locData, c.typ, mangleName(c), OnUnknown); - if sfImportc in c.flags then - appf(p.module.s[cfsData], 'extern NIM_CONST $1 $2;$n', - [getTypeDesc(p.module, c.typ), c.loc.r]) - else - appf(p.module.s[cfsData], 'NIM_CONST $1 $2 = $3;$n', - [getTypeDesc(p.module, c.typ), c.loc.r, - genConstExpr(p, c.ast)]) - end - end -end; - -procedure genIfStmt(p: BProc; n: PNode); -(* - if (!expr1) goto L1; - thenPart - goto LEnd - L1: - if (!expr2) goto L2; - thenPart2 - goto LEnd - L2: - elsePart - Lend: -*) -var - i: int; - it: PNode; - a: TLoc; - Lend, Lelse: TLabel; -begin - genLineDir(p, n); - Lend := getLabel(p); - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - case it.kind of - nkElifBranch: begin - initLocExpr(p, it.sons[0], a); - Lelse := getLabel(p); - inc(p.labels); - appff(p.s[cpsStmts], 'if (!$1) goto $2;$n', - 'br i1 $1, label %LOC$3, label %$2$n' + - 'LOC$3: $n', - [rdLoc(a), Lelse, toRope(p.labels)]); - genStmts(p, it.sons[1]); - if sonsLen(n) > 1 then - appff(p.s[cpsStmts], 'goto $1;$n', 'br label %$1$n', [Lend]); - fixLabel(p, Lelse); - end; - nkElse: begin - genStmts(p, it.sons[0]); - end; - else internalError(n.info, 'genIfStmt()'); - end - end; - if sonsLen(n) > 1 then - fixLabel(p, Lend); -end; - -procedure genWhileStmt(p: BProc; t: PNode); -// we don't generate labels here as for example GCC would produce -// significantly worse code -var - a: TLoc; - Labl: TLabel; - len: int; -begin - genLineDir(p, t); - assert(sonsLen(t) = 2); - inc(p.labels); - Labl := con('LA', toRope(p.labels)); - len := length(p.blocks); - setLength(p.blocks, len+1); - 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); - 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; - genStmts(p, t.sons[1]); - 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; - -procedure genBlock(p: BProc; t: PNode; var d: TLoc); -var - idx: int; - sym: PSym; -begin - inc(p.labels); - idx := length(p.blocks); - if t.sons[0] <> nil then begin // named block? - assert(t.sons[0].kind = nkSym); - sym := t.sons[0].sym; - sym.loc.k := locOther; - sym.loc.a := idx - end; - setLength(p.blocks, idx+1); - p.blocks[idx].id := -p.labels; // negative because it isn't used yet - p.blocks[idx].nestedTryStmts := p.nestedTryStmts; - 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], 'LA$1: ;$n', [toRope(p.blocks[idx].id)]); - setLength(p.blocks, idx) -end; - -// try: -// while: -// try: -// if ...: -// break # we need to finish only one try statement here! -// finally: - -procedure genBreakStmt(p: BProc; t: PNode); -var - idx: int; - sym: PSym; -begin - genLineDir(p, t); - idx := length(p.blocks)-1; - if t.sons[0] <> nil then begin // named break? - assert(t.sons[0].kind = nkSym); - sym := t.sons[0].sym; - assert(sym.loc.k = locOther); - idx := sym.loc.a - 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 LA$1;$n', [toRope(p.blocks[idx].id)]) -end; - -procedure genAsmStmt(p: BProc; t: PNode); -var - i: int; - sym: PSym; - r, s: PRope; - a: TLoc; -begin - genLineDir(p, t); - assert(t.kind = nkAsmStmt); - s := nil; - for i := 0 to sonsLen(t) - 1 do begin - case t.sons[i].Kind of - nkStrLit..nkTripleStrLit: app(s, t.sons[i].strVal); - nkSym: begin - sym := t.sons[i].sym; - if sym.kind in [skProc, skMethod] then begin - initLocExpr(p, t.sons[i], a); - app(s, rdLoc(a)); - end - else begin - r := sym.loc.r; - if r = nil then begin // if no name has already been given, - // it doesn't matter much: - r := mangleName(sym); - sym.loc.r := r; // but be consequent! - end; - app(s, r) - end - end - else - InternalError(t.sons[i].info, 'genAsmStmt()') - end - end; - appf(p.s[cpsStmts], CC[ccompiler].asmStmtFrmt, [s]); -end; - -function getRaiseFrmt(p: BProc): string; -begin - if gCmd = cmdCompileToCpp then - result := 'throw nimException($1, $2);$n' - else begin - useMagic(p.module, 'E_Base'); - result := 'raiseException((E_Base*)$1, $2);$n' - end -end; - -procedure genRaiseStmt(p: BProc; t: PNode); -var - e: PRope; - a: TLoc; - typ: PType; -begin - genLineDir(p, t); - if t.sons[0] <> nil then begin - if gCmd <> cmdCompileToCpp then useMagic(p.module, 'raiseException'); - InitLocExpr(p, t.sons[0], a); - e := rdLoc(a); - typ := t.sons[0].typ; - while typ.kind in [tyVar, tyRef, tyPtr] do typ := typ.sons[0]; - appf(p.s[cpsStmts], getRaiseFrmt(p), - [e, makeCString(typ.sym.name.s)]) - end - else begin - // reraise the last exception: - if gCmd = cmdCompileToCpp then - app(p.s[cpsStmts], 'throw;' + tnl) - else begin - useMagic(p.module, 'reraiseException'); - app(p.s[cpsStmts], 'reraiseException();' + tnl) - end - end -end; - -// ---------------- case statement generation ----------------------------- - -const - stringCaseThreshold = 100000; - // above X strings a hash-switch for strings is generated - // this version sets it too high to avoid hashing, because this has not - // been tested for a long time - // XXX test and enable this optimization! - -procedure genCaseGenericBranch(p: BProc; b: PNode; const e: TLoc; - const rangeFormat, eqFormat: TFormatStr; - labl: TLabel); -var - len, i: int; - x, y: TLoc; -begin - len := sonsLen(b); - for i := 0 to len - 2 do begin - if b.sons[i].kind = nkRange then begin - initLocExpr(p, b.sons[i].sons[0], x); - initLocExpr(p, b.sons[i].sons[1], y); - appf(p.s[cpsStmts], rangeFormat, - [rdCharLoc(e), rdCharLoc(x), rdCharLoc(y), labl]) - end - else begin - initLocExpr(p, b.sons[i], x); - appf(p.s[cpsStmts], eqFormat, - [rdCharLoc(e), rdCharLoc(x), labl]) - end - end -end; - -procedure genCaseSecondPass(p: BProc; t: PNode; labId: int); -var - Lend: TLabel; - i, len: int; -begin - Lend := getLabel(p); - for i := 1 to sonsLen(t) - 1 do begin - 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]); - appf(p.s[cpsStmts], 'goto $1;$n', [Lend]) - end - else // else statement - genStmts(p, t.sons[i].sons[0]) - end; - fixLabel(p, Lend); -end; - -procedure genCaseGeneric(p: BProc; t: PNode; const rangeFormat, - eqFormat: TFormatStr); - // generate a C-if statement for a Nimrod case statement -var - a: TLoc; - i, labId: int; -begin - 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('LA', toRope(p.labels))) - else - // else statement - appf(p.s[cpsStmts], 'goto LA$1;$n', [toRope(p.labels)]); - end; - // second pass: generate statements - genCaseSecondPass(p, t, labId); -end; - -{@ignore} -{$ifopt Q+} { we need Q- here! } - {$define Q_on} - {$Q-} -{$endif} - -{$ifopt R+} - {$define R_on} - {$R-} -{$endif} -{@emit} -function hashString(const s: string): biggestInt; -var - a: int32; - b: int64; - i: int; -begin - if CPU[targetCPU].bit = 64 then begin // we have to use the same bitwidth - // as the target CPU - b := 0; - for i := 0 to Length(s)-1 do begin - b := b +{%} Ord(s[i]); - b := b +{%} shlu(b, 10); - b := b xor shru(b, 6) - end; - b := b +{%} shlu(b, 3); - b := b xor shru(b, 11); - b := b +{%} shlu(b, 15); - result := b - end - else begin - a := 0; - for i := 0 to Length(s)-1 do begin - a := a +{%} int32(Ord(s[i])); - a := a +{%} shlu(a, int32(10)); - a := a xor shru(a, int32(6)); - end; - a := a +{%} shlu(a, int32(3)); - a := a xor shru(a, int32(11)); - a := a +{%} shlu(a, int32(15)); - result := a - end -end; -{@ignore} -{$ifdef Q_on} - {$undef Q_on} - {$Q+} -{$endif} - -{$ifdef R_on} - {$undef R_on} - {$R+} -{$endif} -{@emit} - -type - TRopeSeq = array of PRope; - -procedure genCaseStringBranch(p: BProc; b: PNode; const e: TLoc; - labl: TLabel; var branches: TRopeSeq); -var - len, i, j: int; - x: TLoc; -begin - len := sonsLen(b); - for i := 0 to len - 2 do begin - assert(b.sons[i].kind <> nkRange); - initLocExpr(p, b.sons[i], x); - assert(b.sons[i].kind in [nkStrLit..nkTripleStrLit]); - j := int(hashString(b.sons[i].strVal) and high(branches)); - appf(branches[j], 'if (eqStrings($1, $2)) goto $3;$n', - [rdLoc(e), rdLoc(x), labl]) - end -end; - -procedure genStringCase(p: BProc; t: PNode); -var - strings, i, j, bitMask, labId: int; - a: TLoc; - branches: TRopeSeq; -begin - useMagic(p.module, 'eqStrings'); - // count how many constant strings there are in the case: - strings := 0; - for i := 1 to sonsLen(t)-1 do - if t.sons[i].kind = nkOfBranch then inc(strings, sonsLen(t.sons[i])-1); - if strings > stringCaseThreshold then begin - useMagic(p.module, 'hashString'); - bitMask := nmath.nextPowerOfTwo(strings)-1; - {@ignore} - setLength(branches, bitMask+1); - {@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('LA', toRope(p.labels)), - branches) - else begin - // else statement: nothing to do yet - // but we reserved a label, which we use later - end - end; - // second pass: generate switch statement based on hash of string: - appf(p.s[cpsStmts], 'switch (hashString($1) & $2) {$n', - [rdLoc(a), toRope(bitMask)]); - for j := 0 to high(branches) do - if branches[j] <> nil then - appf(p.s[cpsStmts], 'case $1: $n$2break;$n', - [intLiteral(j), branches[j]]); - app(p.s[cpsStmts], '}' + tnl); - // else statement: - if t.sons[sonsLen(t)-1].kind <> nkOfBranch then - appf(p.s[cpsStmts], 'goto LA$1;$n', [toRope(p.labels)]); - // third pass: generate statements - genCaseSecondPass(p, t, labId); - end - else - genCaseGeneric(p, t, '', 'if (eqStrings($1, $2)) goto $3;$n') -end; - -function branchHasTooBigRange(b: PNode): bool; -var - i: int; -begin - for i := 0 to sonsLen(b)-2 do begin // last son is block - if (b.sons[i].Kind = nkRange) and - (b.sons[i].sons[1].intVal - b.sons[i].sons[0].intVal > - RangeExpandLimit) then begin - result := true; exit - end; - end; - result := false -end; - -procedure genOrdinalCase(p: BProc; t: PNode); -// We analyse if we have a too big switch range. If this is the case, -// we generate an ordinary if statement and rely on the C compiler -// to produce good code. -var - canGenerateSwitch, hasDefault: bool; - i, j, len: int; - a: TLoc; - v: PNode; -begin - canGenerateSwitch := true; - if not (hasSwitchRange in CC[ccompiler].props) then - // if the C compiler supports switch ranges, no analysis is necessary - for i := 1 to sonsLen(t)-1 do - if (t.sons[i].kind = nkOfBranch) and branchHasTooBigRange(t.sons[i]) then - begin - canGenerateSwitch := false; - break - end; - if canGenerateSwitch then begin - initLocExpr(p, t.sons[0], a); - appf(p.s[cpsStmts], 'switch ($1) {$n', [rdCharLoc(a)]); - hasDefault := false; - for i := 1 to sonsLen(t)-1 do begin - if t.sons[i].kind = nkOfBranch then begin - len := sonsLen(t.sons[i]); - for j := 0 to len-2 do begin - if t.sons[i].sons[j].kind = nkRange then begin // a range - if hasSwitchRange in CC[ccompiler].props then - appf(p.s[cpsStmts], 'case $1 ... $2:$n', - [genLiteral(p, t.sons[i].sons[j].sons[0]), - genLiteral(p, t.sons[i].sons[j].sons[1])]) - else begin - v := copyNode(t.sons[i].sons[j].sons[0]); - while (v.intVal <= t.sons[i].sons[j].sons[1].intVal) do begin - appf(p.s[cpsStmts], 'case $1:$n', [genLiteral(p, v)]); - Inc(v.intVal) - end - end; - end - else - appf(p.s[cpsStmts], 'case $1:$n', - [genLiteral(p, t.sons[i].sons[j])]); - end; - genStmts(p, t.sons[i].sons[len-1]) - end - else begin // else part of case statement: - app(p.s[cpsStmts], 'default:' + tnl); - genStmts(p, t.sons[i].sons[0]); - hasDefault := true; - end; - app(p.s[cpsStmts], 'break;' + tnl); - end; - if (hasAssume in CC[ccompiler].props) and not hasDefault then - app(p.s[cpsStmts], 'default: __assume(0);' + tnl); - app(p.s[cpsStmts], '}' + tnl); - end - else - genCaseGeneric(p, t, - 'if ($1 >= $2 && $1 <= $3) goto $4;$n', - 'if ($1 == $2) goto $3;$n') -end; - -procedure genCaseStmt(p: BProc; t: PNode); -begin - genLineDir(p, t); - case skipTypes(t.sons[0].typ, abstractVarRange).kind of - tyString: genStringCase(p, t); - tyFloat..tyFloat128: - genCaseGeneric(p, t, 'if ($1 >= $2 && $1 <= $3) goto $4;$n', - 'if ($1 == $2) goto $3;$n'); - // ordinal type: generate a switch statement - else genOrdinalCase(p, t) - end -end; - -// ----------------------- end of case statement generation --------------- - -function hasGeneralExceptSection(t: PNode): bool; -var - len, i, blen: int; -begin - len := sonsLen(t); - i := 1; - while (i < len) and (t.sons[i].kind = nkExceptBranch) do begin - blen := sonsLen(t.sons[i]); - if blen = 1 then begin result := true; exit end; - inc(i) - end; - result := false -end; - -procedure genTryStmtCpp(p: BProc; t: PNode); - // code to generate: -(* - bool tmpRethrow = false; - try - { - myDiv(4, 9); - } catch (NimException& tmp) { - tmpRethrow = true; - switch (tmp.exc) - { - case DIVIDE_BY_ZERO: - tmpRethrow = false; - printf('Division by Zero\n'); - break; - default: // used for general except! - generalExceptPart(); - tmpRethrow = false; - } - } - excHandler = excHandler->prev; // we handled the exception - finallyPart(); - if (tmpRethrow) throw; *) -var - rethrowFlag: PRope; - exc: PRope; - i, len, blen, j: int; -begin - genLineDir(p, t); - rethrowFlag := nil; - exc := getTempName(); - if not hasGeneralExceptSection(t) then begin - rethrowFlag := getTempName(); - appf(p.s[cpsLocals], 'volatile NIM_BOOL $1 = NIM_FALSE;$n', - [rethrowFlag]) - end; - if optStackTrace in p.Options then - app(p.s[cpsStmts], 'framePtr = (TFrame*)&F;' + tnl); - app(p.s[cpsStmts], 'try {' + tnl); - inc(p.nestedTryStmts); - genStmts(p, t.sons[0]); - len := sonsLen(t); - if t.sons[1].kind = nkExceptBranch then begin - appf(p.s[cpsStmts], '} catch (NimException& $1) {$n', [exc]); - if rethrowFlag <> nil then - appf(p.s[cpsStmts], '$1 = NIM_TRUE;$n', [rethrowFlag]); - appf(p.s[cpsStmts], 'if ($1.sp.exc) {$n', [exc]) - end; // XXX: this is not correct! - i := 1; - while (i < len) and (t.sons[i].kind = nkExceptBranch) do begin - blen := sonsLen(t.sons[i]); - if blen = 1 then begin // general except section: - app(p.s[cpsStmts], 'default: ' + tnl); - genStmts(p, t.sons[i].sons[0]) - end - else begin - for j := 0 to blen - 2 do begin - assert(t.sons[i].sons[j].kind = nkType); - appf(p.s[cpsStmts], 'case $1:$n', - [toRope(t.sons[i].sons[j].typ.id)]) - end; - genStmts(p, t.sons[i].sons[blen - 1]) - end; - // code to clear the exception: - if rethrowFlag <> nil then - appf(p.s[cpsStmts], '$1 = NIM_FALSE; ', [rethrowFlag]); - app(p.s[cpsStmts], 'break;' + tnl); - inc(i); - end; - if t.sons[1].kind = nkExceptBranch then // BUGFIX - app(p.s[cpsStmts], '}}' + tnl); // end of catch-switch statement - dec(p.nestedTryStmts); - app(p.s[cpsStmts], 'excHandler = excHandler->prev;' + tnl); - if (i < len) and (t.sons[i].kind = nkFinally) then begin - genStmts(p, t.sons[i].sons[0]); - if rethrowFlag <> nil then - appf(p.s[cpsStmts], 'if ($1) { throw; }$n', [rethrowFlag]) - end -end; - -procedure genTryStmt(p: BProc; t: PNode); - // code to generate: -(* - sp.prev = excHandler; - excHandler = &sp; - sp.status = setjmp(sp.context); - if (sp.status == 0) { - myDiv(4, 9); - } else { - /* except DivisionByZero: */ - if (sp.status == DivisionByZero) { - printf('Division by Zero\n'); - - /* longjmp(excHandler->context, RangeError); /* raise rangeError */ - sp.status = RangeError; /* if raise; else 0 */ - } - } - /* finally: */ - printf('fin!\n'); - if (sp.status != 0) - longjmp(excHandler->context, sp.status); - excHandler = excHandler->prev; /* deactivate this safe point */ *) -var - i, j, len, blen: int; - safePoint, orExpr: PRope; -begin - genLineDir(p, t); - - safePoint := getTempName(); - useMagic(p.module, 'TSafePoint'); - useMagic(p.module, 'E_Base'); - useMagic(p.module, 'excHandler'); - appf(p.s[cpsLocals], 'TSafePoint $1;$n', [safePoint]); - appf(p.s[cpsStmts], '$1.prev = excHandler;$n' + - 'excHandler = &$1;$n' + - '$1.status = setjmp($1.context);$n', - [safePoint]); - if optStackTrace in p.Options then - app(p.s[cpsStmts], 'framePtr = (TFrame*)&F;' + tnl); - appf(p.s[cpsStmts], 'if ($1.status == 0) {$n', [safePoint]); - len := sonsLen(t); - inc(p.nestedTryStmts); - genStmts(p, t.sons[0]); - app(p.s[cpsStmts], '} else {' + tnl); - i := 1; - while (i < len) and (t.sons[i].kind = nkExceptBranch) do begin - blen := sonsLen(t.sons[i]); - if blen = 1 then begin - // general except section: - if i > 1 then app(p.s[cpsStmts], 'else {' + tnl); - genStmts(p, t.sons[i].sons[0]); - appf(p.s[cpsStmts], '$1.status = 0;$n', [safePoint]); - if i > 1 then app(p.s[cpsStmts], '}' + tnl); - end - else begin - orExpr := nil; - for j := 0 to blen - 2 do begin - assert(t.sons[i].sons[j].kind = nkType); - if orExpr <> nil then app(orExpr, '||'); - appf(orExpr, '($1.exc->Sup.m_type == $2)', - [safePoint, genTypeInfo(p.module, t.sons[i].sons[j].typ)]) - end; - if i > 1 then app(p.s[cpsStmts], 'else '); - appf(p.s[cpsStmts], 'if ($1) {$n', [orExpr]); - genStmts(p, t.sons[i].sons[blen - 1]); - // code to clear the exception: - appf(p.s[cpsStmts], '$1.status = 0;}$n', [safePoint]); - end; - inc(i) - end; - app(p.s[cpsStmts], '}' + tnl); // end of if statement - finishTryStmt(p, p.nestedTryStmts); - dec(p.nestedTryStmts); - if (i < len) and (t.sons[i].kind = nkFinally) then begin - genStmts(p, t.sons[i].sons[0]); - useMagic(p.module, 'raiseException'); - appf(p.s[cpsStmts], 'if ($1.status != 0) { ' + - 'raiseException($1.exc, $1.exc->name); }$n', [safePoint]) - end -end; - -var - breakPointId: int = 0; - gBreakpoints: PRope; // later the breakpoints are inserted into the main proc - -procedure genBreakPoint(p: BProc; t: PNode); -var - name: string; -begin - if optEndb in p.Options then begin - if t.kind = nkExprColonExpr then begin - assert(t.sons[1].kind in [nkStrLit..nkTripleStrLit]); - name := normalize(t.sons[1].strVal) - end - else begin - inc(breakPointId); - name := 'bp' + toString(breakPointId) - end; - genLineDir(p, t); // BUGFIX - appf(gBreakpoints, - 'dbgRegisterBreakpoint($1, (NCSTRING)$2, (NCSTRING)$3);$n', - [toRope(toLinenumber(t.info)), makeCString(toFilename(t.info)), - makeCString(name)]) - end -end; - -procedure genPragma(p: BProc; n: PNode); -var - i: int; - it, key: PNode; -begin - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if it.kind = nkExprColonExpr then begin - key := it.sons[0]; - end - else begin - key := it; - end; - if key.kind = nkIdent then - case whichKeyword(key.ident) of - wBreakpoint: genBreakPoint(p, it); - wDeadCodeElim: begin - if not (optDeadCodeElim in gGlobalOptions) then begin - // we need to keep track of ``deadCodeElim`` pragma - if (sfDeadCodeElim in p.module.module.flags) then - addPendingModule(p.module) - end - end - else begin end - end - end -end; - -procedure genAsgn(p: BProc; e: PNode); -var - a: TLoc; -begin - genLineDir(p, e); // BUGFIX - InitLocExpr(p, e.sons[0], a); - assert(a.t <> nil); - expr(p, e.sons[1], a); -end; - -procedure genFastAsgn(p: BProc; e: PNode); -var - a: TLoc; -begin - genLineDir(p, e); // BUGFIX - InitLocExpr(p, e.sons[0], a); - include(a.flags, lfNoDeepCopy); - assert(a.t <> nil); - expr(p, e.sons[1], a); -end; - -procedure genStmts(p: BProc; t: PNode); -var - a: TLoc; - i: int; - prc: PSym; -begin - //assert(t <> nil); - if inCheckpoint(t.info) then - MessageOut(renderTree(t)); - case t.kind of - 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); - nkVarSection: genVarStmt(p, t); - nkConstSection: genConstStmt(p, t); - nkForStmt: internalError(t.info, 'for statement not eliminated'); - nkCaseStmt: genCaseStmt(p, t); - nkReturnStmt: genReturnStmt(p, t); - nkBreakStmt: genBreakStmt(p, t); - nkCall, nkHiddenCallConv, nkInfix, nkPrefix, nkPostfix, nkCommand, - nkCallStrLit: begin - genLineDir(p, t); - initLocExpr(p, t, a); - end; - nkAsgn: genAsgn(p, t); - nkFastAsgn: genFastAsgn(p, t); - nkDiscardStmt: begin - genLineDir(p, t); - initLocExpr(p, t.sons[0], a); - end; - nkAsmStmt: genAsmStmt(p, t); - nkTryStmt: begin - if gCmd = cmdCompileToCpp then genTryStmtCpp(p, t) - else genTryStmt(p, t); - end; - nkRaiseStmt: genRaiseStmt(p, t); - nkTypeSection: begin - // we have to emit the type information for object types here to support - // separate compilation: - genTypeSection(p.module, t); - end; - nkCommentStmt, nkNilLit, nkIteratorDef, nkIncludeStmt, nkImportStmt, - nkFromStmt, nkTemplateDef, nkMacroDef: begin end; - nkPragma: genPragma(p, t); - nkProcDef, nkMethodDef, nkConverterDef: begin - if (t.sons[genericParamsPos] = nil) then begin - prc := t.sons[namePos].sym; - if not (optDeadCodeElim in gGlobalOptions) and - not (sfDeadCodeElim in getModule(prc).flags) - or ([sfExportc, sfCompilerProc] * prc.flags = [sfExportc]) - or (prc.kind = skMethod) then begin - if (t.sons[codePos] <> nil) or (lfDynamicLib in prc.loc.flags) then begin - genProc(p.module, prc) - end - end - end - end; - else - internalError(t.info, 'genStmts(' +{&} nodeKindToStr[t.kind] +{&} ')') - end -end; diff --git a/nim/ccgtypes.pas b/nim/ccgtypes.pas deleted file mode 100755 index 1c07fe5c7..000000000 --- a/nim/ccgtypes.pas +++ /dev/null @@ -1,1082 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -//var -// newDummyVar: int; // just to check the symbol file mechanism - -// ------------------------- Name Mangling -------------------------------- - -function mangle(const name: string): string; -var - i: int; -begin - 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'))); - '_': begin end; - 'a'..'z', '0'..'9': addChar(result, name[i]); - else begin - add(result, 'HEX'); - add(result, toHex(ord(name[i]), 2)) - end - end - end -end; - -function mangleName(s: PSym): PRope; -begin - result := s.loc.r; - if result = nil then begin - if gCmd = cmdCompileToLLVM then begin - case s.kind of - skProc, skMethod, skConverter, skConst: result := toRope('@'+''); - skVar: begin - if (sfGlobal in s.flags) then result := toRope('@'+'') - else result := toRope('%'+''); - end; - skForVar, skTemp, skParam, skType, skEnumField, skModule: - result := toRope('%'+''); - else InternalError(s.info, 'mangleName'); - end; - end; - app(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, 'r"$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 <> []) - and (gCmd <> cmdCompileToLLVM) then - result := typ.sym.loc.r - else begin - if typ.loc.r = nil then - typ.loc.r := ropeff('TY$1', '%TY$1', [toRope(typ.id)]); - result := typ.loc.r - end; - if result = nil then InternalError('getTypeName: ' + typeKindToStr[typ.kind]); -end; - -// ----------------------------- other helpers ---------------------------- -(* -function getSizeof(m: BModule; var labels: int; - var body: PRope; typ: PType): PRope; -begin - if (gCmd <> cmdCompileToLLVM) then - result := ropef('sizeof($1)', getTypeDesc(m, typ)) - else begin - inc(labels, 2); - result := ropef('%UOC$1', [toRope(labels)]); - appf(body, '%UOC$1 = getelementptr $3* null, %NI 1$n' + - '$2 = cast $3* %UOC$1 to i32$n', - [toRope(labels-1), result, getTypeDesc(m, typ)]); - end -end; *) - -// ------------------------------ C type generator ------------------------ - -function mapType(typ: PType): TCTypeKind; -begin - case typ.kind of - tyNone: result := ctVoid; - tyBool: result := ctBool; - tyChar: result := ctChar; - tySet: begin - case int(getSize(typ)) of - 1: result := ctInt8; - 2: result := ctInt16; - 4: result := ctInt32; - 8: result := ctInt64; - else result := ctArray - end - end; - tyOpenArray, tyArrayConstr, tyArray: result := ctArray; - tyObject, tyTuple: result := ctStruct; - tyGenericBody, tyGenericInst, tyGenericParam, tyDistinct, tyOrdinal: - result := mapType(lastSon(typ)); - tyEnum: begin - if firstOrd(typ) < 0 then - result := ctInt32 - else begin - case int(getSize(typ)) of - 1: result := ctUInt8; - 2: result := ctUInt16; - 4: result := ctInt32; - 8: result := ctInt64; - else internalError('mapType'); - end - end - end; - tyRange: result := mapType(typ.sons[0]); - tyPtr, tyVar, tyRef: begin - case typ.sons[0].kind of - tyOpenArray, tyArrayConstr, tyArray: result := ctArray; - else result := ctPtr - end - end; - tyPointer: result := ctPtr; - tySequence: result := ctNimSeq; - tyProc: result := ctProc; - tyString: result := ctNimStr; - tyCString: result := ctCString; - tyInt..tyFloat128: - result := TCTypeKind(ord(typ.kind) - ord(tyInt) + ord(ctInt)); - else InternalError('mapType'); - end -end; - -function mapReturnType(typ: PType): TCTypeKind; -begin - if skipTypes(typ, abstractInst).kind = tyArray then result := ctPtr - else result := mapType(typ) -end; - -function getTypeDescAux(m: BModule; typ: PType; - var check: TIntSet): PRope; forward; - -function needsComplexAssignment(typ: PType): bool; -begin - result := containsGarbageCollectedRef(typ); -end; - -function isInvalidReturnType(rettype: PType): bool; -begin - // Arrays and sets cannot be returned by a C procedure, because C is - // such a poor programming language. - // We exclude records with refs too. This enhances efficiency and - // is necessary for proper code generation of assignments. - if rettype = nil then - result := true - else begin - case mapType(rettype) of - ctArray: - result := not (skipTypes(rettype, abstractInst).kind in [tyVar, tyRef, tyPtr]); - ctStruct: - result := needsComplexAssignment(skipTypes(rettype, abstractInst)); - else result := false; - end - end -end; - -const - CallingConvToStr: array [TCallingConvention] of string = ('N_NIMCALL', - '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_NOINLINE', 'N_FASTCALL', 'N_CLOSURE', 'N_NOCONV'); - - CallingConvToStrLLVM: array [TCallingConvention] of string = ('fastcc $1', - 'stdcall $1', 'ccc $1', 'safecall $1', 'syscall $1', - '$1 alwaysinline', '$1 noinline', 'fastcc $1', 'ccc $1', '$1'); - -function CacheGetType(const tab: TIdTable; key: PType): PRope; -begin - // returns nil if we need to declare this type - // 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 - result := ropeff('TMP$1', '%TMP$1', [toRope(gId)]); - inc(gId); -end; - -function getGlobalTempName(): PRope; -begin - result := ropeff('TMP$1', '@TMP$1', [toRope(gId)]); - inc(gId); -end; - -function ccgIntroducedPtr(s: PSym): bool; -var - pt: PType; -begin - pt := s.typ; - assert(not (sfResult in s.flags)); - case pt.Kind of - tyObject: begin - // XXX quick hack floatSize*2 for the pegs module under 64bit - if (optByRef in s.options) or (getSize(pt) > platform.floatSize*2) then - result := true // requested anyway - else if (tfFinal in pt.flags) and (pt.sons[0] = nil) then - result := false // no need, because no subtyping possible - else - result := true; // ordinary objects are always passed by reference, - // otherwise casting doesn't work - end; - tyTuple: - result := (getSize(pt) > platform.floatSize) or (optByRef in s.options); - else - result := false - end -end; - -procedure fillResult(param: PSym); -begin - fillLoc(param.loc, locParam, param.typ, ropeff('Result', '%Result', []), - OnStack); - if (mapReturnType(param.typ) <> ctArray) - and IsInvalidReturnType(param.typ) then - begin - include(param.loc.flags, lfIndirect); - param.loc.s := OnUnknown - end -end; - -procedure genProcParams(m: BModule; t: PType; out rettype, params: PRope; - var check: TIntSet); -var - i, j: int; - param: PSym; - arr: PType; -begin - params := nil; - if (t.sons[0] = nil) or isInvalidReturnType(t.sons[0]) then - // C cannot return arrays (what a poor language...) - rettype := toRope('void') - else - 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, getTypeDescAux(m, param.typ, check)); - if ccgIntroducedPtr(param) then begin - app(params, '*'+''); - include(param.loc.flags, lfIndirect); - param.loc.s := OnUnknown; - end; - app(params, ' '+''); - app(params, param.loc.r); - // declare the len field for open arrays: - arr := param.typ; - if arr.kind = tyVar then arr := arr.sons[0]; - j := 0; - while arr.Kind = tyOpenArray do begin // need to pass hidden parameter: - appff(params, ', NI $1Len$2', ', @NI $1Len$2', [param.loc.r, toRope(j)]); - inc(j); - arr := arr.sons[0] - end; - if i < sonsLen(t.n)-1 then app(params, ', '); - end; - if (t.sons[0] <> nil) and isInvalidReturnType(t.sons[0]) then begin - if params <> nil then app(params, ', '); - arr := t.sons[0]; - app(params, getTypeDescAux(m, arr, check)); - if (mapReturnType(t.sons[0]) <> ctArray) or (gCmd = cmdCompileToLLVM) then - app(params, '*'+''); - appff(params, ' Result', ' @Result', []); - end; - if t.callConv = ccClosure then begin - if params <> nil then app(params, ', '); - app(params, 'void* ClPart') - end; - if tfVarargs in t.flags then begin - if params <> nil then app(params, ', '); - app(params, '...') - end; - if (params = nil) and (gCmd <> cmdCompileToLLVM) then - app(params, 'void)') - else - app(params, ')'+''); - params := con('('+'', params); -end; - -function isImportedType(t: PType): bool; -begin - result := (t.sym <> nil) and (sfImportc in t.sym.flags) -end; - -function typeNameOrLiteral(t: PType; const literal: string): PRope; -begin - 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(m: BModule; typ: PType): PRope; -const - NumericalTypeToStr: array [tyInt..tyFloat128] of string = ( - 'NI', 'NI8', 'NI16', 'NI32', 'NI64', 'NF', 'NF32', 'NF64', 'NF128'); -begin - case typ.Kind of - tyPointer: result := typeNameOrLiteral(typ, 'void*'); - tyEnum: begin - if firstOrd(typ) < 0 then - result := typeNameOrLiteral(typ, 'NI32') - else begin - case int(getSize(typ)) of - 1: result := typeNameOrLiteral(typ, 'NU8'); - 2: result := typeNameOrLiteral(typ, 'NU16'); - 4: result := typeNameOrLiteral(typ, 'NI32'); - 8: result := typeNameOrLiteral(typ, 'NI64'); - else begin - internalError(typ.sym.info, - 'getSimpleTypeDesc: ' + toString(getSize(typ))); - result := nil - end - end - end - end; - 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(m, typ.sons[0]); - else result := nil; - end -end; - -function getTypePre(m: BModule; typ: PType): PRope; -begin - if typ = nil then - result := toRope('void') - else begin - result := getSimpleTypeDesc(m, typ); - if result = nil then - result := CacheGetType(m.typeCache, typ) - end -end; - -function getForwardStructFormat(): string; -begin - if gCmd = cmdCompileToCpp then result := 'struct $1;$n' - else result := 'typedef struct $1 $1;$n' -end; - -function getTypeForward(m: BModule; typ: PType): PRope; -begin - result := CacheGetType(m.forwTypeCache, typ); - if result <> nil then exit; - result := getTypePre(m, typ); - if result <> nil then exit; - case typ.kind of - tySequence, tyTuple, tyObject: begin - result := getTypeName(typ); - if not isImportedType(typ) then - appf(m.s[cfsForwardTypes], getForwardStructFormat(), [result]); - IdTablePut(m.forwTypeCache, typ, result) - end - else - InternalError('getTypeForward(' + typeKindToStr[typ.kind] + ')') - end -end; - -function mangleRecFieldName(field: PSym; rectype: PType): PRope; -begin - if (rectype.sym <> nil) - and ([sfImportc, sfExportc] * rectype.sym.flags <> []) then - result := field.loc.r - else - result := toRope(mangle(field.name.s)); - if result = nil then InternalError(field.info, 'mangleRecFieldName'); -end; - -function genRecordFieldsAux(m: BModule; n: PNode; accessExpr: PRope; - rectype: PType; var check: TIntSet): PRope; -var - i: int; - ae, uname, sname, a: PRope; - k: PNode; - field: PSym; -begin - result := nil; - case n.kind of - nkRecList: begin - for i := 0 to sonsLen(n)-1 do begin - 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, check)); - uname := toRope(mangle(n.sons[0].sym.name.s)+ 'U'); - if accessExpr <> nil then ae := ropef('$1.$2', [accessExpr, uname]) - else ae := uname; - app(result, 'union {'+tnl); - for i := 1 to sonsLen(n)-1 do begin - case n.sons[i].kind of - nkOfBranch, nkElse: begin - k := lastSon(n.sons[i]); - if k.kind <> nkSym then begin - sname := con('S'+'', toRope(i)); - a := genRecordFieldsAux(m, k, ropef('$1.$2', [ae, sname]), - 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, check)); - end; - else internalError('genRecordFieldsAux(record case branch)'); - end; - end; - appf(result, '} $1;$n', [uname]) - end; - nkSym: begin - field := n.sym; - assert(field.ast = nil); - sname := mangleRecFieldName(field, rectype); - 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', [getTypeDescAux(m, field.loc.t, check), sname]) - end; - else internalError(n.info, 'genRecordFieldsAux()'); - end -end; - -function getRecordFields(m: BModule; typ: PType; var check: TIntSet): PRope; -begin - result := genRecordFieldsAux(m, typ.n, nil, typ, check); -end; - -function getRecordDesc(m: BModule; typ: PType; name: PRope; - var check: TIntSet): PRope; -var - desc: PRope; - hasField: bool; -begin - // declare the record: - hasField := false; - if typ.kind = tyObject then begin - useMagic(m, 'TNimType'); - if typ.sons[0] = nil then begin - if (typ.sym <> nil) and (sfPure in typ.sym.flags) - or (tfFinal in typ.flags) then - result := ropef('struct $1 {$n', [name]) - else begin - result := ropef('struct $1 {$nTNimType* m_type;$n', [name]); - hasField := true - end - end - else if gCmd = cmdCompileToCpp then begin - result := ropef('struct $1 : public $2 {$n', - [name, getTypeDescAux(m, typ.sons[0], check)]); - hasField := true - end - else begin - result := ropef('struct $1 {$n $2 Sup;$n', - [name, getTypeDescAux(m, typ.sons[0], check)]); - hasField := true - end - end - else - result := ropef('struct $1 {$n', [name]); - 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', []) - else - app(result, desc); - app(result, '};' + tnl); -end; - -function getTupleDesc(m: BModule; typ: PType; name: PRope; - var check: TIntSet): PRope; -var - desc: PRope; - i: int; -begin - result := ropef('struct $1 {$n', [name]); - desc := nil; - for i := 0 to sonsLen(typ)-1 do - appf(desc, '$1 Field$2;$n', - [getTypeDescAux(m, typ.sons[i], check), toRope(i)]); - if (desc = nil) then app(result, 'char dummy;' + tnl) - else app(result, desc); - app(result, '};' + tnl); -end; - -procedure pushType(m: BModule; typ: PType); -var - L: int; -begin - L := length(m.typeStack); - setLength(m.typeStack, L+1); - m.typeStack[L] := typ; -end; - -function getTypeDescAux(m: BModule; typ: PType; var check: TIntSet): PRope; -// returns only the type's name -var - name, rettype, desc, recdesc: PRope; - n: biggestInt; - t, et: PType; -begin - t := getUniqueType(typ); - 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: begin - et := getUniqueType(t.sons[0]); - if et.kind in [tyArrayConstr, tyArray, tyOpenArray] then - et := getUniqueType(elemType(et)); - case et.Kind of - tyObject, tyTuple: begin - // no restriction! We have a forward declaration for structs - name := getTypeForward(m, et); - result := con(name, '*'+''); - IdTablePut(m.typeCache, t, result); - pushType(m, et); - end; - tySequence: begin - // no restriction! We have a forward declaration for structs - name := getTypeForward(m, et); - result := con(name, '**'); - IdTablePut(m.typeCache, t, result); - pushType(m, et); - end; - else begin - // else we have a strong dependency :-( - 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, check); - if not isImportedType(t) then begin - if t.callConv <> ccClosure then - appf(m.s[cfsTypes], 'typedef $1_PTR($2, $3) $4;$n', - [toRope(CallingConvToStr[t.callConv]), rettype, result, desc]) - else // procedure vars may need a closure! - appf(m.s[cfsTypes], 'typedef struct $1 {$n' + - 'N_CDECL_PTR($2, PrcPart) $3;$n' + - 'void* ClPart;$n};$n', - [result, rettype, desc]); - end - end; - tySequence: begin - // we cannot use getTypeForward here because then t would be associated - // with the name of the struct, not with the pointer to the struct: - result := CacheGetType(m.forwTypeCache, t); - if result = nil then begin - result := getTypeName(t); - if not isImportedType(t) then - appf(m.s[cfsForwardTypes], getForwardStructFormat(), [result]); - IdTablePut(m.forwTypeCache, t, result); - end; - assert(CacheGetType(m.typeCache, t) = nil); - IdTablePut(m.typeCache, t, con(result, '*'+'')); - if not isImportedType(t) then begin - useMagic(m, 'TGenericSeq'); - if skipTypes(t.sons[0], abstractInst).kind <> tyEmpty then - appf(m.s[cfsSeqTypes], - 'struct $2 {$n' + - ' TGenericSeq Sup;$n' + - ' $1 data[SEQ_DECL_SIZE];$n' + - '};$n', [getTypeDescAux(m, t.sons[0], check), result]) - else - result := toRope('TGenericSeq') - end; - app(result, '*'+''); - end; - tyArrayConstr, tyArray: begin - n := lengthOrd(t); - if n <= 0 then n := 1; // make an array of at least one element - result := getTypeName(t); - IdTablePut(m.typeCache, t, result); - if not isImportedType(t) then - appf(m.s[cfsTypes], 'typedef $1 $2[$3];$n', - [getTypeDescAux(m, t.sons[1], check), result, ToRope(n)]) - end; - tyObject, tyTuple: begin - result := CacheGetType(m.forwTypeCache, t); - if result = nil then begin - result := getTypeName(t); - if not isImportedType(t) then - appf(m.s[cfsForwardTypes], getForwardStructFormat(), [result]); - IdTablePut(m.forwTypeCache, t, result) - end; - IdTablePut(m.typeCache, t, result); - // always call for sideeffects: - if t.n <> nil then - recdesc := getRecordDesc(m, t, result, check) - else - recdesc := getTupleDesc(m, t, result, check); - if not isImportedType(t) then app(m.s[cfsTypes], recdesc); - end; - tySet: begin - case int(getSize(t)) of - 1: result := toRope('NU8'); - 2: result := toRope('NU16'); - 4: result := toRope('NU32'); - 8: result := toRope('NU64'); - else begin - result := getTypeName(t); - IdTablePut(m.typeCache, t, result); - if not isImportedType(t) then - appf(m.s[cfsTypes], 'typedef NU8 $1[$2];$n', - [result, toRope(getSize(t))]) - end - end - end; - tyGenericInst, tyDistinct, tyOrdinal: - result := getTypeDescAux(m, lastSon(t), check); - else begin - InternalError('getTypeDescAux(' + typeKindToStr[t.kind] + ')'); - result := nil - end - end -end; - -function getTypeDesc(m: BModule; typ: PType): PRope; overload; -var - check: TIntSet; -begin - IntSetInit(check); - result := getTypeDescAux(m, typ, check); -end; - -function getTypeDesc(m: BModule; const magic: string): PRope; overload; -var - sym: PSym; -begin - sym := magicsys.getCompilerProc(magic); - if sym <> nil then - result := getTypeDesc(m, sym.typ) - else begin - rawMessage(errSystemNeeds, magic); - result := nil - end -end; - -procedure finishTypeDescriptions(m: BModule); -var - i: int; -begin - i := 0; - while i < length(m.typeStack) do begin - {@discard} getTypeDesc(m, m.typeStack[i]); - inc(i); - end; -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, check); - appf(result, '$1($2, $3)$4', - [toRope(CallingConvToStr[prc.typ.callConv]), - rettype, prc.loc.r, params]) -end; - -// ----------------------- type information ---------------------------------- - -function genTypeInfo(m: BModule; typ: PType): PRope; forward; - -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 := getNimType(m); - appf(m.s[cfsTypeInit2], '$2 = &$1;$n', [tmp, name]); -end; - -procedure genTypeInfoAuxBase(m: BModule; typ: PType; name, base: PRope); -var - nimtypeKind, flags: int; -begin - 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 - else - nimtypeKind := ord(typ.kind); - appf(m.s[cfsTypeInit3], - '$1->size = sizeof($2);$n' + - '$1->kind = $3;$n' + - '$1->base = $4;$n', [ - name, getTypeDesc(m, typ), toRope(nimtypeKind), base]); - // 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); -var - base: PRope; -begin - if (sonsLen(typ) > 0) and (typ.sons[0] <> nil) then - base := genTypeInfo(m, typ.sons[0]) - else - base := toRope('0'+''); - genTypeInfoAuxBase(m, typ, name, base); -end; - -procedure genObjectFields(m: BModule; typ: PType; n: PNode; expr: PRope); -var - tmp, tmp2: PRope; - len, i, j, x, y: int; - field: PSym; - b: PNode; -begin - case n.kind of - nkRecList: begin - len := sonsLen(n); - if len = 1 then // generates more compact code! - genObjectFields(m, typ, n.sons[0], expr) - else if len > 0 then begin - tmp := getTempName(); - appf(m.s[cfsTypeInit1], 'static TNimNode* $1[$2];$n', - [tmp, toRope(len)]); - for i := 0 to len-1 do begin - 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], - '$1.len = $2; $1.kind = 2; $1.sons = &$3[0];$n', [ - expr, toRope(len), tmp]); - end - else - appf(m.s[cfsTypeInit3], - '$1.len = $2; $1.kind = 2;$n', [expr, toRope(len)]); - end; - nkRecCase: begin - len := sonsLen(n); - assert(n.sons[0].kind = nkSym); - field := n.sons[0].sym; - tmp := getTempName(); - useMagic(m, 'chckNil'); - appf(m.s[cfsTypeInit3], '$1.kind = 3;$n' + - '$1.offset = offsetof($2, $3);$n' + - '$1.typ = $4;$n' + - 'chckNil($1.typ);$n' + - '$1.name = $5;$n' + - '$1.sons = &$6[0];$n' + - '$1.len = $7;$n', - [expr, getTypeDesc(m, typ), field.loc.r, - genTypeInfo(m, field.typ), - makeCString(field.name.s), tmp, - toRope(lengthOrd(field.typ))]); - appf(m.s[cfsTypeInit1], 'static TNimNode* $1[$2];$n', - [tmp, toRope(lengthOrd(field.typ)+1)]); - for i := 1 to len-1 do begin - b := n.sons[i]; // branch - tmp2 := getNimNode(m); - genObjectFields(m, typ, lastSon(b), tmp2); - case b.kind of - nkOfBranch: begin - if sonsLen(b) < 2 then - internalError(b.info, 'genObjectFields; nkOfBranch broken'); - for j := 0 to sonsLen(b)-2 do begin - if b.sons[j].kind = nkRange then begin - x := int(getOrdValue(b.sons[j].sons[0])); - y := int(getOrdValue(b.sons[j].sons[1])); - while x <= y do begin - appf(m.s[cfsTypeInit3], '$1[$2] = &$3;$n', - [tmp, toRope(x), tmp2]); - inc(x); - end; - end - else - appf(m.s[cfsTypeInit3], '$1[$2] = &$3;$n', - [tmp, toRope(getOrdValue(b.sons[j])), tmp2]) - end - end; - nkElse: begin - appf(m.s[cfsTypeInit3], '$1[$2] = &$3;$n', - [tmp, toRope(lengthOrd(field.typ)), tmp2]); - end - else - internalError(n.info, 'genObjectFields(nkRecCase)'); - end - end - end; - nkSym: begin - field := n.sym; - useMagic(m, 'chckNil'); - appf(m.s[cfsTypeInit3], '$1.kind = 1;$n' + - '$1.offset = offsetof($2, $3);$n' + - '$1.typ = $4;$n' + - 'chckNil($1.typ);$n' + - '$1.name = $5;$n', - [expr, getTypeDesc(m, typ), field.loc.r, - genTypeInfo(m, field.typ), - makeCString(field.name.s)]); - end; - else internalError(n.info, 'genObjectFields'); - end -end; - -procedure genObjectInfo(m: BModule; typ: PType; name: PRope); -var - tmp: PRope; -begin - if typ.kind = tyObject then genTypeInfoAux(m, typ, name) - else genTypeInfoAuxBase(m, typ, name, toRope('0'+'')); - tmp := getNimNode(m); - genObjectFields(m, typ, typ.n, tmp); - appf(m.s[cfsTypeInit3], '$1->node = &$2;$n', [name, tmp]); -end; - -procedure genTupleInfo(m: BModule; typ: PType; name: PRope); -var - tmp, expr, tmp2: PRope; - i, len: int; - a: PType; -begin - genTypeInfoAuxBase(m, typ, name, toRope('0'+'')); - expr := getNimNode(m); - len := sonsLen(typ); - if len > 0 then begin - tmp := getTempName(); - appf(m.s[cfsTypeInit1], 'static TNimNode* $1[$2];$n', [tmp, toRope(len)]); - for i := 0 to len-1 do begin - a := typ.sons[i]; - tmp2 := getNimNode(m); - appf(m.s[cfsTypeInit3], '$1[$2] = &$3;$n', [tmp, toRope(i), tmp2]); - useMagic(m, 'chckNil'); - appf(m.s[cfsTypeInit3], '$1.kind = 1;$n' + - '$1.offset = offsetof($2, Field$3);$n' + - '$1.typ = $4;$n' + - 'chckNil($1.typ);$n' + - '$1.name = "Field$3";$n', - [tmp2, getTypeDesc(m, typ), toRope(i), - genTypeInfo(m, a)]); - end; - appf(m.s[cfsTypeInit3], - '$1.len = $2; $1.kind = 2; $1.sons = &$3[0];$n', [ - expr, toRope(len), tmp]); - end - else - appf(m.s[cfsTypeInit3], - '$1.len = $2; $1.kind = 2;$n', [expr, toRope(len)]); - appf(m.s[cfsTypeInit3], '$1->node = &$2;$n', [name, tmp]); -end; - -procedure genEnumInfo(m: BModule; typ: PType; name: PRope); -var - 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); - nodePtrs := getTempName(); - len := sonsLen(typ.n); - 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; - 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', [ - getNimNode(m), toRope(len), nodePtrs, name]); -end; - -procedure genSetInfo(m: BModule; typ: PType; name: PRope); -var - tmp: PRope; -begin - assert(typ.sons[0] <> nil); - genTypeInfoAux(m, typ, name); - tmp := getNimNode(m); - appf(m.s[cfsTypeInit3], - '$1.len = $2; $1.kind = 0;$n' + - '$3->node = &$1;$n', [tmp, toRope(firstOrd(typ)), name]); -end; - -procedure genArrayInfo(m: BModule; typ: PType; name: PRope); -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; - dataGenerated: bool; -begin - t := getUniqueType(typ); - id := IiTableGet(gToTypeInfoId, t.id); - if id = invalidKey then begin - dataGenerated := false; - id := t.id; // getID(); - IiTablePut(gToTypeInfoId, t.id, id); - end - else - dataGenerated := true; - result := ropef('NTI$1', [toRope(id)]); - if not IntSetContainsOrIncl(m.typeInfoMarker, id) then begin - // declare type information structures: - useMagic(m, 'TNimType'); - useMagic(m, 'TNimNode'); - appf(m.s[cfsVars], 'extern TNimType* $1; /* $2 */$n', - [result, toRope(typeToString(t))]); - end; - if dataGenerated then exit; - case t.kind of - tyEmpty: result := toRope('0'+''); - tyPointer, tyProc, tyBool, tyChar, tyCString, tyString, - tyInt..tyFloat128, tyVar: - genTypeInfoAuxBase(gNimDat, t, result, toRope('0'+'')); - tyRef, tyPtr, tySequence, tyRange: genTypeInfoAux(gNimDat, t, result); - tyArrayConstr, tyArray: genArrayInfo(gNimDat, t, result); - tySet: genSetInfo(gNimDat, t, result); - tyEnum: genEnumInfo(gNimDat, t, result); - tyObject: genObjectInfo(gNimDat, t, result); - tyTuple: begin - if t.n <> nil then genObjectInfo(gNimDat, t, result) - else genTupleInfo(gNimDat, t, result); - end; - else InternalError('genTypeInfo(' + typekindToStr[t.kind] + ')'); - end -end; - -procedure genTypeSection(m: BModule; n: PNode); -begin -end; - -(* -procedure genTypeSection(m: BModule; n: PNode); -var - i: int; - a: PNode; - t: PType; -begin - if not (optDeadCodeElim in gGlobalOptions) then 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 isPureObject(t) 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 -end; -*) diff --git a/nim/ccgutils.pas b/nim/ccgutils.pas deleted file mode 100755 index da6b8774f..000000000 --- a/nim/ccgutils.pas +++ /dev/null @@ -1,188 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit ccgutils; - -interface - -{$include 'config.inc'} - -// This module declares some helpers for the C code generator. - -uses - charsets, nsystem, - ast, astalgo, ropes, lists, nhashes, strutils, types, msgs; - -function toCChar(c: Char): string; -function makeCString(const s: string): PRope; -function makeLLVMString(const s: string): PRope; - -function TableGetType(const tab: TIdTable; key: PType): PObject; -function GetUniqueType(key: PType): PType; - -implementation - -var - gTypeTable: array [TTypeKind] of TIdTable; - -procedure initTypeTables(); -var - i: TTypeKind; -begin - for i := low(TTypeKind) to high(TTypeKind) do - InitIdTable(gTypeTable[i]); -end; - -function GetUniqueType(key: PType): PType; -var - t: PType; - h: THash; - k: TTypeKind; -begin - // this is a hotspot in the compiler! - result := key; - if key = nil then exit; - k := key.kind; - case k of - tyObject, tyEnum: begin - result := PType(IdTableGet(gTypeTable[k], key)); - if result = nil then begin - IdTablePut(gTypeTable[k], key, key); - result := key; - end - end; - tyGenericInst, tyDistinct, tyOrdinal: - result := GetUniqueType(lastSon(key)); - tyProc: begin end; - else begin - // we have to do a slow linear search because types may need - // to be compared by their structure: - if IdTableHasObjectAsKey(gTypeTable[k], key) then exit; - for h := 0 to high(gTypeTable[k].data) do begin - t := PType(gTypeTable[k].data[h].key); - if (t <> nil) and sameType(t, key) then begin result := t; exit end - end; - IdTablePut(gTypeTable[k], key, key); - end; - end; - (* - case key.Kind of - tyEmpty, tyChar, tyBool, tyNil, tyPointer, tyString, tyCString, - tyInt..tyFloat128, tyProc, tyAnyEnum: begin end; - tyNone, tyForward: - InternalError('GetUniqueType: ' + typeToString(key)); - tyGenericParam, tyGeneric, tyAbstract, 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; - tyObject, tyEnum: begin - result := PType(IdTableGet(gTypeTable, key)); - if result = nil then begin - IdTablePut(gTypeTable, key, key); - result := key; - end - end; - tyGenericInst, tyAbstract: result := GetUniqueType(lastSon(key)); - end; *) -end; - -function TableGetType(const tab: TIdTable; key: PType): PObject; -var - t: PType; - h: THash; -begin // returns nil if we need to declare this type - result := IdTableGet(tab, key); - if (result = nil) and (tab.counter > 0) then begin - // we have to do a slow linear search because types may need - // to be compared by their structure: - for h := 0 to high(tab.data) do begin - t := PType(tab.data[h].key); - if t <> nil then begin - if sameType(t, key) then begin - result := tab.data[h].val; - exit - end - end - end - end -end; - -function toCChar(c: Char): string; -begin - case c of - #0..#31, #128..#255: result := '\' + toOctal(c); - '''', '"', '\': result := '\' + c; - else result := {@ignore} c {@emit toString(c)} - end; -end; - -function makeCString(const s: string): PRope; -// BUGFIX: We have to split long strings into many ropes. Otherwise -// this could trigger an InternalError(). See the ropes module for -// further information. -const - MaxLineLength = 64; -var - i: int; - res: string; -begin - result := nil; - res := '"'+''; - for i := strStart to length(s)+strStart-1 do begin - if (i-strStart+1) mod MaxLineLength = 0 then begin - add(res, '"'); - add(res, nl); - app(result, toRope(res)); - // reset: - setLength(res, 1); - res[strStart] := '"'; - end; - add(res, toCChar(s[i])); - end; - addChar(res, '"'); - app(result, toRope(res)); -end; - -function makeLLVMString(const s: string): PRope; -const - MaxLineLength = 64; -var - i: int; - res: string; -begin - result := nil; - res := 'c"'; - for i := strStart to length(s)+strStart-1 do begin - if (i-strStart+1) mod MaxLineLength = 0 then begin - app(result, toRope(res)); - setLength(res, 0); - end; - case s[i] of - #0..#31, #128..#255, '"', '\': begin - addChar(res, '\'); - add(res, toHex(ord(s[i]), 2)); - end - else - addChar(res, s[i]) - end; - end; - add(res, '\00"'); - app(result, toRope(res)); -end; - -begin - InitTypeTables(); -end. diff --git a/nim/cgen.pas b/nim/cgen.pas deleted file mode 100755 index 83c34241a..000000000 --- a/nim/cgen.pas +++ /dev/null @@ -1,1270 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// 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 -// than the old one. It also generates better code. - -interface - -{$include 'config.inc'} - -uses - nsystem, ast, astalgo, strutils, nhashes, trees, platform, magicsys, - extccomp, options, nversion, nimsets, msgs, crc, bitsets, idents, - lists, types, ccgutils, nos, ntime, ropes, nmath, passes, rodread, - wordrecg, rnimsyn, treetab, cgmeth; - -function cgenPass(): TPass; - -implementation - -type - TLabel = PRope; // for the C generator a label is just a rope - - TCFileSection = ( // the sections a generated C file consists of - cfsHeaders, // section for C include file headers - cfsForwardTypes, // section for C forward typedefs - cfsTypes, // section for C typedefs - cfsSeqTypes, // section for sequence types only - // this is needed for strange type generation - // reasons - cfsFieldInfo, // section for field information - cfsTypeInfo, // section for type information - cfsProcHeaders, // section for C procs prototypes - cfsData, // section for C constant data - cfsVars, // section for C variable declarations - cfsProcs, // section for C procs that are not inline - cfsTypeInit1, // section 1 for declarations of type information - cfsTypeInit2, // section 2 for initialization of type information - cfsTypeInit3, // section 3 for initialization of type information - cfsDebugInit, // section for initialization of debug information - cfsDynLibInit, // section for initialization of dynamic library binding - cfsDynLibDeinit // section for deinitialization of dynamic libraries - ); - - TCTypeKind = ( // describes the type kind of a C type - ctVoid, - ctChar, - ctBool, - ctUInt, ctUInt8, ctUInt16, ctUInt32, ctUInt64, - ctInt, ctInt8, ctInt16, ctInt32, ctInt64, - ctFloat, ctFloat32, ctFloat64, ctFloat128, - ctArray, - ctStruct, - ctPtr, - ctNimStr, - ctNimSeq, - ctProc, - ctCString - ); - - TCFileSections = array [TCFileSection] of PRope; - // TCFileSections represents a generated C file - TCProcSection = ( // the sections a generated C proc consists of - cpsLocals, // section of local variables for C proc - cpsInit, // section for initialization of variables for C proc - cpsStmts // section of local statements for C proc - ); - - TCProcSections = array [TCProcSection] of PRope; - // TCProcSections represents a generated C proc - - BModule = ^TCGen; - BProc = ^TCProc; - - TBlock = record - id: int; // the ID of the label; positive means that it - // has been used (i.e. the label should be emitted) - nestedTryStmts: int; // how many try statements is it nested into - end; - - TCProc = record // represents C proc that is currently generated - s: TCProcSections; // the procs sections; short name for readability - prc: PSym; // the Nimrod proc that this C proc belongs to - BeforeRetNeeded: bool; // true iff 'BeforeRet' label for proc is needed - nestedTryStmts: Natural; // in how many nested try statements we are - // (the vars must be volatile then) - labels: Natural; // for generating unique labels in the C proc - blocks: array of TBlock; // nested blocks - options: TOptions; // options that should be used for code - // generation; this is the same as prc.options - // unless prc == nil - frameLen: int; // current length of frame descriptor - sendClosure: PType; // closure record type that we pass - receiveClosure: PType; // closure record type that we get - module: BModule; // used to prevent excessive parameter passing - end; - TTypeSeq = array of PType; - 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) - typeCache: TIdTable; // cache the generated types - forwTypeCache: TIdTable; // cache for forward declarations of types - declaredThings: TIntSet; // things we have declared in this .c file - declaredProtos: TIntSet; // prototypes we have declared in this .c file - headerFiles: TLinkedList; // needed headers to include - typeInfoMarker: TIntSet; // needed for generating type information - initProc: BProc; // code for init procedure - typeStack: TTypeSeq; // used for type generation - dataCache: TNodeTable; - forwardedProcs: TSymSeq; // keep forwarded procs here - typeNodes, nimTypes: int;// used for type info generation - typeNodesName, nimTypesName: PRope; // used for type info generation - labels: natural; // for generating unique module-scope names - end; - -var - mainModProcs, mainModInit: PRope; // parts of the main module - gMapping: PRope; // the generated mapping file (if requested) - gProcProfile: Natural; // proc profile counter - gGeneratedSyms: TIntSet; // set of ID's of generated symbols - gPendingModules: array of BModule = {@ignore} nil {@emit @[]}; - // list of modules that are not finished with code generation - gForwardedProcsCounter: int = 0; - gNimDat: BModule; // generated global data - -function ropeff(const cformat, llvmformat: string; - const args: array of PRope): PRope; -begin - if gCmd = cmdCompileToLLVM then - result := ropef(llvmformat, args) - else - result := ropef(cformat, args) -end; - -procedure appff(var dest: PRope; const cformat, llvmformat: string; - const args: array of PRope); -begin - if gCmd = cmdCompileToLLVM then - appf(dest, llvmformat, args) - else - appf(dest, cformat, args); -end; - -procedure addForwardedProc(m: BModule; prc: PSym); -var - L: int; -begin - L := length(m.forwardedProcs); - setLength(m.forwardedProcs, L+1); - m.forwardedProcs[L] := prc; - inc(gForwardedProcsCounter); -end; - -procedure addPendingModule(m: BModule); -var - L, i: int; -begin - for i := 0 to high(gPendingModules) do - if gPendingModules[i] = m then - InternalError('module already pending: ' + m.module.name.s); - L := length(gPendingModules); - setLength(gPendingModules, L+1); - gPendingModules[L] := m; -end; - -function findPendingModule(m: BModule; s: PSym): BModule; -var - ms: PSym; - i: int; -begin - ms := getModule(s); - if ms.id = m.module.id then begin - result := m; exit - end; - for i := 0 to high(gPendingModules) do begin - result := gPendingModules[i]; - if result.module.id = ms.id then exit; - end; - InternalError(s.info, 'no pending module found for: ' + s.name.s); -end; - -procedure initLoc(var result: TLoc; k: TLocKind; typ: PType; s: TStorageLoc); -begin - result.k := k; - result.s := s; - result.t := GetUniqueType(typ); - result.r := nil; - result.a := -1; - result.flags := {@set}[] -end; - -procedure fillLoc(var a: TLoc; k: TLocKind; typ: PType; r: PRope; - s: TStorageLoc); -begin - // fills the loc if it is not already initialized - if a.k = locNone then begin - a.k := k; - a.t := getUniqueType(typ); - a.a := -1; - a.s := s; - if a.r = nil then a.r := r; - end -end; - -function newProc(prc: PSym; module: BModule): BProc; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.prc := prc; - result.module := module; - if prc <> nil then - result.options := prc.options - else - result.options := gOptions; -{@ignore} - setLength(result.blocks, 0); -{@emit - result.blocks := @[];} -end; - -function isSimpleConst(typ: PType): bool; -begin - result := not (skipTypes(typ, abstractVar).kind in [tyTuple, tyObject, - tyArray, tyArrayConstr, tySet, tySequence]) -end; - -procedure useHeader(m: BModule; sym: PSym); -begin - if lfHeader in sym.loc.Flags then begin - assert(sym.annex <> nil); - {@discard} lists.IncludeStr(m.headerFiles, sym.annex.path) - end -end; - -procedure UseMagic(m: BModule; const name: string); forward; - -{$include 'ccgtypes.pas'} - -// ------------------------------ Manager of temporaries ------------------ - -procedure getTemp(p: BProc; t: PType; var result: TLoc); -begin - inc(p.labels); - if gCmd = cmdCompileToLLVM then - result.r := con('%LOC', toRope(p.labels)) - else begin - result.r := con('LOC', toRope(p.labels)); - appf(p.s[cpsLocals], '$1 $2;$n', [getTypeDesc(p.module, t), result.r]); - end; - result.k := locTemp; - result.a := -1; - result.t := getUniqueType(t); - result.s := OnStack; - result.flags := {@set}[]; -end; - -// -------------------------- Variable manager ---------------------------- - -function cstringLit(p: BProc; var r: PRope; const s: string): PRope; overload; -begin - if gCmd = cmdCompileToLLVM then begin - inc(p.module.labels); - inc(p.labels); - result := ropef('%LOC$1', [toRope(p.labels)]); - appf(p.module.s[cfsData], '@C$1 = private constant [$2 x i8] $3$n', [ - toRope(p.module.labels), toRope(length(s)), makeLLVMString(s)]); - appf(r, '$1 = getelementptr [$2 x i8]* @C$3, %NI 0, %NI 0$n', - [result, toRope(length(s)), toRope(p.module.labels)]); - end - else - result := makeCString(s) -end; - -function cstringLit(m: BModule; var r: PRope; const s: string): PRope; overload; -begin - if gCmd = cmdCompileToLLVM then begin - inc(m.labels, 2); - result := ropef('%MOC$1', [toRope(m.labels-1)]); - appf(m.s[cfsData], '@MOC$1 = private constant [$2 x i8] $3$n', [ - toRope(m.labels), toRope(length(s)), makeLLVMString(s)]); - appf(r, '$1 = getelementptr [$2 x i8]* @MOC$3, %NI 0, %NI 0$n', - [result, toRope(length(s)), toRope(m.labels)]); - end - else - result := makeCString(s) -end; - -procedure allocParam(p: BProc; s: PSym); -var - tmp: PRope; -begin - assert(s.kind = skParam); - if not (lfParamCopy in s.loc.flags) then begin - inc(p.labels); - tmp := con('%LOC', toRope(p.labels)); - include(s.loc.flags, lfParamCopy); - include(s.loc.flags, lfIndirect); - appf(p.s[cpsInit], - '$1 = alloca $3$n' + - 'store $3 $2, $3* $1$n', [tmp, s.loc.r, getTypeDesc(p.module, s.loc.t)]); - s.loc.r := tmp - end; -end; - -procedure localDebugInfo(p: BProc; s: PSym); -var - name, a: PRope; -begin - if [optStackTrace, optEndb] * p.options <> [optStackTrace, optEndb] then exit; - if gCmd = cmdCompileToLLVM then begin - // "address" is the 0th field - // "typ" is the 1rst field - // "name" is the 2nd field - name := cstringLit(p, p.s[cpsInit], normalize(s.name.s)); - if (s.kind = skParam) and not ccgIntroducedPtr(s) then allocParam(p, s); - inc(p.labels, 3); - appf(p.s[cpsInit], - '%LOC$6 = getelementptr %TF* %F, %NI 0, $1, %NI 0$n' + - '%LOC$7 = getelementptr %TF* %F, %NI 0, $1, %NI 1$n' + - '%LOC$8 = getelementptr %TF* %F, %NI 0, $1, %NI 2$n' + - 'store i8* $2, i8** %LOC$6$n' + - 'store $3* $4, $3** %LOC$7$n' + - 'store i8* $5, i8** %LOC$8$n', - [toRope(p.frameLen), s.loc.r, getTypeDesc(p.module, 'TNimType'), - genTypeInfo(p.module, s.loc.t), name, toRope(p.labels), - toRope(p.labels-1), toRope(p.labels-2)]) - end - else begin - a := con('&'+'', s.loc.r); - if (s.kind = skParam) and ccgIntroducedPtr(s) then a := s.loc.r; - appf(p.s[cpsInit], - 'F.s[$1].address = (void*)$3; F.s[$1].typ = $4; F.s[$1].name = $2;$n', - [toRope(p.frameLen), makeCString(normalize(s.name.s)), a, - genTypeInfo(p.module, s.loc.t)]); - end; - inc(p.frameLen); -end; - -procedure assignLocalVar(p: BProc; s: PSym); -begin - //assert(s.loc.k == locNone) // not yet assigned - // this need not be fullfilled for inline procs; they are regenerated - // for each module that uses them! - if s.loc.k = locNone then - fillLoc(s.loc, locLocalVar, s.typ, mangleName(s), OnStack); - if gCmd = cmdCompileToLLVM then begin - appf(p.s[cpsLocals], '$1 = alloca $2$n', - [s.loc.r, getTypeDesc(p.module, s.loc.t)]); - include(s.loc.flags, lfIndirect); - end - else begin - app(p.s[cpsLocals], getTypeDesc(p.module, s.loc.t)); - if sfRegister in s.flags then - app(p.s[cpsLocals], ' register'); - if (sfVolatile in s.flags) or (p.nestedTryStmts > 0) then - app(p.s[cpsLocals], ' volatile'); - - appf(p.s[cpsLocals], ' $1;$n', [s.loc.r]); - end; - // if debugging we need a new slot for the local variable: - localDebugInfo(p, s); -end; - -procedure assignGlobalVar(p: BProc; s: PSym); -begin - if s.loc.k = locNone then - fillLoc(s.loc, locGlobalVar, s.typ, mangleName(s), OnHeap); - if gCmd = cmdCompileToLLVM then begin - appf(p.module.s[cfsVars], '$1 = linkonce global $2 zeroinitializer$n', - [s.loc.r, getTypeDesc(p.module, s.loc.t)]); - include(s.loc.flags, lfIndirect); - end - else begin - useHeader(p.module, s); - if lfNoDecl in s.loc.flags then exit; - if sfImportc in s.flags then app(p.module.s[cfsVars], 'extern '); - app(p.module.s[cfsVars], getTypeDesc(p.module, s.loc.t)); - if sfRegister in s.flags then app(p.module.s[cfsVars], ' register'); - if sfVolatile in s.flags then app(p.module.s[cfsVars], ' volatile'); - if sfThreadVar in s.flags then app(p.module.s[cfsVars], ' NIM_THREADVAR'); - appf(p.module.s[cfsVars], ' $1;$n', [s.loc.r]); - end; - if [optStackTrace, optEndb] * p.module.module.options = - [optStackTrace, optEndb] then begin - useMagic(p.module, 'dbgRegisterGlobal'); - appff(p.module.s[cfsDebugInit], - 'dbgRegisterGlobal($1, &$2, $3);$n', - 'call void @dbgRegisterGlobal(i8* $1, i8* $2, $4* $3)$n', - [cstringLit(p, p.module.s[cfsDebugInit], - normalize(s.owner.name.s + '.' +{&} s.name.s)), - s.loc.r, - genTypeInfo(p.module, s.typ), - getTypeDesc(p.module, 'TNimType')]); - end; -end; - -function iff(cond: bool; the, els: PRope): PRope; -begin - if cond then result := the else result := els -end; - -procedure assignParam(p: BProc; s: PSym); -begin - assert(s.loc.r <> nil); - if (sfAddrTaken in s.flags) and (gCmd = cmdCompileToLLVM) then - allocParam(p, s); - localDebugInfo(p, s); -end; - -procedure fillProcLoc(sym: PSym); -begin - if sym.loc.k = locNone then - fillLoc(sym.loc, locProc, sym.typ, mangleName(sym), OnStack); -end; - -// -------------------------- label manager ------------------------------- - -// note that a label is a location too -function getLabel(p: BProc): TLabel; -begin - inc(p.labels); - result := con('LA', toRope(p.labels)) -end; - -procedure fixLabel(p: BProc; labl: TLabel); -begin - appf(p.s[cpsStmts], '$1: ;$n', [labl]) -end; - -procedure genVarPrototype(m: BModule; sym: PSym); forward; -procedure genConstPrototype(m: BModule; sym: PSym); forward; -procedure genProc(m: BModule; prc: PSym); forward; -procedure genStmts(p: BProc; t: PNode); forward; -procedure genProcPrototype(m: BModule; sym: PSym); forward; - -{$include 'ccgexprs.pas'} -{$include 'ccgstmts.pas'} - -// ----------------------------- dynamic library handling ----------------- - -// We don't finalize dynamic libs as this does the OS for us. - -procedure libCandidates(const s: string; var dest: TStringSeq); -var - prefix, suffix: string; - le, ri, i, L: int; - temp: TStringSeq; -begin - le := strutils.find(s, '('); - ri := strutils.find(s, ')'); - if (le >= strStart) and (ri > le) then begin - prefix := ncopy(s, strStart, le-1); - suffix := ncopy(s, ri+1); - temp := split(ncopy(s, le+1, ri-1), {@set}['|']); - for i := 0 to high(temp) do - libCandidates(prefix +{&} temp[i] +{&} suffix, dest); - end - else begin - {@ignore} - L := length(dest); - setLength(dest, L+1); - dest[L] := s; - {@emit add(dest, s);} - end -end; - -procedure loadDynamicLib(m: BModule; lib: PLib); -var - tmp, loadlib: PRope; - s: TStringSeq; - i: int; -begin - assert(lib <> nil); - if not lib.generated then begin - lib.generated := true; - tmp := getGlobalTempName(); - assert(lib.name = nil); - lib.name := tmp; - // BUGFIX: useMagic has awful side-effects - appff(m.s[cfsVars], 'static void* $1;$n', - '$1 = linkonce global i8* zeroinitializer$n', [tmp]); - {@ignore} s := nil; {@emit s := @[];} - libCandidates(lib.path, s); - loadlib := nil; - for i := 0 to high(s) do begin - inc(m.labels); - if i > 0 then app(loadlib, '||'); - appff(loadlib, - '($1 = nimLoadLibrary((NimStringDesc*) &$2))$n', - '%MOC$4 = call i8* @nimLoadLibrary($3 $2)$n' + - 'store i8* %MOC$4, i8** $1$n', - [tmp, getStrLit(m, s[i]), getTypeDesc(m, getSysType(tyString)), - toRope(m.labels)]); - end; - appff(m.s[cfsDynLibInit], - 'if (!($1)) nimLoadLibraryError((NimStringDesc*) &$2);$n', - 'XXX too implement', - [loadlib, getStrLit(m, lib.path)]); - //appf(m.s[cfsDynLibDeinit], - // 'if ($1 != NIM_NIL) nimUnloadLibrary($1);$n', [tmp]); - useMagic(m, 'nimLoadLibrary'); - useMagic(m, 'nimUnloadLibrary'); - useMagic(m, 'NimStringDesc'); - useMagic(m, 'nimLoadLibraryError'); - end; - if lib.name = nil then InternalError('loadDynamicLib'); -end; - -procedure SymInDynamicLib(m: BModule; sym: PSym); -var - lib: PLib; - extname, tmp: PRope; -begin - lib := sym.annex; - extname := sym.loc.r; - loadDynamicLib(m, lib); - useMagic(m, 'nimGetProcAddr'); - if gCmd = cmdCompileToLLVM then include(sym.loc.flags, lfIndirect); - - tmp := ropeff('Dl_$1', '@Dl_$1', [toRope(sym.id)]); - sym.loc.r := tmp; // from now on we only need the internal name - sym.typ.sym := nil; // generate a new name - inc(m.labels, 2); - appff(m.s[cfsDynLibInit], - '$1 = ($2) nimGetProcAddr($3, $4);$n', - '%MOC$5 = load i8* $3$n' + - '%MOC$6 = call $2 @nimGetProcAddr(i8* %MOC$5, i8* $4)$n' + - 'store $2 %MOC$6, $2* $1$n', - [tmp, getTypeDesc(m, sym.typ), lib.name, - cstringLit(m, m.s[cfsDynLibInit], ropeToStr(extname)), - toRope(m.labels), toRope(m.labels-1)]); - - appff(m.s[cfsVars], - '$2 $1;$n', - '$1 = linkonce global $2 zeroinitializer$n', - [sym.loc.r, getTypeDesc(m, sym.loc.t)]); -end; - -// ----------------------------- sections --------------------------------- - -procedure UseMagic(m: BModule; const name: string); -var - sym: PSym; -begin - sym := magicsys.getCompilerProc(name); - if sym <> nil then - case sym.kind of - skProc, skMethod, skConverter: genProc(m, sym); - skVar: genVarPrototype(m, sym); - skType: {@discard} getTypeDesc(m, sym.typ); - else InternalError('useMagic: ' + name) - end - else if not (sfSystemModule in m.module.flags) then - rawMessage(errSystemNeeds, name); // don't be too picky here -end; - -procedure generateHeaders(m: BModule); -var - it: PStrEntry; -begin - app(m.s[cfsHeaders], '#include "nimbase.h"' +{&} tnl +{&} tnl); - it := PStrEntry(m.headerFiles.head); - while it <> nil do begin - if not (it.data[strStart] in ['"', '<']) then - appf(m.s[cfsHeaders], - '#include "$1"$n', [toRope(it.data)]) - else - appf(m.s[cfsHeaders], '#include $1$n', [toRope(it.data)]); - it := PStrEntry(it.Next) - end -end; - -procedure getFrameDecl(p: BProc); -var - slots: PRope; -begin - if p.frameLen > 0 then begin - useMagic(p.module, 'TVarSlot'); - slots := ropeff(' TVarSlot s[$1];$n', - ', [$1 x %TVarSlot]', [toRope(p.frameLen)]) - end - else - slots := nil; - appff(p.s[cpsLocals], - 'volatile struct {TFrame* prev;' + - 'NCSTRING procname;NI line;NCSTRING filename;' + - 'NI len;$n$1} F;$n', - '%TF = type {%TFrame*, i8*, %NI, %NI$1}$n' + - '%F = alloca %TF$n', - [slots]); - inc(p.labels); - prepend(p.s[cpsInit], ropeff('F.len = $1;$n', - '%LOC$2 = getelementptr %TF %F, %NI 4$n' + - 'store %NI $1, %NI* %LOC$2$n', - [toRope(p.frameLen), toRope(p.labels)])) -end; - -function retIsNotVoid(s: PSym): bool; -begin - result := (s.typ.sons[0] <> nil) and not isInvalidReturnType(s.typ.sons[0]) -end; - -function initFrame(p: BProc; procname, filename: PRope): PRope; -begin - inc(p.labels, 5); - result := ropeff( - 'F.procname = $1;$n' + - 'F.prev = framePtr;$n' + - 'F.filename = $2;$n' + - 'F.line = 0;$n' + - 'framePtr = (TFrame*)&F;$n', - - '%LOC$3 = getelementptr %TF %F, %NI 1$n' + - '%LOC$4 = getelementptr %TF %F, %NI 0$n' + - '%LOC$5 = getelementptr %TF %F, %NI 3$n' + - '%LOC$6 = getelementptr %TF %F, %NI 2$n' + - - 'store i8* $1, i8** %LOC$3$n' + - 'store %TFrame* @framePtr, %TFrame** %LOC$4$n' + - 'store i8* $2, i8** %LOC$5$n' + - 'store %NI 0, %NI* %LOC$6$n' + - - '%LOC$7 = bitcast %TF* %F to %TFrame*$n' + - 'store %TFrame* %LOC$7, %TFrame** @framePtr$n', - [procname, filename, toRope(p.labels), toRope(p.labels-1), - toRope(p.labels-2), toRope(p.labels-3), toRope(p.labels-4)]); -end; - -function deinitFrame(p: BProc): PRope; -begin - inc(p.labels, 3); - result := ropeff('framePtr = framePtr->prev;$n', - - '%LOC$1 = load %TFrame* @framePtr$n' + - '%LOC$2 = getelementptr %TFrame* %LOC$1, %NI 0$n' + - '%LOC$3 = load %TFrame** %LOC$2$n' + - 'store %TFrame* $LOC$3, %TFrame** @framePtr', [ - toRope(p.labels), toRope(p.labels-1), toRope(p.labels-2)]) -end; - -procedure genProcAux(m: BModule; prc: PSym); -var - p: BProc; - generatedProc, header, returnStmt, procname, filename: PRope; - i: int; - res, param: PSym; -begin - p := newProc(prc, m); - header := genProcHeader(m, prc); - if (gCmd <> cmdCompileToLLVM) and (lfExportLib in prc.loc.flags) then - header := con('N_LIB_EXPORT ', header); - returnStmt := nil; - assert(prc.ast <> nil); - - 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 - // declare the result symbol: - assignLocalVar(p, res); - assert(res.loc.r <> nil); - returnStmt := ropeff('return $1;$n', 'ret $1$n', [rdLoc(res.loc)]); - end - else begin - fillResult(res); - assignParam(p, res); - if skipTypes(res.typ, abstractInst).kind = tyArray then begin - include(res.loc.flags, lfIndirect); - res.loc.s := OnUnknown; - end; - 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; - assignParam(p, param) - end; - - genStmts(p, prc.ast.sons[codePos]); // modifies p.locals, p.init, etc. - if sfPure in prc.flags then - generatedProc := ropeff('$1 {$n$2$3$4}$n', 'define $1 {$n$2$3$4}$n', - [header, p.s[cpsLocals], p.s[cpsInit], p.s[cpsStmts]]) - else begin - generatedProc := ropeff('$1 {$n', 'define $1 {$n', [header]); - if optStackTrace in prc.options then begin - getFrameDecl(p); - app(generatedProc, p.s[cpsLocals]); - procname := CStringLit(p, generatedProc, - prc.owner.name.s +{&} '.' +{&} prc.name.s); - filename := CStringLit(p, generatedProc, toFilename(prc.info)); - app(generatedProc, initFrame(p, procname, filename)); - end - else - app(generatedProc, p.s[cpsLocals]); - if (optProfiler in prc.options) and (gCmd <> cmdCompileToLLVM) 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, p.s[cpsInit]); - app(generatedProc, p.s[cpsStmts]); - if p.beforeRetNeeded then - app(generatedProc, 'BeforeRet: ;' + tnl); - if optStackTrace in prc.options then - app(generatedProc, deinitFrame(p)); - if (optProfiler in prc.options) and (gCmd <> cmdCompileToLLVM) then - appf(generatedProc, - 'profileData[$1].total += elapsed(getticks(), NIM_profilingStart);$n', - [toRope(prc.loc.a)]); - app(generatedProc, returnStmt); - app(generatedProc, '}' + tnl); - end; - app(m.s[cfsProcs], generatedProc); - //if prc.kind = skMethod then addMethodToCompile(gNimDat, prc); -end; - -procedure genProcPrototype(m: BModule; sym: PSym); -begin - useHeader(m, sym); - if (lfNoDecl in sym.loc.Flags) then exit; - if lfDynamicLib in sym.loc.Flags then begin - if (sym.owner.id <> m.module.id) and - not intSetContainsOrIncl(m.declaredThings, sym.id) then begin - appff(m.s[cfsVars], 'extern $1 Dl_$2;$n', - '@Dl_$2 = linkonce global $1 zeroinitializer$n', - [getTypeDesc(m, sym.loc.t), toRope(sym.id)]); - if gCmd = cmdCompileToLLVM then include(sym.loc.flags, lfIndirect); - end - end - else begin - if not IntSetContainsOrIncl(m.declaredProtos, sym.id) then begin - appf(m.s[cfsProcHeaders], '$1;$n', [genProcHeader(m, sym)]); - end - end -end; - -procedure genProcNoForward(m: BModule; prc: PSym); -begin - fillProcLoc(prc); - useHeader(m, prc); - genProcPrototype(m, prc); - if (lfNoDecl in prc.loc.Flags) then exit; - if prc.typ.callConv = ccInline then begin - // We add inline procs to the calling module to enable C based inlining. - // This also means that a check with ``gGeneratedSyms`` is wrong, we need - // a check for ``m.declaredThings``. - if not intSetContainsOrIncl(m.declaredThings, prc.id) then - genProcAux(m, prc); - end - else if lfDynamicLib in prc.loc.flags then begin - if not IntSetContainsOrIncl(gGeneratedSyms, prc.id) then - SymInDynamicLib(findPendingModule(m, prc), prc); - end - else if not (sfImportc in prc.flags) then begin - if not IntSetContainsOrIncl(gGeneratedSyms, prc.id) then - genProcAux(findPendingModule(m, prc), prc); - end -end; - -procedure genProc(m: BModule; prc: PSym); -begin - if sfBorrow in prc.flags then exit; - fillProcLoc(prc); - if [sfForward, sfFromGeneric] * prc.flags <> [] then - addForwardedProc(m, prc) - else - genProcNoForward(m, prc) -end; - -procedure genVarPrototype(m: BModule; sym: PSym); -begin - assert(sfGlobal in sym.flags); - useHeader(m, sym); - fillLoc(sym.loc, locGlobalVar, sym.typ, mangleName(sym), OnHeap); - if (lfNoDecl in sym.loc.Flags) or - intSetContainsOrIncl(m.declaredThings, sym.id) then - exit; - if sym.owner.id <> m.module.id then begin - // else we already have the symbol generated! - assert(sym.loc.r <> nil); - if gCmd = cmdCompileToLLVM then begin - include(sym.loc.flags, lfIndirect); - appf(m.s[cfsVars], '$1 = linkonce global $2 zeroinitializer$n', - [sym.loc.r, getTypeDesc(m, sym.loc.t)]); - end - else begin - app(m.s[cfsVars], 'extern '); - app(m.s[cfsVars], getTypeDesc(m, sym.loc.t)); - if sfRegister in sym.flags then - 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 -end; - -procedure genConstPrototype(m: BModule; sym: PSym); -begin - useHeader(m, sym); - if sym.loc.k = locNone then - fillLoc(sym.loc, locData, sym.typ, mangleName(sym), OnUnknown); - if (lfNoDecl in sym.loc.Flags) or - intSetContainsOrIncl(m.declaredThings, sym.id) then - exit; - if sym.owner.id <> m.module.id then begin - // else we already have the symbol generated! - assert(sym.loc.r <> nil); - appff(m.s[cfsData], - 'extern NIM_CONST $1 $2;$n', - '$1 = linkonce constant $2 zeroinitializer', - [getTypeDesc(m, sym.loc.t), sym.loc.r]) - end -end; - -function getFileHeader(const cfilenoext: string): PRope; -begin - if optCompileOnly in gGlobalOptions then - result := ropeff( - '/* Generated by Nimrod Compiler v$1 */$n' + - '/* (c) 2009 Andreas Rumpf */$n', - '; Generated by Nimrod Compiler v$1$n' + - '; (c) 2009 Andreas Rumpf$n', - [toRope(versionAsString)]) - else - result := ropeff( - '/* Generated by Nimrod Compiler v$1 */$n' + - '/* (c) 2009 Andreas Rumpf */$n' + - '/* Compiled for: $2, $3, $4 */$n' + - '/* Command for C compiler:$n $5 */$n', - '; Generated by Nimrod Compiler v$1$n' + - '; (c) 2009 Andreas Rumpf$n' + - '; Compiled for: $2, $3, $4$n' + - '; Command for LLVM 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: appff(result, '$ntypedef short int NI;$n' + - 'typedef unsigned short int NU;$n', - '$n%NI = type i16$n', []); - 32: appff(result, '$ntypedef long int NI;$n' + - 'typedef unsigned long int NU;$n', - '$n%NI = type i32$n', []); - 64: appff(result, '$ntypedef long long int NI;$n' + - 'typedef unsigned long long int NU;$n', - '$n%NI = type i64$n', []); - else begin end - end -end; - -procedure genMainProc(m: BModule); -const - CommonMainBody = - ' setStackBottom(dummy);$n' + - ' nim__datInit();$n' + - ' systemInit();$n' + - '$1' + - '$2'; - CommonMainBodyLLVM = - ' %MOC$3 = bitcast [8 x %NI]* %dummy to i8*$n' + - ' call void @setStackBottom(i8* %MOC$3)$n' + - ' call void @nim__datInit()$n' + - ' call void systemInit()$n' + - '$1' + - '$2'; - PosixNimMain = - 'int cmdCount;$n' + - 'char** cmdLine;$n' + - 'char** gEnv;$n' + - 'N_CDECL(void, NimMain)(void) {$n' + - ' int dummy[8];$n' +{&} - CommonMainBody +{&} - '}$n'; - PosixCMain = - 'int main(int argc, char** args, char** env) {$n' + - ' cmdLine = args;$n' + - ' cmdCount = argc;$n' + - ' gEnv = env;$n' + - ' NimMain();$n' + - ' return 0;$n' + - '}$n'; - PosixNimMainLLVM = - '@cmdCount = linkonce i32$n' + - '@cmdLine = linkonce i8**$n' + - '@gEnv = linkonce i8**$n' + - 'define void @NimMain(void) {$n' + - ' %dummy = alloca [8 x %NI]$n' +{&} - CommonMainBodyLLVM +{&} - '}$n'; - PosixCMainLLVM = - 'define i32 @main(i32 %argc, i8** %args, i8** %env) {$n' + - ' store i8** %args, i8*** @cmdLine$n' + - ' store i32 %argc, i32* @cmdCount$n' + - ' store i8** %env, i8*** @gEnv$n' + - ' call void @NimMain()$n' + - ' ret i32 0$n' + - '}$n'; - WinNimMain = - 'N_CDECL(void, NimMain)(void) {$n' + - ' int dummy[8];$n' +{&} - CommonMainBody +{&} - '}$n'; - WinCMain = - 'N_STDCALL(int, WinMain)(HINSTANCE hCurInstance, $n' + - ' HINSTANCE hPrevInstance, $n' + - ' LPSTR lpCmdLine, int nCmdShow) {$n' + - ' NimMain();$n' + - ' return 0;$n' + - '}$n'; - WinNimMainLLVM = - 'define void @NimMain(void) {$n' + - ' %dummy = alloca [8 x %NI]$n' +{&} - CommonMainBodyLLVM +{&} - '}$n'; - WinCMainLLVM = - 'define stdcall i32 @WinMain(i32 %hCurInstance, $n' + - ' i32 %hPrevInstance, $n' + - ' i8* %lpCmdLine, i32 %nCmdShow) {$n' + - ' call void @NimMain()$n' + - ' ret i32 0$n' + - '}$n'; - WinNimDllMain = - 'N_LIB_EXPORT N_CDECL(void, NimMain)(void) {$n' + - ' int dummy[8];$n' +{&} - CommonMainBody +{&} - '}$n'; - WinCDllMain = - 'BOOL WINAPI DllMain(HINSTANCE hinstDLL, DWORD fwdreason, $n' + - ' LPVOID lpvReserved) {$n' + - ' NimMain();$n' + - ' return 1;$n' + - '}$n'; - WinNimDllMainLLVM = WinNimMainLLVM; - WinCDllMainLLVM = - 'define stdcall i32 @DllMain(i32 %hinstDLL, i32 %fwdreason, $n' + - ' i8* %lpvReserved) {$n' + - ' call void @NimMain()$n' + - ' ret i32 1$n' + - '}$n'; -var - nimMain, otherMain: TFormatStr; -begin - useMagic(m, 'setStackBottom'); - if (platform.targetOS = osWindows) and - (gGlobalOptions * [optGenGuiApp, optGenDynLib] <> []) then begin - if optGenGuiApp in gGlobalOptions then begin - if gCmd = cmdCompileToLLVM then begin - nimMain := WinNimMainLLVM; - otherMain := WinCMainLLVM - end - else begin - nimMain := WinNimMain; - otherMain := WinCMain; - end - end - else begin - if gCmd = cmdCompileToLLVM then begin - nimMain := WinNimDllMainLLVM; - otherMain := WinCDllMainLLVM; - end - else begin - nimMain := WinNimDllMain; - otherMain := WinCDllMain; - end - end; - {@discard} lists.IncludeStr(m.headerFiles, '<windows.h>') - end - else begin - if gCmd = cmdCompileToLLVM then begin - nimMain := PosixNimMainLLVM; - otherMain := PosixCMainLLVM; - end - else begin - nimMain := PosixNimMain; - otherMain := PosixCMain; - end - end; - if gBreakpoints <> nil then useMagic(m, 'dbgRegisterBreakpoint'); - inc(m.labels); - appf(m.s[cfsProcs], nimMain, [gBreakpoints, mainModInit, toRope(m.labels)]); - if not (optNoMain in gGlobalOptions) then - appf(m.s[cfsProcs], otherMain, []); -end; - -function getInitName(m: PSym): PRope; -begin - result := ropeff('$1Init', '@$1Init', [toRope(m.name.s)]); -end; - -procedure registerModuleToMain(m: PSym); -var - initname: PRope; -begin - initname := getInitName(m); - appff(mainModProcs, 'N_NOINLINE(void, $1)(void);$n', - 'declare void $1() noinline$n', [initname]); - if not (sfSystemModule in m.flags) then - appff(mainModInit, '$1();$n', 'call void ()* $1$n', [initname]); -end; - -procedure genInitCode(m: BModule); -var - initname, prc, procname, filename: PRope; -begin - 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); - prc := ropeff('N_NOINLINE(void, $1)(void) {$n', - 'define void $1() noinline {$n', [initname]); - if m.typeNodes > 0 then begin - useMagic(m, 'TNimNode'); - appff(m.s[cfsTypeInit1], 'static TNimNode $1[$2];$n', - '$1 = private alloca [$2 x @TNimNode]$n', - [m.typeNodesName, toRope(m.typeNodes)]); - end; - if m.nimTypes > 0 then begin - useMagic(m, 'TNimType'); - appff(m.s[cfsTypeInit1], 'static TNimType $1[$2];$n', - '$1 = private alloca [$2 x @TNimType]$n', - [m.nimTypesName, toRope(m.nimTypes)]); - end; - if optStackTrace in m.initProc.options then begin - getFrameDecl(m.initProc); - app(prc, m.initProc.s[cpsLocals]); - app(prc, m.s[cfsTypeInit1]); - - procname := CStringLit(m.initProc, prc, 'module ' +{&} m.module.name.s); - filename := CStringLit(m.initProc, prc, toFilename(m.module.info)); - app(prc, initFrame(m.initProc, procname, filename)); - end - else begin - app(prc, m.initProc.s[cpsLocals]); - app(prc, m.s[cfsTypeInit1]); - end; - app(prc, m.s[cfsTypeInit2]); - app(prc, m.s[cfsTypeInit3]); - app(prc, m.s[cfsDebugInit]); - app(prc, m.s[cfsDynLibInit]); - app(prc, m.initProc.s[cpsInit]); - app(prc, m.initProc.s[cpsStmts]); - if optStackTrace in m.initProc.options then - app(prc, deinitFrame(m.initProc)); - app(prc, '}' +{&} tnl +{&} tnl); - app(m.s[cfsProcs], prc) -end; - -function genModule(m: BModule; const cfilenoext: string): PRope; -var - i: TCFileSection; -begin - result := getFileHeader(cfilenoext); - generateHeaders(m); - for i := low(TCFileSection) to cfsProcs do app(result, m.s[i]) -end; - -function rawNewModule(module: PSym; const filename: string): BModule; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - InitLinkedList(result.headerFiles); - intSetInit(result.declaredThings); - intSetInit(result.declaredProtos); - 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; - initNodeTable(result.dataCache); -{@emit result.typeStack := @[];} -{@emit result.forwardedProcs := @[];} - result.typeNodesName := getTempName(); - result.nimTypesName := getTempName(); -end; - -function newModule(module: PSym; const filename: string): BModule; -begin - result := rawNewModule(module, filename); - if (optDeadCodeElim in gGlobalOptions) then begin - if (sfDeadCodeElim in module.flags) then - InternalError('added pending module twice: ' + filename); - addPendingModule(result) - end; -end; - -procedure registerTypeInfoModule(); -const - moduleName = 'nim__dat'; -var - s: PSym; -begin - s := NewSym(skModule, getIdent(moduleName), nil); - gNimDat := rawNewModule(s, joinPath(options.projectPath, moduleName)+'.nim'); - addPendingModule(gNimDat); - appff(mainModProcs, 'N_NOINLINE(void, $1)(void);$n', - 'declare void $1() noinline$n', [getInitName(s)]); -end; - -function myOpen(module: PSym; const filename: string): PPassContext; -begin - if gNimDat = nil then registerTypeInfoModule(); - result := newModule(module, filename); -end; - -function myOpenCached(module: PSym; const filename: string; - rd: PRodReader): PPassContext; -var - cfile, cfilenoext, objFile: string; -begin - if gNimDat = nil then registerTypeInfoModule(); - //MessageOut('cgen.myOpenCached has been called ' + filename); - cfile := changeFileExt(completeCFilePath(filename), cExt); - cfilenoext := changeFileExt(cfile, ''); - addFileToLink(cfilenoext); - registerModuleToMain(module); - // XXX: this cannot be right here, initalization has to be appended during - // the ``myClose`` call - result := nil; -end; - -function shouldRecompile(code: PRope; const cfile, cfilenoext: string): bool; -var - objFile: string; -begin - result := true; - 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 - result := false - end - else - writeRope(code, cfile); -end; - -function myProcess(b: PPassContext; n: PNode): PNode; -var - m: BModule; -begin - result := n; - if b = nil then exit; - m := BModule(b); - m.initProc.options := gOptions; - genStmts(m.initProc, n); -end; - -procedure finishModule(m: BModule); -var - i: int; - prc: PSym; -begin - i := 0; - while i <= high(m.forwardedProcs) do begin - // Note: ``genProc`` may add to ``m.forwardedProcs``, so we cannot use - // a ``for`` loop here - prc := m.forwardedProcs[i]; - if sfForward in prc.flags then InternalError(prc.info, 'still forwarded'); - genProcNoForward(m, prc); - inc(i); - end; - assert(gForwardedProcsCounter >= i); - dec(gForwardedProcsCounter, i); - setLength(m.forwardedProcs, 0); -end; - -procedure writeModule(m: BModule); -var - cfile, cfilenoext: string; - code: PRope; -begin - // 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 main file: - app(m.s[cfsProcHeaders], mainModProcs); - end; - code := genModule(m, cfilenoext); - if shouldRecompile(code, changeFileExt(cfile, cExt), cfilenoext) then begin - addFileToCompile(cfilenoext); - end; - addFileToLink(cfilenoext); -end; - -function myClose(b: PPassContext; n: PNode): PNode; -var - m: BModule; - i: int; - disp: PNode; -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; - registerModuleToMain(m.module); - if not (optDeadCodeElim in gGlobalOptions) and - not (sfDeadCodeElim in m.module.flags) then - finishModule(m); - if sfMainModule in m.module.flags then begin - disp := generateMethodDispatchers(); - for i := 0 to sonsLen(disp)-1 do genProcAux(gNimDat, disp.sons[i].sym); - genMainProc(m); - // we need to process the transitive closure because recursive module - // deps are allowed (and the system module is processed in the wrong - // order anyway) - while gForwardedProcsCounter > 0 do - for i := 0 to high(gPendingModules) do - finishModule(gPendingModules[i]); - for i := 0 to high(gPendingModules) do writeModule(gPendingModules[i]); - setLength(gPendingModules, 0); - end; - if not (optDeadCodeElim in gGlobalOptions) and - not (sfDeadCodeElim in m.module.flags) then - writeModule(m); - if sfMainModule in m.module.flags then - writeMapping(gMapping); -end; - -function cgenPass(): TPass; -begin - initPass(result); - result.open := myOpen; - result.openCached := myOpenCached; - result.process := myProcess; - result.close := myClose; -end; - -initialization - InitIiTable(gToTypeInfoId); - IntSetInit(gGeneratedSyms); -end. diff --git a/nim/cgmeth.pas b/nim/cgmeth.pas deleted file mode 100755 index 6b9335c4c..000000000 --- a/nim/cgmeth.pas +++ /dev/null @@ -1,269 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -unit cgmeth; - -// This module implements code generation for multi methods. - -interface - -{$include 'config.inc'} - -uses - sysutils, nsystem, - options, ast, astalgo, msgs, idents, rnimsyn, types, magicsys; - -procedure methodDef(s: PSym); -function methodCall(n: PNode): PNode; -function generateMethodDispatchers(): PNode; - -implementation - -const - skipPtrs = {@set}[tyVar, tyPtr, tyRef, tyGenericInst]; - -function genConv(n: PNode; d: PType; downcast: bool): PNode; -var - dest, source: PType; - diff: int; -begin - dest := skipTypes(d, abstractPtrs); - source := skipTypes(n.typ, abstractPtrs); - if (source.kind = tyObject) and (dest.kind = tyObject) then begin - diff := inheritanceDiff(dest, source); - if diff = high(int) then InternalError(n.info, 'cgmeth.genConv'); - if diff < 0 then begin - result := newNodeIT(nkObjUpConv, n.info, d); - addSon(result, n); - if downCast then - InternalError(n.info, 'cgmeth.genConv: no upcast allowed'); - end - else if diff > 0 then begin - result := newNodeIT(nkObjDownConv, n.info, d); - addSon(result, n); - if not downCast then - InternalError(n.info, 'cgmeth.genConv: no downcast allowed'); - end - else result := n - end - else result := n -end; - -function methodCall(n: PNode): PNode; -var - disp: PSym; - i: int; -begin - result := n; - disp := lastSon(result.sons[0].sym.ast).sym; - result.sons[0].sym := disp; - for i := 1 to sonsLen(result)-1 do - result.sons[i] := genConv(result.sons[i], disp.typ.sons[i], true) -end; - -var - gMethods: array of TSymSeq; - -function sameMethodBucket(a, b: PSym): bool; -var - i: int; - aa, bb: PType; -begin - result := false; - if a.name.id <> b.name.id then exit; - if sonsLen(a.typ) <> sonsLen(b.typ) then exit; - // check for return type: - if not sameTypeOrNil(a.typ.sons[0], b.typ.sons[0]) then exit; - for i := 1 to sonsLen(a.typ)-1 do begin - aa := a.typ.sons[i]; - bb := b.typ.sons[i]; - while true do begin - aa := skipTypes(aa, {@set}[tyGenericInst]); - bb := skipTypes(bb, {@set}[tyGenericInst]); - if (aa.kind = bb.kind) and (aa.kind in [tyVar, tyPtr, tyRef]) then begin - aa := aa.sons[0]; - bb := bb.sons[0]; - end - else - break - end; - if sameType(aa, bb) - or (aa.kind = tyObject) and (bb.kind = tyObject) - and (inheritanceDiff(bb, aa) < 0) then begin end - else exit; - end; - result := true -end; - -procedure methodDef(s: PSym); -var - i, L, q: int; - disp: PSym; -begin - L := length(gMethods); - for i := 0 to L-1 do begin - if sameMethodBucket(gMethods[i][0], s) then begin - {@ignore} - q := length(gMethods[i]); - setLength(gMethods[i], q+1); - gMethods[i][q] := s; - {@emit - add(gMethods[i], s); - } - // store a symbol to the dispatcher: - addSon(s.ast, lastSon(gMethods[i][0].ast)); - exit - end - end; -{@ignore} - setLength(gMethods, L+1); - setLength(gMethods[L], 1); - gMethods[L][0] := s; -{@emit - add(gMethods, @[s]); -} - // create a new dispatcher: - disp := copySym(s); - disp.typ := copyType(disp.typ, disp.typ.owner, false); - if disp.typ.callConv = ccInline then disp.typ.callConv := ccDefault; - disp.ast := copyTree(s.ast); - disp.ast.sons[codePos] := nil; - if s.typ.sons[0] <> nil then - disp.ast.sons[resultPos].sym := copySym(s.ast.sons[resultPos].sym); - addSon(s.ast, newSymNode(disp)); -end; - -function relevantCol(methods: TSymSeq; col: int): bool; -var - t: PType; - i: int; -begin - // returns true iff the position is relevant - t := methods[0].typ.sons[col]; - result := false; - if skipTypes(t, skipPtrs).kind = tyObject then - for i := 1 to high(methods) do - if not SameType(methods[i].typ.sons[col], t) then begin - result := true; exit - end -end; - -function cmpSignatures(a, b: PSym; const relevantCols: TIntSet): int; -var - col, d: int; - aa, bb: PType; -begin - result := 0; - for col := 1 to sonsLen(a.typ)-1 do - if intSetContains(relevantCols, col) then begin - aa := skipTypes(a.typ.sons[col], skipPtrs); - bb := skipTypes(b.typ.sons[col], skipPtrs); - d := inheritanceDiff(aa, bb); - if (d <> high(int)) then begin - result := d; exit - end - end -end; - -procedure sortBucket(var a: TSymSeq; const relevantCols: TIntSet); -// we use shellsort here; fast and simple -var - N, i, j, h: int; - v: PSym; -begin - N := length(a); - h := 1; repeat h := 3*h+1; until h > N; - repeat - h := h div 3; - for i := h to N-1 do begin - v := a[i]; j := i; - while cmpSignatures(a[j-h], v, relevantCols) >= 0 do begin - a[j] := a[j-h]; j := j - h; - if j < h then break - end; - a[j] := v; - end; - until h = 1 -end; - -function genDispatcher(methods: TSymSeq; const relevantCols: TIntSet): PSym; -var - disp, cond, call, ret, a, isn: PNode; - base, curr, ands, iss: PSym; - meth, col, paramLen: int; -begin - base := lastSon(methods[0].ast).sym; - result := base; - paramLen := sonsLen(base.typ); - disp := newNodeI(nkIfStmt, base.info); - ands := getSysSym('and'); - iss := getSysSym('is'); - for meth := 0 to high(methods) do begin - curr := methods[meth]; - // generate condition: - cond := nil; - for col := 1 to paramLen-1 do begin - if IntSetContains(relevantCols, col) then begin - isn := newNodeIT(nkCall, base.info, getSysType(tyBool)); - addSon(isn, newSymNode(iss)); - addSon(isn, newSymNode(base.typ.n.sons[col].sym)); - addSon(isn, newNodeIT(nkType, base.info, curr.typ.sons[col])); - if cond <> nil then begin - a := newNodeIT(nkCall, base.info, getSysType(tyBool)); - addSon(a, newSymNode(ands)); - addSon(a, cond); - addSon(a, isn); - cond := a - end - else - cond := isn - end - end; - // generate action: - call := newNodeI(nkCall, base.info); - addSon(call, newSymNode(curr)); - for col := 1 to paramLen-1 do begin - addSon(call, genConv(newSymNode(base.typ.n.sons[col].sym), - curr.typ.sons[col], false)); - end; - if base.typ.sons[0] <> nil then begin - a := newNodeI(nkAsgn, base.info); - addSon(a, newSymNode(base.ast.sons[resultPos].sym)); - addSon(a, call); - ret := newNodeI(nkReturnStmt, base.info); - addSon(ret, a); - end - else - ret := call; - a := newNodeI(nkElifBranch, base.info); - addSon(a, cond); - addSon(a, ret); - addSon(disp, a); - end; - result.ast.sons[codePos] := disp; -end; - -function generateMethodDispatchers(): PNode; -var - bucket, col: int; - relevantCols: TIntSet; -begin - result := newNode(nkStmtList); - for bucket := 0 to length(gMethods)-1 do begin - IntSetInit(relevantCols); - for col := 1 to sonsLen(gMethods[bucket][0].typ)-1 do - if relevantCol(gMethods[bucket], col) then IntSetIncl(relevantCols, col); - sortBucket(gMethods[bucket], relevantCols); - addSon(result, newSymNode(genDispatcher(gMethods[bucket], relevantCols))); - end -end; - -initialization - {@emit gMethods := @[]; } -end. diff --git a/nim/charsets.pas b/nim/charsets.pas deleted file mode 100755 index a5f14450f..000000000 --- a/nim/charsets.pas +++ /dev/null @@ -1,56 +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 charsets; - -interface - -const - CharSize = SizeOf(Char); - Lrz = ' '; - Apo = ''''; - Tabulator = #9; - ESC = #27; - CR = #13; - FF = #12; - LF = #10; - BEL = #7; - BACKSPACE = #8; - VT = #11; -{$ifdef macos} - DirSep = ':'; - NL = CR + ''; - FirstNLchar = CR; - PathSep = ';'; // XXX: is this correct? -{$else} - {$ifdef unix} - DirSep = '/'; - NL = LF + ''; - FirstNLchar = LF; - PathSep = ':'; - {$else} // windows, dos - DirSep = '\'; - NL = CR + LF; - FirstNLchar = CR; - DriveSeparator = ':'; - PathSep = ';'; - {$endif} -{$endif} - UpLetters = ['A'..'Z', #192..#222]; - DownLetters = ['a'..'z', #223..#255]; - Numbers = ['0'..'9']; - Letters = UpLetters + DownLetters; - -type - TCharSet = set of Char; - PCharSet = ^TCharSet; - -implementation - -end. diff --git a/nim/commands.pas b/nim/commands.pas deleted file mode 100755 index 19f79fb4a..000000000 --- a/nim/commands.pas +++ /dev/null @@ -1,588 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -unit commands; - -// This module handles the parsing of command line arguments. - -interface - -{$include 'config.inc'} - -uses - nsystem, charsets, nos, msgs, options, nversion, condsyms, strutils, extccomp, - platform, lists, wordrecg; - -procedure writeCommandLineUsage; - -type - TCmdLinePass = ( - passCmd1, // first pass over the command line - passCmd2, // second pass over the command line - passPP // preprocessor called ProcessCommand() - ); - -procedure ProcessCommand(const switch: string; pass: TCmdLinePass); -procedure processSwitch(const switch, arg: string; pass: TCmdlinePass; - const info: TLineInfo); - -implementation - -{@ignore} -const -{$ifdef fpc} - compileDate = {$I %date%}; -{$else} - compileDate = '2009-0-0'; -{$endif} -{@emit} - -const - HelpMessage = 'Nimrod Compiler Version $1 (' +{&} - compileDate +{&} ') [$2: $3]' +{&} nl +{&} - 'Copyright (c) 2004-2009 by Andreas Rumpf' +{&} nl; - -const - Usage = '' -//[[[cog -//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, c compile project with default code generator (C)' +{&} nl -+{&} ' compileToC, cc compile project with C code generator' +{&} nl -+{&} ' doc generate the documentation for inputfile' +{&} nl -+{&} ' rst2html converts a reStructuredText file to HTML' +{&} nl -+{&} ' rst2tex converts a reStructuredText file to TeX' +{&} nl -+{&} 'Arguments:' +{&} nl -+{&} ' arguments are passed to the program being run (if --run option is selected)' +{&} nl -+{&} 'Options:' +{&} nl -+{&} ' -p, --path:PATH add path to search paths' +{&} nl -+{&} ' -o, --out:FILE set the output filename' +{&} nl -+{&} ' -d, --define:SYMBOL define a conditional symbol' +{&} nl -+{&} ' -u, --undef:SYMBOL undefine a conditional symbol' +{&} nl -+{&} ' -f, --forceBuild force rebuilding of all modules' +{&} nl -+{&} ' --symbolFiles:on|off use symbol files to speed up compilation (buggy!)' +{&} nl -+{&} ' --stackTrace:on|off code generation for stack trace ON|OFF' +{&} nl -+{&} ' --lineTrace:on|off code generation for line trace ON|OFF' +{&} nl -+{&} ' --debugger:on|off turn Embedded Nimrod Debugger ON|OFF' +{&} nl -+{&} ' -x, --checks:on|off code generation for all runtime checks ON|OFF' +{&} nl -+{&} ' --objChecks:on|off code generation for obj conversion checks ON|OFF' +{&} nl -+{&} ' --fieldChecks:on|off code generation for case variant fields ON|OFF' +{&} nl -+{&} ' --rangeChecks:on|off code generation for range checks ON|OFF' +{&} nl -+{&} ' --boundChecks:on|off code generation for bound checks ON|OFF' +{&} nl -+{&} ' --overflowChecks:on|off code generation for over-/underflow checks ON|OFF' +{&} nl -+{&} ' -a, --assertions:on|off code generation for assertions ON|OFF' +{&} nl -+{&} ' --deadCodeElim:on|off whole program dead code elimination ON|OFF' +{&} nl -+{&} ' --opt:none|speed|size optimize not at all or for speed|size' +{&} nl -+{&} ' --app:console|gui|lib generate a console|GUI application|dynamic library' +{&} nl -+{&} ' -r, --run run the compiled program with given arguments' +{&} nl -+{&} ' --advanced show advanced command line switches' +{&} nl -+{&} ' -h, --help show this help' +{&} nl -//[[[end]]] - ; - - AdvancedUsage = '' -//[[[cog -//for line in open("data/advopt.txt").readlines(): -// cog.outl(f(line)) -//]]] -+{&} 'Advanced commands::' +{&} nl -+{&} ' pas convert a Pascal file to Nimrod syntax' +{&} nl -+{&} ' pretty pretty print the inputfile' +{&} nl -+{&} ' genDepend generate a DOT file containing the' +{&} nl -+{&} ' module dependency graph' +{&} nl -+{&} ' listDef list all defined conditionals and exit' +{&} nl -+{&} ' check checks the project for syntax and semantic' +{&} nl -+{&} ' parse parses a single file (for debugging Nimrod)' +{&} 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 -+{&} ' --lib:PATH set the system library path' +{&} nl -+{&} ' -c, --compileOnly compile only; do not assemble or link' +{&} nl -+{&} ' --noLinking compile but do not link' +{&} nl -+{&} ' --noMain do not generate a main procedure' +{&} nl -+{&} ' --genScript 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 -+{&} ' --debuginfo enables debug information' +{&} nl -+{&} ' -t, --passc:OPTION pass an option to the C compiler' +{&} nl -+{&} ' -l, --passl:OPTION pass an option to the linker' +{&} nl -+{&} ' --genMapping generate a mapping file containing' +{&} nl -+{&} ' (Nimrod, mangled) identifier pairs' +{&} nl -+{&} ' --lineDir:on|off generation of #line directive ON|OFF' +{&} nl -+{&} ' --checkpoints:on|off turn on|off checkpoints; for debugging Nimrod' +{&} nl -+{&} ' --skipCfg do not read the general configuration file' +{&} nl -+{&} ' --skipProjCfg do not read the project''s configuration file' +{&} nl -+{&} ' --gc:refc|boehm|none use Nimrod''s native GC|Boehm GC|no GC' +{&} nl -+{&} ' --index:FILE use FILE to generate a documenation index file' +{&} nl -+{&} ' --putenv:key=value set an environment variable' +{&} nl -+{&} ' --listCmd list the commands used to execute external programs' +{&} nl -+{&} ' --parallelBuild=0|1|... perform a parallel build' +{&} nl -+{&} ' value = number of processors (0 for auto-detect)' +{&} nl -+{&} ' --verbosity:0|1|2|3 set Nimrod''s verbosity level (0 is default)' +{&} nl -+{&} ' -v, --version show detailed version information' +{&} nl -//[[[end]]] - ; - -function getCommandLineDesc: string; -begin - result := format(HelpMessage, [VersionAsString, - platform.os[platform.hostOS].name, cpu[platform.hostCPU].name]) +{&} Usage -end; - -var - helpWritten: boolean; // BUGFIX 19 - versionWritten: boolean; - advHelpWritten: boolean; - -procedure HelpOnError(pass: TCmdLinePass); -begin - if (pass = passCmd1) and not helpWritten then begin - // BUGFIX 19 - MessageOut(getCommandLineDesc()); - helpWritten := true; - halt(0); - end -end; - -procedure writeAdvancedUsage(pass: TCmdLinePass); -begin - if (pass = passCmd1) and not advHelpWritten then begin - // BUGFIX 19 - MessageOut(format(HelpMessage, [VersionAsString, - platform.os[platform.hostOS].name, - cpu[platform.hostCPU].name]) +{&} - AdvancedUsage); - advHelpWritten := true; - helpWritten := true; - halt(0); - end -end; - -procedure writeVersionInfo(pass: TCmdLinePass); -begin - if (pass = passCmd1) and not versionWritten then begin - versionWritten := true; - helpWritten := true; - messageOut(format(HelpMessage, [VersionAsString, - platform.os[platform.hostOS].name, - cpu[platform.hostCPU].name])); - halt(0); - end -end; - -procedure writeCommandLineUsage; -begin - if not helpWritten then begin - messageOut(getCommandLineDesc()); - helpWritten := true - end -end; - -procedure InvalidCmdLineOption(pass: TCmdLinePass; const switch: string; - const info: TLineInfo); -begin - liMessage(info, errInvalidCmdLineOption, switch) -end; - -procedure splitSwitch(const switch: string; out cmd, arg: string; - pass: TCmdLinePass; const info: TLineInfo); -var - i: int; -begin - cmd := ''; - i := strStart; - if (i < length(switch)+strStart) and (switch[i] = '-') then inc(i); - if (i < length(switch)+strStart) and (switch[i] = '-') then inc(i); - while i < length(switch) + strStart do begin - case switch[i] of - 'a'..'z', 'A'..'Z', '0'..'9', '_', '.': - addChar(cmd, switch[i]); - else break; - end; - inc(i); - end; - if i >= length(switch) + strStart then - arg := '' - else if switch[i] in [':', '=', '['] then - arg := ncopy(switch, i + 1) - else - InvalidCmdLineOption(pass, switch, info) -end; - -procedure ProcessOnOffSwitch(const op: TOptions; const arg: string; - pass: TCmdlinePass; const info: TLineInfo); -begin - case whichKeyword(arg) of - wOn: gOptions := gOptions + op; - wOff: gOptions := gOptions - op; - else liMessage(info, errOnOrOffExpectedButXFound, arg) - end -end; - -procedure ProcessOnOffSwitchG(const op: TGlobalOptions; const arg: string; - pass: TCmdlinePass; const info: TLineInfo); -begin - case whichKeyword(arg) of - wOn: gGlobalOptions := gGlobalOptions + op; - wOff: gGlobalOptions := gGlobalOptions - op; - else liMessage(info, errOnOrOffExpectedButXFound, arg) - end -end; - -procedure ExpectArg(const switch, arg: string; pass: TCmdLinePass; - const info: TLineInfo); -begin - if (arg = '') then - liMessage(info, errCmdLineArgExpected, switch) -end; - -procedure ExpectNoArg(const switch, arg: string; pass: TCmdLinePass; - const info: TLineInfo); -begin - if (arg <> '') then - liMessage(info, errCmdLineNoArgExpected, switch) -end; - -procedure ProcessSpecificNote(const arg: string; state: TSpecialWord; - pass: TCmdlinePass; const info: TLineInfo); -var - i, x: int; - n: TNoteKind; - id: string; -begin - id := ''; - // arg = "X]:on|off" - i := strStart; - n := hintMin; - while (i < length(arg)+strStart) and (arg[i] <> ']') do begin - addChar(id, arg[i]); - inc(i) - end; - if (i < length(arg)+strStart) and (arg[i] = ']') then - inc(i) - else - InvalidCmdLineOption(pass, arg, info); - if (i < length(arg)+strStart) and (arg[i] in [':', '=']) then - inc(i) - else - InvalidCmdLineOption(pass, arg, info); - if state = wHint then begin - x := findStr(msgs.HintsToStr, id); - if x >= 0 then - n := TNoteKind(x + ord(hintMin)) - else - InvalidCmdLineOption(pass, arg, info) - end - else begin - x := findStr(msgs.WarningsToStr, id); - if x >= 0 then - n := TNoteKind(x + ord(warnMin)) - else - InvalidCmdLineOption(pass, arg, info) - end; - case whichKeyword(ncopy(arg, i)) of - wOn: include(gNotes, n); - wOff: exclude(gNotes, n); - else liMessage(info, errOnOrOffExpectedButXFound, arg) - end -end; - -function processPath(const path: string): string; -begin - result := UnixToNativePath(format(path, - ['nimrod', getPrefixDir(), 'lib', libpath])) -end; - -procedure processCompile(const filename: string); -var - found, trunc: string; -begin - found := findFile(filename); - if found = '' then found := filename; - trunc := changeFileExt(found, ''); - extccomp.addExternalFileToCompile(trunc); - extccomp.addFileToLink(completeCFilePath(trunc, false)); -end; - -procedure processSwitch(const switch, arg: string; pass: TCmdlinePass; - const info: TLineInfo); -var - theOS: TSystemOS; - cpu: TSystemCPU; - key, val, path: string; -begin - case whichKeyword(switch) of - wPath, wP: begin - expectArg(switch, arg, pass, info); - path := processPath(arg); - {@discard} lists.IncludeStr(options.searchPaths, path) - end; - wOut, wO: begin - expectArg(switch, arg, pass, info); - options.outFile := arg; - end; - wDefine, wD: begin - expectArg(switch, arg, pass, info); - DefineSymbol(arg) - end; - wUndef, wU: begin - expectArg(switch, arg, pass, info); - UndefSymbol(arg) - end; - wCompile: begin - expectArg(switch, arg, pass, info); - if pass in {@set}[passCmd2, passPP] then - processCompile(arg); - end; - wLink: begin - expectArg(switch, arg, pass, info); - if pass in {@set}[passCmd2, passPP] then - addFileToLink(arg); - end; - wDebuginfo: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optCDebug); - end; - wCompileOnly, wC: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optCompileOnly); - end; - wNoLinking: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optNoLinking); - end; - wNoMain: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optNoMain); - end; - wForceBuild, wF: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optForceFullMake); - end; - wGC: begin - expectArg(switch, arg, pass, info); - case whichKeyword(arg) of - wBoehm: begin - include(gGlobalOptions, optBoehmGC); - exclude(gGlobalOptions, optRefcGC); - DefineSymbol('boehmgc'); - end; - wRefc: begin - exclude(gGlobalOptions, optBoehmGC); - include(gGlobalOptions, optRefcGC) - end; - wNone: begin - exclude(gGlobalOptions, optRefcGC); - exclude(gGlobalOptions, optBoehmGC); - defineSymbol('nogc'); - end - else - 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); - wDebugger: begin - ProcessOnOffSwitch({@set}[optEndb], arg, pass, info); - if optEndb in gOptions then - DefineSymbol('endb') - else - UndefSymbol('endb') - end; - 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); - wDeadCodeElim: ProcessOnOffSwitchG({@set}[optDeadCodeElim], arg, pass, info); - wOpt: begin - expectArg(switch, arg, pass, info); - case whichKeyword(arg) of - wSpeed: begin - include(gOptions, optOptimizeSpeed); - exclude(gOptions, optOptimizeSize) - end; - wSize: begin - exclude(gOptions, optOptimizeSpeed); - include(gOptions, optOptimizeSize) - end; - wNone: begin - exclude(gOptions, optOptimizeSpeed); - exclude(gOptions, optOptimizeSize) - end - else - liMessage(info, errNoneSpeedOrSizeExpectedButXFound, arg) - end - end; - wApp: begin - expectArg(switch, arg, pass, info); - case whichKeyword(arg) of - wGui: begin - include(gGlobalOptions, optGenGuiApp); - defineSymbol('guiapp') - end; - wConsole: - exclude(gGlobalOptions, optGenGuiApp); - wLib: begin - include(gGlobalOptions, optGenDynLib); - exclude(gGlobalOptions, optGenGuiApp); - defineSymbol('library') - end; - else - liMessage(info, errGuiConsoleOrLibExpectedButXFound, arg) - end - end; - wListDef: begin - expectNoArg(switch, arg, pass, info); - if pass in {@set}[passCmd2, passPP] then - condsyms.listSymbols(); - end; - wPassC, wT: begin - expectArg(switch, arg, pass, info); - if pass in {@set}[passCmd2, passPP] then - extccomp.addCompileOption(arg) - end; - wPassL, wL: begin - expectArg(switch, arg, pass, info); - if pass in {@set}[passCmd2, passPP] then - extccomp.addLinkOption(arg) - end; - wIndex: begin - expectArg(switch, arg, pass, info); - if pass in {@set}[passCmd2, passPP] then - gIndexFile := arg - end; - wImport: begin - expectArg(switch, arg, pass, info); - options.addImplicitMod(arg); - end; - wListCmd: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optListCmd); - end; - wGenMapping: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optGenMapping); - end; - wOS: begin - expectArg(switch, arg, pass, info); - if (pass = passCmd1) then begin - theOS := platform.NameToOS(arg); - if theOS = osNone then - liMessage(info, errUnknownOS, arg); - if theOS <> platform.hostOS then begin - setTarget(theOS, targetCPU); - include(gGlobalOptions, optCompileOnly); - condsyms.InitDefines() - end - end - end; - wCPU: begin - expectArg(switch, arg, pass, info); - if (pass = passCmd1) then begin - cpu := platform.NameToCPU(arg); - if cpu = cpuNone then - liMessage(info, errUnknownCPU, arg); - if cpu <> platform.hostCPU then begin - setTarget(targetOS, cpu); - include(gGlobalOptions, optCompileOnly); - condsyms.InitDefines() - end - end - end; - wRun, wR: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optRun); - end; - wVerbosity: begin - expectArg(switch, arg, pass, info); - gVerbosity := parseInt(arg); - end; - wParallelBuild: begin - expectArg(switch, arg, pass, info); - gNumberOfProcessors := parseInt(arg); - end; - wVersion, wV: begin - expectNoArg(switch, arg, pass, info); - writeVersionInfo(pass); - end; - wAdvanced: begin - expectNoArg(switch, arg, pass, info); - writeAdvancedUsage(pass); - end; - wHelp, wH: begin - expectNoArg(switch, arg, pass, info); - helpOnError(pass); - end; - wSymbolFiles: ProcessOnOffSwitchG({@set}[optSymbolFiles], arg, pass, info); - wSkipCfg: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optSkipConfigFile); - end; - wSkipProjCfg: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optSkipProjConfigFile); - end; - wGenScript: begin - expectNoArg(switch, arg, pass, info); - include(gGlobalOptions, optGenScript); - end; - wLib: begin - expectArg(switch, arg, pass, info); - libpath := processPath(arg) - end; - wPutEnv: begin - expectArg(switch, arg, pass, info); - splitSwitch(arg, key, val, pass, info); - nos.putEnv(key, val); - end; - wCC: begin - expectArg(switch, arg, pass, info); - setCC(arg) - end; - else if strutils.find(switch, '.') >= strStart then - options.setConfigVar(switch, arg) - else - InvalidCmdLineOption(pass, switch, info) - end -end; - -procedure ProcessCommand(const switch: string; pass: TCmdLinePass); -var - cmd, arg: string; - info: TLineInfo; -begin - info := newLineInfo('command line', 1, 1); - splitSwitch(switch, cmd, arg, pass, info); - ProcessSwitch(cmd, arg, pass, info) -end; - -end. diff --git a/nim/condsyms.pas b/nim/condsyms.pas deleted file mode 100755 index d22bc0e18..000000000 --- a/nim/condsyms.pas +++ /dev/null @@ -1,152 +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 condsyms; - -// This module handles the conditional symbols. - -{$include 'config.inc'} - -interface - -uses - nsystem, ast, astalgo, msgs, nhashes, platform, strutils, idents; - -var - gSymbols: TStrTable; - -procedure InitDefines; -procedure DeinitDefines; - -procedure DefineSymbol(const symbol: string); -procedure UndefSymbol(const symbol: string); -function isDefined(symbol: PIdent): Boolean; -procedure ListSymbols; - -function countDefinedSymbols: int; - -implementation - -procedure DefineSymbol(const symbol: string); -var - sym: PSym; - i: PIdent; -begin - i := getIdent(symbol); - sym := StrTableGet(gSymbols, i); - if sym = nil then begin - 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; -end; - -procedure UndefSymbol(const symbol: string); -var - sym: PSym; -begin - sym := StrTableGet(gSymbols, getIdent(symbol)); - if sym <> nil then sym.position := 0; -end; - -function isDefined(symbol: PIdent): Boolean; -var - sym: PSym; -begin - sym := StrTableGet(gSymbols, symbol); - result := (sym <> nil) and (sym.position = 1) -end; - -procedure ListSymbols; -var - it: TTabIter; - s: PSym; -begin - s := InitTabIter(it, gSymbols); - MessageOut('-- List of currently defined symbols --'); - while s <> nil do begin - if s.position = 1 then MessageOut(s.name.s); - s := nextIter(it, gSymbols); - end; - 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); - DefineSymbol('nimrod'); // 'nimrod' is always defined -{@ignore} - DefineSymbol('nim'); // Pascal version defines 'nim' in addition -{@emit} - // add platform specific symbols: - case targetCPU of - cpuI386: DefineSymbol('x86'); - cpuIa64: DefineSymbol('itanium'); - cpuAmd64: DefineSymbol('x8664'); - else begin end - end; - case targetOS of - osDOS: DefineSymbol('msdos'); - osWindows: begin - DefineSymbol('mswindows'); - DefineSymbol('win32'); - end; - osLinux, osMorphOS, osSkyOS, osIrix, osPalmOS, osQNX, osAtari, osAix: begin - // these are all 'unix-like' - DefineSymbol('unix'); - DefineSymbol('posix'); - end; - osSolaris: begin - DefineSymbol('sunos'); - DefineSymbol('unix'); - DefineSymbol('posix'); - end; - osNetBSD, osFreeBSD, osOpenBSD: begin - DefineSymbol('unix'); - DefineSymbol('bsd'); - DefineSymbol('posix'); - end; - osMacOS: begin - DefineSymbol('macintosh'); - end; - osMacOSX: begin - DefineSymbol('macintosh'); - DefineSymbol('unix'); - DefineSymbol('posix'); - end; - else begin end - end; - DefineSymbol('cpu' + ToString( cpu[targetCPU].bit )); - DefineSymbol(normalize(endianToStr[cpu[targetCPU].endian])); - DefineSymbol(cpu[targetCPU].name); - DefineSymbol(platform.os[targetOS].name); -end; - -procedure DeinitDefines; -begin -end; - -end. diff --git a/nim/config.inc b/nim/config.inc deleted file mode 100755 index f73444a71..000000000 --- a/nim/config.inc +++ /dev/null @@ -1,62 +0,0 @@ -{$define debug} -{.$define symtabdebug} -// uncomment this code for debugging the symbol table -// (shouldn't be used anymore; the symbol table is stable!) - -{$ifdef fpc} - {$inline on} - {$mode delphi} - {$define hasInline} // later versions of delphi have this too - {$implicitexceptions off} // produce better code - {$H+} - {$warnings off} // FPC produces way too many warnings ... -{$else} // Delphi does not define these: - {$define delphi} // Delphi does not even define a symbol for its compiler! - {$define x86} - {$define cpu386} - {$define cpu387} - {$define cpu86} - {$define cpu87} - {$define cpui386} -{$endif} - -{.$define GC} // Boehm's GC is broken again! (I don't need it much longer!) -// define if we have a GC: if we have none, the compiler leaks memory, -// but it still should work for bootstraping (the OS will clean up later) - -{$ifdef win32} - {$ifndef mswindows} {$define mswindows} {$endif} - {$ifndef windows} {$define windows} {$endif} -{$endif} - -{$ifdef CPU386} - {$define I386} // Delphi does not define this! -{$endif} - -{$ifdef CPUI386} - {$define I386} -{$endif} - -{$ifdef CPUamd64} - {$define amd64} -{$endif} - -{$ifdef debug} - {$define yamlgen} // when debugging we want the YAML code generator - {$R+} {$Q+} // turn code generation checks on - {$ifndef fpc} - {$O-} // deactivate optimization for Delphi - {$endif} - {$C+} // turn assertions on -{$endif} - -{$define cgen} // activate later if parser is stable -{.$define vmgen} // vmgen is not up to date - -{$ifdef cpu64} - {$define bit64clean} // BUGFIX -{$endif} -{$ifdef fpc} - {$define bit64clean} -{$endif} - diff --git a/nim/crc.pas b/nim/crc.pas deleted file mode 100755 index e14716605..000000000 --- a/nim/crc.pas +++ /dev/null @@ -1,227 +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 crc; - -interface - -{$include 'config.inc'} - -uses - nsystem, strutils; - -type - TCrc32 = int32; - -const - InitCrc32 = TCrc32(-1); - - InitAdler32 = int32(1); - -function updateCrc32(val: Byte; crc: TCrc32): TCrc32; overload; -function updateCrc32(val: Char; crc: TCrc32): TCrc32; overload; - -function crcFromBuf(buf: Pointer; len: int): TCrc32; -function strCrc32(const s: string): TCrc32; - -function crcFromFile(const filename: string): TCrc32; - -function updateAdler32(adler: int32; buf: pointer; len: int): int32; - - -implementation - -{@ignore} -{$ifopt Q+} { we need Q- here! } - {$define Q_on} - {$Q-} -{$endif} - -{$ifopt R+} - {$define R_on} - {$R-} -{$endif} -{@emit} - -{@ignore} -type - TCRC_TabEntry = TCrc32; -{@emit -type - TCRC_TabEntry = int -} - -const - crc32table: array [0..255] of TCRC_TabEntry = ( - 0, 1996959894, -301047508, -1727442502, - 124634137, 1886057615, -379345611, -1637575261, - 249268274, 2044508324, -522852066, -1747789432, - 162941995, 2125561021, -407360249, -1866523247, - 498536548, 1789927666, -205950648, -2067906082, - 450548861, 1843258603, -187386543, -2083289657, - 325883990, 1684777152, -43845254, -1973040660, - 335633487, 1661365465, -99664541, -1928851979, - 997073096, 1281953886, -715111964, -1570279054, - 1006888145, 1258607687, -770865667, -1526024853, - 901097722, 1119000684, -608450090, -1396901568, - 853044451, 1172266101, -589951537, -1412350631, - 651767980, 1373503546, -925412992, -1076862698, - 565507253, 1454621731, -809855591, -1195530993, - 671266974, 1594198024, -972236366, -1324619484, - 795835527, 1483230225, -1050600021, -1234817731, - 1994146192, 31158534, -1731059524, -271249366, - 1907459465, 112637215, -1614814043, -390540237, - 2013776290, 251722036, -1777751922, -519137256, - 2137656763, 141376813, -1855689577, -429695999, - 1802195444, 476864866, -2056965928, -228458418, - 1812370925, 453092731, -2113342271, -183516073, - 1706088902, 314042704, -1950435094, -54949764, - 1658658271, 366619977, -1932296973, -69972891, - 1303535960, 984961486, -1547960204, -725929758, - 1256170817, 1037604311, -1529756563, -740887301, - 1131014506, 879679996, -1385723834, -631195440, - 1141124467, 855842277, -1442165665, -586318647, - 1342533948, 654459306, -1106571248, -921952122, - 1466479909, 544179635, -1184443383, -832445281, - 1591671054, 702138776, -1328506846, -942167884, - 1504918807, 783551873, -1212326853, -1061524307, - -306674912, -1698712650, 62317068, 1957810842, - -355121351, -1647151185, 81470997, 1943803523, - -480048366, -1805370492, 225274430, 2053790376, - -468791541, -1828061283, 167816743, 2097651377, - -267414716, -2029476910, 503444072, 1762050814, - -144550051, -2140837941, 426522225, 1852507879, - -19653770, -1982649376, 282753626, 1742555852, - -105259153, -1900089351, 397917763, 1622183637, - -690576408, -1580100738, 953729732, 1340076626, - -776247311, -1497606297, 1068828381, 1219638859, - -670225446, -1358292148, 906185462, 1090812512, - -547295293, -1469587627, 829329135, 1181335161, - -882789492, -1134132454, 628085408, 1382605366, - -871598187, -1156888829, 570562233, 1426400815, - -977650754, -1296233688, 733239954, 1555261956, - -1026031705, -1244606671, 752459403, 1541320221, - -1687895376, -328994266, 1969922972, 40735498, - -1677130071, -351390145, 1913087877, 83908371, - -1782625662, -491226604, 2075208622, 213261112, - -1831694693, -438977011, 2094854071, 198958881, - -2032938284, -237706686, 1759359992, 534414190, - -2118248755, -155638181, 1873836001, 414664567, - -2012718362, -15766928, 1711684554, 285281116, - -1889165569, -127750551, 1634467795, 376229701, - -1609899400, -686959890, 1308918612, 956543938, - -1486412191, -799009033, 1231636301, 1047427035, - -1362007478, -640263460, 1088359270, 936918000, - -1447252397, -558129467, 1202900863, 817233897, - -1111625188, -893730166, 1404277552, 615818150, - -1160759803, -841546093, 1423857449, 601450431, - -1285129682, -1000256840, 1567103746, 711928724, - -1274298825, -1022587231, 1510334235, 755167117 - ); - -function updateCrc32(val: Byte; crc: TCrc32): TCrc32; overload; -begin - result := TCrc32(crc32Table[(int(crc) xor (int(val) and $ff)) and $ff]) xor - (crc shr TCrc32(8)); -end; - -function updateCrc32(val: Char; crc: TCrc32): TCrc32; overload; -begin - result := updateCrc32(byte(ord(val)), crc); -end; - -function strCrc32(const s: string): TCrc32; -var - i: int; -begin - result := InitCrc32; - for i := strStart to length(s)+StrStart-1 do - result := updateCrc32(s[i], result) -end; - -type - TByteArray = array [0..10000000] of Byte; - PByteArray = ^TByteArray; -function crcFromBuf(buf: Pointer; len: int): TCrc32; -var - p: PByteArray; - i: int; -begin - p := {@cast}PByteArray(buf); - result := InitCrc32; - for i := 0 to len-1 do result := updateCrc32(p[i], result) -end; - -function crcFromFile(const filename: string): TCrc32; -const - bufSize = 8 * 1024; -var - bin: TBinaryFile; - buf: Pointer; - readBytes, i: int; - p: PByteArray; -begin - result := InitCrc32; - if not openFile(bin, filename) then exit; // not equal if file does not exist - buf := alloc(BufSize); - p := {@cast}PByteArray(buf); - while true do begin - readBytes := readBuffer(bin, buf, bufSize); - for i := 0 to readBytes-1 do result := updateCrc32(p[i], result); - if readBytes <> bufSize then break; - end; - dealloc(buf); - 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} - {$Q+} -{$endif} - -{$ifdef R_on} - {$undef R_on} - {$R+} -{$endif} -{@emit} - -end. diff --git a/nim/depends.pas b/nim/depends.pas deleted file mode 100755 index 6711875fe..000000000 --- a/nim/depends.pas +++ /dev/null @@ -1,97 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit depends; - -// This module implements a dependency file generator. - -interface - -{$include 'config.inc'} - -uses - nsystem, nos, options, ast, astalgo, msgs, ropes, idents, passes, importer; - -function genDependPass(): TPass; -procedure generateDot(const project: string); - -implementation - -type - TGen = object(TPassContext) - module: PSym; - filename: string; - end; - PGen = ^TGen; - -var - gDotGraph: PRope; // the generated DOT file; we need a global variable - -procedure addDependencyAux(const importing, imported: string); -begin - appf(gDotGraph, '$1 -> $2;$n', [toRope(importing), - toRope(imported)]); - // s1 -> s2_4 [label="[0-9]"]; -end; - -function addDotDependency(c: PPassContext; n: PNode): PNode; -var - i: int; - g: PGen; - imported: string; -begin - result := n; - if n = nil then exit; - g := PGen(c); - case n.kind of - nkImportStmt: begin - for i := 0 to sonsLen(n)-1 do begin - imported := splitFile(getModuleFile(n.sons[i])).name; - addDependencyAux(g.module.name.s, imported); - end - end; - nkFromStmt: begin - imported := splitFile(getModuleFile(n.sons[0])).name; - addDependencyAux(g.module.name.s, imported); - end; - nkStmtList, nkBlockStmt, nkStmtListExpr, nkBlockExpr: begin - for i := 0 to sonsLen(n)-1 do {@discard} addDotDependency(c, 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 myOpen(module: PSym; const filename: string): PPassContext; -var - g: PGen; -begin - new(g); -{@ignore} - fillChar(g^, sizeof(g^), 0); -{@emit} - g.module := module; - g.filename := filename; - result := g; -end; - -function gendependPass(): TPass; -begin - initPass(result); - result.open := myOpen; - result.process := addDotDependency; -end; - -end. diff --git a/nim/docgen.pas b/nim/docgen.pas deleted file mode 100755 index 468dd1bc9..000000000 --- a/nim/docgen.pas +++ /dev/null @@ -1,1176 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -unit docgen; - -// This is the documentation generator. It is currently pretty simple: No -// semantic checking is done for the code. Cross-references are generated -// by knowing how the anchors are going to be named. - -interface - -{$include 'config.inc'} - -uses - nsystem, charsets, ast, astalgo, strutils, nhashes, options, nversion, msgs, - nos, ropes, idents, wordrecg, nmath, syntaxes, rnimsyn, scanner, rst, ntime, - highlite; - -procedure CommandDoc(const filename: string); -procedure CommandRst2Html(const filename: string); -procedure CommandRst2TeX(const filename: string); - -implementation - -type - TTocEntry = record - n: PRstNode; - refname, header: PRope; - end; - TSections = array [TSymKind] of PRope; - TMetaEnum = (metaNone, metaTitle, metaSubtitle, metaAuthor, metaVersion); - TDocumentor = record // contains a module's documentation - filename: string; // filename of the source file; without extension - basedir: string; // base directory (where to put the documentation) - modDesc: PRope; // module description - dependsOn: PRope; // dependencies - id: int; // for generating IDs - splitAfter: int; // split too long entries in the TOC - tocPart: array of TTocEntry; - hasToc: bool; - toc, section: TSections; - indexFile, theIndex: PRstNode; - indexValFilename: string; - indent, verbatim: int; // for code generation - meta: array [TMetaEnum] of PRope; - end; - PDoc = ^TDocumentor; - -var - splitter: string = '<wbr />'; - -function findIndexNode(n: PRstNode): PRstNode; -var - i: int; -begin - if n = nil then - result := nil - else if n.kind = rnIndex then begin - result := n.sons[2]; - if result = nil then begin - result := newRstNode(rnDefList); - n.sons[2] := result - end - else if result.kind = rnInner then - result := result.sons[0] - end - else begin - result := nil; - for i := 0 to rsonsLen(n)-1 do begin - result := findIndexNode(n.sons[i]); - if result <> nil then exit - end - end -end; - -procedure initIndexFile(d: PDoc); -var - h: PRstNode; - dummyHasToc: bool; -begin - if gIndexFile = '' then exit; - gIndexFile := addFileExt(gIndexFile, 'txt'); - d.indexValFilename := changeFileExt(extractFilename(d.filename), HtmlExt); - if ExistsFile(gIndexFile) then begin - d.indexFile := rstParse(readFile(gIndexFile), false, gIndexFile, 0, 1, - dummyHasToc); - d.theIndex := findIndexNode(d.indexFile); - if (d.theIndex = nil) or (d.theIndex.kind <> rnDefList) then - rawMessage(errXisNoValidIndexFile, gIndexFile); - clearIndex(d.theIndex, d.indexValFilename); - end - else begin - d.indexFile := newRstNode(rnInner); - h := newRstNode(rnOverline); - h.level := 1; - addSon(h, newRstNode(rnLeaf, 'Index')); - addSon(d.indexFile, h); - h := newRstNode(rnIndex); - addSon(h, nil); // no argument - addSon(h, nil); // no options - d.theIndex := newRstNode(rnDefList); - addSon(h, d.theIndex); - addSon(d.indexFile, h); - end -end; - -function newDocumentor(const filename: string): PDoc; -var - s: string; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit - result.tocPart := @[]; -} - result.filename := filename; - result.id := 100; - result.splitAfter := 20; - s := getConfigVar('split.item.toc'); - if s <> '' then - result.splitAfter := parseInt(s); -end; - -function getVarIdx(const varnames: array of string; const id: string): int; -var - i: int; -begin - for i := 0 to high(varnames) do - if cmpIgnoreStyle(varnames[i], id) = 0 then begin - result := i; exit - end; - result := -1 -end; - -function ropeFormatNamedVars(const frmt: TFormatStr; - const varnames: array of string; - const varvalues: array of PRope): PRope; -var - i, j, L, start, idx, num: int; - id: string; -begin - i := strStart; - L := length(frmt); - result := nil; - num := 0; - while i <= L + StrStart - 1 do begin - if frmt[i] = '$' then begin - inc(i); // skip '$' - case frmt[i] of - '#': begin - app(result, varvalues[num]); - inc(num); - inc(i); - end; - '$': begin - app(result, '$'+''); - inc(i) - end; - '0'..'9': begin - j := 0; - while true do begin - j := (j * 10) + Ord(frmt[i]) - ord('0'); - inc(i); - if (i > L+StrStart-1) or not (frmt[i] in ['0'..'9']) then break - end; - if j > high(varvalues) + 1 then - internalError('ropeFormatNamedVars'); - num := j; - app(result, varvalues[j - 1]) - end; - 'A'..'Z', 'a'..'z', #128..#255: begin - id := ''; - while true do begin - addChar(id, frmt[i]); - inc(i); - if not (frmt[i] in ['A'..'Z', '_', 'a'..'z', #128..#255]) then break - end; - // search for the variable: - idx := getVarIdx(varnames, id); - if idx >= 0 then app(result, varvalues[idx]) - else rawMessage(errUnkownSubstitionVar, id) - end; - '{': begin - id := ''; - inc(i); - while frmt[i] <> '}' do begin - if frmt[i] = #0 then rawMessage(errTokenExpected, '}'+''); - addChar(id, frmt[i]); - inc(i); - end; - inc(i); // skip } - // search for the variable: - idx := getVarIdx(varnames, id); - if idx >= 0 then app(result, varvalues[idx]) - else rawMessage(errUnkownSubstitionVar, id) - end - else - InternalError('ropeFormatNamedVars') - end - end; - start := i; - while (i <= L + StrStart - 1) do begin - if (frmt[i] <> '$') then - inc(i) - else - break - end; - if i - 1 >= start then - app(result, ncopy(frmt, start, i - 1)) - end -end; - -// -------------------- dispatcher ------------------------------------------- - -procedure addXmlChar(var dest: string; c: Char); -begin - case c of - '&': add(dest, '&'); - '<': add(dest, '<'); - '>': add(dest, '>'); - '"': add(dest, '"'); - else addChar(dest, c) - end -end; - -procedure addRtfChar(var dest: string; c: Char); -begin - case c of - '{': add(dest, '\{'); - '}': add(dest, '\}'); - '\': add(dest, '\\'); - else addChar(dest, c) - end -end; - -procedure addTexChar(var dest: string; c: Char); -begin - case c of - '_': add(dest, '\_'); - '{': add(dest, '\symbol{123}'); - '}': add(dest, '\symbol{125}'); - '[': add(dest, '\symbol{91}'); - ']': add(dest, '\symbol{93}'); - '\': add(dest, '\symbol{92}'); - '$': add(dest, '\$'); - '&': add(dest, '\&'); - '#': add(dest, '\#'); - '%': add(dest, '\%'); - '~': add(dest, '\symbol{126}'); - '@': add(dest, '\symbol{64}'); - '^': add(dest, '\symbol{94}'); - '`': add(dest, '\symbol{96}'); - else addChar(dest, c) - end -end; - -procedure escChar(var dest: string; c: Char); -begin - if gCmd <> cmdRst2Tex then addXmlChar(dest, c) - else addTexChar(dest, c); -end; - -function nextSplitPoint(const s: string; start: int): 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 esc(const s: string; splitAfter: int = -1): string; -var - i, j, k, partLen: int; -begin - result := ''; - if splitAfter >= 0 then begin - partLen := 0; - j := strStart; - while j < length(s)+strStart do begin - k := nextSplitPoint(s, j); - if (splitter <> ' '+'') or (partLen + k - j + 1 > splitAfter) then begin - partLen := 0; - add(result, splitter); - end; - for i := j to k do escChar(result, s[i]); - inc(partLen, k - j + 1); - j := k+1; - end; - end - else begin - for i := strStart to length(s)+strStart-1 do escChar(result, s[i]) - end -end; - -function disp(const xml, tex: string): string; -begin - if gCmd <> cmdRst2Tex then - result := xml - else - result := tex -end; - -function dispF(const xml, tex: string; const args: array of PRope): PRope; -begin - if gCmd <> cmdRst2Tex then - result := ropef(xml, args) - else - result := ropef(tex, args) -end; - -procedure dispA(var dest: PRope; const xml, tex: string; - const args: array of PRope); -begin - if gCmd <> cmdRst2Tex then - appf(dest, xml, args) - else - appf(dest, tex, args) -end; - -// --------------------------------------------------------------------------- - -function renderRstToOut(d: PDoc; n: PRstNode): PRope; forward; - -function renderAux(d: PDoc; n: PRstNode; const outer: string = '$1'): PRope; -var - i: int; -begin - result := nil; - for i := 0 to rsonsLen(n)-1 do - app(result, renderRstToOut(d, n.sons[i])); - result := ropef(outer, [result]); -end; - -procedure setIndexForSourceTerm(d: PDoc; name: PRstNode; id: int); -var - a, h: PRstNode; -begin - if d.theIndex = nil then exit; - h := newRstNode(rnHyperlink); - a := newRstNode(rnLeaf, d.indexValFilename +{&} disp('#'+'', '') - +{&} toString(id)); - addSon(h, a); - addSon(h, a); - a := newRstNode(rnIdx); - addSon(a, name); - setIndexPair(d.theIndex, a, h); -end; - -function renderIndexTerm(d: PDoc; n: PRstNode): PRope; -var - a, h: PRstNode; -begin - inc(d.id); - result := dispF('<em id="$1">$2</em>', - '$2\label{$1}', [toRope(d.id), renderAux(d, n)]); - h := newRstNode(rnHyperlink); - a := newRstNode(rnLeaf, d.indexValFilename +{&} disp('#'+'', '') - +{&} toString(d.id)); - addSon(h, a); - addSon(h, a); - setIndexPair(d.theIndex, n, h); -end; - -function genComment(d: PDoc; n: PNode): PRope; -var - dummyHasToc: bool; -begin - if (n.comment <> snil) and startsWith(n.comment, '##') then - result := renderRstToOut(d, rstParse(n.comment, true, toFilename(n.info), - toLineNumber(n.info), - toColumn(n.info), dummyHasToc)) - else - result := nil; -end; - -function genRecComment(d: PDoc; n: PNode): PRope; -var - i: int; -begin - if n = nil then begin result := nil; exit end; - result := genComment(d, n); - if result = nil then begin - if not (n.kind in [nkEmpty..nkNilLit]) then - for i := 0 to sonsLen(n)-1 do begin - result := genRecComment(d, n.sons[i]); - if result <> nil then exit - end - end - else - n.comment := snil -end; - -function isVisible(n: PNode): bool; -var - v: PIdent; -begin - result := false; - if n.kind = nkPostfix then begin - if (sonsLen(n) = 2) and (n.sons[0].kind = nkIdent) then begin - v := n.sons[0].ident; - result := (v.id = ord(wStar)) or (v.id = ord(wMinus)); - end - end - else if n.kind = nkSym then - result := sfInInterface in n.sym.flags - else if n.kind = nkPragmaExpr then - result := isVisible(n.sons[0]); -end; - -function getName(n: PNode; splitAfter: int = -1): string; -begin - case n.kind of - nkPostfix: result := getName(n.sons[1], splitAfter); - nkPragmaExpr: result := getName(n.sons[0], splitAfter); - nkSym: result := esc(n.sym.name.s, splitAfter); - nkIdent: result := esc(n.ident.s, splitAfter); - nkAccQuoted: - result := esc('`'+'') +{&} getName(n.sons[0], splitAfter) +{&} - esc('`'+''); - else begin - internalError(n.info, 'getName()'); - result := '' - end - end -end; - -function getRstName(n: PNode): PRstNode; -begin - case n.kind of - nkPostfix: result := getRstName(n.sons[1]); - nkPragmaExpr: result := getRstName(n.sons[0]); - nkSym: result := newRstNode(rnLeaf, n.sym.name.s); - nkIdent: result := newRstNode(rnLeaf, n.ident.s); - nkAccQuoted: result := getRstName(n.sons[0]); - else begin - internalError(n.info, 'getRstName()'); - result := nil - end - end -end; - -procedure genItem(d: PDoc; n, nameNode: PNode; k: TSymKind); -var - r: TSrcGen; - kind: TTokType; - literal: string; - name, result, comm: PRope; -begin - if not isVisible(nameNode) then exit; - name := toRope(getName(nameNode)); - result := nil; - literal := ''; - kind := tkEof; -{@ignore} - fillChar(r, sizeof(r), 0); -{@emit} - comm := genRecComment(d, n); // call this here for the side-effect! - initTokRender(r, n, {@set}[renderNoPragmas, renderNoBody, renderNoComments, - renderDocComments]); - while true do begin - getNextTok(r, kind, literal); - case kind of - tkEof: break; - tkComment: - dispA(result, '<span class="Comment">$1</span>', - '\spanComment{$1}', - [toRope(esc(literal))]); - tokKeywordLow..tokKeywordHigh: - dispA(result, '<span class="Keyword">$1</span>', - '\spanKeyword{$1}', - [toRope(literal)]); - tkOpr, tkHat: - dispA(result, '<span class="Operator">$1</span>', - '\spanOperator{$1}', - [toRope(esc(literal))]); - tkStrLit..tkTripleStrLit: - dispA(result, '<span class="StringLit">$1</span>', - '\spanStringLit{$1}', - [toRope(esc(literal))]); - tkCharLit: - dispA(result, '<span class="CharLit">$1</span>', - '\spanCharLit{$1}', - [toRope(esc(literal))]); - tkIntLit..tkInt64Lit: - dispA(result, '<span class="DecNumber">$1</span>', - '\spanDecNumber{$1}', - [toRope(esc(literal))]); - tkFloatLit..tkFloat64Lit: - dispA(result, '<span class="FloatNumber">$1</span>', - '\spanFloatNumber{$1}', - [toRope(esc(literal))]); - tkSymbol: - dispA(result, '<span class="Identifier">$1</span>', - '\spanIdentifier{$1}', - [toRope(esc(literal))]); - tkInd, tkSad, tkDed, tkSpaces: begin - app(result, literal) - end; - tkParLe, tkParRi, tkBracketLe, tkBracketRi, tkCurlyLe, tkCurlyRi, - tkBracketDotLe, tkBracketDotRi, tkCurlyDotLe, tkCurlyDotRi, - tkParDotLe, tkParDotRi, tkComma, tkSemiColon, tkColon, - tkEquals, tkDot, tkDotDot, tkAccent: - dispA(result, '<span class="Other">$1</span>', - '\spanOther{$1}', - [toRope(esc(literal))]); - else InternalError(n.info, 'docgen.genThing(' + toktypeToStr[kind] + ')'); - end - end; - inc(d.id); - app(d.section[k], ropeFormatNamedVars(getConfigVar('doc.item'), - ['name', 'header', 'desc', 'itemID'], - [name, result, comm, toRope(d.id)])); - app(d.toc[k], ropeFormatNamedVars(getConfigVar('doc.item.toc'), - ['name', 'header', 'desc', 'itemID'], - [toRope(getName(nameNode, d.splitAfter)), result, comm, toRope(d.id)])); - setIndexForSourceTerm(d, getRstName(nameNode), d.id); -end; - -function renderHeadline(d: PDoc; n: PRstNode): PRope; -var - i, len: int; - refname: PRope; -begin - result := nil; - for i := 0 to rsonsLen(n)-1 do - app(result, renderRstToOut(d, n.sons[i])); - refname := toRope(rstnodeToRefname(n)); - if d.hasToc then begin - len := length(d.tocPart); - setLength(d.tocPart, len+1); - d.tocPart[len].refname := refname; - d.tocPart[len].n := n; - d.tocPart[len].header := result; - result := dispF( - '<h$1><a class="toc-backref" id="$2" href="#$2_toc">$3</a></h$1>', - '\rsth$4{$3}\label{$2}$n', - [toRope(n.level), d.tocPart[len].refname, result, - toRope(chr(n.level-1+ord('A'))+'')]); - end - else - result := dispF('<h$1 id="$2">$3</h$1>', - '\rsth$4{$3}\label{$2}$n', - [toRope(n.level), refname, result, - toRope(chr(n.level-1+ord('A'))+'')]); -end; - -function renderOverline(d: PDoc; n: PRstNode): PRope; -var - i: int; - t: PRope; -begin - t := nil; - for i := 0 to rsonsLen(n)-1 do - app(t, renderRstToOut(d, n.sons[i])); - result := nil; - if d.meta[metaTitle] = nil then d.meta[metaTitle] := t - else if d.meta[metaSubtitle] = nil then d.meta[metaSubtitle] := t - else - result := dispF('<h$1 id="$2"><center>$3</center></h$1>', - '\rstov$4{$3}\label{$2}$n', - [toRope(n.level), toRope(rstnodeToRefname(n)), t, - toRope(chr(n.level-1+ord('A'))+'')]); -end; - -function renderRstToRst(d: PDoc; n: PRstNode): PRope; forward; - -function renderRstSons(d: PDoc; n: PRstNode): PRope; -var - i: int; -begin - result := nil; - for i := 0 to rsonsLen(n)-1 do app(result, renderRstToRst(d, n.sons[i])); -end; - -function renderRstToRst(d: PDoc; n: PRstNode): PRope; -// this is needed for the index generation; it may also be useful for -// debugging, but most code is already debugged... -const - lvlToChar: array [0..8] of char = ('!', '=', '-', '~', '`', - '<', '*', '|', '+'); -var - L: int; - ind: PRope; -begin - result := nil; - if n = nil then exit; - ind := toRope(repeatChar(d.indent)); - case n.kind of - rnInner: result := renderRstSons(d, n); - rnHeadline: begin - result := renderRstSons(d, n); - L := ropeLen(result); - result := ropef('$n$1$2$n$1$3', [ind, result, - toRope(repeatChar(L, lvlToChar[n.level]))]); - end; - rnOverline: begin - result := renderRstSons(d, n); - L := ropeLen(result); - result := ropef('$n$1$3$n$1$2$n$1$3', [ind, result, - toRope(repeatChar(L, lvlToChar[n.level]))]); - end; - rnTransition: - result := ropef('$n$n$1$2$n$n', - [ind, toRope(repeatChar(78-d.indent, '-'))]); - rnParagraph: begin - result := renderRstSons(d, n); - result := ropef('$n$n$1$2', [ind, result]); - end; - rnBulletItem: begin - inc(d.indent, 2); - result := renderRstSons(d, n); - if result <> nil then result := ropef('$n$1* $2', [ind, result]); - dec(d.indent, 2); - end; - rnEnumItem: begin - inc(d.indent, 4); - result := renderRstSons(d, n); - if result <> nil then result := ropef('$n$1(#) $2', [ind, result]); - dec(d.indent, 4); - end; - rnOptionList, rnFieldList, rnDefList, rnDefItem, rnLineBlock, rnFieldName, - rnFieldBody, rnStandaloneHyperlink, rnBulletList, rnEnumList: - result := renderRstSons(d, n); - rnDefName: begin - result := renderRstSons(d, n); - result := ropef('$n$n$1$2', [ind, result]); - end; - rnDefBody: begin - inc(d.indent, 2); - result := renderRstSons(d, n); - if n.sons[0].kind <> rnBulletList then - result := ropef('$n$1 $2', [ind, result]); - dec(d.indent, 2); - end; - rnField: begin - result := renderRstToRst(d, n.sons[0]); - L := max(ropeLen(result)+3, 30); - inc(d.indent, L); - result := ropef('$n$1:$2:$3$4', [ - ind, result, toRope(repeatChar(L-ropeLen(result)-2)), - renderRstToRst(d, n.sons[1])]); - dec(d.indent, L); - end; - rnLineBlockItem: begin - result := renderRstSons(d, n); - result := ropef('$n$1| $2', [ind, result]); - end; - rnBlockQuote: begin - inc(d.indent, 2); - result := renderRstSons(d, n); - dec(d.indent, 2); - end; - rnRef: begin - result := renderRstSons(d, n); - result := ropef('`$1`_', [result]); - end; - rnHyperlink: begin - result := ropef('`$1 <$2>`_', [renderRstToRst(d, n.sons[0]), - renderRstToRst(d, n.sons[1])]); - end; - rnGeneralRole: begin - result := renderRstToRst(d, n.sons[0]); - result := ropef('`$1`:$2:', [result, renderRstToRst(d, n.sons[1])]); - end; - rnSub: begin - result := renderRstSons(d, n); - result := ropef('`$1`:sub:', [result]); - end; - rnSup: begin - result := renderRstSons(d, n); - result := ropef('`$1`:sup:', [result]); - end; - rnIdx: begin - result := renderRstSons(d, n); - result := ropef('`$1`:idx:', [result]); - end; - rnEmphasis: begin - result := renderRstSons(d, n); - result := ropef('*$1*', [result]); - end; - rnStrongEmphasis: begin - result := renderRstSons(d, n); - result := ropef('**$1**', [result]); - end; - rnInterpretedText: begin - result := renderRstSons(d, n); - result := ropef('`$1`', [result]); - end; - rnInlineLiteral: begin - inc(d.verbatim); - result := renderRstSons(d, n); - result := ropef('``$1``', [result]); - dec(d.verbatim); - end; - rnLeaf: begin - if (d.verbatim = 0) and (n.text = '\'+'') then - result := toRope('\\') // XXX: escape more special characters! - else - result := toRope(n.text); - end; - rnIndex: begin - inc(d.indent, 3); - if n.sons[2] <> nil then - result := renderRstSons(d, n.sons[2]); - dec(d.indent, 3); - result := ropef('$n$n$1.. index::$n$2', [ind, result]); - end; - rnContents: begin - result := ropef('$n$n$1.. contents::', [ind]); - end; - else rawMessage(errCannotRenderX, rstnodeKindToStr[n.kind]); - end; -end; - -function renderTocEntry(d: PDoc; const e: TTocEntry): PRope; -begin - result := dispF( - '<li><a class="reference" id="$1_toc" href="#$1">$2</a></li>$n', - '\item\label{$1_toc} $2\ref{$1}$n', - [e.refname, e.header]); -end; - -function renderTocEntries(d: PDoc; var j: int; lvl: int): PRope; -var - a: int; -begin - result := nil; - while (j <= high(d.tocPart)) do begin - a := abs(d.tocPart[j].n.level); - if (a = lvl) then begin - app(result, renderTocEntry(d, d.tocPart[j])); - inc(j); - end - else if (a > lvl) then - app(result, renderTocEntries(d, j, a)) - else - break - end; - if lvl > 1 then - result := dispF('<ul class="simple">$1</ul>', - '\begin{enumerate}$1\end{enumerate}', [result]); -end; - -function fieldAux(const s: string): PRope; -begin - result := toRope(strip(s)) -end; - -function renderImage(d: PDoc; n: PRstNode): PRope; -var - s, scale: string; - options: PRope; -begin - options := nil; - s := getFieldValue(n, 'scale'); - if s <> '' then dispA(options, ' scale="$1"', ' scale=$1', [fieldAux(scale)]); - - s := getFieldValue(n, 'height'); - if s <> '' then dispA(options, ' height="$1"', ' height=$1', [fieldAux(s)]); - - s := getFieldValue(n, 'width'); - if s <> '' then dispA(options, ' width="$1"', ' width=$1', [fieldAux(s)]); - - s := getFieldValue(n, 'alt'); - if s <> '' then dispA(options, ' alt="$1"', '', [fieldAux(s)]); - s := getFieldValue(n, 'align'); - if s <> '' then dispA(options, ' align="$1"', '', [fieldAux(s)]); - - if options <> nil then options := dispF('$1', '[$1]', [options]); - result := dispF('<img src="$1"$2 />', - '\includegraphics$2{$1}', [toRope(getArgument(n)), options]); - if rsonsLen(n) >= 3 then app(result, renderRstToOut(d, n.sons[2])) -end; - -function renderCodeBlock(d: PDoc; n: PRstNode): PRope; -var - m: PRstNode; - g: TGeneralTokenizer; - langstr: string; - lang: TSourceLanguage; -begin - result := nil; - if n.sons[2] = nil then exit; - m := n.sons[2].sons[0]; - if (m.kind <> rnLeaf) then InternalError('renderCodeBlock'); - langstr := strip(getArgument(n)); - if langstr = '' then lang := langNimrod // default language - else lang := getSourceLanguage(langstr); - if lang = langNone then begin - rawMessage(warnLanguageXNotSupported, langstr); - result := toRope(m.text) - end - else begin - initGeneralTokenizer(g, m.text); - while true do begin - getNextToken(g, lang); - case g.kind of - gtEof: break; - gtNone, gtWhitespace: begin - app(result, ncopy(m.text, g.start+strStart, - g.len+g.start-1+strStart)) - end - else - dispA(result, - '<span class="$2">$1</span>', - '\span$2{$1}', - [toRope(esc(ncopy(m.text, g.start+strStart, - g.len+g.start-1+strStart))), - toRope(tokenClassToStr[g.kind])]); - end; - end; - deinitGeneralTokenizer(g); - end; - if result <> nil then - result := dispF('<pre>$1</pre>', '\begin{rstpre}$n$1$n\end{rstpre}$n', - [result]) -end; - -function renderContainer(d: PDoc; n: PRstNode): PRope; -var - arg: PRope; -begin - result := renderRstToOut(d, n.sons[2]); - arg := toRope(strip(getArgument(n))); - if arg = nil then result := dispF('<div>$1</div>', '$1', [result]) - else result := dispF('<div class="$1">$2</div>', '$2', [arg, result]) -end; - -function texColumns(n: PRstNode): string; -var - i: int; -begin - result := ''; - for i := 1 to rsonsLen(n) do add(result, '|X'); -end; - -function renderField(d: PDoc; n: PRstNode): PRope; -var - fieldname: string; - fieldval: PRope; - b: bool; -begin - b := false; - if gCmd = cmdRst2Tex then begin - fieldname := addNodes(n.sons[0]); - fieldval := toRope(esc(strip(addNodes(n.sons[1])))); - if cmpIgnoreStyle(fieldname, 'author') = 0 then begin - if d.meta[metaAuthor] = nil then begin - d.meta[metaAuthor] := fieldval; - b := true - end - end - else if cmpIgnoreStyle(fieldName, 'version') = 0 then begin - if d.meta[metaVersion] = nil then begin - d.meta[metaVersion] := fieldval; - b := true - end - end - end; - if b then result := nil - else result := renderAux(d, n, disp('<tr>$1</tr>$n', '$1')); -end; - -function renderRstToOut(d: PDoc; n: PRstNode): PRope; -var - i: int; -begin - if n = nil then begin result := nil; exit end; - case n.kind of - rnInner: result := renderAux(d, n); - rnHeadline: result := renderHeadline(d, n); - rnOverline: result := renderOverline(d, n); - rnTransition: - result := renderAux(d, n, disp('<hr />'+nl, '\hrule'+nl)); - rnParagraph: - result := renderAux(d, n, disp('<p>$1</p>'+nl, '$1$n$n')); - rnBulletList: - result := renderAux(d, n, disp('<ul class="simple">$1</ul>'+nl, - '\begin{itemize}$1\end{itemize}'+nl)); - rnBulletItem, rnEnumItem: - result := renderAux(d, n, disp('<li>$1</li>'+nl, '\item $1'+nl)); - rnEnumList: - result := renderAux(d, n, disp('<ol class="simple">$1</ol>'+nl, - '\begin{enumerate}$1\end{enumerate}'+nl)); - rnDefList: - result := renderAux(d, n, disp('<dl class="docutils">$1</dl>'+nl, - '\begin{description}$1\end{description}'+nl)); - rnDefItem: - result := renderAux(d, n); - rnDefName: - result := renderAux(d, n, disp('<dt>$1</dt>'+nl, '\item[$1] ')); - rnDefBody: - result := renderAux(d, n, disp('<dd>$1</dd>'+nl, '$1'+nl)); - rnFieldList: begin - result := nil; - for i := 0 to rsonsLen(n)-1 do app(result, renderRstToOut(d, n.sons[i])); - if result <> nil then - result := dispf('<table class="docinfo" frame="void" rules="none">' + - '<col class="docinfo-name" />' + - '<col class="docinfo-content" />' + - '<tbody valign="top">$1' + - '</tbody></table>', - '\begin{description}$1\end{description}'+nl, [result]); - end; - rnField: result := renderField(d, n); - rnFieldName: - result := renderAux(d, n, disp( - '<th class="docinfo-name">$1:</th>', '\item[$1:]')); - rnFieldBody: - result := renderAux(d, n, disp('<td>$1</td>', ' $1$n')); - rnIndex: - result := renderRstToOut(d, n.sons[2]); - - rnOptionList: - result := renderAux(d, n, disp('<table frame="void">$1</table>', - '\begin{description}$n$1\end{description}'+nl)); - rnOptionListItem: - result := renderAux(d, n, disp('<tr>$1</tr>$n', '$1')); - rnOptionGroup: - result := renderAux(d, n, disp('<th align="left">$1</th>', '\item[$1]')); - rnDescription: - result := renderAux(d, n, disp('<td align="left">$1</td>$n', ' $1$n')); - rnOption, - rnOptionString, - rnOptionArgument: InternalError('renderRstToOut'); - - rnLiteralBlock: - result := renderAux(d, n, disp('<pre>$1</pre>$n', - '\begin{rstpre}$n$1$n\end{rstpre}$n')); - rnQuotedLiteralBlock: InternalError('renderRstToOut'); - - rnLineBlock: result := renderAux(d, n, disp('<p>$1</p>', '$1$n$n')); - rnLineBlockItem: result := renderAux(d, n, disp('$1<br />', '$1\\$n')); - - rnBlockQuote: - result := renderAux(d, n, disp('<blockquote><p>$1</p></blockquote>$n', - '\begin{quote}$1\end{quote}$n')); - - rnTable, rnGridTable: begin - result := renderAux(d, n, - disp('<table border="1" class="docutils">$1</table>', - '\begin{table}\begin{rsttab}{' +{&} - texColumns(n) +{&} - '|}$n\hline$n$1\end{rsttab}\end{table}')); - end; - rnTableRow: begin - if rsonsLen(n) >= 1 then begin - result := renderRstToOut(d, n.sons[0]); - for i := 1 to rsonsLen(n)-1 do - dispa(result, '$1', ' & $1', [renderRstToOut(d, n.sons[i])]); - result := dispf('<tr>$1</tr>$n', '$1\\$n\hline$n', [result]); - end - else - result := nil; - end; - rnTableDataCell: result := renderAux(d, n, disp('<td>$1</td>', '$1')); - rnTableHeaderCell: - result := renderAux(d, n, disp('<th>$1</th>', '\textbf{$1}')); - - rnLabel: InternalError('renderRstToOut'); // used for footnotes and other - rnFootnote: InternalError('renderRstToOut'); // a footnote - - rnCitation: InternalError('renderRstToOut'); // similar to footnote - rnRef: - result := dispF('<a class="reference external" href="#$2">$1</a>', - '$1\ref{$2}', - [renderAux(d, n), toRope(rstnodeToRefname(n))]); - rnStandaloneHyperlink: - result := renderAux(d, n, disp( - '<a class="reference external" href="$1">$1</a>', - '\href{$1}{$1}')); - rnHyperlink: - result := dispF('<a class="reference external" href="$2">$1</a>', - '\href{$2}{$1}', - [renderRstToOut(d, n.sons[0]), - renderRstToOut(d, n.sons[1])]); - rnDirArg, rnRaw: result := renderAux(d, n); - rnImage, rnFigure: result := renderImage(d, n); - rnCodeBlock: result := renderCodeBlock(d, n); - rnContainer: result := renderContainer(d, n); - rnSubstitutionReferences, rnSubstitutionDef: - result := renderAux(d, n, disp('|$1|', '|$1|')); - rnDirective: result := renderAux(d, n, ''); - - // Inline markup: - rnGeneralRole: - result := dispF('<span class="$2">$1</span>', - '\span$2{$1}', - [renderRstToOut(d, n.sons[0]), - renderRstToOut(d, n.sons[1])]); - rnSub: result := renderAux(d, n, disp('<sub>$1</sub>', '\rstsub{$1}')); - rnSup: result := renderAux(d, n, disp('<sup>$1</sup>', '\rstsup{$1}')); - rnEmphasis: result := renderAux(d, n, disp('<em>$1</em>', '\emph{$1}')); - rnStrongEmphasis: - result := renderAux(d, n, disp('<strong>$1</strong>', '\textbf{$1}')); - rnInterpretedText: - result := renderAux(d, n, disp('<cite>$1</cite>', '\emph{$1}')); - rnIdx: begin - if d.theIndex = nil then - result := renderAux(d, n, disp('<em>$1</em>', '\emph{$1}')) - else - result := renderIndexTerm(d, n); - end; - rnInlineLiteral: - result := renderAux(d, n, disp( - '<tt class="docutils literal"><span class="pre">$1</span></tt>', - '\texttt{$1}')); - rnLeaf: result := toRope(esc(n.text)); - rnContents: d.hasToc := true; - rnTitle: d.meta[metaTitle] := renderRstToOut(d, n.sons[0]); - else InternalError('renderRstToOut'); - end -end; - -procedure generateDoc(d: PDoc; n: PNode); -var - i: int; -begin - if n = nil then exit; - case n.kind of - nkCommentStmt: app(d.modDesc, genComment(d, n)); - nkProcDef: genItem(d, n, n.sons[namePos], skProc); - nkMethodDef: genItem(d, n, n.sons[namePos], skMethod); - nkIteratorDef: genItem(d, n, n.sons[namePos], skIterator); - nkMacroDef: genItem(d, n, n.sons[namePos], skMacro); - nkTemplateDef: genItem(d, n, n.sons[namePos], skTemplate); - nkConverterDef: genItem(d, n, n.sons[namePos], skConverter); - nkVarSection: begin - for i := 0 to sonsLen(n)-1 do - if n.sons[i].kind <> nkCommentStmt then - genItem(d, n.sons[i], n.sons[i].sons[0], skVar); - end; - nkConstSection: begin - for i := 0 to sonsLen(n)-1 do - if n.sons[i].kind <> nkCommentStmt then - genItem(d, n.sons[i], n.sons[i].sons[0], skConst); - end; - nkTypeSection: begin - for i := 0 to sonsLen(n)-1 do - if n.sons[i].kind <> nkCommentStmt then - genItem(d, n.sons[i], n.sons[i].sons[0], skType); - end; - nkStmtList: begin - for i := 0 to sonsLen(n)-1 do generateDoc(d, n.sons[i]); - end; - nkWhenStmt: begin - // generate documentation for the first branch only: - generateDoc(d, lastSon(n.sons[0])); - end - else begin end - end -end; - -procedure genSection(d: PDoc; kind: TSymKind); -var - title: PRope; -begin - if d.section[kind] = nil then exit; - title := toRope(ncopy(symKindToStr[kind], strStart+2) + 's'); - d.section[kind] := ropeFormatNamedVars(getConfigVar('doc.section'), - ['sectionid', 'sectionTitle', 'sectionTitleID', 'content'], - [toRope(ord(kind)), title, toRope(ord(kind)+50), d.section[kind]]); - d.toc[kind] := ropeFormatNamedVars(getConfigVar('doc.section.toc'), - ['sectionid', 'sectionTitle', 'sectionTitleID', 'content'], - [toRope(ord(kind)), title, toRope(ord(kind)+50), d.toc[kind]]); -end; - -function genOutFile(d: PDoc): PRope; -var - code, toc, title, content: PRope; - bodyname: string; - i: TSymKind; - j: int; -begin - j := 0; - toc := renderTocEntries(d, j, 1); - code := nil; - content := nil; - title := nil; - for i := low(TSymKind) to high(TSymKind) do begin - genSection(d, i); - app(toc, d.toc[i]); - end; - if toc <> nil then - toc := ropeFormatNamedVars(getConfigVar('doc.toc'), ['content'], [toc]); - for i := low(TSymKind) to high(TSymKind) do app(code, d.section[i]); - if d.meta[metaTitle] <> nil then - title := d.meta[metaTitle] - else - title := toRope('Module ' + extractFilename(changeFileExt(d.filename, ''))); - if d.hasToc then - bodyname := 'doc.body_toc' - else - bodyname := 'doc.body_no_toc'; - content := ropeFormatNamedVars(getConfigVar(bodyname), - ['title', 'tableofcontents', 'moduledesc', 'date', 'time', 'content'], - [title, toc, d.modDesc, toRope(getDateStr()), toRope(getClockStr()), code]); - if not (optCompileOnly in gGlobalOptions) then - code := ropeFormatNamedVars(getConfigVar('doc.file'), - ['title', 'tableofcontents', 'moduledesc', 'date', 'time', - 'content', 'author', 'version'], - [title, toc, d.modDesc, toRope(getDateStr()), toRope(getClockStr()), - content, d.meta[metaAuthor], d.meta[metaVersion]]) - else - code := content; - result := code; -end; - -procedure generateIndex(d: PDoc); -begin - if d.theIndex <> nil then begin - sortIndex(d.theIndex); - writeRope(renderRstToRst(d, d.indexFile), gIndexFile); - end -end; - -procedure CommandDoc(const filename: string); -var - ast: PNode; - d: PDoc; -begin - ast := parseFile(addFileExt(filename, nimExt)); - if ast = nil then exit; - d := newDocumentor(filename); - initIndexFile(d); - d.hasToc := true; - generateDoc(d, ast); - writeRope(genOutFile(d), getOutFile(filename, HtmlExt)); - generateIndex(d); -end; - -procedure CommandRstAux(const filename, outExt: string); -var - filen: string; - d: PDoc; - rst: PRstNode; - code: PRope; -begin - filen := addFileExt(filename, 'txt'); - d := newDocumentor(filen); - initIndexFile(d); - rst := rstParse(readFile(filen), false, filen, 0, 1, d.hasToc); - d.modDesc := renderRstToOut(d, rst); - code := genOutFile(d); - writeRope(code, getOutFile(filename, outExt)); - generateIndex(d); -end; - -procedure CommandRst2Html(const filename: string); -begin - CommandRstAux(filename, HtmlExt); -end; - -procedure CommandRst2TeX(const filename: string); -begin - splitter := '\-'; - CommandRstAux(filename, TexExt); -end; - -end. diff --git a/nim/ecmasgen.pas b/nim/ecmasgen.pas deleted file mode 100755 index 59cb3c330..000000000 --- a/nim/ecmasgen.pas +++ /dev/null @@ -1,1902 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit ecmasgen; - -// This is the EMCAScript (also known as JavaScript) code generator. -// **Invariant: each expression only occurs once in the generated -// code!** - -interface - -{$include 'config.inc'} - -uses - nsystem, ast, astalgo, strutils, nhashes, trees, platform, magicsys, - extccomp, options, nversion, nimsets, msgs, crc, bitsets, idents, - lists, types, nos, ntime, ropes, nmath, passes, ccgutils, wordrecg, rnimsyn, - rodread; - -function ecmasgenPass(): TPass; - -implementation - -type - TEcmasGen = object(TPassContext) - filename: string; - module: PSym; - end; - BModule = ^TEcmasGen; - - TEcmasTypeKind = ( - etyNone, // no type - etyNull, // null type - etyProc, // proc type - etyBool, // bool type - etyInt, // Ecmascript's int - etyFloat, // Ecmascript's float - etyString, // Ecmascript's string - etyObject, // Ecmascript's reference to an object - etyBaseIndex // base + index needed - ); - - TCompRes = record - kind: TEcmasTypeKind; - com: PRope; // computation part - // address if this is a (address, index)-tuple - res: PRope; // result part; index if this is a (address, index)-tuple - end; - - TBlock = record - id: int; // the ID of the label; positive means that it - // has been used (i.e. the label should be emitted) - nestedTryStmts: int; // how many try statements is it nested into - end; - - TGlobals = record - typeInfo, code: PRope; - typeInfoGenerated: TIntSet; - end; - PGlobals = ^TGlobals; - - TProc = record - procDef: PNode; - prc: PSym; - data: PRope; - options: TOptions; - module: BModule; - globals: PGlobals; - BeforeRetNeeded: bool; - nestedTryStmts: int; - unique: int; - blocks: array of TBlock; - end; - -function newGlobals(): PGlobals; -begin - new(result); -{@ignore} fillChar(result^, sizeof(result^), 0); {@emit} - IntSetInit(result.typeInfoGenerated); -end; - -procedure initCompRes(var r: TCompRes); -begin - r.com := nil; r.res := nil; r.kind := etyNone; -end; - -procedure initProc(var p: TProc; globals: PGlobals; module: BModule; - procDef: PNode; options: TOptions); -begin -{@ignore} - fillChar(p, sizeof(p), 0); -{@emit - p.blocks := @[];} - p.options := options; - p.module := module; - p.procDef := procDef; - p.globals := globals; - if procDef <> nil then p.prc := procDef.sons[namePos].sym; -end; - -const - MappedToObject = {@set}[tyObject, tyArray, tyArrayConstr, tyTuple, - tyOpenArray, tySet, tyVar, tyRef, tyPtr]; - -function mapType(typ: PType): TEcmasTypeKind; -var - t: PType; -begin - t := skipTypes(typ, abstractInst); - case t.kind of - tyVar, tyRef, tyPtr: begin - if skipTypes(t.sons[0], abstractInst).kind in mappedToObject then - result := etyObject - else - result := etyBaseIndex - end; - tyPointer: begin - // treat a tyPointer like a typed pointer to an array of bytes - result := etyInt; - end; - tyRange, tyDistinct, tyOrdinal: result := mapType(t.sons[0]); - tyInt..tyInt64, tyEnum, tyChar: - result := etyInt; - tyBool: result := etyBool; - tyFloat..tyFloat128: result := etyFloat; - tySet: begin - result := etyObject // map a set to a table - end; - tyString, tySequence: - result := etyInt; // little hack to get the right semantics - tyObject, tyArray, tyArrayConstr, tyTuple, tyOpenArray: - result := etyObject; - tyNil: result := etyNull; - tyGenericInst, tyGenericParam, tyGenericBody, tyGenericInvokation, - tyNone, tyForward, tyEmpty, tyExpr, tyStmt, tyTypeDesc: - result := etyNone; - tyProc: result := etyProc; - tyCString: result := etyString; - end -end; - -function mangle(const name: string): string; -var - i: int; -begin - result := ''; - for i := strStart to length(name) + strStart-1 do begin - case name[i] of - 'A'..'Z': addChar(result, chr(ord(name[i]) - ord('A') + ord('a'))); - '_': begin end; - 'a'..'z', '0'..'9': addChar(result, name[i]); - else result := result +{&} 'X' +{&} toHex(ord(name[i]), 2); - end - end -end; - -function mangleName(s: PSym): PRope; -begin - result := s.loc.r; - if result = nil then begin - result := toRope(mangle(s.name.s)); - app(result, '_'+''); - app(result, toRope(s.id)); - s.loc.r := result; - end -end; - -// ----------------------- type information ---------------------------------- - -function genTypeInfo(var p: TProc; typ: PType): PRope; forward; - -function genObjectFields(var p: TProc; typ: PType; n: PNode): PRope; -var - s, u: PRope; - len, i, j: int; - field: PSym; - b: PNode; -begin - result := nil; - case n.kind of - nkRecList: begin - len := sonsLen(n); - if len = 1 then // generates more compact code! - result := genObjectFields(p, typ, n.sons[0]) - else begin - s := nil; - for i := 0 to len-1 do begin - if i > 0 then app(s, ', ' + tnl); - app(s, genObjectFields(p, typ, n.sons[i])); - end; - result := ropef('{kind: 2, len: $1, offset: 0, ' + - 'typ: null, name: null, sons: [$2]}', [toRope(len), s]); - end - end; - nkSym: begin - field := n.sym; - s := genTypeInfo(p, field.typ); - result := ropef('{kind: 1, offset: "$1", len: 0, ' + - 'typ: $2, name: $3, sons: null}', [ - mangleName(field), s, makeCString(field.name.s)]); - end; - nkRecCase: begin - len := sonsLen(n); - if (n.sons[0].kind <> nkSym) then - InternalError(n.info, 'genObjectFields'); - field := n.sons[0].sym; - s := genTypeInfo(p, field.typ); - for i := 1 to len-1 do begin - b := n.sons[i]; // branch - u := nil; - case b.kind of - nkOfBranch: begin - if sonsLen(b) < 2 then - internalError(b.info, 'genObjectFields; nkOfBranch broken'); - for j := 0 to sonsLen(b)-2 do begin - if u <> nil then app(u, ', '); - if b.sons[j].kind = nkRange then begin - appf(u, '[$1, $2]', [toRope(getOrdValue(b.sons[j].sons[0])), - toRope(getOrdValue(b.sons[j].sons[1]))]); - end - else - app(u, toRope(getOrdValue(b.sons[j]))) - end - end; - nkElse: u := toRope(lengthOrd(field.typ)); - else internalError(n.info, 'genObjectFields(nkRecCase)'); - end; - if result <> nil then app(result, ', ' + tnl); - appf(result, '[SetConstr($1), $2]', - [u, genObjectFields(p, typ, lastSon(b))]); - end; - result := ropef('{kind: 3, offset: "$1", len: $3, ' + - 'typ: $2, name: $4, sons: [$5]}', [mangleName(field), s, - toRope(lengthOrd(field.typ)), - makeCString(field.name.s), - result]); - end; - else internalError(n.info, 'genObjectFields'); - end -end; - -procedure genObjectInfo(var p: TProc; typ: PType; name: PRope); -var - s: PRope; -begin - s := ropef('var $1 = {size: 0, kind: $2, base: null, node: null, ' + - 'finalizer: null};$n', [name, toRope(ord(typ.kind))]); - prepend(p.globals.typeInfo, s); - - appf(p.globals.typeInfo, 'var NNI$1 = $2;$n', - [toRope(typ.id), genObjectFields(p, typ, typ.n)]); - appf(p.globals.typeInfo, '$1.node = NNI$2;$n', [name, toRope(typ.id)]); - if (typ.kind = tyObject) and (typ.sons[0] <> nil) then begin - appf(p.globals.typeInfo, '$1.base = $2;$n', - [name, genTypeInfo(p, typ.sons[0])]); - end -end; - -procedure genEnumInfo(var p: TProc; typ: PType; name: PRope); -var - s, n: PRope; - len, i: int; - field: PSym; -begin - len := sonsLen(typ.n); - s := nil; - for i := 0 to len-1 do begin - if (typ.n.sons[i].kind <> nkSym) then - InternalError(typ.n.info, 'genEnumInfo'); - field := typ.n.sons[i].sym; - if i > 0 then app(s, ', '+tnl); - appf(s, '{kind: 1, offset: $1, typ: $2, name: $3, len: 0, sons: null}', - [toRope(field.position), name, makeCString(field.name.s)]); - end; - n := ropef('var NNI$1 = {kind: 2, offset: 0, typ: null, ' + - 'name: null, len: $2, sons: [$3]};$n', - [toRope(typ.id), toRope(len), s]); - - s := ropef('var $1 = {size: 0, kind: $2, base: null, node: null, ' + - 'finalizer: null};$n', [name, toRope(ord(typ.kind))]); - prepend(p.globals.typeInfo, s); - - app(p.globals.typeInfo, n); - appf(p.globals.typeInfo, '$1.node = NNI$2;$n', [name, toRope(typ.id)]); - if typ.sons[0] <> nil then begin - appf(p.globals.typeInfo, '$1.base = $2;$n', - [name, genTypeInfo(p, typ.sons[0])]); - end; -end; - -function genTypeInfo(var p: TProc; typ: PType): PRope; -var - t: PType; - s: PRope; -begin - t := typ; - if t.kind = tyGenericInst then t := lastSon(t); - result := ropef('NTI$1', [toRope(t.id)]); - if IntSetContainsOrIncl(p.globals.TypeInfoGenerated, t.id) then exit; - case t.kind of - tyDistinct: result := genTypeInfo(p, typ.sons[0]); - tyPointer, tyProc, tyBool, tyChar, tyCString, tyString, - tyInt..tyFloat128: begin - s := ropef( - 'var $1 = {size: 0, kind: $2, base: null, node: null, finalizer: null};$n', - [result, toRope(ord(t.kind))]); - prepend(p.globals.typeInfo, s); - end; - tyVar, tyRef, tyPtr, tySequence, tyRange, tySet: begin - s := ropef( - 'var $1 = {size: 0, kind: $2, base: null, node: null, finalizer: null};$n', - [result, toRope(ord(t.kind))]); - prepend(p.globals.typeInfo, s); - appf(p.globals.typeInfo, '$1.base = $2;$n', - [result, genTypeInfo(p, typ.sons[0])]); - end; - tyArrayConstr, tyArray: begin - s := ropef( - 'var $1 = {size: 0, kind: $2, base: null, node: null, finalizer: null};$n', - [result, toRope(ord(t.kind))]); - prepend(p.globals.typeInfo, s); - appf(p.globals.typeInfo, '$1.base = $2;$n', - [result, genTypeInfo(p, typ.sons[1])]); - end; - tyEnum: genEnumInfo(p, t, result); - tyObject, tyTuple: genObjectInfo(p, t, result); - else InternalError('genTypeInfo(' + typekindToStr[t.kind] + ')'); - end -end; - -// --------------------------------------------------------------------------- - -procedure gen(var p: TProc; n: PNode; var r: TCompRes); forward; -procedure genStmt(var p: TProc; n: PNode; var r: TCompRes); forward; - -procedure useMagic(var p: TProc; const ident: string); -begin - // to implement -end; - -function mergeExpr(a, b: PRope): PRope; overload; -begin - if (a <> nil) then begin - if b <> nil then result := ropef('($1, $2)', [a, b]) - else result := a - end - else result := b -end; - -function mergeExpr(const r: TCompRes): PRope; overload; -begin - result := mergeExpr(r.com, r.res); -end; - -function mergeStmt(const r: TCompRes): PRope; -begin - if r.res = nil then result := r.com - else if r.com = nil then result := r.res - else result := ropef('$1$2', [r.com, r.res]) -end; - -procedure genAnd(var p: TProc; a, b: PNode; var r: TCompRes); -var - x, y: TCompRes; -begin - gen(p, a, x); - gen(p, b, y); - r.res := ropef('($1 && $2)', [mergeExpr(x), mergeExpr(y)]) -end; - -procedure genOr(var p: TProc; a, b: PNode; var r: TCompRes); -var - x, y: TCompRes; -begin - gen(p, a, x); - gen(p, b, y); - r.res := ropef('($1 || $2)', [mergeExpr(x), mergeExpr(y)]) -end; - -type - TMagicFrmt = array [0..3] of string; - -const - // magic checked op; magic unchecked op; checked op; unchecked op - ops: array [mAddi..mStrToStr] of TMagicFrmt = ( - ('addInt', '', 'addInt($1, $2)', '($1 + $2)'), // AddI - ('subInt', '', 'subInt($1, $2)', '($1 - $2)'), // SubI - ('mulInt', '', 'mulInt($1, $2)', '($1 * $2)'), // MulI - ('divInt', '', 'divInt($1, $2)', 'Math.floor($1 / $2)'), // DivI - ('modInt', '', 'modInt($1, $2)', 'Math.floor($1 % $2)'), // ModI - ('addInt64', '', 'addInt64($1, $2)', '($1 + $2)'), // AddI64 - ('subInt64', '', 'subInt64($1, $2)', '($1 - $2)'), // SubI64 - ('mulInt64', '', 'mulInt64($1, $2)', '($1 * $2)'), // MulI64 - ('divInt64', '', 'divInt64($1, $2)', 'Math.floor($1 / $2)'), // DivI64 - ('modInt64', '', 'modInt64($1, $2)', 'Math.floor($1 % $2)'), // ModI64 - ('', '', '($1 >>> $2)', '($1 >>> $2)'), // ShrI - ('', '', '($1 << $2)', '($1 << $2)'), // ShlI - ('', '', '($1 & $2)', '($1 & $2)'), // BitandI - ('', '', '($1 | $2)', '($1 | $2)'), // BitorI - ('', '', '($1 ^ $2)', '($1 ^ $2)'), // BitxorI - ('nimMin', 'nimMin', 'nimMin($1, $2)', 'nimMin($1, $2)'), // MinI - ('nimMax', 'nimMax', 'nimMax($1, $2)', 'nimMax($1, $2)'), // MaxI - ('', '', '($1 >>> $2)', '($1 >>> $2)'), // ShrI64 - ('', '', '($1 << $2)', '($1 << $2)'), // ShlI64 - ('', '', '($1 & $2)', '($1 & $2)'), // BitandI64 - ('', '', '($1 | $2)', '($1 | $2)'), // BitorI64 - ('', '', '($1 ^ $2)', '($1 ^ $2)'), // BitxorI64 - ('nimMin', 'nimMin', 'nimMin($1, $2)', 'nimMin($1, $2)'), // MinI64 - ('nimMax', 'nimMax', 'nimMax($1, $2)', 'nimMax($1, $2)'), // MaxI64 - ('', '', '($1 + $2)', '($1 + $2)'), // AddF64 - ('', '', '($1 - $2)', '($1 - $2)'), // SubF64 - ('', '', '($1 * $2)', '($1 * $2)'), // MulF64 - ('', '', '($1 / $2)', '($1 / $2)'), // DivF64 - ('nimMin', 'nimMin', 'nimMin($1, $2)', 'nimMin($1, $2)'), // MinF64 - ('nimMax', 'nimMax', 'nimMax($1, $2)', 'nimMax($1, $2)'), // MaxF64 - ('AddU', 'AddU', 'AddU($1, $2)', 'AddU($1, $2)'), // AddU - ('SubU', 'SubU', 'SubU($1, $2)', 'SubU($1, $2)'), // SubU - ('MulU', 'MulU', 'MulU($1, $2)', 'MulU($1, $2)'), // MulU - ('DivU', 'DivU', 'DivU($1, $2)', 'DivU($1, $2)'), // DivU - ('ModU', 'ModU', 'ModU($1, $2)', 'ModU($1, $2)'), // ModU - ('AddU64', 'AddU64', 'AddU64($1, $2)', 'AddU64($1, $2)'), // AddU64 - ('SubU64', 'SubU64', 'SubU64($1, $2)', 'SubU64($1, $2)'), // SubU64 - ('MulU64', 'MulU64', 'MulU64($1, $2)', 'MulU64($1, $2)'), // MulU64 - ('DivU64', 'DivU64', 'DivU64($1, $2)', 'DivU64($1, $2)'), // DivU64 - ('ModU64', 'ModU64', 'ModU64($1, $2)', 'ModU64($1, $2)'), // ModU64 - ('', '', '($1 == $2)', '($1 == $2)'), // EqI - ('', '', '($1 <= $2)', '($1 <= $2)'), // LeI - ('', '', '($1 < $2)', '($1 < $2)'), // LtI - ('', '', '($1 == $2)', '($1 == $2)'), // EqI64 - ('', '', '($1 <= $2)', '($1 <= $2)'), // LeI64 - ('', '', '($1 < $2)', '($1 < $2)'), // LtI64 - ('', '', '($1 == $2)', '($1 == $2)'), // EqF64 - ('', '', '($1 <= $2)', '($1 <= $2)'), // LeF64 - ('', '', '($1 < $2)', '($1 < $2)'), // LtF64 - ('LeU', 'LeU', 'LeU($1, $2)', 'LeU($1, $2)'), // LeU - ('LtU', 'LtU', 'LtU($1, $2)', 'LtU($1, $2)'), // LtU - ('LeU64', 'LeU64', 'LeU64($1, $2)', 'LeU64($1, $2)'), // LeU64 - ('LtU64', 'LtU64', 'LtU64($1, $2)', 'LtU64($1, $2)'), // LtU64 - ('', '', '($1 == $2)', '($1 == $2)'), // EqEnum - ('', '', '($1 <= $2)', '($1 <= $2)'), // LeEnum - ('', '', '($1 < $2)', '($1 < $2)'), // LtEnum - ('', '', '($1 == $2)', '($1 == $2)'), // EqCh - ('', '', '($1 <= $2)', '($1 <= $2)'), // LeCh - ('', '', '($1 < $2)', '($1 < $2)'), // LtCh - ('', '', '($1 == $2)', '($1 == $2)'), // EqB - ('', '', '($1 <= $2)', '($1 <= $2)'), // LeB - ('', '', '($1 < $2)', '($1 < $2)'), // LtB - ('', '', '($1 == $2)', '($1 == $2)'), // EqRef - ('', '', '($1 == $2)', '($1 == $2)'), // EqProc - ('', '', '($1 == $2)', '($1 == $2)'), // EqUntracedRef - ('', '', '($1 <= $2)', '($1 <= $2)'), // LePtr - ('', '', '($1 < $2)', '($1 < $2)'), // LtPtr - ('', '', '($1 == $2)', '($1 == $2)'), // EqCString - ('', '', '($1 != $2)', '($1 != $2)'), // Xor - ('NegInt', '', 'NegInt($1)', '-($1)'), // UnaryMinusI - ('NegInt64', '', 'NegInt64($1)', '-($1)'), // UnaryMinusI64 - ('AbsInt', '', 'AbsInt($1)', 'Math.abs($1)'), // AbsI - ('AbsInt64', '', 'AbsInt64($1)', 'Math.abs($1)'), // AbsI64 - ('', '', '!($1)', '!($1)'), // Not - ('', '', '+($1)', '+($1)'), // UnaryPlusI - ('', '', '~($1)', '~($1)'), // BitnotI - ('', '', '+($1)', '+($1)'), // UnaryPlusI64 - ('', '', '~($1)', '~($1)'), // BitnotI64 - ('', '', '+($1)', '+($1)'), // UnaryPlusF64 - ('', '', '-($1)', '-($1)'), // UnaryMinusF64 - ('', '', 'Math.abs($1)', 'Math.abs($1)'), // AbsF64 - - ('Ze8ToI', 'Ze8ToI', 'Ze8ToI($1)', 'Ze8ToI($1)'), // mZe8ToI - ('Ze8ToI64', 'Ze8ToI64', 'Ze8ToI64($1)', 'Ze8ToI64($1)'), // mZe8ToI64 - ('Ze16ToI', 'Ze16ToI', 'Ze16ToI($1)', 'Ze16ToI($1)'), // mZe16ToI - ('Ze16ToI64', 'Ze16ToI64', 'Ze16ToI64($1)', 'Ze16ToI64($1)'), // mZe16ToI64 - ('Ze32ToI64', 'Ze32ToI64', 'Ze32ToI64($1)', 'Ze32ToI64($1)'), // mZe32ToI64 - ('ZeIToI64', 'ZeIToI64', 'ZeIToI64($1)', 'ZeIToI64($1)'), // mZeIToI64 - - ('ToU8', 'ToU8', 'ToU8($1)', 'ToU8($1)'), // ToU8 - ('ToU16', 'ToU16', 'ToU16($1)', 'ToU16($1)'), // ToU16 - ('ToU32', 'ToU32', 'ToU32($1)', 'ToU32($1)'), // ToU32 - ('', '', '$1', '$1'), // ToFloat - ('', '', '$1', '$1'), // ToBiggestFloat - ('', '', 'Math.floor($1)', 'Math.floor($1)'), // ToInt - ('', '', 'Math.floor($1)', 'Math.floor($1)'), // ToBiggestInt - - ('nimCharToStr', 'nimCharToStr', 'nimCharToStr($1)', 'nimCharToStr($1)'), - ('nimBoolToStr', 'nimBoolToStr', 'nimBoolToStr($1)', 'nimBoolToStr($1)'), - ('cstrToNimStr', 'cstrToNimStr', 'cstrToNimStr(($1)+"")', 'cstrToNimStr(($1)+"")'), - ('cstrToNimStr', 'cstrToNimStr', 'cstrToNimStr(($1)+"")', 'cstrToNimStr(($1)+"")'), - ('cstrToNimStr', 'cstrToNimStr', 'cstrToNimStr(($1)+"")', 'cstrToNimStr(($1)+"")'), - ('cstrToNimStr', 'cstrToNimStr', 'cstrToNimStr($1)', 'cstrToNimStr($1)'), - ('', '', '$1', '$1') - ); - -procedure binaryExpr(var p: TProc; n: PNode; var r: TCompRes; - const magic, frmt: string); -var - x, y: TCompRes; -begin - if magic <> '' then useMagic(p, magic); - gen(p, n.sons[1], x); - gen(p, n.sons[2], y); - r.res := ropef(frmt, [x.res, y.res]); - r.com := mergeExpr(x.com, y.com); -end; - -procedure binaryStmt(var p: TProc; n: PNode; var r: TCompRes; - const magic, frmt: string); -var - x, y: TCompRes; -begin - if magic <> '' then useMagic(p, magic); - gen(p, n.sons[1], x); - gen(p, n.sons[2], y); - if x.com <> nil then appf(r.com, '$1;$n', [x.com]); - if y.com <> nil then appf(r.com, '$1;$n', [y.com]); - appf(r.com, frmt, [x.res, y.res]); -end; - -procedure unaryExpr(var p: TProc; n: PNode; var r: TCompRes; - const magic, frmt: string); -begin - if magic <> '' then useMagic(p, magic); - gen(p, n.sons[1], r); - r.res := ropef(frmt, [r.res]); -end; - -procedure arith(var p: TProc; n: PNode; var r: TCompRes; op: TMagic); -var - x, y: TCompRes; - i: int; -begin - if optOverflowCheck in p.options then i := 0 else i := 1; - useMagic(p, ops[op][i]); - if sonsLen(n) > 2 then begin - gen(p, n.sons[1], x); - gen(p, n.sons[2], y); - r.res := ropef(ops[op][i+2], [x.res, y.res]); - r.com := mergeExpr(x.com, y.com); - end - else begin - gen(p, n.sons[1], r); - r.res := ropef(ops[op][i+2], [r.res]) - end -end; - -procedure genLineDir(var p: TProc; n: PNode; var r: TCompRes); -var - line: int; -begin - line := toLinenumber(n.info); - if optLineDir in p.Options then // pretty useless, but better than nothing - appf(r.com, '// line $2 "$1"$n', - [toRope(toFilename(n.info)), toRope(line)]); - if ([optStackTrace, optEndb] * p.Options = [optStackTrace, optEndb]) and - ((p.prc = nil) or not (sfPure in p.prc.flags)) then begin - useMagic(p, 'endb'); - appf(r.com, 'endb($1);$n', [toRope(line)]) - end - else if ([optLineTrace, optStackTrace] * p.Options = - [optLineTrace, optStackTrace]) and ((p.prc = nil) or - not (sfPure in p.prc.flags)) then - appf(r.com, 'F.line = $1;$n', [toRope(line)]) -end; - -procedure finishTryStmt(var p: TProc; var r: TCompRes; howMany: int); -var - i: int; -begin - for i := 1 to howMany do - app(r.com, 'excHandler = excHandler.prev;' + tnl); -end; - -procedure genWhileStmt(var p: TProc; n: PNode; var r: TCompRes); -var - cond, stmt: TCompRes; - len, labl: int; -begin - genLineDir(p, n, r); - inc(p.unique); - len := length(p.blocks); - setLength(p.blocks, len+1); - p.blocks[len].id := -p.unique; - p.blocks[len].nestedTryStmts := p.nestedTryStmts; - labl := p.unique; - gen(p, n.sons[0], cond); - genStmt(p, n.sons[1], stmt); - if p.blocks[len].id > 0 then - appf(r.com, 'L$3: while ($1) {$n$2}$n', - [mergeExpr(cond), mergeStmt(stmt), toRope(labl)]) - else - appf(r.com, 'while ($1) {$n$2}$n', - [mergeExpr(cond), mergeStmt(stmt)]); - setLength(p.blocks, len); -end; - -procedure genTryStmt(var p: TProc; n: PNode; var r: TCompRes); - // code to generate: -(* - var sp = {prev: excHandler, exc: null}; - excHandler = sp; - try { - stmts; - } catch (e) { - if (e.typ && e.typ == NTI433 || e.typ == NTI2321) { - stmts; - } else if (e.typ && e.typ == NTI32342) { - stmts; - } else { - stmts; - } - } finally { - stmts; - excHandler = excHandler.prev; - } -*) -var - i, j, len, blen: int; - safePoint, orExpr, epart: PRope; - a: TCompRes; -begin - genLineDir(p, n, r); - inc(p.unique); - safePoint := ropef('Tmp$1', [toRope(p.unique)]); - appf(r.com, 'var $1 = {prev: excHandler, exc: null};$n' + - 'excHandler = $1;$n', [safePoint]); - if optStackTrace in p.Options then - app(r.com, 'framePtr = F;' + tnl); - app(r.com, 'try {' + tnl); - len := sonsLen(n); - inc(p.nestedTryStmts); - genStmt(p, n.sons[0], a); - app(r.com, mergeStmt(a)); - i := 1; - epart := nil; - while (i < len) and (n.sons[i].kind = nkExceptBranch) do begin - blen := sonsLen(n.sons[i]); - if blen = 1 then begin - // general except section: - if i > 1 then app(epart, 'else {' + tnl); - genStmt(p, n.sons[i].sons[0], a); - app(epart, mergeStmt(a)); - if i > 1 then app(epart, '}' + tnl); - end - else begin - orExpr := nil; - for j := 0 to blen-2 do begin - if (n.sons[i].sons[j].kind <> nkType) then - InternalError(n.info, 'genTryStmt'); - if orExpr <> nil then app(orExpr, '||'); - appf(orExpr, '($1.exc.m_type == $2)', - [safePoint, genTypeInfo(p, n.sons[i].sons[j].typ)]) - end; - if i > 1 then app(epart, 'else '); - appf(epart, 'if ($1.exc && $2) {$n', [safePoint, orExpr]); - genStmt(p, n.sons[i].sons[blen - 1], a); - appf(epart, '$1}$n', [mergeStmt(a)]); - end; - inc(i) - end; - if epart <> nil then - appf(r.com, '} catch (EXC) {$n$1', [epart]); - finishTryStmt(p, r, p.nestedTryStmts); - dec(p.nestedTryStmts); - app(r.com, '} finally {' + tnl + 'excHandler = excHandler.prev;' +{&} tnl); - if (i < len) and (n.sons[i].kind = nkFinally) then begin - genStmt(p, n.sons[i].sons[0], a); - app(r.com, mergeStmt(a)); - end; - app(r.com, '}' + tnl); -end; - -procedure genRaiseStmt(var p: TProc; n: PNode; var r: TCompRes); -var - a: TCompRes; - typ: PType; -begin - genLineDir(p, n, r); - if n.sons[0] <> nil then begin - gen(p, n.sons[0], a); - if a.com <> nil then appf(r.com, '$1;$n', [a.com]); - typ := skipTypes(n.sons[0].typ, abstractPtrs); - useMagic(p, 'raiseException'); - appf(r.com, 'raiseException($1, $2);$n', - [a.res, makeCString(typ.sym.name.s)]); - end - else begin - useMagic(p, 'reraiseException'); - app(r.com, 'reraiseException();' + tnl); - end -end; - -procedure genCaseStmt(var p: TProc; n: PNode; var r: TCompRes); -var - cond, stmt: TCompRes; - i, j: int; - it, e, v: PNode; - stringSwitch: bool; -begin - genLineDir(p, n, r); - gen(p, n.sons[0], cond); - if cond.com <> nil then - appf(r.com, '$1;$n', [cond.com]); - stringSwitch := skipTypes(n.sons[0].typ, abstractVar).kind = tyString; - if stringSwitch then begin - useMagic(p, 'toEcmaStr'); - appf(r.com, 'switch (toEcmaStr($1)) {$n', [cond.res]) - end - else - appf(r.com, 'switch ($1) {$n', [cond.res]); - for i := 1 to sonsLen(n)-1 do begin - it := n.sons[i]; - case it.kind of - nkOfBranch: begin - for j := 0 to sonsLen(it)-2 do begin - e := it.sons[j]; - if e.kind = nkRange then begin - v := copyNode(e.sons[0]); - while (v.intVal <= e.sons[1].intVal) do begin - gen(p, v, cond); - if cond.com <> nil then - internalError(v.info, 'ecmasgen.genCaseStmt'); - appf(r.com, 'case $1: ', [cond.res]); - Inc(v.intVal) - end - end - else begin - gen(p, e, cond); - if cond.com <> nil then - internalError(e.info, 'ecmasgen.genCaseStmt'); - if stringSwitch then begin - case e.kind of - nkStrLit..nkTripleStrLit: - appf(r.com, 'case $1: ', [makeCString(e.strVal)]); - else InternalError(e.info, 'ecmasgen.genCaseStmt: 2'); - end - end - else - appf(r.com, 'case $1: ', [cond.res]); - end - end; - genStmt(p, lastSon(it), stmt); - appf(r.com, '$n$1break;$n', [mergeStmt(stmt)]); - end; - nkElse: begin - genStmt(p, it.sons[0], stmt); - appf(r.com, 'default: $n$1break;$n', [mergeStmt(stmt)]); - end - else internalError(it.info, 'ecmasgen.genCaseStmt') - end - end; - appf(r.com, '}$n', []); -end; - -procedure genStmtListExpr(var p: TProc; n: PNode; var r: TCompRes); forward; - -procedure genBlock(var p: TProc; n: PNode; var r: TCompRes); -var - idx, labl: int; - sym: PSym; -begin - inc(p.unique); - idx := length(p.blocks); - if n.sons[0] <> nil then begin // named block? - if (n.sons[0].kind <> nkSym) then InternalError(n.info, 'genBlock'); - sym := n.sons[0].sym; - sym.loc.k := locOther; - sym.loc.a := idx - end; - setLength(p.blocks, idx+1); - p.blocks[idx].id := -p.unique; // negative because it isn't used yet - p.blocks[idx].nestedTryStmts := p.nestedTryStmts; - labl := p.unique; - if n.kind = nkBlockExpr then genStmtListExpr(p, n.sons[1], r) - else genStmt(p, n.sons[1], r); - if p.blocks[idx].id > 0 then begin // label has been used: - r.com := ropef('L$1: do {$n$2} while(false);$n', - [toRope(labl), r.com]); - end; - setLength(p.blocks, idx) -end; - -procedure genBreakStmt(var p: TProc; n: PNode; var r: TCompRes); -var - idx: int; - sym: PSym; -begin - genLineDir(p, n, r); - idx := length(p.blocks)-1; - if n.sons[0] <> nil then begin // named break? - assert(n.sons[0].kind = nkSym); - sym := n.sons[0].sym; - assert(sym.loc.k = locOther); - idx := sym.loc.a - end; - p.blocks[idx].id := abs(p.blocks[idx].id); // label is used - finishTryStmt(p, r, p.nestedTryStmts - p.blocks[idx].nestedTryStmts); - appf(r.com, 'break L$1;$n', [toRope(p.blocks[idx].id)]) -end; - -procedure genAsmStmt(var p: TProc; n: PNode; var r: TCompRes); -var - i: int; -begin - genLineDir(p, n, r); - assert(n.kind = nkAsmStmt); - for i := 0 to sonsLen(n)-1 do begin - case n.sons[i].Kind of - nkStrLit..nkTripleStrLit: app(r.com, n.sons[i].strVal); - nkSym: app(r.com, mangleName(n.sons[i].sym)); - else InternalError(n.sons[i].info, 'ecmasgen: genAsmStmt()') - end - end -end; - -procedure genIfStmt(var p: TProc; n: PNode; var r: TCompRes); -var - i, toClose: int; - cond, stmt: TCompRes; - it: PNode; -begin - toClose := 0; - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if sonsLen(it) <> 1 then begin - gen(p, it.sons[0], cond); - genStmt(p, it.sons[1], stmt); - if i > 0 then begin appf(r.com, 'else {$n', []); inc(toClose) end; - if cond.com <> nil then appf(r.com, '$1;$n', [cond.com]); - appf(r.com, 'if ($1) {$n$2}', [cond.res, mergeStmt(stmt)]); - end - else begin - // else part: - genStmt(p, it.sons[0], stmt); - appf(r.com, 'else {$n$1}$n', [mergeStmt(stmt)]); - end - end; - app(r.com, repeatChar(toClose, '}')+{&}tnl); -end; - -procedure genIfExpr(var p: TProc; n: PNode; var r: TCompRes); -var - i, toClose: int; - cond, stmt: TCompRes; - it: PNode; -begin - toClose := 0; - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if sonsLen(it) <> 1 then begin - gen(p, it.sons[0], cond); - gen(p, it.sons[1], stmt); - if i > 0 then begin app(r.res, ': ('); inc(toClose); end; - r.com := mergeExpr(r.com, cond.com); - r.com := mergeExpr(r.com, stmt.com); - appf(r.res, '($1) ? ($2)', [cond.res, stmt.res]); - end - else begin - // else part: - gen(p, it.sons[0], stmt); - r.com := mergeExpr(r.com, stmt.com); - appf(r.res, ': ($1)', [stmt.res]); - end - end; - app(r.res, repeatChar(toClose, ')')); -end; - -function generateHeader(var p: TProc; typ: PType): PRope; -var - i: int; - param: PSym; - name: PRope; -begin - result := nil; - for i := 1 to sonsLen(typ.n)-1 do begin - if result <> nil then app(result, ', '); - assert(typ.n.sons[i].kind = nkSym); - param := typ.n.sons[i].sym; - name := mangleName(param); - app(result, name); - if mapType(param.typ) = etyBaseIndex then begin - app(result, ', '); - app(result, name); - app(result, '_Idx'); - end - end -end; - -const - nodeKindsNeedNoCopy = {@set}[nkCharLit..nkInt64Lit, nkStrLit..nkTripleStrLit, - nkFloatLit..nkFloat64Lit, - nkCurly, nkPar, - nkStringToCString, nkCStringToString, - nkCall, nkCommand, nkHiddenCallConv, - nkCallStrLit]; - -function needsNoCopy(y: PNode): bool; -begin - result := (y.kind in nodeKindsNeedNoCopy) - or (skipTypes(y.typ, abstractInst).kind in [tyRef, tyPtr, tyVar]) -end; - -procedure genAsgnAux(var p: TProc; x, y: PNode; var r: TCompRes; - noCopyNeeded: bool); -var - a, b: TCompRes; -begin - gen(p, x, a); - gen(p, y, b); - case mapType(x.typ) of - etyObject: begin - if a.com <> nil then appf(r.com, '$1;$n', [a.com]); - if b.com <> nil then appf(r.com, '$1;$n', [b.com]); - if needsNoCopy(y) or noCopyNeeded then - appf(r.com, '$1 = $2;$n', [a.res, b.res]) - else begin - useMagic(p, 'NimCopy'); - appf(r.com, '$1 = NimCopy($2, $3);$n', - [a.res, b.res, genTypeInfo(p, y.typ)]); - end - end; - etyBaseIndex: begin - if (a.kind <> etyBaseIndex) or (b.kind <> etyBaseIndex) then - internalError(x.info, 'genAsgn'); - appf(r.com, '$1 = $2; $3 = $4;$n', [a.com, b.com, a.res, b.res]); - end - else begin - if a.com <> nil then appf(r.com, '$1;$n', [a.com]); - if b.com <> nil then appf(r.com, '$1;$n', [b.com]); - appf(r.com, '$1 = $2;$n', [a.res, b.res]); - end - end -end; - -procedure genAsgn(var p: TProc; n: PNode; var r: TCompRes); -begin - genLineDir(p, n, r); - genAsgnAux(p, n.sons[0], n.sons[1], r, false); -end; - -procedure genFastAsgn(var p: TProc; n: PNode; var r: TCompRes); -begin - genLineDir(p, n, r); - genAsgnAux(p, n.sons[0], n.sons[1], r, true); -end; - -procedure genSwap(var p: TProc; n: PNode; var r: TCompRes); -var - a, b: TCompRes; - tmp, tmp2: PRope; -begin - gen(p, n.sons[1], a); - gen(p, n.sons[2], b); - inc(p.unique); - tmp := ropef('Tmp$1', [toRope(p.unique)]); - case mapType(n.sons[1].typ) of - etyBaseIndex: begin - inc(p.unique); - tmp2 := ropef('Tmp$1', [toRope(p.unique)]); - if (a.kind <> etyBaseIndex) or (b.kind <> etyBaseIndex) then - internalError(n.info, 'genSwap'); - appf(r.com, 'var $1 = $2; $2 = $3; $3 = $1;$n', [tmp, a.com, b.com]); - appf(r.com, 'var $1 = $2; $2 = $3; $3 = $1', [tmp2, a.res, b.res]); - end - else begin - if a.com <> nil then appf(r.com, '$1;$n', [a.com]); - if b.com <> nil then appf(r.com, '$1;$n', [b.com]); - appf(r.com, 'var $1 = $2; $2 = $3; $3 = $1', [tmp, a.res, b.res]); - end - end -end; - -procedure genFieldAddr(var p: TProc; n: PNode; var r: TCompRes); -var - a: TCompRes; - f: PSym; -begin - r.kind := etyBaseIndex; - gen(p, n.sons[0], a); - if n.sons[1].kind <> nkSym then - InternalError(n.sons[1].info, 'genFieldAddr'); - f := n.sons[1].sym; - if f.loc.r = nil then f.loc.r := mangleName(f); - r.res := makeCString(ropeToStr(f.loc.r)); - r.com := mergeExpr(a); -end; - -procedure genFieldAccess(var p: TProc; n: PNode; var r: TCompRes); -var - f: PSym; -begin - r.kind := etyNone; - gen(p, n.sons[0], r); - if n.sons[1].kind <> nkSym then - InternalError(n.sons[1].info, 'genFieldAddr'); - f := n.sons[1].sym; - if f.loc.r = nil then f.loc.r := mangleName(f); - r.res := ropef('$1.$2', [r.res, f.loc.r]); -end; - -procedure genCheckedFieldAddr(var p: TProc; n: PNode; var r: TCompRes); -begin - genFieldAddr(p, n.sons[0], r); // XXX -end; - -procedure genCheckedFieldAccess(var p: TProc; n: PNode; var r: TCompRes); -begin - genFieldAccess(p, n.sons[0], r); // XXX -end; - -procedure genArrayAddr(var p: TProc; n: PNode; var r: TCompRes); -var - a, b: TCompRes; - first: biggestInt; - typ: PType; -begin - r.kind := etyBaseIndex; - gen(p, n.sons[0], a); - gen(p, n.sons[1], b); - r.com := mergeExpr(a); - typ := skipTypes(n.sons[0].typ, abstractPtrs); - if typ.kind in [tyArray, tyArrayConstr] then first := FirstOrd(typ.sons[0]) - else first := 0; - if (optBoundsCheck in p.options) and not isConstExpr(n.sons[1]) then begin - useMagic(p, 'chckIndx'); - b.res := ropef('chckIndx($1, $2, $3.length)-$2', - [b.res, toRope(first), a.res]); - // XXX: BUG: a.res evaluated twice! - end - else if first <> 0 then begin - b.res := ropef('($1)-$2', [b.res, toRope(first)]); - end; - r.res := mergeExpr(b); -end; - -procedure genArrayAccess(var p: TProc; n: PNode; var r: TCompRes); -begin - genArrayAddr(p, n, r); - r.kind := etyNone; - r.res := ropef('$1[$2]', [r.com, r.res]); - r.com := nil; -end; - -(* -type - TMyList = record - x: seq[ptr ptr int] - L: int - next: ptr TMyList - -proc myAdd(head: var ptr TMyList, item: ptr TMyList) = - item.next = head - head = item - -proc changeInt(i: var int) = inc(i) - -proc f(p: ptr TMyList, x: ptr ptr int) = - add p.x, x - p.next = nil - changeInt(p.L) - -*) - -procedure genAddr(var p: TProc; n: PNode; var r: TCompRes); -var - s: PSym; -begin - case n.sons[0].kind of - nkSym: begin - s := n.sons[0].sym; - if s.loc.r = nil then InternalError(n.info, 'genAddr: 3'); - case s.kind of - skVar: begin - if mapType(n.typ) = etyObject then begin - // make addr() a no-op: - r.kind := etyNone; - r.res := s.loc.r; - r.com := nil; - end - else if sfGlobal in s.flags then begin - // globals are always indirect accessible - r.kind := etyBaseIndex; - r.com := toRope('Globals'); - r.res := makeCString(ropeToStr(s.loc.r)); - end - else if sfAddrTaken in s.flags then begin - r.kind := etyBaseIndex; - r.com := s.loc.r; - r.res := toRope('0'+''); - end - else InternalError(n.info, 'genAddr: 4'); - end; - else InternalError(n.info, 'genAddr: 2'); - end; - end; - nkCheckedFieldExpr: genCheckedFieldAddr(p, n, r); - nkDotExpr: genFieldAddr(p, n, r); - nkBracketExpr: genArrayAddr(p, n, r); - else InternalError(n.info, 'genAddr'); - end -end; - -procedure genSym(var p: TProc; n: PNode; var r: TCompRes); -var - s: PSym; - k: TEcmasTypeKind; -begin - s := n.sym; - if s.loc.r = nil then - InternalError(n.info, 'symbol has no generated name: ' + s.name.s); - case s.kind of - skVar, skParam, skTemp: begin - k := mapType(s.typ); - if k = etyBaseIndex then begin - r.kind := etyBaseIndex; - if [sfAddrTaken, sfGlobal] * s.flags <> [] then begin - r.com := ropef('$1[0]', [s.loc.r]); - r.res := ropef('$1[1]', [s.loc.r]); - end - else begin - r.com := s.loc.r; - r.res := con(s.loc.r, '_Idx'); - end - end - else if (k <> etyObject) and (sfAddrTaken in s.flags) then - r.res := ropef('$1[0]', [s.loc.r]) - else - r.res := s.loc.r - end - else r.res := s.loc.r; - end -end; - -procedure genDeref(var p: TProc; n: PNode; var r: TCompRes); -var - a: TCompRes; -begin - if mapType(n.sons[0].typ) = etyObject then - gen(p, n.sons[0], r) - else begin - gen(p, n.sons[0], a); - if a.kind <> etyBaseIndex then InternalError(n.info, 'genDeref'); - r.res := ropef('$1[$2]', [a.com, a.res]) - end -end; - -procedure genCall(var p: TProc; n: PNode; var r: TCompRes); -var - a: TCompRes; - i: int; -begin - gen(p, n.sons[0], r); - app(r.res, '('+''); - for i := 1 to sonsLen(n)-1 do begin - if i > 1 then app(r.res, ', '); - gen(p, n.sons[i], a); - if a.kind = etyBaseIndex then begin - app(r.res, a.com); - app(r.res, ', '); - app(r.res, a.res); - end - else - app(r.res, mergeExpr(a)); - end; - app(r.res, ')'+''); -end; - -function putToSeq(const s: string; indirect: bool): PRope; -begin - result := toRope(s); - if indirect then result := ropef('[$1]', [result]) -end; - -function createVar(var p: TProc; typ: PType; - indirect: bool): PRope; forward; - -function createRecordVarAux(var p: TProc; rec: PNode; var c: int): PRope; -var - i: int; -begin - result := nil; - case rec.kind of - nkRecList: begin - for i := 0 to sonsLen(rec)-1 do - app(result, createRecordVarAux(p, rec.sons[i], c)) - end; - nkRecCase: begin - app(result, createRecordVarAux(p, rec.sons[0], c)); - for i := 1 to sonsLen(rec)-1 do - app(result, createRecordVarAux(p, lastSon(rec.sons[i]), c)); - end; - nkSym: begin - if c > 0 then app(result, ', '); - app(result, mangleName(rec.sym)); - app(result, ': '); - app(result, createVar(p, rec.sym.typ, false)); - inc(c); - end; - else InternalError(rec.info, 'createRecordVarAux') - end -end; - -function createVar(var p: TProc; typ: PType; indirect: bool): PRope; -var - i, len, c: int; - t, e: PType; -begin - t := skipTypes(typ, abstractInst); - case t.kind of - tyInt..tyInt64, tyEnum, tyChar: begin - result := putToSeq('0'+'', indirect) - end; - tyFloat..tyFloat128: result := putToSeq('0.0', indirect); - tyRange: result := createVar(p, typ.sons[0], indirect); - tySet: result := toRope('{}'); - tyBool: result := putToSeq('false', indirect); - tyArray, tyArrayConstr: begin - len := int(lengthOrd(t)); - e := elemType(t); - if len > 32 then begin - useMagic(p, 'ArrayConstr'); - result := ropef('ArrayConstr($1, $2, $3)', - [toRope(len), createVar(p, e, false), - genTypeInfo(p, e)]) - end - else begin - result := toRope('['+''); - i := 0; - while i < len do begin - if i > 0 then app(result, ', '); - app(result, createVar(p, e, false)); - inc(i); - end; - app(result, ']'+''); - end - end; - tyTuple: begin - result := toRope('{'+''); - c := 0; - app(result, createRecordVarAux(p, t.n, c)); - app(result, '}'+''); - end; - tyObject: begin - result := toRope('{'+''); - c := 0; - if not (tfFinal in t.flags) or (t.sons[0] <> nil) then begin - inc(c); - appf(result, 'm_type: $1', [genTypeInfo(p, t)]); - end; - while t <> nil do begin - app(result, createRecordVarAux(p, t.n, c)); - t := t.sons[0]; - end; - app(result, '}'+''); - end; - tyVar, tyPtr, tyRef: begin - if mapType(t) = etyBaseIndex then - result := putToSeq('[null, 0]', indirect) - else - result := putToSeq('null', indirect); - end; - tySequence, tyString, tyCString, tyPointer: begin - result := putToSeq('null', indirect); - end - else begin - internalError('createVar: ' + typekindtoStr[t.kind]); - result := nil; - end - end -end; - -function isIndirect(v: PSym): bool; -begin - result := (sfAddrTaken in v.flags) and (mapType(v.typ) <> etyObject); -end; - -procedure genVarInit(var p: TProc; v: PSym; n: PNode; var r: TCompRes); -var - a: TCompRes; - s: PRope; -begin - if n = nil then begin - appf(r.com, 'var $1 = $2;$n', - [mangleName(v), createVar(p, v.typ, isIndirect(v))]) - end - else begin - {@discard} mangleName(v); - gen(p, n, a); - case mapType(v.typ) of - etyObject: begin - if a.com <> nil then appf(r.com, '$1;$n', [a.com]); - if needsNoCopy(n) then s := a.res - else begin - useMagic(p, 'NimCopy'); - s := ropef('NimCopy($1, $2)', [a.res, genTypeInfo(p, n.typ)]); - end - end; - etyBaseIndex: begin - if (a.kind <> etyBaseIndex) then InternalError(n.info, 'genVarInit'); - if [sfAddrTaken, sfGlobal] * v.flags <> [] then - appf(r.com, 'var $1 = [$2, $3];$n', [v.loc.r, a.com, a.res]) - else - appf(r.com, 'var $1 = $2; var $1_Idx = $3;$n', - [v.loc.r, a.com, a.res]); - exit - end - else begin - if a.com <> nil then appf(r.com, '$1;$n', [a.com]); - s := a.res; - end - end; - if isIndirect(v) then - appf(r.com, 'var $1 = [$2];$n', [v.loc.r, s]) - else - appf(r.com, 'var $1 = $2;$n', [v.loc.r, s]) - end; -end; - -procedure genVarStmt(var p: TProc; n: PNode; var r: TCompRes); -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 lfNoDecl in v.loc.flags then continue; - genLineDir(p, a, r); - genVarInit(p, v, a.sons[2], r); - end -end; - -procedure genConstStmt(var p: TProc; n: PNode; var r: TCompRes); -var - c: PSym; - i: int; -begin - genLineDir(p, n, r); - for i := 0 to sonsLen(n)-1 do begin - if n.sons[i].kind = nkCommentStmt then continue; - assert(n.sons[i].kind = nkConstDef); - c := n.sons[i].sons[0].sym; - if (c.ast <> nil) and (c.typ.kind in ConstantDataTypes) and - not (lfNoDecl in c.loc.flags) then begin - genLineDir(p, n.sons[i], r); - genVarInit(p, c, c.ast, r); - end - end -end; - -procedure genNew(var p: TProc; n: PNode; var r: TCompRes); -var - a: TCompRes; - t: Ptype; -begin - gen(p, n.sons[1], a); - t := skipTypes(n.sons[1].typ, abstractVar).sons[0]; - if a.com <> nil then appf(r.com, '$1;$n', [a.com]); - appf(r.com, '$1 = $2;$n', [a.res, createVar(p, t, true)]); -end; - -procedure genOrd(var p: TProc; n: PNode; var r: TCompRes); -begin - case skipTypes(n.sons[1].typ, abstractVar).kind of - tyEnum, tyInt..tyInt64, tyChar: gen(p, n.sons[1], r); - tyBool: unaryExpr(p, n, r, '', '($1 ? 1:0)'); - else InternalError(n.info, 'genOrd'); - end -end; - -procedure genConStrStr(var p: TProc; n: PNode; var r: TCompRes); -var - a, b: TCompRes; -begin - gen(p, n.sons[1], a); - gen(p, n.sons[2], b); - r.com := mergeExpr(a.com, b.com); - if skipTypes(n.sons[1].typ, abstractVarRange).kind = tyChar then - a.res := ropef('[$1, 0]', [a.res]); - if skipTypes(n.sons[2].typ, abstractVarRange).kind = tyChar then - b.res := ropef('[$1, 0]', [b.res]); - r.res := ropef('($1.slice(0,-1)).concat($2)', [a.res, b.res]); -end; - -procedure genMagic(var p: TProc; n: PNode; var r: TCompRes); -var - a: TCompRes; - line, filen: PRope; - op: TMagic; -begin - op := n.sons[0].sym.magic; - case op of - mOr: genOr(p, n.sons[1], n.sons[2], r); - mAnd: genAnd(p, n.sons[1], n.sons[2], r); - mAddi..mStrToStr: arith(p, n, r, op); - //mRepr: genRepr(p, n, r); - mSwap: genSwap(p, n, r); - mPred: begin // XXX: range checking? - if not (optOverflowCheck in p.Options) then - binaryExpr(p, n, r, '', '$1 - $2') - else - binaryExpr(p, n, r, 'subInt', 'subInt($1, $2)') - end; - mSucc: begin // XXX: range checking? - if not (optOverflowCheck in p.Options) then - binaryExpr(p, n, r, '', '$1 - $2') - else - binaryExpr(p, n, r, 'addInt', 'addInt($1, $2)') - end; - mAppendStrCh: binaryStmt(p, n, r, 'addChar', '$1 = addChar($1, $2)'); - mAppendStrStr: - binaryStmt(p, n, r, '', '$1 = ($1.slice(0,-1)).concat($2)'); - // XXX: make a copy of $2, because of EMCAScript's sucking semantics - mAppendSeqElem: binaryStmt(p, n, r, '', '$1.push($2)'); - mConStrStr: genConStrStr(p, n, r); - mEqStr: binaryExpr(p, n, r, 'eqStrings', 'eqStrings($1, $2)'); - mLeStr: binaryExpr(p, n, r, 'cmpStrings', '(cmpStrings($1, $2) <= 0)'); - mLtStr: binaryExpr(p, n, r, 'cmpStrings', '(cmpStrings($1, $2) < 0)'); - mIsNil: unaryExpr(p, n, r, '', '$1 == null'); - mAssert: begin - if (optAssert in p.Options) then begin - useMagic(p, 'internalAssert'); - gen(p, n.sons[1], a); - line := toRope(toLinenumber(n.info)); - filen := makeCString(ToFilename(n.info)); - appf(r.com, 'if (!($3)) internalAssert($1, $2)', - [filen, line, mergeExpr(a)]) - end - end; - mNew, mNewFinalize: genNew(p, n, r); - mSizeOf: r.res := toRope(getSize(n.sons[1].typ)); - mChr: gen(p, n.sons[1], r); // nothing to do - mOrd: genOrd(p, n, r); - mLengthStr: unaryExpr(p, n, r, '', '($1.length-1)'); - mLengthSeq, mLengthOpenArray, mLengthArray: - unaryExpr(p, n, r, '', '$1.length'); - mHigh: begin - if skipTypes(n.sons[0].typ, abstractVar).kind = tyString then - unaryExpr(p, n, r, '', '($1.length-2)') - else - unaryExpr(p, n, r, '', '($1.length-1)'); - end; - mInc: begin - if not (optOverflowCheck in p.Options) then - binaryStmt(p, n, r, '', '$1 += $2') - else - binaryStmt(p, n, r, 'addInt', '$1 = addInt($1, $2)') - end; - ast.mDec: begin - if not (optOverflowCheck in p.Options) then - binaryStmt(p, n, r, '', '$1 -= $2') - else - binaryStmt(p, n, r, 'subInt', '$1 = subInt($1, $2)') - end; - mSetLengthStr: binaryStmt(p, n, r, '', '$1.length = ($2)-1'); - mSetLengthSeq: binaryStmt(p, n, r, '', '$1.length = $2'); - mCard: unaryExpr(p, n, r, 'SetCard', 'SetCard($1)'); - mLtSet: binaryExpr(p, n, r, 'SetLt', 'SetLt($1, $2)'); - mLeSet: binaryExpr(p, n, r, 'SetLe', 'SetLe($1, $2)'); - mEqSet: binaryExpr(p, n, r, 'SetEq', 'SetEq($1, $2)'); - mMulSet: binaryExpr(p, n, r, 'SetMul', 'SetMul($1, $2)'); - mPlusSet: binaryExpr(p, n, r, 'SetPlus', 'SetPlus($1, $2)'); - mMinusSet: binaryExpr(p, n, r, 'SetMinus', 'SetMinus($1, $2)'); - mIncl: binaryStmt(p, n, r, '', '$1[$2] = true'); - mExcl: binaryStmt(p, n, r, '', 'delete $1[$2]'); - mInSet: binaryExpr(p, n, r, '', '($1[$2] != undefined)'); - mNLen..mNError: - liMessage(n.info, errCannotGenerateCodeForX, n.sons[0].sym.name.s); - else genCall(p, n, r); - //else internalError(e.info, 'genMagic: ' + magicToStr[op]); - end -end; - -procedure genSetConstr(var p: TProc; n: PNode; var r: TCompRes); -var - a, b: TCompRes; - i: int; - it: PNode; -begin - useMagic(p, 'SetConstr'); - r.res := toRope('SetConstr('); - for i := 0 to sonsLen(n)-1 do begin - if i > 0 then app(r.res, ', '); - it := n.sons[i]; - if it.kind = nkRange then begin - gen(p, it.sons[0], a); - gen(p, it.sons[1], b); - r.com := mergeExpr(r.com, mergeExpr(a.com, b.com)); - appf(r.res, '[$1, $2]', [a.res, b.res]); - end - else begin - gen(p, it, a); - r.com := mergeExpr(r.com, a.com); - app(r.res, a.res); - end - end; - app(r.res, ')'+''); -end; - -procedure genArrayConstr(var p: TProc; n: PNode; var r: TCompRes); -var - a: TCompRes; - i: int; -begin - r.res := toRope('['+''); - for i := 0 to sonsLen(n)-1 do begin - if i > 0 then app(r.res, ', '); - gen(p, n.sons[i], a); - r.com := mergeExpr(r.com, a.com); - app(r.res, a.res); - end; - app(r.res, ']'+''); -end; - -procedure genRecordConstr(var p: TProc; n: PNode; var r: TCompRes); -var - a: TCompRes; - i, len: int; -begin - i := 0; - len := sonsLen(n); - r.res := toRope('{'+''); - while i < len do begin - if i > 0 then app(r.res, ', '); - if (n.sons[i].kind <> nkSym) then - internalError(n.sons[i].info, 'genRecordConstr'); - gen(p, n.sons[i+1], a); - r.com := mergeExpr(r.com, a.com); - appf(r.res, '$1: $2', [mangleName(n.sons[i].sym), a.res]); - inc(i, 2) - end -end; - -procedure genConv(var p: TProc; n: PNode; var r: TCompRes); -var - src, dest: PType; -begin - dest := skipTypes(n.typ, abstractVarRange); - src := skipTypes(n.sons[1].typ, abstractVarRange); - gen(p, n.sons[1], r); - if (dest.kind <> src.kind) and (src.kind = tyBool) then - r.res := ropef('(($1)? 1:0)', [r.res]) -end; - -procedure upConv(var p: TProc; n: PNode; var r: TCompRes); -begin - gen(p, n.sons[0], r); // XXX -end; - -procedure genRangeChck(var p: TProc; n: PNode; var r: TCompRes; - const magic: string); -var - a, b: TCompRes; -begin - gen(p, n.sons[0], r); - if optRangeCheck in p.options then begin - gen(p, n.sons[1], a); - gen(p, n.sons[2], b); - r.com := mergeExpr(r.com, mergeExpr(a.com, b.com)); - useMagic(p, 'chckRange'); - r.res := ropef('chckRange($1, $2, $3)', [r.res, a.res, b.res]); - end -end; - -procedure convStrToCStr(var p: TProc; n: PNode; var r: TCompRes); -begin - // we do an optimization here as this is likely to slow down - // much of the code otherwise: - if n.sons[0].kind = nkCStringToString then - gen(p, n.sons[0].sons[0], r) - else begin - gen(p, n.sons[0], r); - if r.res = nil then InternalError(n.info, 'convStrToCStr'); - useMagic(p, 'toEcmaStr'); - r.res := ropef('toEcmaStr($1)', [r.res]); - end; -end; - -procedure convCStrToStr(var p: TProc; n: PNode; var r: TCompRes); -begin - // we do an optimization here as this is likely to slow down - // much of the code otherwise: - if n.sons[0].kind = nkStringToCString then - gen(p, n.sons[0].sons[0], r) - else begin - gen(p, n.sons[0], r); - if r.res = nil then InternalError(n.info, 'convCStrToStr'); - useMagic(p, 'cstrToNimstr'); - r.res := ropef('cstrToNimstr($1)', [r.res]); - end; -end; - -procedure genReturnStmt(var p: TProc; n: PNode; var r: TCompRes); -var - a: TCompRes; -begin - if p.procDef = nil then InternalError(n.info, 'genReturnStmt'); - p.BeforeRetNeeded := true; - if (n.sons[0] <> nil) then begin - genStmt(p, n.sons[0], a); - if a.com <> nil then appf(r.com, '$1;$n', mergeStmt(a)); - end - else genLineDir(p, n, r); - finishTryStmt(p, r, p.nestedTryStmts); - app(r.com, 'break BeforeRet;' + tnl); -end; - -function genProcBody(var p: TProc; prc: PSym; const r: TCompRes): PRope; -begin - if optStackTrace in prc.options then begin - result := ropef( - 'var F = {procname: $1, prev: framePtr, filename: $2, line: 0};$n' + - 'framePtr = F;$n', - [makeCString(prc.owner.name.s +{&} '.' +{&} prc.name.s), - makeCString(toFilename(prc.info))]); - end - else - result := nil; - if p.beforeRetNeeded then - appf(result, 'BeforeRet: do {$n$1} while (false); $n', [mergeStmt(r)]) - else - app(result, mergeStmt(r)); - if prc.typ.callConv = ccSysCall then begin - result := ropef('try {$n$1} catch (e) {$n'+ - ' alert("Unhandled exception:\n" + e.message + "\n"$n}', - [result]); - end; - if optStackTrace in prc.options then - app(result, 'framePtr = framePtr.prev;' + tnl); -end; - -procedure genProc(var oldProc: TProc; n: PNode; var r: TCompRes); -var - p: TProc; - prc, resultSym: PSym; - name, returnStmt, resultAsgn, header: PRope; - a: TCompRes; -begin - prc := n.sons[namePos].sym; - initProc(p, oldProc.globals, oldProc.module, n, prc.options); - returnStmt := nil; - resultAsgn := nil; - name := mangleName(prc); - header := generateHeader(p, prc.typ); - if (prc.typ.sons[0] <> nil) and not (sfPure in prc.flags) then begin - resultSym := n.sons[resultPos].sym; - resultAsgn := ropef('var $1 = $2;$n', [mangleName(resultSym), - createVar(p, resultSym.typ, isIndirect(resultSym))]); - gen(p, n.sons[resultPos], a); - if a.com <> nil then appf(returnStmt, '$1;$n', [a.com]); - returnStmt := ropef('return $1;$n', [a.res]); - end; - genStmt(p, n.sons[codePos], r); - r.com := ropef('function $1($2) {$n$3$4$5}$n', - [name, header, resultAsgn, genProcBody(p, prc, r), returnStmt]); - r.res := nil; -end; - -procedure genStmtListExpr(var p: TProc; n: PNode; var r: TCompRes); -var - i: int; - a: TCompRes; -begin - // watch out this trick: ``function () { stmtList; return expr; }()`` - r.res := toRope('function () {'); - for i := 0 to sonsLen(n)-2 do begin - genStmt(p, n.sons[i], a); - app(r.res, mergeStmt(a)); - end; - gen(p, lastSon(n), a); - if a.com <> nil then appf(r.res, '$1;$n', [a.com]); - appf(r.res, 'return $1; }()', [a.res]); -end; - -procedure genStmt(var p: TProc; n: PNode; var r: TCompRes); -var - prc: PSym; - i: int; - a: TCompRes; -begin - r.kind := etyNone; - r.com := nil; - r.res := nil; - case n.kind of - nkNilLit: begin end; - nkStmtList: begin - for i := 0 to sonsLen(n)-1 do begin - genStmt(p, n.sons[i], a); - app(r.com, mergeStmt(a)); - end - end; - nkBlockStmt: genBlock(p, n, r); - nkIfStmt: genIfStmt(p, n, r); - nkWhileStmt: genWhileStmt(p, n, r); - nkVarSection: genVarStmt(p, n, r); - nkConstSection: genConstStmt(p, n, r); - nkForStmt: internalError(n.info, 'for statement not eliminated'); - nkCaseStmt: genCaseStmt(p, n, r); - nkReturnStmt: genReturnStmt(p, n, r); - nkBreakStmt: genBreakStmt(p, n, r); - nkAsgn: genAsgn(p, n, r); - nkFastAsgn: genFastAsgn(p, n, r); - nkDiscardStmt: begin - genLineDir(p, n, r); - gen(p, n.sons[0], r); - app(r.res, ';'+ tnl); - end; - nkAsmStmt: genAsmStmt(p, n, r); - nkTryStmt: genTryStmt(p, n, r); - nkRaiseStmt: genRaiseStmt(p, n, r); - nkTypeSection, nkCommentStmt, nkIteratorDef, - nkIncludeStmt, nkImportStmt, - nkFromStmt, nkTemplateDef, nkMacroDef, nkPragma: begin end; - nkProcDef, nkMethodDef, nkConverterDef: begin - if (n.sons[genericParamsPos] = nil) then begin - prc := n.sons[namePos].sym; - if (n.sons[codePos] <> nil) and not (lfNoDecl in prc.loc.flags) then - genProc(p, n, r) - else - {@discard} mangleName(prc); - end - end; - else begin - genLineDir(p, n, r); - gen(p, n, r); - app(r.res, ';'+ tnl); - end - end -end; - -procedure gen(var p: TProc; n: PNode; var r: TCompRes); -var - f: BiggestFloat; -begin - r.kind := etyNone; - r.com := nil; - r.res := nil; - case n.kind of - nkSym: genSym(p, n, r); - nkCharLit..nkInt64Lit: begin - r.res := toRope(n.intVal); - end; - nkNilLit: begin - if mapType(n.typ) = etyBaseIndex then begin - r.kind := etyBaseIndex; - r.com := toRope('null'); - r.res := toRope('0'+''); - end - else - r.res := toRope('null'); - end; - nkStrLit..nkTripleStrLit: begin - if skipTypes(n.typ, abstractVarRange).kind = tyString then begin - useMagic(p, 'cstrToNimstr'); - r.res := ropef('cstrToNimstr($1)', [makeCString(n.strVal)]) - end - else - r.res := makeCString(n.strVal) - end; - nkFloatLit..nkFloat64Lit: begin - f := n.floatVal; - if f <> f then - r.res := toRope('NaN') - else if f = 0.0 then - r.res := toRopeF(f) - else if f = 0.5 * f then - if f > 0.0 then r.res := toRope('Infinity') - else r.res := toRope('-Infinity') - else - r.res := toRopeF(f); - end; - nkBlockExpr: genBlock(p, n, r); - nkIfExpr: genIfExpr(p, n, r); - nkCall, nkHiddenCallConv, nkCommand, nkCallStrLit: begin - if (n.sons[0].kind = nkSym) and (n.sons[0].sym.magic <> mNone) then - genMagic(p, n, r) - else - genCall(p, n, r) - end; - nkCurly: genSetConstr(p, n, r); - nkBracket: genArrayConstr(p, n, r); - nkPar: genRecordConstr(p, n, r); - nkHiddenStdConv, nkHiddenSubConv, nkConv: genConv(p, n, r); - nkAddr, nkHiddenAddr: genAddr(p, n, r); - nkDerefExpr, nkHiddenDeref: genDeref(p, n, r); - nkBracketExpr: genArrayAccess(p, n, r); - nkDotExpr: genFieldAccess(p, n, r); - nkCheckedFieldExpr: genCheckedFieldAccess(p, n, r); - nkObjDownConv: gen(p, n.sons[0], r); - nkObjUpConv: upConv(p, n, r); - nkChckRangeF: genRangeChck(p, n, r, 'chckRangeF'); - nkChckRange64: genRangeChck(p, n, r, 'chckRange64'); - nkChckRange: genRangeChck(p, n, r, 'chckRange'); - nkStringToCString: convStrToCStr(p, n, r); - nkCStringToString: convCStrToStr(p, n, r); - nkPassAsOpenArray: gen(p, n.sons[0], r); - nkStmtListExpr: genStmtListExpr(p, n, r); - else - InternalError(n.info, 'gen: unknown node type: ' + nodekindToStr[n.kind]) - end -end; - -// ------------------------------------------------------------------------ - -var - globals: PGlobals; - -function newModule(module: PSym; const filename: string): BModule; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.filename := filename; - result.module := module; - if globals = nil then globals := newGlobals(); -end; - -function genHeader(): PRope; -begin - result := ropef( - '/* Generated by the Nimrod Compiler v$1 */$n' + - '/* (c) 2008 Andreas Rumpf */$n$n' + - '$nvar Globals = this;$n' + - 'var framePtr = null;$n' + - 'var excHandler = null;$n', - [toRope(versionAsString)]) -end; - -procedure genModule(var p: TProc; n: PNode; var r: TCompRes); -begin - genStmt(p, n, r); - if optStackTrace in p.options then begin - r.com := ropef( - 'var F = {procname: $1, prev: framePtr, filename: $2, line: 0};$n' + - 'framePtr = F;$n' + - '$3' + - 'framePtr = framePtr.prev;$n', - [makeCString('module ' + p.module.module.name.s), - makeCString(toFilename(p.module.module.info)), r.com]) - end -end; - -function myProcess(b: PPassContext; n: PNode): PNode; -var - m: BModule; - p: TProc; - r: TCompRes; -begin - result := n; - m := BModule(b); - 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(globals.typeInfo, globals.code); - outfile := changeFileExt(completeCFilePath(m.filename), 'js'); - {@discard} writeRopeIfNotEqual(con(genHeader(), code), outfile); - end -end; - -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 - InitPass(result); - result.open := myOpen; - result.close := myClose; - result.openCached := myOpenCached; - result.process := myProcess; -end; - -end. diff --git a/nim/evals.pas b/nim/evals.pas deleted file mode 100755 index b7edc43ed..000000000 --- a/nim/evals.pas +++ /dev/null @@ -1,1414 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit evals; - -// 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. - -interface - -{$include 'config.inc'} - -uses - sysutils, nsystem, charsets, strutils, magicsys, - lists, options, ast, astalgo, trees, treetab, nimsets, - msgs, nos, condsyms, idents, rnimsyn, types, passes, semfold; - -type - PStackFrame = ^TStackFrame; - TStackFrame = record - mapping: TIdNodeTable; // mapping from symbols to nodes - prc: PSym; // current prc; proc that is evaluated - call: PNode; - next: PStackFrame; // for stacking - params: TNodeSeq; // parameters passed to the proc - end; - - TEvalContext = object(passes.TPassContext) - module: PSym; - tos: PStackFrame; // top of stack - lastException: PNode; - optEval: bool; // evaluation done for optimization purposes - end; - PEvalContext = ^TEvalContext; - -function newStackFrame(): PStackFrame; -procedure pushStackFrame(c: PEvalContext; t: PStackFrame); -procedure popStackFrame(c: PEvalContext); - -function newEvalContext(module: PSym; const filename: string; - optEval: bool): PEvalContext; - -function eval(c: PEvalContext; n: PNode): PNode; -// eval never returns nil! This simplifies the code a lot and -// makes it faster too. - -function evalConstExpr(module: PSym; e: PNode): PNode; - -function evalPass(): TPass; - -implementation - -const - evalMaxIterations = 10000000; // max iterations of all loops - evalMaxRecDepth = 100000; // max recursion depth for evaluation - -var - emptyNode: PNode; - -function newStackFrame(): PStackFrame; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - initIdNodeTable(result.mapping); -{@emit result.params := @[];} -end; - -function newEvalContext(module: PSym; const filename: string; - optEval: bool): PEvalContext; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.module := module; - result.optEval := optEval; -end; - -procedure pushStackFrame(c: PEvalContext; t: PStackFrame); -begin - t.next := c.tos; - c.tos := t; -end; - -procedure popStackFrame(c: PEvalContext); -begin - if (c.tos = nil) then InternalError('popStackFrame'); - c.tos := c.tos.next; -end; - -function evalAux(c: PEvalContext; n: PNode): PNode; forward; - -procedure stackTraceAux(x: PStackFrame); -begin - if x <> nil then begin - stackTraceAux(x.next); - messageOut(format('file: $1, line: $2', [toFilename(x.call.info), - toString(toLineNumber(x.call.info))])); - end -end; - -procedure stackTrace(c: PEvalContext; n: PNode; msg: TMsgKind; - const arg: string = ''); -begin - messageOut('stack trace: (most recent call last)'); - stackTraceAux(c.tos); - liMessage(n.info, msg, arg); -end; - -function isSpecial(n: PNode): bool; -begin - result := (n.kind = nkExceptBranch) or (n.kind = nkEmpty) -end; - -function evalIf(c: PEvalContext; 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 isSpecial(result) 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[i].sons[0]) - else - result := emptyNode -end; - -function evalCase(c: PEvalContext; n: PNode): PNode; -var - i, j: int; - res: PNode; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) 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 prevent 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: PEvalContext; n: PNode): PNode; -begin - while true do begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) 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, nkEmpty: break; - else begin end - end; - dec(gWhileCounter); - if gWhileCounter <= 0 then begin - stackTrace(c, n, errTooManyIterations); - break; - end - end -end; - -function evalBlock(c: PEvalContext; 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: PEvalContext; 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: PEvalContext; 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 - if sonsLen(result) >= 1 then begin - // creating a nkExceptBranch without sons means that it could not be - // evaluated - 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 - end - else - result := evalFinally(c, n, emptyNode); - end -end; - -function getNullValue(typ: PType; const info: TLineInfo): PNode; -var - i: int; - t: PType; -begin - t := skipTypes(typ, abstractRange); - 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, tyExpr, - tyStmt, tyTypeDesc: - result := newNodeIT(nkNilLit, info, t); - tyObject: begin - result := newNodeIT(nkPar, info, t); - internalError(info, 'init to implement'); - // XXX - 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: PEvalContext; 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 isSpecial(result) then exit; - end - else - result := getNullValue(a.sons[0].typ, a.sons[0].info); - IdNodeTablePut(c.tos.mapping, v, result); - end; - result := emptyNode; -end; - -function evalCall(c: PEvalContext; n: PNode): PNode; -var - d: PStackFrame; - prc: PNode; - i: int; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - prc := result; - // bind the actual params to the local parameter - // of a new binding - d := newStackFrame(); - d.call := n; - if prc.kind = nkSym then begin - d.prc := 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 isSpecial(result) then exit; - d.params[i] := result; - end; - if n.typ <> nil then d.params[0] := getNullValue(n.typ, n.info); - pushStackFrame(c, d); - result := evalAux(c, prc); - if isSpecial(result) then exit; - if n.typ <> nil then result := d.params[0]; - popStackFrame(c); -end; - -function evalVariable(c: PStackFrame; sym: PSym): PNode; -// We need to return a node to the actual value, -// which can be modified. -var - x: PStackFrame; -begin - x := c; - while x <> nil do begin - if sfResult in sym.flags then begin - result := x.params[0]; - if result = nil then result := emptyNode; - exit - end; - result := IdNodeTableGet(x.mapping, sym); - if result <> nil then exit; - x := x.next - end; - result := emptyNode; -end; - -function evalArrayAccess(c: PEvalContext; n: PNode): PNode; -var - x: PNode; - idx: biggestInt; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - x := result; - result := evalAux(c, n.sons[1]); - if isSpecial(result) 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, errNilAccess); - end -end; - -function evalFieldAccess(c: PEvalContext; 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 isSpecial(result) 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: PEvalContext; n: PNode): PNode; -var - x: PNode; - i: int; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - x := result; - result := evalAux(c, n.sons[1]); - if isSpecial(result) 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: PEvalContext; n: PNode): PNode; -var - x: PNode; - i: int; - tmpi: biggestInt; - tmpf: biggestFloat; - tmps: string; - tmpn: PNode; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - x := result; - result := evalAux(c, n.sons[1]); - if isSpecial(result) 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: PEvalContext; n: PNode): PNode; -begin - case n.sym.kind of - skProc, skConverter, skMacro: result := n.sym.ast.sons[codePos]; - skVar, skForVar, skTemp: result := evalVariable(c.tos, n.sym); - skParam: result := c.tos.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 - stackTrace(c, n, errCannotInterpretNodeX, n.sym.name.s); -end; - -function evalIncDec(c: PEvalContext; n: PNode; sign: biggestInt): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) 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 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 evalEcho(c: PEvalContext; n: PNode): PNode; -var - i: int; -begin - for i := 1 to sonsLen(n)-1 do begin - result := evalAux(c, n.sons[i]); - if isSpecial(result) then exit; - Write(output, getStrValue(result)); - end; - writeln(output, ''); - result := emptyNode -end; - -function evalExit(c: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - liMessage(n.info, hintQuitCalled); - halt(int(getOrdValue(result))); -end; - -function evalOr(c: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) 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: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - if result.kind <> nkIntLit then InternalError(n.info, 'evalAnd'); - if result.intVal <> 0 then result := evalAux(c, n.sons[2]) -end; - -function evalNoOpt(c: PEvalContext; n: PNode): PNode; -begin - result := newNodeI(nkExceptBranch, n.info); - // creating a nkExceptBranch without sons means that it could not be - // evaluated -end; - -function evalNew(c: PEvalContext; n: PNode): PNode; -var - t: PType; -begin - if c.optEval then - result := evalNoOpt(c, n) - else begin - t := skipTypes(n.sons[1].typ, abstractVar); - result := newNodeIT(nkRefTy, n.info, t); - addSon(result, getNullValue(t.sons[0], n.info)); - end -end; - -function evalDeref(c: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - case result.kind of - nkNilLit: stackTrace(c, n, errNilAccess); - nkRefTy: result := result.sons[0]; - else InternalError(n.info, 'evalDeref ' + nodeKindToStr[result.kind]); - end; -end; - -function evalAddr(c: PEvalContext; n: PNode): PNode; -var - a: PNode; - t: PType; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - a := result; - t := newType(tyPtr, c.module); - addSon(t, a.typ); - result := newNodeIT(nkRefTy, n.info, t); - addSon(result, a); -end; - -function evalConv(c: PEvalContext; 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: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[0]); -end; - -function evalUpConv(c: PEvalContext; n: PNode): PNode; -var - dest, src: PType; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - dest := skipTypes(n.typ, abstractPtrs); - src := skipTypes(result.typ, abstractPtrs); - if inheritanceDiff(src, dest) > 0 then - stackTrace(c, n, errInvalidConversionFromTypeX, typeToString(src)); -end; - -function evalRangeChck(c: PEvalContext; n: PNode): PNode; -var - x, a, b: PNode; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - x := result; - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) 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: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - result.typ := n.typ; -end; - -function evalConvCStrToStr(c: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) then exit; - result.typ := n.typ; -end; - -function evalRaise(c: PEvalContext; n: PNode): PNode; -var - a: PNode; -begin - if n.sons[0] <> nil then begin - result := evalAux(c, n.sons[0]); - if isSpecial(result) 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: PEvalContext; n: PNode): PNode; -begin - if n.sons[0] <> nil then begin - result := evalAsgn(c, n.sons[0]); - if isSpecial(result) then exit; - end; - result := newNodeIT(nkReturnToken, n.info, nil); -end; - -function evalProc(c: PEvalContext; 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.tos.mapping, v, result); - end; - result := evalAux(c, n.sons[codePos]); - if result.kind = nkReturnToken then - result := IdNodeTableGet(c.tos.mapping, v); - end - else - result := emptyNode -end; - -function evalHigh(c: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - case skipTypes(n.sons[1].typ, abstractVar).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 evalIs(c: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - result := newIntNodeT(ord(inheritanceDiff(result.typ, n.sons[2].typ) >= 0), n) -end; - -function evalSetLengthStr(c: PEvalContext; n: PNode): PNode; -var - a, b: PNode; - oldLen, newLen: int; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - b := result; - case a.kind of - nkStrLit..nkTripleStrLit: begin - {@ignore} - oldLen := length(a.strVal); - {@emit} - newLen := int(getOrdValue(b)); - setLength(a.strVal, newLen); - {@ignore} - FillChar(a.strVal[oldLen+1], newLen-oldLen, 0); - {@emit} - end - else InternalError(n.info, 'evalSetLengthStr') - end; - result := emptyNode -end; - -function evalSetLengthSeq(c: PEvalContext; n: PNode): PNode; -var - a, b: PNode; - newLen, oldLen, i: int; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - b := result; - if a.kind <> nkBracket then InternalError(n.info, 'evalSetLengthSeq'); - newLen := int(getOrdValue(b)); - oldLen := sonsLen(a); - setLength(a.sons, newLen); - for i := oldLen to newLen-1 do - a.sons[i] := getNullValue(skipTypes(n.sons[1].typ, abstractVar), n.info); - result := emptyNode -end; - -function evalNewSeq(c: PEvalContext; n: PNode): PNode; -var - a, b: PNode; - t: PType; - i: int; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - b := result; - - t := skipTypes(n.sons[1].typ, abstractVar); - if a.kind = nkEmpty then InternalError(n.info, 'first parameter is empty'); - a.kind := nkBracket; - a.info := n.info; - a.typ := t; - for i := 0 to int(getOrdValue(b))-1 do - addSon(a, getNullValue(t.sons[0], n.info)); - result := emptyNode -end; - -function evalAssert(c: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - if getOrdValue(result) <> 0 then - result := emptyNode - else - stackTrace(c, n, errAssertionFailed) -end; - -function evalIncl(c: PEvalContext; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - b := result; - if not inSet(a, b) then addSon(a, copyTree(b)); - result := emptyNode; -end; - -function evalExcl(c: PEvalContext; n: PNode): PNode; -var - a, b, r: PNode; - i: int; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) 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: PEvalContext; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) 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 evalConStrStr(c: PEvalContext; n: PNode): PNode; -// we cannot use ``evalOp`` for this as we can here have more than 2 arguments -var - a: PNode; - i: int; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - for i := 2 to sonsLen(n)-1 do begin - result := evalAux(c, n.sons[i]); - if isSpecial(result) then exit; - a.strVal := getStrValue(a) +{&} getStrValue(result); - end; - result := a; -end; - -function evalAppendStrStr(c: PEvalContext; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) 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: PEvalContext; n: PNode): PNode; -var - a, b: PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - b := result; - if a.kind = nkBracket then addSon(a, copyTree(b)) - else InternalError(n.info, 'evalAppendSeqElem'); - result := emptyNode; -end; - -function evalRepr(c: PEvalContext; n: PNode): PNode; -begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - result := newStrNodeT(renderTree(result, {@set}[renderNoComments]), n); -end; - -function isEmpty(n: PNode): bool; -begin - result := (n <> nil) and (n.kind = nkEmpty) -end; - -function evalMagicOrCall(c: PEvalContext; n: PNode): PNode; -var - m: TMagic; - a, b, cc: PNode; - k: biggestInt; - i: int; -begin - m := getMagic(n); - case m of - mNone: result := evalCall(c, n); - mIs: result := evalIs(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); - mNewSeq: result := evalNewSeq(c, n); - mSwap: result := evalSwap(c, n); - mInc: result := evalIncDec(c, n, 1); - ast.mDec: result := evalIncDec(c, n, -1); - mEcho: result := evalEcho(c, n); - 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); - - mNLen: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) 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 isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - k := getOrdValue(result); - if not (a.kind in [nkEmpty..nkNilLit]) and (k >= 0) - and (k < sonsLen(a)) then begin - result := a.sons[int(k)]; - if result = nil then result := newNode(nkEmpty) - end - else begin - stackTrace(c, n, errIndexOutOfBounds); - result := emptyNode - end; - end; - mNSetChild: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - b := result; - result := evalAux(c, n.sons[3]); - if isSpecial(result) then exit; - k := getOrdValue(b); - if (k >= 0) and (k < sonsLen(a)) - and not (a.kind in [nkEmpty..nkNilLit]) then begin - if result.kind = nkEmpty then a.sons[int(k)] := nil - else a.sons[int(k)] := result - end - else - stackTrace(c, n, errIndexOutOfBounds); - result := emptyNode; - end; - mNAdd: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - addSon(a, result); - result := emptyNode - end; - mNAddMultiple: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) 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 isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - b := result; - result := evalAux(c, n.sons[3]); - if isSpecial(result) 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 isSpecial(result) 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 isSpecial(result) 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 isSpecial(result) 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 isSpecial(result) then exit; - if result.kind <> nkSym then InternalError(n.info, 'no symbol') - end; - mNIdent: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) 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 isSpecial(result) 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 isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - a.intVal := result.intVal; // XXX: exception handling? - result := emptyNode - end; - mNSetFloatVal: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - a.floatVal := result.floatVal; // XXX: exception handling? - result := emptyNode - end; - mNSetSymbol: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - a.sym := result.sym; // XXX: exception handling? - result := emptyNode - end; - mNSetIdent: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - a.ident := result.ident; // XXX: exception handling? - result := emptyNode - end; - mNSetType: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - a.typ := result.typ; // XXX: exception handling? - result := emptyNode - end; - mNSetStrVal: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - a.strVal := result.strVal; // XXX: exception handling? - result := emptyNode - end; - mNNewNimNode: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - k := getOrdValue(result); - result := evalAux(c, n.sons[2]); - if isSpecial(result) 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 isSpecial(result) then exit; - result := copyNode(result); - end; - mNCopyNimTree: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - result := copyTree(result); - end; - mStrToIdent: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) 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 isSpecial(result) 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 isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) 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; - mEqNimrodNode: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - b := result; - result := newNodeIT(nkIntLit, n.info, n.typ); - if (a = b) - or (b.kind in [nkNilLit, nkEmpty]) - and (a.kind in [nkNilLit, nkEmpty]) then - result.intVal := 1 - end; - mNHint: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - liMessage(n.info, hintUser, getStrValue(result)); - result := emptyNode - end; - mNWarning: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - liMessage(n.info, warnUser, getStrValue(result)); - result := emptyNode - end; - mNError: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - stackTrace(c, n, errUser, getStrValue(result)); - result := emptyNode - end; - mConStrStr: result := evalConStrStr(c, n); - mRepr: result := evalRepr(c, n); - mNewString: begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - result := newNodeIT(nkStrLit, n.info, n.typ); - result.strVal := newString(int(getOrdValue(a))); - end; - else begin - result := evalAux(c, n.sons[1]); - if isSpecial(result) then exit; - a := result; - b := nil; - cc := nil; - if sonsLen(n) > 2 then begin - result := evalAux(c, n.sons[2]); - if isSpecial(result) then exit; - b := result; - if sonsLen(n) > 3 then begin - result := evalAux(c, n.sons[3]); - if isSpecial(result) then exit; - cc := result; - end - end; - if isEmpty(a) or isEmpty(b) or isEmpty(cc) then - result := emptyNode - else - result := evalOp(m, n, a, b, cc); - end - end -end; - -function evalAux(c: PEvalContext; n: PNode): PNode; -var - i: int; - a: PNode; -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, nkCommand, nkCallStrLit: - result := evalMagicOrCall(c, n); - nkCurly, nkBracket, nkRange: begin - a := copyNode(n); - for i := 0 to sonsLen(n)-1 do begin - result := evalAux(c, n.sons[i]); - if isSpecial(result) then exit; - addSon(a, result); - end; - result := a - end; - nkPar: begin - a := copyTree(n); - for i := 0 to sonsLen(n)-1 do begin - result := evalAux(c, n.sons[i].sons[1]); - if isSpecial(result) then exit; - a.sons[i].sons[1] := result; - end; - result := a - 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, nkFastAsgn: 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, nkMethodDef, nkMacroDef, nkCommentStmt, nkPragma, nkTypeSection, - nkTemplateDef, nkConstSection, nkIteratorDef, nkConverterDef, - nkIncludeStmt, nkImportStmt, nkFromStmt: begin end; - nkIdentDefs, nkCast, nkYieldStmt, nkAsmStmt, nkForStmt, nkPragmaExpr, - nkLambda, nkContinueStmt, nkIdent: - 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: PEvalContext; n: PNode): PNode; -begin - gWhileCounter := evalMaxIterations; - gNestedEvals := evalMaxRecDepth; - result := evalAux(c, n); - if (result.kind = nkExceptBranch) and (sonsLen(result) >= 1) then - stackTrace(c, n, errUnhandledExceptionX, typeToString(result.typ)); -end; - -function evalConstExpr(module: PSym; e: PNode): PNode; -var - p: PEvalContext; - s: PStackFrame; -begin - p := newEvalContext(module, '', true); - s := newStackFrame(); - s.call := e; - pushStackFrame(p, s); - result := eval(p, e); - if (result <> nil) and (result.kind = nkExceptBranch) then - result := nil; - popStackFrame(p); -end; - -function myOpen(module: PSym; const filename: string): PPassContext; -var - c: PEvalContext; -begin - c := newEvalContext(module, filename, false); - pushStackFrame(c, newStackFrame()); - result := c; -end; - -function myProcess(c: PPassContext; n: PNode): PNode; -begin - result := eval(PEvalContext(c), n); -end; - -function evalPass(): TPass; -begin - initPass(result); - result.open := myOpen; - result.close := myProcess; - result.process := myProcess; -end; - -initialization - emptyNode := newNode(nkEmpty); -end. diff --git a/nim/extccomp.pas b/nim/extccomp.pas deleted file mode 100755 index 7df3e8748..000000000 --- a/nim/extccomp.pas +++ /dev/null @@ -1,676 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit extccomp; - -// module for calling the different external C compilers - -interface - -{$include 'config.inc'} - -uses - nsystem, charsets, lists, ropes, nos, strutils, osproc, platform, condsyms, - options, msgs; - -// some things are read in from the configuration file - -type - TSystemCC = (ccNone, ccGcc, ccLLVM_Gcc, ccLcc, ccBcc, ccDmc, ccWcc, ccVcc, - ccTcc, ccPcc, ccUcc, ccIcc, ccGpp); - - TInfoCCProp = ( // properties of the C compiler: - hasSwitchRange, // CC allows ranges in switch statements (GNU C extension) - hasComputedGoto, // CC has computed goto (GNU C extension) - hasCpp, // CC is/contains a C++ compiler - hasAssume // CC has __assume (Visual C extension) - ); - TInfoCCProps = set of TInfoCCProp; - TInfoCC = record{@tuple} - name: string; // the short name of the compiler - objExt: string; // the compiler's object file extenstion - optSpeed: string; // the options for optimization for speed - optSize: string; // the options for optimization for size - compilerExe: string; // the compiler's executable - compileTmpl: string; // the compile command template - buildGui: string; // command to build a GUI application - buildDll: string; // command to build a shared library - linkerExe: string; // the linker's executable - linkTmpl: string; // command to link files to produce an executable - includeCmd: string; // command to add an include directory path - debug: string; // flags for debug build - pic: string; // command for position independent code - // used on some platforms - asmStmtFrmt: string; // format of ASM statement - props: TInfoCCProps; // properties of the C compiler - end; -const - CC: array [succ(low(TSystemCC))..high(TSystemCC)] of TInfoCC = ( - ( - name: 'gcc'; - objExt: 'o'+''; - optSpeed: ' -O3 -ffast-math '; - optSize: ' -Os -ffast-math '; - compilerExe: 'gcc'; - compileTmpl: '-c $options $include -o $objfile $file'; - buildGui: ' -mwindows'; - buildDll: ' -mdll'; - linkerExe: 'gcc'; - linkTmpl: '$options $buildgui $builddll -o $exefile $objfiles'; - includeCmd: ' -I'; - debug: ''; - pic: '-fPIC'; - asmStmtFrmt: 'asm($1);$n'; - props: {@set}[hasSwitchRange, hasComputedGoto, hasCpp]; - ), - ( - name: 'llvm_gcc'; - objExt: 'o'+''; - optSpeed: ' -O3 -ffast-math '; - optSize: ' -Os -ffast-math '; - compilerExe: 'llvm-gcc'; - compileTmpl: '-c $options $include -o $objfile $file'; - buildGui: ' -mwindows'; - buildDll: ' -mdll'; - linkerExe: 'llvm-gcc'; - linkTmpl: '$options $buildgui $builddll -o $exefile $objfiles'; - includeCmd: ' -I'; - debug: ''; - pic: '-fPIC'; - asmStmtFrmt: 'asm($1);$n'; - props: {@set}[hasSwitchRange, hasComputedGoto, hasCpp]; - ), - ( - name: 'lcc'; - objExt: 'obj'; - optSpeed: ' -O -p6 '; - optSize: ' -O -p6 '; - compilerExe: 'lcc'; - compileTmpl: '$options $include -Fo$objfile $file'; - buildGui: ' -subsystem windows'; - buildDll: ' -dll'; - linkerExe: 'lcclnk'; - linkTmpl: '$options $buildgui $builddll -O $exefile $objfiles'; - includeCmd: ' -I'; - debug: ' -g5 '; - pic: ''; - asmStmtFrmt: '_asm{$n$1$n}$n'; - props: {@set}[]; - ), - ( - name: 'bcc'; - objExt: 'obj'; - optSpeed: ' -O2 -6 '; - optSize: ' -O1 -6 '; - compilerExe: 'bcc32'; - compileTmpl: '-c $options $include -o$objfile $file'; - buildGui: ' -tW'; - buildDll: ' -tWD'; - linkerExe: 'bcc32'; - linkTmpl: '$options $buildgui $builddll -e$exefile $objfiles'; - includeCmd: ' -I'; - debug: ''; - pic: ''; - asmStmtFrmt: '__asm{$n$1$n}$n'; - props: {@set}[hasCpp]; - ), - ( - name: 'dmc'; - objExt: 'obj'; - optSpeed: ' -ff -o -6 '; - optSize: ' -ff -o -6 '; - compilerExe: 'dmc'; - compileTmpl: '-c $options $include -o$objfile $file'; - buildGui: ' -L/exet:nt/su:windows'; - buildDll: ' -WD'; - linkerExe: 'dmc'; - linkTmpl: '$options $buildgui $builddll -o$exefile $objfiles'; - includeCmd: ' -I'; - debug: ' -g '; - pic: ''; - asmStmtFrmt: '__asm{$n$1$n}$n'; - props: {@set}[hasCpp]; - ), - ( - name: 'wcc'; - objExt: 'obj'; - optSpeed: ' -ox -on -6 -d0 -fp6 -zW '; - optSize: ''; - compilerExe: 'wcl386'; - compileTmpl: '-c $options $include -fo=$objfile $file'; - buildGui: ' -bw'; - buildDll: ' -bd'; - linkerExe: 'wcl386'; - linkTmpl: '$options $buildgui $builddll -fe=$exefile $objfiles '; - includeCmd: ' -i='; - debug: ' -d2 '; - pic: ''; - asmStmtFrmt: '__asm{$n$1$n}$n'; - props: {@set}[hasCpp]; - ), - ( - name: 'vcc'; - objExt: 'obj'; - optSpeed: ' /Ogityb2 /G7 /arch:SSE2 '; - optSize: ' /O1 /G7 '; - compilerExe: 'cl'; - compileTmpl: '/c $options $include /Fo$objfile $file'; - buildGui: ' /link /SUBSYSTEM:WINDOWS '; - buildDll: ' /LD'; - linkerExe: 'cl'; - linkTmpl: '$options $builddll /Fe$exefile $objfiles $buildgui'; - includeCmd: ' /I'; - debug: ' /GZ /Zi '; - pic: ''; - asmStmtFrmt: '__asm{$n$1$n}$n'; - props: {@set}[hasCpp, hasAssume]; - ), - ( - name: 'tcc'; - objExt: 'o'+''; - optSpeed: ''; - optSize: ''; - compilerExe: 'tcc'; - compileTmpl: '-c $options $include -o $objfile $file'; - buildGui: 'UNAVAILABLE!'; - buildDll: ' -shared'; - linkerExe: 'tcc'; - linkTmpl: '-o $exefile $options $buildgui $builddll $objfiles'; - includeCmd: ' -I'; - debug: ' -g '; - pic: ''; - asmStmtFrmt: '__asm{$n$1$n}$n'; - props: {@set}[hasSwitchRange, hasComputedGoto]; - ), - ( - name: 'pcc'; // Pelles C - objExt: 'obj'; - optSpeed: ' -Ox '; - optSize: ' -Os '; - compilerExe: 'cc'; - compileTmpl: '-c $options $include -Fo$objfile $file'; - buildGui: ' -SUBSYSTEM:WINDOWS'; - buildDll: ' -DLL'; - linkerExe: 'cc'; - linkTmpl: '$options $buildgui $builddll -OUT:$exefile $objfiles'; - includeCmd: ' -I'; - debug: ' -Zi '; - pic: ''; - asmStmtFrmt: '__asm{$n$1$n}$n'; - props: {@set}[]; - ), - ( - name: 'ucc'; - objExt: 'o'+''; - optSpeed: ' -O3 '; - optSize: ' -O1 '; - compilerExe: 'cc'; - compileTmpl: '-c $options $include -o $objfile $file'; - buildGui: ''; - buildDll: ' -shared '; - linkerExe: 'cc'; - linkTmpl: '-o $exefile $options $buildgui $builddll $objfiles'; - includeCmd: ' -I'; - debug: ''; - pic: ''; - asmStmtFrmt: '__asm{$n$1$n}$n'; - props: {@set}[]; - ), ( - name: 'icc'; - objExt: 'o'+''; - optSpeed: ' -O3 '; - optSize: ' -Os '; - compilerExe: 'icc'; - compileTmpl: '-c $options $include -o $objfile $file'; - buildGui: ' -mwindows'; - buildDll: ' -mdll'; - linkerExe: 'icc'; - linkTmpl: '$options $buildgui $builddll -o $exefile $objfiles'; - includeCmd: ' -I'; - debug: ''; - pic: '-fPIC'; - asmStmtFrmt: 'asm($1);$n'; - props: {@set}[hasSwitchRange, hasComputedGoto, hasCpp]; - ), ( - name: 'gpp'; - objExt: 'o'+''; - optSpeed: ' -O3 -ffast-math '; - optSize: ' -Os -ffast-math '; - compilerExe: 'g++'; - compileTmpl: '-c $options $include -o $objfile $file'; - buildGui: ' -mwindows'; - buildDll: ' -mdll'; - linkerExe: 'g++'; - linkTmpl: '$options $buildgui $builddll -o $exefile $objfiles'; - includeCmd: ' -I'; - debug: ' -g '; - pic: '-fPIC'; - asmStmtFrmt: 'asm($1);$n'; - props: {@set}[hasSwitchRange, hasComputedGoto, hasCpp]; - ) - ); - -var - ccompiler: TSystemCC = ccGcc; // the used compiler - -const - hExt = 'h'+''; - -var - cExt: string = 'c'+''; // extension of generated C/C++ files - // (can be changed to .cpp later) - -function completeCFilePath(const cfile: string; - createSubDir: Boolean = true): string; - -function getCompileCFileCmd(const cfilename: string; - isExternal: bool = false): string; - -procedure addFileToCompile(const filename: string); -procedure addExternalFileToCompile(const filename: string); -procedure addFileToLink(const filename: string); - -procedure addCompileOption(const option: string); -procedure addLinkOption(const option: string); - -function toObjFile(const filenameWithoutExt: string): string; - -procedure CallCCompiler(const projectFile: string); - -procedure execExternalProgram(const cmd: string); - -function NameToCC(const name: string): TSystemCC; - -procedure initVars; - -procedure setCC(const ccname: string); -procedure writeMapping(gSymbolMapping: PRope); - -implementation - -var - toLink, toCompile, externalToCompile: TLinkedList; - linkOptions: string = ''; - compileOptions: string = ''; - - ccompilerpath: string = ''; - -procedure setCC(const ccname: string); -var - i: TSystemCC; -begin - ccompiler := nameToCC(ccname); - if ccompiler = ccNone then rawMessage(errUnknownCcompiler, ccname); - compileOptions := getConfigVar(CC[ccompiler].name + '.options.always'); - linkOptions := getConfigVar(CC[ccompiler].name + '.options.linker'); - 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! - 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')); - addLinkOption(getConfigVar(CC[ccompiler].name + '.options.linker')); - if length(ccompilerPath) = 0 then - ccompilerpath := getConfigVar(CC[ccompiler].name + '.path'); -end; - -function completeCFilePath(const cfile: string; - createSubDir: Boolean = true): string; -begin - result := completeGeneratedFilePath(cfile, createSubDir); -end; - -function NameToCC(const name: string): TSystemCC; -var - i: TSystemCC; -begin - for i := succ(ccNone) to high(TSystemCC) do - if cmpIgnoreStyle(name, CC[i].name) = 0 then begin - result := i; exit - end; - result := ccNone -end; - -procedure addOpt(var dest: string; const src: string); -begin - if (length(dest) = 0) or (dest[length(dest)-1+strStart] <> ' ') then - add(dest, ' '+''); - add(dest, src); -end; - -procedure addCompileOption(const option: string); -begin - if strutils.find(compileOptions, option, strStart) < strStart then - addOpt(compileOptions, option) -end; - -procedure addLinkOption(const option: string); -begin - if find(linkOptions, option, strStart) < strStart then - addOpt(linkOptions, option) -end; - -function toObjFile(const filenameWithoutExt: string): string; -begin - result := changeFileExt(filenameWithoutExt, cc[ccompiler].objExt) -end; - -procedure addFileToCompile(const filename: string); -begin - appendStr(toCompile, filename); -end; - -procedure addExternalFileToCompile(const filename: string); -begin - appendStr(externalToCompile, filename); -end; - -procedure addFileToLink(const filename: string); -begin - prependStr(toLink, filename); // BUGFIX - //appendStr(toLink, filename); -end; - -procedure execExternalProgram(const cmd: string); -begin - if (optListCmd in gGlobalOptions) or (gVerbosity > 0) then - MessageOut(cmd); - if execCmd(cmd) <> 0 then - rawMessage(errExecutionOfProgramFailed); -end; - -procedure generateScript(const projectFile: string; script: PRope); -var - path, scriptname, name, ext: string; -begin - splitPath(projectFile, path, scriptname); - SplitFilename(scriptname, name, ext); - name := addFileExt('compile_' + name, platform.os[targetOS].scriptExt); - WriteRope(script, joinPath(path, name)); -end; - -function getOptSpeed(c: TSystemCC): string; -begin - result := getConfigVar(cc[c].name + '.options.speed'); - if result = '' then - result := cc[c].optSpeed // use default settings from this file -end; - -function getDebug(c: TSystemCC): string; -begin - result := getConfigVar(cc[c].name + '.options.debug'); - if result = '' then - result := cc[c].debug // use default settings from this file -end; - -function getOptSize(c: TSystemCC): string; -begin - result := getConfigVar(cc[c].name + '.options.size'); - if result = '' then - 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, key, trunk, exe: string; - c: TSystemCC; // an alias to ccompiler -begin - c := ccompiler; - options := compileOptions; - trunk := splitFile(cfilename).name; - 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 targetOS = osWindows then exe := addFileExt(exe, 'exe'); - - if (optGenDynLib in gGlobalOptions) - and (ospNeedsPIC in platform.OS[targetOS].props) then - add(options, ' ' + cc[c].pic); - - if targetOS = platform.hostOS then begin - // compute include paths: - includeCmd := cc[c].includeCmd; // this is more complex than needed, but - // a workaround of a FPC bug... - add(includeCmd, quoteIfContainsWhite(libpath)); - compilePattern := JoinPath(ccompilerpath, exe); - end - else begin - includeCmd := ''; - compilePattern := cc[c].compilerExe - end; - if targetOS = platform.hostOS then - cfile := cfilename - else - cfile := extractFileName(cfilename); - - if not isExternal or (targetOS <> platform.hostOS) then - objfile := toObjFile(cfile) - else - objfile := completeCFilePath(toObjFile(cfile)); - cfile := quoteIfContainsWhite(AddFileExt(cfile, cExt)); - objfile := quoteIfContainsWhite(objfile); - - result := quoteIfContainsWhite(format(compilePattern, - ['file', cfile, - 'objfile', objfile, - 'options', options, - 'include', includeCmd, - 'nimrod', getPrefixDir(), - 'lib', libpath - ])); - add(result, ' '); - add(result, format(cc[c].compileTmpl, - ['file', cfile, - 'objfile', objfile, - 'options', options, - 'include', includeCmd, - 'nimrod', quoteIfContainsWhite(getPrefixDir()), - 'lib', quoteIfContainsWhite(libpath) - ])); -end; - -procedure CompileCFile(const list: TLinkedList; - var script: PRope; - var cmds: TStringSeq; - isExternal: Boolean); -var - it: PStrEntry; - compileCmd: string; -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 - add(cmds, compileCmd); //execExternalProgram(compileCmd); - if (optGenScript in gGlobalOptions) then begin - app(script, compileCmd); - app(script, tnl); - end; - it := PStrEntry(it.next); - end; -end; - -procedure CallCCompiler(const projectfile: string); -var - it: PStrEntry; - linkCmd, objfiles, exefile, buildgui, builddll, linkerExe: string; - c: TSystemCC; // an alias to ccompiler - script: PRope; - cmds: TStringSeq; - res, i: int; -begin - if (gGlobalOptions * [optCompileOnly, optGenScript] = [optCompileOnly]) then - exit; // speed up that call if only compiling and no script shall be - // generated - if (toCompile.head = nil) and (externalToCompile.head = nil) then exit; - fileCounter := 0; - c := ccompiler; - script := nil; - cmds := {@ignore} nil {@emit @[]}; - CompileCFile(toCompile, script, cmds, false); - CompileCFile(externalToCompile, script, cmds, true); - if not (optCompileOnly in gGlobalOptions) then begin - if gNumberOfProcessors = 0 then - gNumberOfProcessors := countProcessors(); - if gNumberOfProcessors <= 1 then begin - res := 0; - for i := 0 to high(cmds) do res := max(execCmd(cmds[i]), res); - end - else if (optListCmd in gGlobalOptions) or (gVerbosity > 0) then - res := execProcesses(cmds, {@set}[poEchoCmd, poUseShell, poParentStreams], - gNumberOfProcessors) - else - res := execProcesses(cmds, {@set}[poUseShell, poParentStreams], - gNumberOfProcessors); - if res <> 0 then - rawMessage(errExecutionOfProgramFailed); - end; - - 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 targetOS = osWindows then linkerExe := addFileExt(linkerExe, 'exe'); - - if (platform.hostOS <> targetOS) then - linkCmd := quoteIfContainsWhite(linkerExe) - else - linkCmd := quoteIfContainsWhite(JoinPath(ccompilerpath, linkerExe)); - - if optGenGuiApp in gGlobalOptions then - buildGui := cc[c].buildGui - else - buildGui := ''; - - if optGenDynLib in gGlobalOptions then begin - exefile := format(platform.os[targetOS].dllFrmt, - [splitFile(projectFile).name]); - buildDll := cc[c].buildDll; - end - else begin - exefile := splitFile(projectFile).name +{&} platform.os[targetOS].exeExt; - buildDll := ''; - end; - if targetOS = platform.hostOS then - exefile := joinPath(splitFile(projectFile).dir, exefile); - exefile := quoteIfContainsWhite(exefile); - - it := PStrEntry(toLink.head); - objfiles := ''; - while it <> nil do begin - add(objfiles, ' '+''); - if targetOS = platform.hostOS then - add(objfiles, quoteIfContainsWhite(toObjfile(it.data))) - else - add(objfiles, quoteIfContainsWhite( - toObjfile(extractFileName(it.data)))); - it := PStrEntry(it.next); - end; - - linkCmd := quoteIfContainsWhite(format(linkCmd, [ - 'builddll', builddll, - 'buildgui', buildgui, - 'options', linkOptions, - 'objfiles', objfiles, - 'exefile', exefile, - 'nimrod', getPrefixDir(), - 'lib', libpath - ])); - add(linkCmd, ' '); - add(linkCmd, format(cc[c].linkTmpl, [ - 'builddll', builddll, - 'buildgui', buildgui, - 'options', linkOptions, - 'objfiles', objfiles, - 'exefile', exefile, - 'nimrod', quoteIfContainsWhite(getPrefixDir()), - 'lib', quoteIfContainsWhite(libpath) - ])); - - if not (optCompileOnly in gGlobalOptions) then - execExternalProgram(linkCmd); - end // end if not noLinking - else - linkCmd := ''; - if (optGenScript in gGlobalOptions) then begin - app(script, linkCmd); - app(script, tnl); - generateScript(projectFile, script) - 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:r"$1"$n', [toRope(AddFileExt(it.data, cExt))]); - it := PStrEntry(it.next); - end; -end; - -procedure writeMapping(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/filters.pas b/nim/filters.pas deleted file mode 100755 index 95f628fe2..000000000 --- a/nim/filters.pas +++ /dev/null @@ -1,137 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit filters; - -// This module implements Nimrod's simple filters and helpers for filters. - -{$include config.inc} - -interface - -uses - nsystem, llstream, nos, charsets, wordrecg, idents, strutils, - ast, astalgo, msgs, options, rnimsyn; - -function filterReplace(input: PLLStream; const filename: string; - call: PNode): PLLStream; -function filterStrip(input: PLLStream; const filename: string; - call: PNode): PLLStream; - -// helpers to retrieve arguments: -function charArg(n: PNode; const name: string; pos: int; default: Char): Char; -function strArg(n: PNode; const name: string; pos: int; - const default: string): string; -function boolArg(n: PNode; const name: string; pos: int; default: bool): bool; - -implementation - -procedure invalidPragma(n: PNode); -begin - liMessage(n.info, errXNotAllowedHere, renderTree(n, {@set}[renderNoComments])); -end; - -function getArg(n: PNode; const name: string; pos: int): PNode; -var - i: int; -begin - result := nil; - if n.kind in [nkEmpty..nkNilLit] then exit; - for i := 1 to sonsLen(n)-1 do - if n.sons[i].kind = nkExprEqExpr then begin - if n.sons[i].sons[0].kind <> nkIdent then invalidPragma(n); - if IdentEq(n.sons[i].sons[0].ident, name) then begin - result := n.sons[i].sons[1]; - exit - end - end - else if i = pos then begin - result := n.sons[i]; exit - end -end; - -function charArg(n: PNode; const name: string; pos: int; default: Char): Char; -var - x: PNode; -begin - x := getArg(n, name, pos); - if x = nil then result := default - else if x.kind = nkCharLit then result := chr(int(x.intVal)) - else invalidPragma(n); -end; - -function strArg(n: PNode; const name: string; pos: int; - const default: string): string; -var - x: PNode; -begin - x := getArg(n, name, pos); - if x = nil then result := default - else if x.kind in [nkStrLit..nkTripleStrLit] then result := x.strVal - else invalidPragma(n); -end; - -function boolArg(n: PNode; const name: string; pos: int; default: bool): bool; -var - x: PNode; -begin - x := getArg(n, name, pos); - if x = nil then result := default - else if (x.kind = nkIdent) and IdentEq(x.ident, 'true') then result := true - else if (x.kind = nkIdent) and IdentEq(x.ident, 'false') then result := false - else invalidPragma(n); -end; - -// -------------------------- strip filter ----------------------------------- - -function filterStrip(input: PLLStream; const filename: string; - call: PNode): PLLStream; -var - line, pattern, stripped: string; - leading, trailing: bool; -begin - pattern := strArg(call, 'startswith', 1, ''); - leading := boolArg(call, 'leading', 2, true); - trailing := boolArg(call, 'trailing', 3, true); - - result := LLStreamOpen(''); - while not LLStreamAtEnd(input) do begin - line := LLStreamReadLine(input); - {@ignore} - stripped := strip(line); - {@emit - stripped := strip(line, leading, trailing); - } - if (length(pattern) = 0) or startsWith(stripped, pattern) then - LLStreamWriteln(result, stripped) - else - LLStreamWriteln(result, line) - end; - LLStreamClose(input); -end; - -// -------------------------- replace filter --------------------------------- - -function filterReplace(input: PLLStream; const filename: string; - call: PNode): PLLStream; -var - line, sub, by: string; -begin - sub := strArg(call, 'sub', 1, ''); - if length(sub) = 0 then invalidPragma(call); - by := strArg(call, 'by', 2, ''); - - result := LLStreamOpen(''); - while not LLStreamAtEnd(input) do begin - line := LLStreamReadLine(input); - LLStreamWriteln(result, replace(line, sub, by)) - end; - LLStreamClose(input); -end; - -end. diff --git a/nim/hashtest.pas b/nim/hashtest.pas deleted file mode 100755 index 7e93ca5bf..000000000 --- a/nim/hashtest.pas +++ /dev/null @@ -1,10 +0,0 @@ -program hashtest; - -{$include 'config.inc'} - -uses - nhashes; - -begin - writeln(output, getNormalizedHash(ParamStr(1))); -end. diff --git a/nim/highlite.pas b/nim/highlite.pas deleted file mode 100755 index fa760d2a2..000000000 --- a/nim/highlite.pas +++ /dev/null @@ -1,743 +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 highlite; - -// Source highlighter for programming or markup languages. -// Currently only few languages are supported, other languages may be added. -// The interface supports one language nested in another. - -interface - -{$include 'config.inc'} - -uses - charsets, nsystem, sysutils, nhashes, options, msgs, strutils, platform, - idents, lexbase, wordrecg, scanner; - -type - TTokenClass = ( - gtEof, - gtNone, - gtWhitespace, - gtDecNumber, - gtBinNumber, - gtHexNumber, - gtOctNumber, - gtFloatNumber, - gtIdentifier, - gtKeyword, - gtStringLit, - gtLongStringLit, - gtCharLit, - gtEscapeSequence, // escape sequence like \xff - gtOperator, - gtPunctation, - gtComment, - gtLongComment, - gtRegularExpression, - gtTagStart, - gtTagEnd, - gtKey, - gtValue, - gtRawData, - gtAssembler, - gtPreprocessor, - gtDirective, - gtCommand, - gtRule, - gtHyperlink, - gtLabel, - gtReference, - gtOther - ); - TGeneralTokenizer = object(NObject) - kind: TTokenClass; - start, len: int; - // private: - buf: PChar; - pos: int; - state: TTokenClass; - end; - TSourceLanguage = ( - langNone, - langNimrod, - langCpp, - langCsharp, - langC, - langJava - ); -const - sourceLanguageToStr: array [TSourceLanguage] of string = ( - 'none', 'Nimrod', 'C++', 'C#', 'C'+'', 'Java' - ); - tokenClassToStr: array [TTokenClass] of string = ( - 'Eof', - 'None', - 'Whitespace', - 'DecNumber', - 'BinNumber', - 'HexNumber', - 'OctNumber', - 'FloatNumber', - 'Identifier', - 'Keyword', - 'StringLit', - 'LongStringLit', - 'CharLit', - 'EscapeSequence', - 'Operator', - 'Punctation', - 'Comment', - 'LongComment', - 'RegularExpression', - 'TagStart', - 'TagEnd', - 'Key', - 'Value', - 'RawData', - 'Assembler', - 'Preprocessor', - 'Directive', - 'Command', - 'Rule', - 'Hyperlink', - 'Label', - 'Reference', - 'Other' - ); - -function getSourceLanguage(const name: string): TSourceLanguage; - -procedure initGeneralTokenizer(var g: TGeneralTokenizer; - const buf: string); -procedure deinitGeneralTokenizer(var g: TGeneralTokenizer); -procedure getNextToken(var g: TGeneralTokenizer; lang: TSourceLanguage); - -implementation - -function getSourceLanguage(const name: string): TSourceLanguage; -var - i: TSourceLanguage; -begin - for i := succ(low(TSourceLanguage)) to high(TSourceLanguage) do - if cmpIgnoreStyle(name, sourceLanguageToStr[i]) = 0 then begin - result := i; exit - end; - result := langNone -end; - -procedure initGeneralTokenizer(var g: TGeneralTokenizer; - const buf: string); -var - pos: int; -begin -{@ignore} fillChar(g, sizeof(g), 0); {@emit} - g.buf := PChar(buf); - g.kind := low(TTokenClass); - g.start := 0; - g.len := 0; - g.state := low(TTokenClass); - pos := 0; - // skip initial whitespace: - while g.buf[pos] in [' ', #9..#13] do inc(pos); - g.pos := pos; -end; - -procedure deinitGeneralTokenizer(var g: TGeneralTokenizer); -begin -end; - -function nimGetKeyword(const id: string): TTokenClass; -var - i: PIdent; -begin - i := getIdent(id); - if (i.id >= ord(tokKeywordLow)-ord(tkSymbol)) and - (i.id <= ord(tokKeywordHigh)-ord(tkSymbol)) then - result := gtKeyword - else - result := gtIdentifier -end; - -function nimNumberPostfix(var g: TGeneralTokenizer; position: int): int; -var - pos: int; -begin - pos := position; - if g.buf[pos] = '''' then begin - inc(pos); - case g.buf[pos] of - 'f', 'F': begin - g.kind := gtFloatNumber; - inc(pos); - if g.buf[pos] in ['0'..'9'] then inc(pos); - if g.buf[pos] in ['0'..'9'] then inc(pos); - end; - 'i', 'I': begin - inc(pos); - if g.buf[pos] in ['0'..'9'] then inc(pos); - if g.buf[pos] in ['0'..'9'] then inc(pos); - end; - else begin end - end - end; - result := pos; -end; - -function nimNumber(var g: TGeneralTokenizer; position: int): int; -const - decChars = ['0'..'9', '_']; -var - pos: int; -begin - pos := position; - g.kind := gtDecNumber; - while g.buf[pos] in decChars do inc(pos); - if g.buf[pos] = '.' then begin - g.kind := gtFloatNumber; - inc(pos); - while g.buf[pos] in decChars do inc(pos); - end; - if g.buf[pos] in ['e', 'E'] then begin - g.kind := gtFloatNumber; - inc(pos); - if g.buf[pos] in ['+', '-'] then inc(pos); - while g.buf[pos] in decChars do inc(pos); - end; - result := nimNumberPostfix(g, pos); -end; - -procedure nimNextToken(var g: TGeneralTokenizer); -const - hexChars = ['0'..'9', 'A'..'F', 'a'..'f', '_']; - octChars = ['0'..'7', '_']; - binChars = ['0'..'1', '_']; -var - pos: int; - id: string; -begin - pos := g.pos; - g.start := g.pos; - if g.state = gtStringLit then begin - g.kind := gtStringLit; - while true do begin - case g.buf[pos] of - '\': begin - g.kind := gtEscapeSequence; - inc(pos); - case g.buf[pos] of - 'x', 'X': begin - inc(pos); - if g.buf[pos] in hexChars then inc(pos); - if g.buf[pos] in hexChars then inc(pos); - end; - '0'..'9': while g.buf[pos] in ['0'..'9'] do inc(pos); - #0: g.state := gtNone; - else inc(pos); - end; - break - end; - #0, #13, #10: begin g.state := gtNone; break end; - '"': begin - inc(pos); - g.state := gtNone; - break - end; - else inc(pos) - end - end - end - else begin - case g.buf[pos] of - ' ', #9..#13: begin - g.kind := gtWhitespace; - while g.buf[pos] in [' ', #9..#13] do inc(pos); - end; - '#': begin - g.kind := gtComment; - while not (g.buf[pos] in [#0, #10, #13]) do inc(pos); - end; - 'a'..'z', 'A'..'Z', '_', #128..#255: begin - id := ''; - while g.buf[pos] in scanner.SymChars+['_'] do begin - addChar(id, g.buf[pos]); - inc(pos) - end; - if (g.buf[pos] = '"') then begin - if (g.buf[pos+1] = '"') and (g.buf[pos+2] = '"') then begin - inc(pos, 3); - g.kind := gtLongStringLit; - while true do begin - case g.buf[pos] of - #0: break; - '"': begin - inc(pos); - if (g.buf[pos] = '"') and (g.buf[pos+1] = '"') then begin - inc(pos, 2); - break - end - end; - else inc(pos); - end - end - end - else begin - g.kind := gtRawData; - inc(pos); - while not (g.buf[pos] in [#0, '"', #10, #13]) do inc(pos); - if g.buf[pos] = '"' then inc(pos); - end - end - else begin - g.kind := nimGetKeyword(id); - end - end; - '0': begin - inc(pos); - case g.buf[pos] of - 'b', 'B': begin - inc(pos); - while g.buf[pos] in binChars do inc(pos); - pos := nimNumberPostfix(g, pos); - end; - 'x', 'X': begin - inc(pos); - while g.buf[pos] in hexChars do inc(pos); - pos := nimNumberPostfix(g, pos); - end; - 'o', 'O': begin - inc(pos); - while g.buf[pos] in octChars do inc(pos); - pos := nimNumberPostfix(g, pos); - end; - else - pos := nimNumber(g, pos); - end - end; - '1'..'9': begin - pos := nimNumber(g, pos); - end; - '''': begin - inc(pos); - g.kind := gtCharLit; - while true do begin - case g.buf[pos] of - #0, #13, #10: break; - '''': begin inc(pos); break end; - '\': begin inc(pos, 2); end; - else inc(pos); - end - end - end; - '"': begin - inc(pos); - if (g.buf[pos] = '"') and (g.buf[pos+1] = '"') then begin - inc(pos, 2); - g.kind := gtLongStringLit; - while true do begin - case g.buf[pos] of - #0: break; - '"': begin - inc(pos); - if (g.buf[pos] = '"') and (g.buf[pos+1] = '"') then begin - inc(pos, 2); - break - end - end; - else inc(pos); - end - end - end - else begin - g.kind := gtStringLit; - while true do begin - case g.buf[pos] of - #0, #13, #10: break; - '"': begin inc(pos); break end; - '\': begin g.state := g.kind; break end; - else inc(pos); - end - end - end - end; - '(', ')', '[', ']', '{', '}', '`', ':', ',', ';': begin - inc(pos); - g.kind := gtPunctation - end; - #0: g.kind := gtEof; - else if g.buf[pos] in scanner.OpChars then begin - g.kind := gtOperator; - while g.buf[pos] in scanner.OpChars do inc(pos); - end - else begin - inc(pos); - g.kind := gtNone - end; - end - end; - g.len := pos - g.pos; - if (g.kind <> gtEof) and (g.len <= 0) then - InternalError('nimNextToken: ' + toString(g.buf)); - g.pos := pos; -end; - -// ------------------------------- helpers ------------------------------------ - -function generalNumber(var g: TGeneralTokenizer; position: int): int; -const - decChars = ['0'..'9']; -var - pos: int; -begin - pos := position; - g.kind := gtDecNumber; - while g.buf[pos] in decChars do inc(pos); - if g.buf[pos] = '.' then begin - g.kind := gtFloatNumber; - inc(pos); - while g.buf[pos] in decChars do inc(pos); - end; - if g.buf[pos] in ['e', 'E'] then begin - g.kind := gtFloatNumber; - inc(pos); - if g.buf[pos] in ['+', '-'] then inc(pos); - while g.buf[pos] in decChars do inc(pos); - end; - result := pos; -end; - -function generalStrLit(var g: TGeneralTokenizer; position: int): int; -const - decChars = ['0'..'9']; - hexChars = ['0'..'9', 'A'..'F', 'a'..'f']; -var - pos: int; - c: Char; -begin - pos := position; - g.kind := gtStringLit; - c := g.buf[pos]; - inc(pos); // skip " or ' - while true do begin - case g.buf[pos] of - #0: break; - '\': begin - inc(pos); - case g.buf[pos] of - #0: break; - '0'..'9': while g.buf[pos] in decChars do inc(pos); - 'x', 'X': begin - inc(pos); - if g.buf[pos] in hexChars then inc(pos); - if g.buf[pos] in hexChars then inc(pos); - end; - else inc(pos, 2) - end - end; - else if g.buf[pos] = c then begin - inc(pos); break; - end - else - inc(pos); - end - end; - result := pos; -end; - -function isKeyword(const x: array of string; const y: string): int; -var - a, b, mid, c: int; -begin - a := 0; - b := length(x)-1; - while a <= b do begin - mid := (a + b) div 2; - c := cmp(x[mid], y); - if c < 0 then - a := mid + 1 - else if c > 0 then - b := mid - 1 - else begin - result := mid; - exit - end - end; - result := -1 -end; - -function isKeywordIgnoreCase(const x: array of string; const y: string): int; -var - a, b, mid, c: int; -begin - a := 0; - b := length(x)-1; - while a <= b do begin - mid := (a + b) div 2; - c := cmpIgnoreCase(x[mid], y); - if c < 0 then - a := mid + 1 - else if c > 0 then - b := mid - 1 - else begin - result := mid; - exit - end - end; - result := -1 -end; - -// --------------------------------------------------------------------------- - -type - TTokenizerFlag = (hasPreprocessor, hasNestedComments); - TTokenizerFlags = set of TTokenizerFlag; - -procedure clikeNextToken(var g: TGeneralTokenizer; - const keywords: array of string; - flags: TTokenizerFlags); -const - hexChars = ['0'..'9', 'A'..'F', 'a'..'f']; - octChars = ['0'..'7']; - binChars = ['0'..'1']; - symChars = ['A'..'Z', 'a'..'z', '0'..'9', '_', #128..#255]; -var - pos, nested: int; - id: string; -begin - pos := g.pos; - g.start := g.pos; - if g.state = gtStringLit then begin - g.kind := gtStringLit; - while true do begin - case g.buf[pos] of - '\': begin - g.kind := gtEscapeSequence; - inc(pos); - case g.buf[pos] of - 'x', 'X': begin - inc(pos); - if g.buf[pos] in hexChars then inc(pos); - if g.buf[pos] in hexChars then inc(pos); - end; - '0'..'9': while g.buf[pos] in ['0'..'9'] do inc(pos); - #0: g.state := gtNone; - else inc(pos); - end; - break - end; - #0, #13, #10: begin g.state := gtNone; break end; - '"': begin - inc(pos); - g.state := gtNone; - break - end; - else inc(pos) - end - end - end - else begin - case g.buf[pos] of - ' ', #9..#13: begin - g.kind := gtWhitespace; - while g.buf[pos] in [' ', #9..#13] do inc(pos); - end; - '/': begin - inc(pos); - if g.buf[pos] = '/' then begin - g.kind := gtComment; - while not (g.buf[pos] in [#0, #10, #13]) do inc(pos); - end - else if g.buf[pos] = '*' then begin - g.kind := gtLongComment; - nested := 0; - inc(pos); - while true do begin - case g.buf[pos] of - '*': begin - inc(pos); - if g.buf[pos] = '/' then begin - inc(pos); - if nested = 0 then break - end; - end; - '/': begin - inc(pos); - if g.buf[pos] = '*' then begin - inc(pos); - if hasNestedComments in flags then inc(nested); - end - end; - #0: break; - else inc(pos); - end - end - end - end; - '#': begin - inc(pos); - if hasPreprocessor in flags then begin - g.kind := gtPreprocessor; - while g.buf[pos] in [' ', Tabulator] do inc(pos); - while g.buf[pos] in symChars do inc(pos); - end - else - g.kind := gtOperator - end; - 'a'..'z', 'A'..'Z', '_', #128..#255: begin - id := ''; - while g.buf[pos] in SymChars do begin - addChar(id, g.buf[pos]); - inc(pos) - end; - if isKeyword(keywords, id) >= 0 then g.kind := gtKeyword - else g.kind := gtIdentifier; - end; - '0': begin - inc(pos); - case g.buf[pos] of - 'b', 'B': begin - inc(pos); - while g.buf[pos] in binChars do inc(pos); - if g.buf[pos] in ['A'..'Z', 'a'..'z'] then inc(pos); - end; - 'x', 'X': begin - inc(pos); - while g.buf[pos] in hexChars do inc(pos); - if g.buf[pos] in ['A'..'Z', 'a'..'z'] then inc(pos); - end; - '0'..'7': begin - inc(pos); - while g.buf[pos] in octChars do inc(pos); - if g.buf[pos] in ['A'..'Z', 'a'..'z'] then inc(pos); - end; - else begin - pos := generalNumber(g, pos); - if g.buf[pos] in ['A'..'Z', 'a'..'z'] then inc(pos); - end - end - end; - '1'..'9': begin - pos := generalNumber(g, pos); - if g.buf[pos] in ['A'..'Z', 'a'..'z'] then inc(pos); - end; - '''': begin - pos := generalStrLit(g, pos); - g.kind := gtCharLit; - end; - '"': begin - inc(pos); - g.kind := gtStringLit; - while true do begin - case g.buf[pos] of - #0: break; - '"': begin inc(pos); break end; - '\': begin g.state := g.kind; break end; - else inc(pos); - end - end - end; - '(', ')', '[', ']', '{', '}', ':', ',', ';', '.': begin - inc(pos); - g.kind := gtPunctation - end; - #0: g.kind := gtEof; - else if g.buf[pos] in scanner.OpChars then begin - g.kind := gtOperator; - while g.buf[pos] in scanner.OpChars do inc(pos); - end - else begin - inc(pos); - g.kind := gtNone - end; - end - end; - g.len := pos - g.pos; - if (g.kind <> gtEof) and (g.len <= 0) then InternalError('clikeNextToken'); - g.pos := pos; -end; - -// -------------------------------------------------------------------------- - -procedure cNextToken(var g: TGeneralTokenizer); -const - keywords: array [0..36] of string = ( - '_Bool', '_Complex', '_Imaginary', - 'auto', 'break', 'case', 'char', 'const', 'continue', 'default', 'do', - 'double', 'else', 'enum', 'extern', 'float', 'for', 'goto', 'if', - 'inline', 'int', 'long', 'register', 'restrict', 'return', 'short', - 'signed', 'sizeof', 'static', 'struct', 'switch', 'typedef', 'union', - 'unsigned', 'void', 'volatile', 'while' - ); -begin - clikeNextToken(g, keywords, {@set}[hasPreprocessor]); -end; - -procedure cppNextToken(var g: TGeneralTokenizer); -const - keywords: array [0..47] of string = ( - 'asm', 'auto', 'break', 'case', 'catch', 'char', 'class', 'const', - 'continue', 'default', 'delete', 'do', 'double', 'else', 'enum', 'extern', - 'float', 'for', 'friend', 'goto', 'if', 'inline', 'int', 'long', 'new', - 'operator', 'private', 'protected', 'public', 'register', 'return', - 'short', 'signed', 'sizeof', 'static', 'struct', 'switch', 'template', - 'this', 'throw', 'try', 'typedef', 'union', 'unsigned', 'virtual', 'void', - 'volatile', 'while' - ); -begin - clikeNextToken(g, keywords, {@set}[hasPreprocessor]); -end; - -procedure csharpNextToken(var g: TGeneralTokenizer); -const - keywords: array [0..76] of string = ( - 'abstract', 'as', 'base', 'bool', 'break', 'byte', 'case', 'catch', - 'char', 'checked', 'class', 'const', 'continue', 'decimal', 'default', - 'delegate', 'do', 'double', 'else', 'enum', 'event', 'explicit', 'extern', - 'false', 'finally', 'fixed', 'float', 'for', 'foreach', 'goto', 'if', - 'implicit', 'in', 'int', 'interface', 'internal', 'is', 'lock', 'long', - 'namespace', 'new', 'null', 'object', 'operator', 'out', 'override', - 'params', 'private', 'protected', 'public', 'readonly', 'ref', 'return', - 'sbyte', 'sealed', 'short', 'sizeof', 'stackalloc', 'static', 'string', - 'struct', 'switch', 'this', 'throw', 'true', 'try', 'typeof', 'uint', - 'ulong', 'unchecked', 'unsafe', 'ushort', 'using', 'virtual', 'void', - 'volatile', 'while' - ); -begin - clikeNextToken(g, keywords, {@set}[hasPreprocessor]); -end; - -procedure javaNextToken(var g: TGeneralTokenizer); -const - keywords: array [0..52] of string = ( - 'abstract', 'assert', 'boolean', 'break', 'byte', 'case', 'catch', - 'char', 'class', 'const', 'continue', 'default', 'do', 'double', 'else', - 'enum', 'extends', 'false', 'final', 'finally', 'float', 'for', 'goto', - 'if', 'implements', 'import', 'instanceof', 'int', 'interface', 'long', - 'native', 'new', 'null', 'package', 'private', 'protected', 'public', - 'return', 'short', 'static', 'strictfp', 'super', 'switch', - 'synchronized', 'this', 'throw', 'throws', 'transient', 'true', 'try', - 'void', 'volatile', 'while' - ); -begin - clikeNextToken(g, keywords, {@set}[]); -end; - -procedure getNextToken(var g: TGeneralTokenizer; lang: TSourceLanguage); -begin - case lang of - langNimrod: nimNextToken(g); - langCpp: cppNextToken(g); - langCsharp: csharpNextToken(g); - langC: cNextToken(g); - langJava: javaNextToken(g); - else InternalError('getNextToken'); - end -end; - -end. diff --git a/nim/idents.pas b/nim/idents.pas deleted file mode 100755 index c1c1755e9..000000000 --- a/nim/idents.pas +++ /dev/null @@ -1,170 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit idents; - -{$include 'config.inc'} - -// Identifier handling -// An identifier is a shared non-modifiable string that can be compared by its -// id. This module is essential for the compiler's performance. - -interface - -uses - nhashes, nsystem, strutils; - -type - TIdObj = object(NObject) - id: int; // unique id; use this for comparisons and not the pointers - end; - PIdObj = ^TIdObj; - - PIdent = ^TIdent; - TIdent = object(TIdObj) - s: string; - next: PIdent; // for hash-table chaining - h: THash; // hash value of s - end {@acyclic}; - -function getIdent(const identifier: string): PIdent; overload; -function getIdent(const identifier: string; h: THash): PIdent; overload; -function getIdent(identifier: cstring; len: int; h: THash): PIdent; overload; - // special version for the scanner; the scanner's buffering scheme makes - // this horribly efficient. Most of the time no character copying is needed! - -function IdentEq(id: PIdent; const name: string): bool; - -implementation - -function IdentEq(id: PIdent; const name: string): bool; -begin - result := id.id = getIdent(name).id; -end; - -var - buckets: array [0..4096*2-1] of PIdent; - -function cmpIgnoreStyle(a, b: cstring; blen: int): int; -var - aa, bb: char; - i, j: int; -begin - i := 0; - j := 0; - result := 1; - while j < blen do begin - while a[i] = '_' do inc(i); - while b[j] = '_' do inc(j); - // tolower inlined: - aa := a[i]; - bb := b[j]; - if (aa >= 'A') and (aa <= 'Z') then - aa := chr(ord(aa) + (ord('a') - ord('A'))); - if (bb >= 'A') and (bb <= 'Z') then - bb := chr(ord(bb) + (ord('a') - ord('A'))); - result := ord(aa) - ord(bb); - if (result <> 0) or (aa = #0) then break; - inc(i); - inc(j) - end; - if result = 0 then - if a[i] <> #0 then result := 1 -end; - -function cmpExact(a, b: cstring; blen: int): int; -var - aa, bb: char; - i, j: int; -begin - i := 0; - j := 0; - result := 1; - while j < blen do begin - aa := a[i]; - bb := b[j]; - result := ord(aa) - ord(bb); - if (result <> 0) or (aa = #0) then break; - inc(i); - inc(j) - end; - if result = 0 then - if a[i] <> #0 then result := 1 -end; - -function getIdent(const identifier: string): PIdent; -begin - result := getIdent(pchar(identifier), length(identifier), - getNormalizedHash(identifier)) -end; - -function getIdent(const identifier: string; h: THash): PIdent; -begin - result := getIdent(pchar(identifier), length(identifier), h) -end; - -var - wordCounter: int = 1; - -function getIdent(identifier: cstring; len: int; h: THash): PIdent; -var - idx, i, id: int; - last: PIdent; -begin - idx := h and high(buckets); - result := buckets[idx]; - last := nil; - id := 0; - while result <> nil do begin - if cmpExact(pchar(result.s), identifier, len) = 0 then begin - if last <> nil then begin - // make access to last looked up identifier faster: - last.next := result.next; - result.next := buckets[idx]; - buckets[idx] := result - end; - exit - end - else if cmpIgnoreStyle(pchar(result.s), identifier, len) = 0 then begin - (*if (id <> 0) and (id <> result.id) then begin - result := buckets[idx]; - writeln('current id ', id); - for i := 0 to len-1 do write(identifier[i]); - writeln; - while result <> nil do begin - writeln(result.s, ' ', result.id); - result := result.next - end - end;*) - assert((id = 0) or (id = result.id)); - id := result.id - end; - last := result; - result := result.next - end; - // new ident: - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.h := h; - result.s := newString(len); - for i := strStart to len+StrStart-1 do - result.s[i] := identifier[i-StrStart]; - result.next := buckets[idx]; - buckets[idx] := result; - if id = 0 then begin - inc(wordCounter); - result.id := - wordCounter; - end - else - result.id := id -// writeln('new word ', result.s); -end; - -end. diff --git a/nim/importer.pas b/nim/importer.pas deleted file mode 100755 index a1ed57978..000000000 --- a/nim/importer.pas +++ /dev/null @@ -1,180 +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 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 - result := options.FindFile(AddFileExt(modulename, nimExt)); - if result = '' then liMessage(info, errCannotOpenFile, modulename); -end; - -function getModuleFile(n: PNode): string; -begin - case n.kind of - nkStrLit, nkRStrLit, nkTripleStrLit: begin - result := findModule(n.info, UnixToNativePath(n.strVal)); - end; - nkIdent: begin - result := findModule(n.info, n.ident.s); - end; - nkSym: begin - result := findModule(n.info, n.sym.name.s); - end; - else begin - internalError(n.info, 'getModuleFile()'); - result := ''; - end - end -end; - -procedure rawImportSymbol(c: PContext; s: PSym); -var - check, copy, e: PSym; - j: int; - etyp: PType; // enumeration type - it: TIdentIter; -begin - // 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) and (check.id <> copy.id) then begin - if not (s.kind in OverloadableSyms) then begin - // s and check need to be qualified: - IntSetIncl(c.AmbiguousSymbols, copy.id); - IntSetIncl(c.AmbiguousSymbols, check.id); - end - end; - StrTableAdd(c.tab.stack[importTablePos], copy); - if s.kind = skType then begin - etyp := s.typ; - 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 - 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); // rodgen assures that converters are no stubs -end; - -procedure importSymbol(c: PContext; ident: PNode; fromMod: PSym); -var - s, e: PSym; - it: TIdentIter; -begin - if (ident.kind <> nkIdent) then InternalError(ident.info, 'importSymbol'); - 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 - case s.Kind of - skProc, skMethod, skIterator, skMacro, skTemplate, skConverter: begin - // for a overloadable syms add all overloaded routines - e := InitIdentIter(it, fromMod.tab, s.name); - while e <> nil do begin - if (e.name.id <> s.Name.id) then - InternalError(ident.info, 'importSymbol: 3'); - rawImportSymbol(c, e); - e := NextIdentIter(it, fromMod.tab); - end - end; - else rawImportSymbol(c, s) - end -end; - -procedure importAllSymbols(c: PContext; fromMod: PSym); -var - i: TTabIter; - s: PSym; -begin - s := InitTabIter(i, fromMod.tab); - while s <> nil do begin - if s.kind <> skModule then begin - if s.kind <> skEnumField then begin - if not (s.Kind in ExportableSymKinds) then - InternalError(s.info, 'importAllSymbols: ' + symKindToStr[s.kind]); - rawImportSymbol(c, s); // this is correct! - end - end; - s := NextIter(i, fromMod.tab) - end -end; - -function evalImport(c: PContext; n: PNode): PNode; -var - m: PSym; - i: int; - f: string; -begin - result := n; - for i := 0 to sonsLen(n)-1 do begin - f := getModuleFile(n.sons[i]); - m := gImportModule(f); - if sfDeprecated in m.flags then - liMessage(n.sons[i].info, warnDeprecated, m.name.s); - // ``addDecl`` needs to be done before ``importAllSymbols``! - addDecl(c, m); // add symbol to symbol table of module - importAllSymbols(c, m); - end; -end; - -function evalFrom(c: PContext; n: PNode): PNode; -var - m: PSym; - i: int; - f: string; -begin - result := n; - checkMinSonsLen(n, 2); - 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; - -end. diff --git a/nim/interact.pas b/nim/interact.pas deleted file mode 100755 index aab3c7fc2..000000000 --- a/nim/interact.pas +++ /dev/null @@ -1,22 +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 interact; - -// This file implements interactive sessions. - -interface - -{$include 'config.inc'} - -uses - nsystem, llstream, strutils, charsets, ropes, nstrtabs, msgs; - -implementation - -end. diff --git a/nim/lexbase.pas b/nim/lexbase.pas deleted file mode 100755 index 2b056c04f..000000000 --- a/nim/lexbase.pas +++ /dev/null @@ -1,232 +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 lexbase; - -// Base Object of a lexer with efficient buffer handling. In fact -// I believe that this is the most efficient method of buffer -// handling that exists! Only at line endings checks are necessary -// if the buffer needs refilling. - -interface - -uses - nsystem, llstream, charsets, strutils; - -{@emit -const - Lrz = ' '; - Apo = ''''; - Tabulator = #9; - ESC = #27; - CR = #13; - FF = #12; - LF = #10; - BEL = #7; - BACKSPACE = #8; - VT = #11; -} - -const - EndOfFile = #0; // end of file marker -{ A little picture makes everything clear :-) - buf: - "Example Text\n ha!" bufLen = 17 - ^pos = 0 ^ sentinel = 12 -} - NewLines = {@set}[CR, LF]; - -type - TBaseLexer = object(NObject) - bufpos: int; - buf: PChar; - bufLen: int; // length of buffer in characters - 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 - end; - -procedure openBaseLexer(out L: TBaseLexer; - inputstream: PLLStream; - bufLen: int = 8192); - // 8K is a reasonable buffer size - -procedure closeBaseLexer(var L: TBaseLexer); - -function getCurrentLine(const L: TBaseLexer; marker: boolean = true): string; -function getColNumber(const L: TBaseLexer; pos: int): int; - -function HandleCR(var L: TBaseLexer; pos: int): int; -// Call this if you scanned over CR in the buffer; it returns the -// position to continue the scanning from. `pos` must be the position -// of the CR. - -function HandleLF(var L: TBaseLexer; pos: int): int; -// Call this if you scanned over LF in the buffer; it returns the the -// position to continue the scanning from. `pos` must be the position -// of the LF. - -implementation - -const - chrSize = sizeof(char); - -procedure closeBaseLexer(var L: TBaseLexer); -begin - dealloc(L.buf); - LLStreamClose(L.stream); -end; - -{@ignore} -{$ifdef false} -procedure printBuffer(const L: TBaseLexer); -var - i: int; -begin - writeln('____________________________________'); - writeln('sentinel: ', L.sentinel); - writeln('bufLen: ', L.bufLen); - writeln('buf: '); - for i := 0 to L.bufLen-1 do write(L.buf[i]); - writeln(NL + '____________________________________'); -end; -{$endif} -{@emit} - -procedure FillBuffer(var L: TBaseLexer); -var - charsRead, toCopy, s: int; // all are in characters, - // not bytes (in case this - // is not the same) - oldBufLen: int; -begin - // we know here that pos == L.sentinel, but not if this proc - // is called the first time by initBaseLexer() - assert(L.sentinel < L.bufLen); - toCopy := L.BufLen - L.sentinel - 1; - assert(toCopy >= 0); - if toCopy > 0 then - MoveMem(L.buf, addr(L.buf[L.sentinel+1]), toCopy * chrSize); - // "moveMem" handles overlapping regions - 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 - L.sentinel := s - end - else begin - // compute sentinel: - dec(s); // BUGFIX (valgrind) - while true do begin - assert(s < L.bufLen); - while (s >= 0) and not (L.buf[s] in NewLines) do Dec(s); - if s >= 0 then begin - // we found an appropriate character for a sentinel: - L.sentinel := s; - break - end - else begin - // rather than to give up here because the line is too long, - // double the buffer's size and try again: - oldBufLen := L.BufLen; - L.bufLen := L.BufLen * 2; - L.buf := {@cast}PChar(realloc(L.buf, L.bufLen*chrSize)); - assert(L.bufLen - oldBuflen = oldBufLen); - 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; - break - end; - s := L.bufLen - 1 - end - end - end -end; - -function fillBaseLexer(var L: TBaseLexer; pos: int): int; -begin - assert(pos <= L.sentinel); - if pos < L.sentinel then begin - result := pos+1; // nothing to do - end - else begin - fillBuffer(L); - L.bufpos := 0; // XXX: is this really correct? - result := 0; - end; - L.lineStart := result; -end; - -function HandleCR(var L: TBaseLexer; pos: int): int; -begin - assert(L.buf[pos] = CR); - inc(L.linenumber); - result := fillBaseLexer(L, pos); - if L.buf[result] = LF then begin - result := fillBaseLexer(L, result); - end; - //L.lastNL := result-1; // BUGFIX: was: result; -end; - -function HandleLF(var L: TBaseLexer; pos: int): int; -begin - assert(L.buf[pos] = LF); - inc(L.linenumber); - result := fillBaseLexer(L, pos); - //L.lastNL := result-1; // BUGFIX: was: result; -end; - -procedure skip_UTF_8_BOM(var L: TBaseLexer); -begin - if (L.buf[0] = #239) and (L.buf[1] = #187) and (L.buf[2] = #191) then begin - inc(L.bufpos, 3); - inc(L.lineStart, 3) - end -end; - -procedure openBaseLexer(out L: TBaseLexer; inputstream: PLLStream; - bufLen: int = 8192); -begin - assert(bufLen > 0); - L.bufpos := 0; - L.bufLen := bufLen; - L.buf := {@cast}PChar(alloc(bufLen * chrSize)); - L.sentinel := bufLen-1; - L.lineStart := 0; - L.linenumber := 1; // lines start at 1 - L.stream := inputstream; - fillBuffer(L); - skip_UTF_8_BOM(L); -end; - -function getColNumber(const L: TBaseLexer; pos: int): int; -begin - result := abs(pos - L.lineStart); -end; - -function getCurrentLine(const L: TBaseLexer; marker: boolean = true): string; -var - i: int; -begin - result := ''; - i := L.lineStart; - while not (L.buf[i] in [CR, LF, EndOfFile]) do begin - addChar(result, L.buf[i]); - inc(i) - end; - result := result +{&} NL; - if marker then - result := result +{&} RepeatChar(getColNumber(L, L.bufpos)) +{&} '^' +{&} NL -end; - -end. diff --git a/nim/lists.pas b/nim/lists.pas deleted file mode 100755 index e3442eb29..000000000 --- a/nim/lists.pas +++ /dev/null @@ -1,165 +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 lists; - -// This module implements a generic doubled linked list. - -interface - -{@ignore} -uses - nsystem; -{@emit} - -{$include 'config.inc'} - -type - PListEntry = ^TListEntry; - TListEntry = object(nobject) - prev, next: PListEntry; - end; - - TStrEntry = object(TListEntry) - data: string; - end; - PStrEntry = ^TStrEntry; - - TLinkedList = object - head, tail: PListEntry; - Counter: int; - end; - - // for the "find" operation: - TCompareProc = function (entry: PListEntry; closure: Pointer): Boolean; - -procedure InitLinkedList(var list: TLinkedList); -procedure Append(var list: TLinkedList; entry: PListEntry); -procedure Prepend(var list: TLinkedList; entry: PListEntry); -procedure Remove(var list: TLinkedList; entry: PListEntry); -procedure InsertBefore(var list: TLinkedList; pos, entry: PListEntry); - -function Find(const list: TLinkedList; fn: TCompareProc; - closure: Pointer): PListEntry; - -procedure AppendStr(var list: TLinkedList; const data: string); -function IncludeStr(var list: TLinkedList; const data: string): boolean; -procedure PrependStr(var list: TLinkedList; const data: string); - -implementation - -procedure InitLinkedList(var list: TLinkedList); -begin - list.Counter := 0; - list.head := nil; - list.tail := nil; -end; - -procedure Append(var list: TLinkedList; entry: PListEntry); -begin - Inc(list.counter); - entry.next := nil; - entry.prev := list.tail; - if list.tail <> nil then begin - assert(list.tail.next = nil); - list.tail.next := entry - end; - list.tail := entry; - if list.head = nil then - list.head := entry; -end; - -function newStrEntry(const data: string): PStrEntry; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.data := data -end; - -procedure AppendStr(var list: TLinkedList; const data: string); -begin - append(list, newStrEntry(data)); -end; - -procedure PrependStr(var list: TLinkedList; const data: string); -begin - prepend(list, newStrEntry(data)); -end; - -function IncludeStr(var list: TLinkedList; const data: string): boolean; -var - it: PListEntry; -begin - it := list.head; - while it <> nil do begin - if PStrEntry(it).data = data then begin - result := true; exit // already in list - end; - it := it.next; - end; - AppendStr(list, data); // else: add to list - result := false -end; - -procedure InsertBefore(var list: TLinkedList; pos, entry: PListEntry); -begin - assert(pos <> nil); - if pos = list.head then - prepend(list, entry) - else begin - Inc(list.counter); - entry.next := pos; - entry.prev := pos.prev; - if pos.prev <> nil then - pos.prev.next := entry; - pos.prev := entry; - end -end; - -procedure Prepend(var list: TLinkedList; entry: PListEntry); -begin - Inc(list.counter); - entry.prev := nil; - entry.next := list.head; - if list.head <> nil then begin - assert(list.head.prev = nil); - list.head.prev := entry - end; - list.head := entry; - if list.tail = nil then - list.tail := entry -end; - -procedure Remove(var list: TLinkedList; entry: PListEntry); -begin - Dec(list.counter); - if entry = list.tail then begin - list.tail := entry.prev - end; - if entry = list.head then begin - list.head := entry.next; - end; - if entry.next <> nil then - entry.next.prev := entry.prev; - if entry.prev <> nil then - entry.prev.next := entry.next; -end; - -function Find(const list: TLinkedList; fn: TCompareProc; - closure: Pointer): PListEntry; -begin - result := list.head; - while result <> nil do begin - if fn(result, closure) then exit; - result := result.next - end -end; - -end. diff --git a/nim/llstream.pas b/nim/llstream.pas deleted file mode 100755 index 30d9c0287..000000000 --- a/nim/llstream.pas +++ /dev/null @@ -1,257 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit llstream; - -// Low-level streams for high performance. - -interface - -uses - nsystem, charsets, strutils; - -type - TLLStreamKind = ( - llsNone, // null stream: reading and writing has no effect - llsString, // stream encapsulates a string - llsFile, // stream encapsulates a file - llsStdIn); // stream encapsulates stdin - TLLStream = object(NObject) - kind: TLLStreamKind; // accessible for low-level access (lexbase uses this) - f: TBinaryFile; - s: string; - rd, wr: int; // for string streams - end; - PLLStream = ^TLLStream; - - -function LLStreamOpen(const data: string): PLLStream; overload; -function LLStreamOpen(var f: TBinaryFile): PLLStream; overload; -function LLStreamOpen(const filename: string; mode: TFileMode): PLLStream; overload; -function LLStreamOpen(): PLLStream; overload; -function LLStreamOpenStdIn(): PLLStream; - -procedure LLStreamClose(s: PLLStream); - -function LLStreamRead(s: PLLStream; buf: pointer; bufLen: int): int; -function LLStreamReadLine(s: PLLStream): string; -function LLStreamReadAll(s: PLLStream): string; - -procedure LLStreamWrite(s: PLLStream; const data: string); overload; -procedure LLStreamWrite(s: PLLStream; data: Char); overload; -procedure LLStreamWrite(s: PLLStream; buf: pointer; buflen: int); overload; - -procedure LLStreamWriteln(s: PLLStream; const data: string); - -function LLStreamAtEnd(s: PLLStream): bool; - -implementation - -function LLStreamOpen(const data: string): PLLStream; overload; -begin - new(result); - {@ignore} - fillChar(result^, sizeof(result^), 0); - {@emit} - result.s := data; - result.kind := llsString; -end; - -function LLStreamOpen(var f: TBinaryFile): PLLStream; overload; -begin - new(result); - {@ignore} - fillChar(result^, sizeof(result^), 0); - {@emit} - result.f := f; - result.kind := llsFile; -end; - -function LLStreamOpen(const filename: string; mode: TFileMode): PLLStream; overload; -begin - new(result); - {@ignore} - fillChar(result^, sizeof(result^), 0); - {@emit} - result.kind := llsFile; - if not OpenFile(result.f, filename, mode) then result := nil; -end; - -function LLStreamOpen(): PLLStream; overload; -begin - new(result); - {@ignore} - fillChar(result^, sizeof(result^), 0); - {@emit} - result.kind := llsNone; -end; - -function LLStreamOpenStdIn(): PLLStream; -begin - new(result); - {@ignore} - fillChar(result^, sizeof(result^), 0); - {@emit} - result.kind := llsStdIn; - result.s := ''; -end; - -procedure LLStreamClose(s: PLLStream); -begin - case s.kind of - llsNone, llsString, llsStdIn: begin end; - llsFile: nimCloseFile(s.f); - end -end; - -function LLreadFromStdin(s: PLLStream; buf: pointer; bufLen: int): int; -var - line: string; - L: int; -begin - s.s := ''; - s.rd := 0; - while true do begin - write(output, 'Nimrod> '); - line := readLine(input); - L := length(line); - add(s.s, line); - add(s.s, nl); - if (L > 0) and (line[L-1+strStart] = '#') then break; - end; - result := min(bufLen, length(s.s)-s.rd); - if result > 0 then begin - copyMem(buf, addr(s.s[strStart+s.rd]), result); - inc(s.rd, result) - end -end; - -function LLStreamRead(s: PLLStream; buf: pointer; bufLen: int): int; -begin - case s.kind of - llsNone: result := 0; - llsString: begin - result := min(bufLen, length(s.s)-s.rd); - if result > 0 then begin - copyMem(buf, addr(s.s[strStart+s.rd]), result); - inc(s.rd, result) - end - end; - llsFile: result := readBuffer(s.f, buf, bufLen); - llsStdIn: result := LLreadFromStdin(s, buf, bufLen); - end -end; - -function LLStreamReadLine(s: PLLStream): string; -begin - case s.kind of - llsNone: result := ''; - llsString: begin - result := ''; - while s.rd < length(s.s) do begin - case s.s[s.rd+strStart] of - #13: begin - inc(s.rd); - if s.s[s.rd+strStart] = #10 then inc(s.rd); - break - end; - #10: begin inc(s.rd); break end; - else begin - addChar(result, s.s[s.rd+strStart]); - inc(s.rd); - end - end - end - end; - llsFile: result := readLine(s.f); - llsStdIn: result := readLine(input); - end -end; - -function LLStreamAtEnd(s: PLLStream): bool; -begin - case s.kind of - llsNone: result := true; - llsString: result := s.rd >= length(s.s); - llsFile: result := endOfFile(s.f); - llsStdIn: result := false; - end -end; - -procedure LLStreamWrite(s: PLLStream; const data: string); overload; -begin - case s.kind of - llsNone, llsStdIn: begin end; - llsString: begin add(s.s, data); inc(s.wr, length(data)) end; - llsFile: nimWrite(s.f, data); - end; -end; - -procedure LLStreamWriteln(s: PLLStream; const data: string); -begin - LLStreamWrite(s, data); - LLStreamWrite(s, nl); -end; - -procedure LLStreamWrite(s: PLLStream; data: Char); overload; -var - c: char; -begin - case s.kind of - llsNone, llsStdIn: begin end; - llsString: begin addChar(s.s, data); inc(s.wr); end; - llsFile: begin - c := data; - {@discard} writeBuffer(s.f, addr(c), sizeof(c)); - end - end -end; - -procedure LLStreamWrite(s: PLLStream; buf: pointer; buflen: int); overload; -begin - case s.kind of - llsNone, llsStdIn: begin end; - llsString: begin - if bufLen > 0 then begin - setLength(s.s, length(s.s) + bufLen); - copyMem(addr(s.s[strStart+s.wr]), buf, bufLen); - inc(s.wr, bufLen); - end - end; - llsFile: {@discard} writeBuffer(s.f, buf, bufLen); - end -end; - -function LLStreamReadAll(s: PLLStream): string; -const - bufSize = 2048; -var - bytes, i: int; -begin - case s.kind of - llsNone, llsStdIn: result := ''; - llsString: begin - if s.rd = 0 then result := s.s - else result := ncopy(s.s, s.rd+strStart); - s.rd := length(s.s); - end; - llsFile: begin - result := newString(bufSize); - bytes := readBuffer(s.f, addr(result[strStart]), bufSize); - i := bytes; - while bytes = bufSize do begin - setLength(result, i+bufSize); - bytes := readBuffer(s.f, addr(result[i+strStart]), bufSize); - inc(i, bytes); - end; - setLength(result, i); - end - end -end; - -end. diff --git a/nim/llvmdata.pas b/nim/llvmdata.pas deleted file mode 100755 index a8ae0f311..000000000 --- a/nim/llvmdata.pas +++ /dev/null @@ -1,139 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit llvmdata; - -// this module implements data structures for emitting LLVM. - -interface - -{$include 'config.inc'} - -uses - nsystem, ast, astalgo, idents, lists, passes; - -type - VTypeKind = ( - VoidTyID, ///< 0: type with no size - FloatTyID, ///< 1: 32 bit floating point type - DoubleTyID, ///< 2: 64 bit floating point type - X86_FP80TyID, ///< 3: 80 bit floating point type (X87) - FP128TyID, ///< 4: 128 bit floating point type (112-bit mantissa) - PPC_FP128TyID, ///< 5: 128 bit floating point type (two 64-bits) - LabelTyID, ///< 6: Labels - MetadataTyID, ///< 7: Metadata - - // Derived types... see DerivedTypes.h file... - // Make sure FirstDerivedTyID stays up to date!!! - IntegerTyID, ///< 8: Arbitrary bit width integers - FunctionTyID, ///< 9: Functions - StructTyID, ///< 10: Structures - ArrayTyID, ///< 11: Arrays - PointerTyID, ///< 12: Pointers - OpaqueTyID, ///< 13: Opaque: type with unknown structure - VectorTyID, ///< 14: SIMD 'packed' format, or other vector type - ); - VType = ^VTypeDesc; - VTypeSeq = array of VType; - VTypeDesc = object(TIdObj) - k: VTypeKind; - s: VTypeSeq; - arrayLen: int; - name: string; - end; - - VInstrKind = ( - iNone, - iAdd, - iSub, - iMul, - iDiv, - iMod, - - ); - VLocalVar = record - - - end; - VInstr = record - k: VInstrKind; - - end; - -/// This represents a single basic block in LLVM. A basic block is simply a -/// container of instructions that execute sequentially. Basic blocks are Values -/// because they are referenced by instructions such as branches and switch -/// tables. The type of a BasicBlock is "Type::LabelTy" because the basic block -/// represents a label to which a branch can jump. -/// - VBlock = ^VBlockDesc; - VBlockDesc = record // LLVM basic block - // list of instructions - end; - - VLinkage = ( - ExternalLinkage, // Externally visible function - LinkOnceLinkage, // Keep one copy of function when linking (inline) - WeakLinkage, // Keep one copy of function when linking (weak) - AppendingLinkage, // Special purpose, only applies to global arrays - InternalLinkage, // Rename collisions when linking (static functions) - DLLImportLinkage, // Function to be imported from DLL - DLLExportLinkage, // Function to be accessible from DLL - ExternalWeakLinkage, // ExternalWeak linkage description - GhostLinkage // Stand-in functions for streaming fns from bitcode - ); - VVisibility = ( - DefaultVisibility, // The GV is visible - HiddenVisibility, // The GV is hidden - ProtectedVisibility // The GV is protected - ); - TLLVMCallConv = ( - CCallConv = 0, - FastCallConv = 8, - ColdCallConv = 9, - X86StdcallCallConv = 64, - X86FastcallCallConv = 65 - ); - - VProc = ^VProcDesc; - VProcDesc = record - b: VBlock; - name: string; - sym: PSym; // proc that is generated - linkage: VLinkage; - vis: VVisibility; - callConv: VCallConv; - next: VProc; - end; - VModule = ^VModuleDesc; - VModuleDesc = object(TPassContext) // represents a C source file - sym: PSym; - filename: string; - typeCache: TIdTable; // cache the generated types - forwTypeCache: TIdTable; // cache for forward declarations of types - declaredThings: TIntSet; // things we have declared in this file - declaredProtos: TIntSet; // prototypes we have declared in this file - headerFiles: TLinkedList; // needed headers to include - typeInfoMarker: TIntSet; // needed for generating type information - initProc: VProc; // code for init procedure - typeStack: TTypeSeq; // used for type generation - dataCache: TNodeTable; - forwardedProcs: TSymSeq; // keep forwarded procs here - typeNodes, nimTypes: int;// used for type info generation - typeNodesName, nimTypesName: PRope; // used for type info generation - labels: natural; // for generating unique module-scope names - next: VModule; // to stack modules - end; - - - -implementation - - -end. - diff --git a/nim/llvmdyn.pas b/nim/llvmdyn.pas deleted file mode 100755 index e039939e5..000000000 --- a/nim/llvmdyn.pas +++ /dev/null @@ -1,443 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit llvmdyn; - -// this module implements the interface to LLVM. - -interface - -{$include 'config.inc'} - -uses - nsystem; - -const - llvmdll = 'llvm.dll'; - -{ Opaque types. } -{ - The top-level container for all other LLVM Intermediate Representation (IR) - objects. See the llvm::Module class. -} -type - cuint = int32; - PLLVMBasicBlockRef = ^TLLVMBasicBlockRef; - PLLVMMemoryBufferRef = ^TLLVMMemoryBufferRef; - PLLVMTypeRef = ^TLLVMTypeRef; - PLLVMValueRef = ^TLLVMValueRef; - - TLLVMOpaqueModule = record end; - TLLVMModuleRef = ^TLLVMOpaqueModule; -{ - Each value in the LLVM IR has a type, an instance of [lltype]. See the - llvm: : Type class. -} - TLLVMOpaqueType = record end; - TLLVMTypeRef = ^TLLVMOpaqueType; -{ - When building recursive types using [refine_type], [lltype] values may become - invalid; use [lltypehandle] to resolve this problem. See the - llvm: : AbstractTypeHolder] class. -} - TLLVMOpaqueTypeHandle = record end; - TLLVMTypeHandleRef = ^TLLVMOpaqueTypeHandle; - TLLVMOpaqueValue = record end; - TLLVMValueRef = ^TLLVMOpaqueValue; - TLLVMOpaqueBasicBlock = record end; - TLLVMBasicBlockRef = ^TLLVMOpaqueBasicBlock; - - TLLVMOpaqueBuilder = record end; - TLLVMBuilderRef = ^TLLVMOpaqueBuilder; -{ Used to provide a module to JIT or interpreter. - See the llvm: : ModuleProvider class. -} - TLLVMOpaqueModuleProvider = record end; - TLLVMModuleProviderRef = ^TLLVMOpaqueModuleProvider; -{ Used to provide a module to JIT or interpreter. - See the llvm: : MemoryBuffer class. -} - TLLVMOpaqueMemoryBuffer = record end; - TLLVMMemoryBufferRef = ^TLLVMOpaqueMemoryBuffer; - - TLLVMTypeKind = ( - LLVMVoidTypeKind, // type with no size - LLVMFloatTypeKind, // 32 bit floating point type - LLVMDoubleTypeKind, // 64 bit floating point type - LLVMX86_FP80TypeKind, // 80 bit floating point type (X87) - LLVMFP128TypeKind, // 128 bit floating point type (112-bit mantissa) - LLVMPPC_FP128TypeKind, // 128 bit floating point type (two 64-bits) - LLVMLabelTypeKind, // Labels - LLVMIntegerTypeKind, // Arbitrary bit width integers - LLVMFunctionTypeKind, // Functions - LLVMStructTypeKind, // Structures - LLVMArrayTypeKind, // Arrays - LLVMPointerTypeKind, // Pointers - LLVMOpaqueTypeKind, // Opaque: type with unknown structure - LLVMVectorTypeKind // SIMD 'packed' format, or other vector type - ); - - TLLVMLinkage = ( - LLVMExternalLinkage, // Externally visible function - LLVMLinkOnceLinkage, // Keep one copy of function when linking (inline) - LLVMWeakLinkage, // Keep one copy of function when linking (weak) - LLVMAppendingLinkage, // Special purpose, only applies to global arrays - LLVMInternalLinkage, // Rename collisions when linking (static functions) - LLVMDLLImportLinkage, // Function to be imported from DLL - LLVMDLLExportLinkage, // Function to be accessible from DLL - LLVMExternalWeakLinkage, // ExternalWeak linkage description - LLVMGhostLinkage // Stand-in functions for streaming fns from bitcode - ); - - TLLVMVisibility = ( - LLVMDefaultVisibility, // The GV is visible - LLVMHiddenVisibility, // The GV is hidden - LLVMProtectedVisibility // The GV is protected - ); - - TLLVMCallConv = ( - LLVMCCallConv = 0, - LLVMFastCallConv = 8, - LLVMColdCallConv = 9, - LLVMX86StdcallCallConv = 64, - LLVMX86FastcallCallConv = 65 - ); - - TLLVMIntPredicate = ( - LLVMIntEQ = 32, // equal - LLVMIntNE, // not equal - LLVMIntUGT, // unsigned greater than - LLVMIntUGE, // unsigned greater or equal - LLVMIntULT, // unsigned less than - LLVMIntULE, // unsigned less or equal - LLVMIntSGT, // signed greater than - LLVMIntSGE, // signed greater or equal - LLVMIntSLT, // signed less than - LLVMIntSLE // signed less or equal - ); - - TLLVMRealPredicate = ( - LLVMRealPredicateFalse, // Always false (always folded) - LLVMRealOEQ, // True if ordered and equal - LLVMRealOGT, // True if ordered and greater than - LLVMRealOGE, // True if ordered and greater than or equal - LLVMRealOLT, // True if ordered and less than - LLVMRealOLE, // True if ordered and less than or equal - LLVMRealONE, // True if ordered and operands are unequal - LLVMRealORD, // True if ordered (no nans) - LLVMRealUNO, // True if unordered: isnan(X) | isnan(Y) - LLVMRealUEQ, // True if unordered or equal - LLVMRealUGT, // True if unordered or greater than - LLVMRealUGE, // True if unordered, greater than, or equal - LLVMRealULT, // True if unordered or less than - LLVMRealULE, // True if unordered, less than, or equal - LLVMRealUNE, // True if unordered or not equal - LLVMRealPredicateTrue // Always true (always folded) - ); - -{===-- Error handling ----------------------------------------------------=== } -procedure LLVMDisposeMessage(msg: pchar); cdecl; external llvmdll; -{===-- Modules -----------------------------------------------------------=== } -{ Create and destroy modules. } -function LLVMModuleCreateWithName(ModuleID: pchar): TLLVMModuleRef; cdecl; external llvmdll; -procedure LLVMDisposeModule(M: TLLVMModuleRef);cdecl;external llvmdll; -{ Data layout } -function LLVMGetDataLayout(M: TLLVMModuleRef): pchar;cdecl;external llvmdll; -procedure LLVMSetDataLayout(M: TLLVMModuleRef; Triple: pchar);cdecl;external llvmdll; -{ Target triple } -function LLVMGetTarget(M: TLLVMModuleRef): pchar;cdecl;external llvmdll; -(* Const before type ignored *) -procedure LLVMSetTarget(M: TLLVMModuleRef; Triple: pchar);cdecl;external llvmdll; -{ Same as Module: : addTypeName. } -function LLVMAddTypeName(M: TLLVMModuleRef; Name: pchar; Ty: TLLVMTypeRef): longint;cdecl;external llvmdll; -procedure LLVMDeleteTypeName(M: TLLVMModuleRef; Name: pchar);cdecl;external llvmdll; -{===-- Types -------------------------------------------------------------=== } -{ LLVM types conform to the following hierarchy: - * - * types: - * integer type - * real type - * function type - * sequence types: - * array type - * pointer type - * vector type - * void type - * label type - * opaque type - } -function LLVMGetTypeKind(Ty: TLLVMTypeRef): TLLVMTypeKind; cdecl; external llvmdll; -procedure LLVMRefineAbstractType(AbstractType: TLLVMTypeRef; ConcreteType: TLLVMTypeRef); cdecl; external llvmdll; -{ Operations on integer types } -function LLVMInt1Type: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMInt8Type: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMInt16Type: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMInt32Type: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMInt64Type: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMIntType(NumBits: cuint): TLLVMTypeRef;cdecl;external llvmdll; -function LLVMGetIntTypeWidth(IntegerTy: TLLVMTypeRef): cuint;cdecl;external llvmdll; -{ Operations on real types } -function LLVMFloatType: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMDoubleType: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMX86FP80Type: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMFP128Type: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMPPCFP128Type: TLLVMTypeRef;cdecl;external llvmdll; -{ Operations on function types } -function LLVMFunctionType(ReturnType: TLLVMTypeRef; ParamTypes: PLLVMTypeRef; ParamCount: cuint; IsVarArg: longint): TLLVMTypeRef;cdecl;external llvmdll; -function LLVMIsFunctionVarArg(FunctionTy: TLLVMTypeRef): longint;cdecl;external llvmdll; -function LLVMGetReturnType(FunctionTy: TLLVMTypeRef): TLLVMTypeRef;cdecl;external llvmdll; -function LLVMCountParamTypes(FunctionTy: TLLVMTypeRef): cuint;cdecl;external llvmdll; -procedure LLVMGetParamTypes(FunctionTy: TLLVMTypeRef; Dest: PLLVMTypeRef);cdecl;external llvmdll; -{ Operations on struct types } -function LLVMStructType(ElementTypes: PLLVMTypeRef; ElementCount: cuint; isPacked: longint): TLLVMTypeRef;cdecl;external llvmdll; -function LLVMCountStructElementTypes(StructTy: TLLVMTypeRef): cuint;cdecl;external llvmdll; -procedure LLVMGetStructElementTypes(StructTy: TLLVMTypeRef; Dest: pLLVMTypeRef);cdecl;external llvmdll; -function LLVMIsPackedStruct(StructTy: TLLVMTypeRef): longint;cdecl;external llvmdll; -{ Operations on array, pointer, and vector types (sequence types) } -function LLVMArrayType(ElementType: TLLVMTypeRef; ElementCount: cuint): TLLVMTypeRef;cdecl;external llvmdll; -function LLVMPointerType(ElementType: TLLVMTypeRef; AddressSpace: cuint): TLLVMTypeRef;cdecl;external llvmdll; -function LLVMVectorType(ElementType: TLLVMTypeRef; ElementCount: cuint): TLLVMTypeRef;cdecl;external llvmdll; -function LLVMGetElementType(Ty: TLLVMTypeRef): TLLVMTypeRef;cdecl;external llvmdll; -function LLVMGetArrayLength(ArrayTy: TLLVMTypeRef): cuint;cdecl;external llvmdll; -function LLVMGetPointerAddressSpace(PointerTy: TLLVMTypeRef): cuint;cdecl;external llvmdll; -function LLVMGetVectorSize(VectorTy: TLLVMTypeRef): cuint;cdecl;external llvmdll; -{ Operations on other types } -function LLVMVoidType: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMLabelType: TLLVMTypeRef;cdecl;external llvmdll; -function LLVMOpaqueType: TLLVMTypeRef;cdecl;external llvmdll; -{ Operations on type handles } -function LLVMCreateTypeHandle(PotentiallyAbstractTy: TLLVMTypeRef): TLLVMTypeHandleRef;cdecl;external llvmdll; -procedure LLVMRefineType(AbstractTy: TLLVMTypeRef; ConcreteTy: TLLVMTypeRef);cdecl;external llvmdll; -function LLVMResolveTypeHandle(TypeHandle: TLLVMTypeHandleRef): TLLVMTypeRef;cdecl;external llvmdll; -procedure LLVMDisposeTypeHandle(TypeHandle: TLLVMTypeHandleRef);cdecl;external llvmdll; -{===-- Values ------------------------------------------------------------=== } -{ The bulk of LLVM's object model consists of values, which comprise a very - * rich type hierarchy. - * - * values: - * constants: - * scalar constants - * composite contants - * globals: - * global variable - * function - * alias - * basic blocks - } -{ Operations on all values } -function LLVMTypeOf(Val: TLLVMValueRef): TLLVMTypeRef;cdecl;external llvmdll; -function LLVMGetValueName(Val: TLLVMValueRef): pchar;cdecl;external llvmdll; -procedure LLVMSetValueName(Val: TLLVMValueRef; Name: pchar);cdecl;external llvmdll; -procedure LLVMDumpValue(Val: TLLVMValueRef);cdecl;external llvmdll; -{ Operations on constants of any type } -function LLVMConstNull(Ty: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -{ all zeroes } -function LLVMConstAllOnes(Ty: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -{ only for int/vector } -function LLVMGetUndef(Ty: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMIsConstant(Val: TLLVMValueRef): longint;cdecl;external llvmdll; -function LLVMIsNull(Val: TLLVMValueRef): longint;cdecl;external llvmdll; -function LLVMIsUndef(Val: TLLVMValueRef): longint;cdecl;external llvmdll; -{ Operations on scalar constants } -function LLVMConstInt(IntTy: TLLVMTypeRef; N: qword; SignExtend: longint): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstReal(RealTy: TLLVMTypeRef; N: double): TLLVMValueRef;cdecl;external llvmdll; -{ Operations on composite constants } -function LLVMConstString(Str: pchar; Length: cuint; DontNullTerminate: longint): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstArray(ArrayTy: TLLVMTypeRef; ConstantVals: pLLVMValueRef; Length: cuint): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstStruct(ConstantVals: pLLVMValueRef; Count: cuint; ispacked: longint): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstVector(ScalarConstantVals: pLLVMValueRef; Size: cuint): TLLVMValueRef;cdecl;external llvmdll; -{ Constant expressions } -function LLVMSizeOf(Ty: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstNeg(ConstantVal: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstNot(ConstantVal: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstAdd(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstSub(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstMul(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstUDiv(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstSDiv(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstFDiv(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstURem(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstSRem(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstFRem(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstAnd(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstOr(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstXor(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstICmp(Predicate: TLLVMIntPredicate; LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstFCmp(Predicate: TLLVMRealPredicate; LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstShl(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstLShr(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstAShr(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstGEP(ConstantVal: TLLVMValueRef; ConstantIndices: PLLVMValueRef; NumIndices: cuint): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstTrunc(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstSExt(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstZExt(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstFPTrunc(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstFPExt(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstUIToFP(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstSIToFP(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstFPToUI(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstFPToSI(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstPtrToInt(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstIntToPtr(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstBitCast(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstSelect(ConstantCondition: TLLVMValueRef; ConstantIfTrue: TLLVMValueRef; ConstantIfFalse: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstExtractElement(VectorConstant: TLLVMValueRef; IndexConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstInsertElement(VectorConstant: TLLVMValueRef; ElementValueConstant: TLLVMValueRef; IndexConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMConstShuffleVector(VectorAConstant: TLLVMValueRef; VectorBConstant: TLLVMValueRef; MaskConstant: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -{ Operations on global variables, functions, and aliases (globals) } -function LLVMIsDeclaration(Global: TLLVMValueRef): longint;cdecl;external llvmdll; -function LLVMGetLinkage(Global: TLLVMValueRef): TLLVMLinkage;cdecl;external llvmdll; -procedure LLVMSetLinkage(Global: TLLVMValueRef; Linkage: TLLVMLinkage);cdecl;external llvmdll; -function LLVMGetSection(Global: TLLVMValueRef): pchar;cdecl;external llvmdll; -procedure LLVMSetSection(Global: TLLVMValueRef; Section: pchar);cdecl;external llvmdll; -function LLVMGetVisibility(Global: TLLVMValueRef): TLLVMVisibility;cdecl;external llvmdll; -procedure LLVMSetVisibility(Global: TLLVMValueRef; Viz: TLLVMVisibility);cdecl;external llvmdll; -function LLVMGetAlignment(Global: TLLVMValueRef): cuint;cdecl;external llvmdll; -procedure LLVMSetAlignment(Global: TLLVMValueRef; Bytes: cuint);cdecl;external llvmdll; -{ Operations on global variables } -(* Const before type ignored *) -function LLVMAddGlobal(M: TLLVMModuleRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -(* Const before type ignored *) -function LLVMGetNamedGlobal(M: TLLVMModuleRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -procedure LLVMDeleteGlobal(GlobalVar: TLLVMValueRef);cdecl;external llvmdll; -function LLVMHasInitializer(GlobalVar: TLLVMValueRef): longint;cdecl;external llvmdll; -function LLVMGetInitializer(GlobalVar: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -procedure LLVMSetInitializer(GlobalVar: TLLVMValueRef; ConstantVal: TLLVMValueRef);cdecl;external llvmdll; -function LLVMIsThreadLocal(GlobalVar: TLLVMValueRef): longint;cdecl;external llvmdll; -procedure LLVMSetThreadLocal(GlobalVar: TLLVMValueRef; IsThreadLocal: longint);cdecl;external llvmdll; -function LLVMIsGlobalConstant(GlobalVar: TLLVMValueRef): longint;cdecl;external llvmdll; -procedure LLVMSetGlobalConstant(GlobalVar: TLLVMValueRef; IsConstant: longint);cdecl;external llvmdll; -{ Operations on functions } -(* Const before type ignored *) -function LLVMAddFunction(M: TLLVMModuleRef; Name: pchar; FunctionTy: TLLVMTypeRef): TLLVMValueRef;cdecl;external llvmdll; -(* Const before type ignored *) -function LLVMGetNamedFunction(M: TLLVMModuleRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -procedure LLVMDeleteFunction(Fn: TLLVMValueRef);cdecl;external llvmdll; -function LLVMCountParams(Fn: TLLVMValueRef): cuint;cdecl;external llvmdll; -procedure LLVMGetParams(Fn: TLLVMValueRef; Params: PLLVMValueRef);cdecl;external llvmdll; -function LLVMGetParam(Fn: TLLVMValueRef; Index: cuint): TLLVMValueRef;cdecl;external llvmdll; -function LLVMGetIntrinsicID(Fn: TLLVMValueRef): cuint;cdecl;external llvmdll; -function LLVMGetFunctionCallConv(Fn: TLLVMValueRef): cuint;cdecl;external llvmdll; -procedure LLVMSetFunctionCallConv(Fn: TLLVMValueRef; CC: cuint);cdecl;external llvmdll; -(* Const before type ignored *) -function LLVMGetCollector(Fn: TLLVMValueRef): pchar;cdecl;external llvmdll; -(* Const before type ignored *) -procedure LLVMSetCollector(Fn: TLLVMValueRef; Coll: pchar);cdecl;external llvmdll; -{ Operations on basic blocks } -function LLVMBasicBlockAsValue(Bb: TLLVMBasicBlockRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMValueIsBasicBlock(Val: TLLVMValueRef): longint;cdecl;external llvmdll; -function LLVMValueAsBasicBlock(Val: TLLVMValueRef): TLLVMBasicBlockRef;cdecl;external llvmdll; -function LLVMCountBasicBlocks(Fn: TLLVMValueRef): cuint;cdecl;external llvmdll; -procedure LLVMGetBasicBlocks(Fn: TLLVMValueRef; BasicBlocks: PLLVMBasicBlockRef);cdecl;external llvmdll; -function LLVMGetEntryBasicBlock(Fn: TLLVMValueRef): TLLVMBasicBlockRef;cdecl;external llvmdll; -(* Const before type ignored *) -function LLVMAppendBasicBlock(Fn: TLLVMValueRef; Name: pchar): TLLVMBasicBlockRef;cdecl;external llvmdll; -(* Const before type ignored *) -function LLVMInsertBasicBlock(InsertBeforeBB: TLLVMBasicBlockRef; Name: pchar): TLLVMBasicBlockRef;cdecl;external llvmdll; -procedure LLVMDeleteBasicBlock(BB: TLLVMBasicBlockRef);cdecl;external llvmdll; -{ Operations on call sites } -procedure LLVMSetInstructionCallConv(Instr: TLLVMValueRef; CC: cuint);cdecl;external llvmdll; -function LLVMGetInstructionCallConv(Instr: TLLVMValueRef): cuint;cdecl;external llvmdll; -{ Operations on phi nodes } -procedure LLVMAddIncoming(PhiNode: TLLVMValueRef; IncomingValues: PLLVMValueRef; IncomingBlocks: PLLVMBasicBlockRef; Count: cuint);cdecl;external llvmdll; -function LLVMCountIncoming(PhiNode: TLLVMValueRef): cuint;cdecl;external llvmdll; -function LLVMGetIncomingValue(PhiNode: TLLVMValueRef; Index: cuint): TLLVMValueRef;cdecl;external llvmdll; -function LLVMGetIncomingBlock(PhiNode: TLLVMValueRef; Index: cuint): TLLVMBasicBlockRef;cdecl;external llvmdll; -{===-- Instruction builders ----------------------------------------------=== } -{ An instruction builder represents a point within a basic block, and is the - * exclusive means of building instructions using the C interface. - } -function LLVMCreateBuilder: TLLVMBuilderRef;cdecl;external llvmdll; -procedure LLVMPositionBuilderBefore(Builder: TLLVMBuilderRef; Instr: TLLVMValueRef);cdecl;external llvmdll; -procedure LLVMPositionBuilderAtEnd(Builder: TLLVMBuilderRef; theBlock: TLLVMBasicBlockRef);cdecl;external llvmdll; -procedure LLVMDisposeBuilder(Builder: TLLVMBuilderRef);cdecl;external llvmdll; -{ Terminators } -function LLVMBuildRetVoid(para1: TLLVMBuilderRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildRet(para1: TLLVMBuilderRef; V: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildBr(para1: TLLVMBuilderRef; Dest: TLLVMBasicBlockRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildCondBr(para1: TLLVMBuilderRef; IfCond: TLLVMValueRef; ThenBranch: TLLVMBasicBlockRef; ElseBranch: TLLVMBasicBlockRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildSwitch(para1: TLLVMBuilderRef; V: TLLVMValueRef; ElseBranch: TLLVMBasicBlockRef; NumCases: cuint): TLLVMValueRef;cdecl;external llvmdll; -(* Const before type ignored *) -function LLVMBuildInvoke(para1: TLLVMBuilderRef; Fn: TLLVMValueRef; Args: PLLVMValueRef; NumArgs: cuint; ThenBranch: TLLVMBasicBlockRef; - Catch: TLLVMBasicBlockRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildUnwind(para1: TLLVMBuilderRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildUnreachable(para1: TLLVMBuilderRef): TLLVMValueRef;cdecl;external llvmdll; -{ Add a case to the switch instruction } -procedure LLVMAddCase(Switch: TLLVMValueRef; OnVal: TLLVMValueRef; Dest: TLLVMBasicBlockRef);cdecl;external llvmdll; -{ Arithmetic } -function LLVMBuildAdd(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildSub(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildMul(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildUDiv(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildSDiv(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildFDiv(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildURem(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildSRem(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildFRem(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildShl(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildLShr(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildAShr(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildAnd(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildOr(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildXor(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildNeg(para1: TLLVMBuilderRef; V: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildNot(para1: TLLVMBuilderRef; V: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -{ Memory } -function LLVMBuildMalloc(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildArrayMalloc(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Val: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildAlloca(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildArrayAlloca(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Val: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildFree(para1: TLLVMBuilderRef; PointerVal: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildLoad(para1: TLLVMBuilderRef; PointerVal: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildStore(para1: TLLVMBuilderRef; Val: TLLVMValueRef; thePtr: TLLVMValueRef): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildGEP(B: TLLVMBuilderRef; Pointer: TLLVMValueRef; Indices: PLLVMValueRef; NumIndices: cuint; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -{ Casts } -function LLVMBuildTrunc(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildZExt(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildSExt(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildFPToUI(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildFPToSI(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildUIToFP(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildSIToFP(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildFPTrunc(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildFPExt(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildPtrToInt(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildIntToPtr(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildBitCast(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -{ Comparisons } -function LLVMBuildICmp(para1: TLLVMBuilderRef; Op: TLLVMIntPredicate; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildFCmp(para1: TLLVMBuilderRef; Op: TLLVMRealPredicate; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -{ Miscellaneous instructions } -function LLVMBuildPhi(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildCall(para1: TLLVMBuilderRef; Fn: TLLVMValueRef; Args: PLLVMValueRef; NumArgs: cuint; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildSelect(para1: TLLVMBuilderRef; IfCond: TLLVMValueRef; ThenBranch: TLLVMValueRef; ElseBranch: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildVAArg(para1: TLLVMBuilderRef; List: TLLVMValueRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildExtractElement(para1: TLLVMBuilderRef; VecVal: TLLVMValueRef; Index: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildInsertElement(para1: TLLVMBuilderRef; VecVal: TLLVMValueRef; EltVal: TLLVMValueRef; Index: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -function LLVMBuildShuffleVector(para1: TLLVMBuilderRef; V1: TLLVMValueRef; V2: TLLVMValueRef; Mask: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl;external llvmdll; -{===-- Module providers --------------------------------------------------=== } -{ Encapsulates the module M in a module provider, taking ownership of the - module. - See the constructor llvm: : ExistingModuleProvider: : ExistingModuleProvider. -} -function LLVMCreateModuleProviderForExistingModule(M: TLLVMModuleRef): TLLVMModuleProviderRef;cdecl;external llvmdll; -{ Destroys the module provider MP as well as the contained module. - See the destructor llvm: : ModuleProvider: : ~ModuleProvider. -} -procedure LLVMDisposeModuleProvider(MP: TLLVMModuleProviderRef);cdecl;external llvmdll; -{===-- Memory buffers ----------------------------------------------------=== } -function LLVMCreateMemoryBufferWithContentsOfFile(Path: pchar; OutMemBuf: pLLVMMemoryBufferRef; var OutMessage: pchar): longint;cdecl;external llvmdll; -function LLVMCreateMemoryBufferWithSTDIN(OutMemBuf: pLLVMMemoryBufferRef; var OutMessage: pchar): longint;cdecl;external llvmdll; -procedure LLVMDisposeMemoryBuffer(MemBuf: TLLVMMemoryBufferRef);cdecl;external llvmdll; - -function LLVMWriteBitcodeToFile(M: TLLVMModuleRef; path: pchar): int; cdecl; external llvmdll; -// Writes a module to the specified path. Returns 0 on success. - -implementation - -end. diff --git a/nim/llvmstat.pas b/nim/llvmstat.pas deleted file mode 100755 index e7d06a284..000000000 --- a/nim/llvmstat.pas +++ /dev/null @@ -1,445 +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 llvmstat; - -// this module implements the interface to LLVM. - -interface - -{$include 'config.inc'} - -uses - nsystem, ropes; - -{ Opaque types. } -{ - The top-level container for all other LLVM Intermediate Representation (IR) - objects. See the llvm::Module class. -} -type - cuint = int32; - - TLLVMTypeKind = ( - LLVMVoidTypeKind, // type with no size - LLVMFloatTypeKind, // 32 bit floating point type - LLVMDoubleTypeKind, // 64 bit floating point type - LLVMX86_FP80TypeKind, // 80 bit floating point type (X87) - LLVMFP128TypeKind, // 128 bit floating point type (112-bit mantissa) - LLVMPPC_FP128TypeKind, // 128 bit floating point type (two 64-bits) - LLVMLabelTypeKind, // Labels - LLVMIntegerTypeKind, // Arbitrary bit width integers - LLVMFunctionTypeKind, // Functions - LLVMStructTypeKind, // Structures - LLVMArrayTypeKind, // Arrays - LLVMPointerTypeKind, // Pointers - LLVMOpaqueTypeKind, // Opaque: type with unknown structure - LLVMVectorTypeKind // SIMD 'packed' format, or other vector type - ); - - TLLVMLinkage = ( - LLVMExternalLinkage, // Externally visible function - LLVMLinkOnceLinkage, // Keep one copy of function when linking (inline) - LLVMWeakLinkage, // Keep one copy of function when linking (weak) - LLVMAppendingLinkage, // Special purpose, only applies to global arrays - LLVMInternalLinkage, // Rename collisions when linking (static functions) - LLVMDLLImportLinkage, // Function to be imported from DLL - LLVMDLLExportLinkage, // Function to be accessible from DLL - LLVMExternalWeakLinkage, // ExternalWeak linkage description - LLVMGhostLinkage // Stand-in functions for streaming fns from bitcode - ); - - TLLVMVisibility = ( - LLVMDefaultVisibility, // The GV is visible - LLVMHiddenVisibility, // The GV is hidden - LLVMProtectedVisibility // The GV is protected - ); - - TLLVMCallConv = ( - LLVMCCallConv = 0, - LLVMFastCallConv = 8, - LLVMColdCallConv = 9, - LLVMX86StdcallCallConv = 64, - LLVMX86FastcallCallConv = 65 - ); - - TLLVMIntPredicate = ( - LLVMIntEQ = 32, // equal - LLVMIntNE, // not equal - LLVMIntUGT, // unsigned greater than - LLVMIntUGE, // unsigned greater or equal - LLVMIntULT, // unsigned less than - LLVMIntULE, // unsigned less or equal - LLVMIntSGT, // signed greater than - LLVMIntSGE, // signed greater or equal - LLVMIntSLT, // signed less than - LLVMIntSLE // signed less or equal - ); - - TLLVMRealPredicate = ( - LLVMRealPredicateFalse, // Always false (always folded) - LLVMRealOEQ, // True if ordered and equal - LLVMRealOGT, // True if ordered and greater than - LLVMRealOGE, // True if ordered and greater than or equal - LLVMRealOLT, // True if ordered and less than - LLVMRealOLE, // True if ordered and less than or equal - LLVMRealONE, // True if ordered and operands are unequal - LLVMRealORD, // True if ordered (no nans) - LLVMRealUNO, // True if unordered: isnan(X) | isnan(Y) - LLVMRealUEQ, // True if unordered or equal - LLVMRealUGT, // True if unordered or greater than - LLVMRealUGE, // True if unordered, greater than, or equal - LLVMRealULT, // True if unordered or less than - LLVMRealULE, // True if unordered, less than, or equal - LLVMRealUNE, // True if unordered or not equal - LLVMRealPredicateTrue // Always true (always folded) - ); - - PLLVMBasicBlockRef = ^TLLVMBasicBlockRef; - PLLVMMemoryBufferRef = ^TLLVMMemoryBufferRef; - PLLVMTypeRef = ^TLLVMTypeRef; - PLLVMValueRef = ^TLLVMValueRef; - - TLLVMOpaqueModule = record - code: PRope; - end; - TLLVMModuleRef = ^TLLVMOpaqueModule; -{ - Each value in the LLVM IR has a type, an instance of [lltype]. See the - llvm::Type class. -} - TLLVMOpaqueType = record - kind: TLLVMTypeKind; - - end; - TLLVMTypeRef = ^TLLVMOpaqueType; -{ - When building recursive types using [refine_type], [lltype] values may become - invalid; use [lltypehandle] to resolve this problem. See the - llvm::AbstractTypeHolder] class. -} - TLLVMOpaqueTypeHandle = record end; - TLLVMTypeHandleRef = ^TLLVMOpaqueTypeHandle; - TLLVMOpaqueValue = record end; - TLLVMValueRef = ^TLLVMOpaqueValue; - TLLVMOpaqueBasicBlock = record end; - TLLVMBasicBlockRef = ^TLLVMOpaqueBasicBlock; - - TLLVMOpaqueBuilder = record end; - TLLVMBuilderRef = ^TLLVMOpaqueBuilder; -{ Used to provide a module to JIT or interpreter. - See the llvm::ModuleProvider class. -} - TLLVMOpaqueModuleProvider = record end; - TLLVMModuleProviderRef = ^TLLVMOpaqueModuleProvider; -{ Used to provide a module to JIT or interpreter. - See the llvm: : MemoryBuffer class. -} - TLLVMOpaqueMemoryBuffer = record end; - TLLVMMemoryBufferRef = ^TLLVMOpaqueMemoryBuffer; - -{===-- Error handling ----------------------------------------------------=== } -procedure LLVMDisposeMessage(msg: pchar); cdecl; -{===-- Modules -----------------------------------------------------------=== } -{ Create and destroy modules. } -function LLVMModuleCreateWithName(ModuleID: pchar): TLLVMModuleRef; cdecl; -procedure LLVMDisposeModule(M: TLLVMModuleRef);cdecl; -{ Data layout } -function LLVMGetDataLayout(M: TLLVMModuleRef): pchar;cdecl; -procedure LLVMSetDataLayout(M: TLLVMModuleRef; Triple: pchar);cdecl; -{ Target triple } -function LLVMGetTarget(M: TLLVMModuleRef): pchar;cdecl; -procedure LLVMSetTarget(M: TLLVMModuleRef; Triple: pchar);cdecl; -{ Same as Module: : addTypeName. } -function LLVMAddTypeName(M: TLLVMModuleRef; Name: pchar; Ty: TLLVMTypeRef): longint;cdecl; -procedure LLVMDeleteTypeName(M: TLLVMModuleRef; Name: pchar);cdecl; -{===-- Types -------------------------------------------------------------=== } -{ LLVM types conform to the following hierarchy: - * - * types: - * integer type - * real type - * function type - * sequence types: - * array type - * pointer type - * vector type - * void type - * label type - * opaque type - } -function LLVMGetTypeKind(Ty: TLLVMTypeRef): TLLVMTypeKind; cdecl; -procedure LLVMRefineAbstractType(AbstractType: TLLVMTypeRef; ConcreteType: TLLVMTypeRef); cdecl; -{ Operations on integer types } -function LLVMInt1Type: TLLVMTypeRef;cdecl; -function LLVMInt8Type: TLLVMTypeRef;cdecl; -function LLVMInt16Type: TLLVMTypeRef;cdecl; -function LLVMInt32Type: TLLVMTypeRef;cdecl; -function LLVMInt64Type: TLLVMTypeRef;cdecl; -function LLVMIntType(NumBits: cuint): TLLVMTypeRef;cdecl; -function LLVMGetIntTypeWidth(IntegerTy: TLLVMTypeRef): cuint;cdecl; -{ Operations on real types } -function LLVMFloatType: TLLVMTypeRef;cdecl; -function LLVMDoubleType: TLLVMTypeRef;cdecl; -function LLVMX86FP80Type: TLLVMTypeRef;cdecl; -function LLVMFP128Type: TLLVMTypeRef;cdecl; -function LLVMPPCFP128Type: TLLVMTypeRef;cdecl; -{ Operations on function types } -function LLVMFunctionType(ReturnType: TLLVMTypeRef; ParamTypes: PLLVMTypeRef; ParamCount: cuint; IsVarArg: longint): TLLVMTypeRef;cdecl; -function LLVMIsFunctionVarArg(FunctionTy: TLLVMTypeRef): longint;cdecl; -function LLVMGetReturnType(FunctionTy: TLLVMTypeRef): TLLVMTypeRef;cdecl; -function LLVMCountParamTypes(FunctionTy: TLLVMTypeRef): cuint;cdecl; -procedure LLVMGetParamTypes(FunctionTy: TLLVMTypeRef; Dest: PLLVMTypeRef);cdecl; -{ Operations on struct types } -function LLVMStructType(ElementTypes: PLLVMTypeRef; ElementCount: cuint; isPacked: longint): TLLVMTypeRef;cdecl; -function LLVMCountStructElementTypes(StructTy: TLLVMTypeRef): cuint;cdecl; -procedure LLVMGetStructElementTypes(StructTy: TLLVMTypeRef; Dest: pLLVMTypeRef);cdecl; -function LLVMIsPackedStruct(StructTy: TLLVMTypeRef): longint;cdecl; -{ Operations on array, pointer, and vector types (sequence types) } -function LLVMArrayType(ElementType: TLLVMTypeRef; ElementCount: cuint): TLLVMTypeRef;cdecl; -function LLVMPointerType(ElementType: TLLVMTypeRef; AddressSpace: cuint): TLLVMTypeRef;cdecl; -function LLVMVectorType(ElementType: TLLVMTypeRef; ElementCount: cuint): TLLVMTypeRef;cdecl; -function LLVMGetElementType(Ty: TLLVMTypeRef): TLLVMTypeRef;cdecl; -function LLVMGetArrayLength(ArrayTy: TLLVMTypeRef): cuint;cdecl; -function LLVMGetPointerAddressSpace(PointerTy: TLLVMTypeRef): cuint;cdecl; -function LLVMGetVectorSize(VectorTy: TLLVMTypeRef): cuint;cdecl; -{ Operations on other types } -function LLVMVoidType: TLLVMTypeRef;cdecl; -function LLVMLabelType: TLLVMTypeRef;cdecl; -function LLVMOpaqueType: TLLVMTypeRef;cdecl; -{ Operations on type handles } -function LLVMCreateTypeHandle(PotentiallyAbstractTy: TLLVMTypeRef): TLLVMTypeHandleRef;cdecl; -procedure LLVMRefineType(AbstractTy: TLLVMTypeRef; ConcreteTy: TLLVMTypeRef);cdecl; -function LLVMResolveTypeHandle(TypeHandle: TLLVMTypeHandleRef): TLLVMTypeRef;cdecl; -procedure LLVMDisposeTypeHandle(TypeHandle: TLLVMTypeHandleRef);cdecl; -{===-- Values ------------------------------------------------------------=== } -{ The bulk of LLVM's object model consists of values, which comprise a very - * rich type hierarchy. - * - * values: - * constants: - * scalar constants - * composite contants - * globals: - * global variable - * function - * alias - * basic blocks - } -{ Operations on all values } -function LLVMTypeOf(Val: TLLVMValueRef): TLLVMTypeRef;cdecl; -function LLVMGetValueName(Val: TLLVMValueRef): pchar;cdecl; -procedure LLVMSetValueName(Val: TLLVMValueRef; Name: pchar);cdecl; -procedure LLVMDumpValue(Val: TLLVMValueRef);cdecl; -{ Operations on constants of any type } -function LLVMConstNull(Ty: TLLVMTypeRef): TLLVMValueRef;cdecl; -{ all zeroes } -function LLVMConstAllOnes(Ty: TLLVMTypeRef): TLLVMValueRef;cdecl; -{ only for int/vector } -function LLVMGetUndef(Ty: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMIsConstant(Val: TLLVMValueRef): longint;cdecl; -function LLVMIsNull(Val: TLLVMValueRef): longint;cdecl; -function LLVMIsUndef(Val: TLLVMValueRef): longint;cdecl; -{ Operations on scalar constants } -function LLVMConstInt(IntTy: TLLVMTypeRef; N: qword; SignExtend: longint): TLLVMValueRef;cdecl; -function LLVMConstReal(RealTy: TLLVMTypeRef; N: double): TLLVMValueRef;cdecl; -{ Operations on composite constants } -function LLVMConstString(Str: pchar; Length: cuint; DontNullTerminate: longint): TLLVMValueRef;cdecl; -function LLVMConstArray(ArrayTy: TLLVMTypeRef; ConstantVals: pLLVMValueRef; Length: cuint): TLLVMValueRef;cdecl; -function LLVMConstStruct(ConstantVals: pLLVMValueRef; Count: cuint; ispacked: longint): TLLVMValueRef;cdecl; -function LLVMConstVector(ScalarConstantVals: pLLVMValueRef; Size: cuint): TLLVMValueRef;cdecl; -{ Constant expressions } -function LLVMSizeOf(Ty: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstNeg(ConstantVal: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstNot(ConstantVal: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstAdd(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstSub(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstMul(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstUDiv(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstSDiv(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstFDiv(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstURem(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstSRem(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstFRem(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstAnd(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstOr(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstXor(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstICmp(Predicate: TLLVMIntPredicate; LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstFCmp(Predicate: TLLVMRealPredicate; LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstShl(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstLShr(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstAShr(LHSConstant: TLLVMValueRef; RHSConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstGEP(ConstantVal: TLLVMValueRef; ConstantIndices: PLLVMValueRef; NumIndices: cuint): TLLVMValueRef;cdecl; -function LLVMConstTrunc(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstSExt(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstZExt(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstFPTrunc(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstFPExt(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstUIToFP(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstSIToFP(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstFPToUI(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstFPToSI(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstPtrToInt(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstIntToPtr(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstBitCast(ConstantVal: TLLVMValueRef; ToType: TLLVMTypeRef): TLLVMValueRef;cdecl; -function LLVMConstSelect(ConstantCondition: TLLVMValueRef; ConstantIfTrue: TLLVMValueRef; ConstantIfFalse: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstExtractElement(VectorConstant: TLLVMValueRef; IndexConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstInsertElement(VectorConstant: TLLVMValueRef; ElementValueConstant: TLLVMValueRef; IndexConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMConstShuffleVector(VectorAConstant: TLLVMValueRef; VectorBConstant: TLLVMValueRef; MaskConstant: TLLVMValueRef): TLLVMValueRef;cdecl; -{ Operations on global variables, functions, and aliases (globals) } -function LLVMIsDeclaration(Global: TLLVMValueRef): longint;cdecl; -function LLVMGetLinkage(Global: TLLVMValueRef): TLLVMLinkage;cdecl; -procedure LLVMSetLinkage(Global: TLLVMValueRef; Linkage: TLLVMLinkage);cdecl; -function LLVMGetSection(Global: TLLVMValueRef): pchar;cdecl; -procedure LLVMSetSection(Global: TLLVMValueRef; Section: pchar);cdecl; -function LLVMGetVisibility(Global: TLLVMValueRef): TLLVMVisibility;cdecl; -procedure LLVMSetVisibility(Global: TLLVMValueRef; Viz: TLLVMVisibility);cdecl; -function LLVMGetAlignment(Global: TLLVMValueRef): cuint;cdecl; -procedure LLVMSetAlignment(Global: TLLVMValueRef; Bytes: cuint);cdecl; -{ Operations on global variables } -(* Const before type ignored *) -function LLVMAddGlobal(M: TLLVMModuleRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -(* Const before type ignored *) -function LLVMGetNamedGlobal(M: TLLVMModuleRef; Name: pchar): TLLVMValueRef;cdecl; -procedure LLVMDeleteGlobal(GlobalVar: TLLVMValueRef);cdecl; -function LLVMHasInitializer(GlobalVar: TLLVMValueRef): longint;cdecl; -function LLVMGetInitializer(GlobalVar: TLLVMValueRef): TLLVMValueRef;cdecl; -procedure LLVMSetInitializer(GlobalVar: TLLVMValueRef; ConstantVal: TLLVMValueRef);cdecl; -function LLVMIsThreadLocal(GlobalVar: TLLVMValueRef): longint;cdecl; -procedure LLVMSetThreadLocal(GlobalVar: TLLVMValueRef; IsThreadLocal: longint);cdecl; -function LLVMIsGlobalConstant(GlobalVar: TLLVMValueRef): longint;cdecl; -procedure LLVMSetGlobalConstant(GlobalVar: TLLVMValueRef; IsConstant: longint);cdecl; -{ Operations on functions } -(* Const before type ignored *) -function LLVMAddFunction(M: TLLVMModuleRef; Name: pchar; FunctionTy: TLLVMTypeRef): TLLVMValueRef;cdecl; -(* Const before type ignored *) -function LLVMGetNamedFunction(M: TLLVMModuleRef; Name: pchar): TLLVMValueRef;cdecl; -procedure LLVMDeleteFunction(Fn: TLLVMValueRef);cdecl; -function LLVMCountParams(Fn: TLLVMValueRef): cuint;cdecl; -procedure LLVMGetParams(Fn: TLLVMValueRef; Params: PLLVMValueRef);cdecl; -function LLVMGetParam(Fn: TLLVMValueRef; Index: cuint): TLLVMValueRef;cdecl; -function LLVMGetIntrinsicID(Fn: TLLVMValueRef): cuint;cdecl; -function LLVMGetFunctionCallConv(Fn: TLLVMValueRef): cuint;cdecl; -procedure LLVMSetFunctionCallConv(Fn: TLLVMValueRef; CC: cuint);cdecl; -(* Const before type ignored *) -function LLVMGetCollector(Fn: TLLVMValueRef): pchar;cdecl; -(* Const before type ignored *) -procedure LLVMSetCollector(Fn: TLLVMValueRef; Coll: pchar);cdecl; -{ Operations on basic blocks } -function LLVMBasicBlockAsValue(Bb: TLLVMBasicBlockRef): TLLVMValueRef;cdecl; -function LLVMValueIsBasicBlock(Val: TLLVMValueRef): longint;cdecl; -function LLVMValueAsBasicBlock(Val: TLLVMValueRef): TLLVMBasicBlockRef;cdecl; -function LLVMCountBasicBlocks(Fn: TLLVMValueRef): cuint;cdecl; -procedure LLVMGetBasicBlocks(Fn: TLLVMValueRef; BasicBlocks: PLLVMBasicBlockRef);cdecl; -function LLVMGetEntryBasicBlock(Fn: TLLVMValueRef): TLLVMBasicBlockRef;cdecl; -(* Const before type ignored *) -function LLVMAppendBasicBlock(Fn: TLLVMValueRef; Name: pchar): TLLVMBasicBlockRef;cdecl; -(* Const before type ignored *) -function LLVMInsertBasicBlock(InsertBeforeBB: TLLVMBasicBlockRef; Name: pchar): TLLVMBasicBlockRef;cdecl; -procedure LLVMDeleteBasicBlock(BB: TLLVMBasicBlockRef);cdecl; -{ Operations on call sites } -procedure LLVMSetInstructionCallConv(Instr: TLLVMValueRef; CC: cuint);cdecl; -function LLVMGetInstructionCallConv(Instr: TLLVMValueRef): cuint;cdecl; -{ Operations on phi nodes } -procedure LLVMAddIncoming(PhiNode: TLLVMValueRef; IncomingValues: PLLVMValueRef; IncomingBlocks: PLLVMBasicBlockRef; Count: cuint);cdecl; -function LLVMCountIncoming(PhiNode: TLLVMValueRef): cuint;cdecl; -function LLVMGetIncomingValue(PhiNode: TLLVMValueRef; Index: cuint): TLLVMValueRef;cdecl; -function LLVMGetIncomingBlock(PhiNode: TLLVMValueRef; Index: cuint): TLLVMBasicBlockRef;cdecl; -{===-- Instruction builders ----------------------------------------------=== } -{ An instruction builder represents a point within a basic block, and is the - * exclusive means of building instructions using the C interface. - } -function LLVMCreateBuilder: TLLVMBuilderRef;cdecl; -procedure LLVMPositionBuilderBefore(Builder: TLLVMBuilderRef; Instr: TLLVMValueRef);cdecl; -procedure LLVMPositionBuilderAtEnd(Builder: TLLVMBuilderRef; theBlock: TLLVMBasicBlockRef);cdecl; -procedure LLVMDisposeBuilder(Builder: TLLVMBuilderRef);cdecl; -{ Terminators } -function LLVMBuildRetVoid(para1: TLLVMBuilderRef): TLLVMValueRef;cdecl; -function LLVMBuildRet(para1: TLLVMBuilderRef; V: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMBuildBr(para1: TLLVMBuilderRef; Dest: TLLVMBasicBlockRef): TLLVMValueRef;cdecl; -function LLVMBuildCondBr(para1: TLLVMBuilderRef; IfCond: TLLVMValueRef; ThenBranch: TLLVMBasicBlockRef; ElseBranch: TLLVMBasicBlockRef): TLLVMValueRef;cdecl; -function LLVMBuildSwitch(para1: TLLVMBuilderRef; V: TLLVMValueRef; ElseBranch: TLLVMBasicBlockRef; NumCases: cuint): TLLVMValueRef;cdecl; -(* Const before type ignored *) -function LLVMBuildInvoke(para1: TLLVMBuilderRef; Fn: TLLVMValueRef; Args: PLLVMValueRef; NumArgs: cuint; ThenBranch: TLLVMBasicBlockRef; - Catch: TLLVMBasicBlockRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildUnwind(para1: TLLVMBuilderRef): TLLVMValueRef;cdecl; -function LLVMBuildUnreachable(para1: TLLVMBuilderRef): TLLVMValueRef;cdecl; -{ Add a case to the switch instruction } -procedure LLVMAddCase(Switch: TLLVMValueRef; OnVal: TLLVMValueRef; Dest: TLLVMBasicBlockRef);cdecl; -{ Arithmetic } -function LLVMBuildAdd(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildSub(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildMul(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildUDiv(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildSDiv(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildFDiv(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildURem(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildSRem(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildFRem(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildShl(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildLShr(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildAShr(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildAnd(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildOr(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildXor(para1: TLLVMBuilderRef; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildNeg(para1: TLLVMBuilderRef; V: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildNot(para1: TLLVMBuilderRef; V: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -{ Memory } -function LLVMBuildMalloc(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildArrayMalloc(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Val: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildAlloca(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildArrayAlloca(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Val: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildFree(para1: TLLVMBuilderRef; PointerVal: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMBuildLoad(para1: TLLVMBuilderRef; PointerVal: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildStore(para1: TLLVMBuilderRef; Val: TLLVMValueRef; thePtr: TLLVMValueRef): TLLVMValueRef;cdecl; -function LLVMBuildGEP(B: TLLVMBuilderRef; Pointer: TLLVMValueRef; Indices: PLLVMValueRef; NumIndices: cuint; Name: pchar): TLLVMValueRef;cdecl; -{ Casts } -function LLVMBuildTrunc(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildZExt(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildSExt(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildFPToUI(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildFPToSI(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildUIToFP(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildSIToFP(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildFPTrunc(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildFPExt(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildPtrToInt(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildIntToPtr(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildBitCast(para1: TLLVMBuilderRef; Val: TLLVMValueRef; DestTy: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -{ Comparisons } -function LLVMBuildICmp(para1: TLLVMBuilderRef; Op: TLLVMIntPredicate; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildFCmp(para1: TLLVMBuilderRef; Op: TLLVMRealPredicate; LHS: TLLVMValueRef; RHS: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -{ Miscellaneous instructions } -function LLVMBuildPhi(para1: TLLVMBuilderRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildCall(para1: TLLVMBuilderRef; Fn: TLLVMValueRef; Args: PLLVMValueRef; NumArgs: cuint; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildSelect(para1: TLLVMBuilderRef; IfCond: TLLVMValueRef; ThenBranch: TLLVMValueRef; ElseBranch: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildVAArg(para1: TLLVMBuilderRef; List: TLLVMValueRef; Ty: TLLVMTypeRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildExtractElement(para1: TLLVMBuilderRef; VecVal: TLLVMValueRef; Index: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildInsertElement(para1: TLLVMBuilderRef; VecVal: TLLVMValueRef; EltVal: TLLVMValueRef; Index: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -function LLVMBuildShuffleVector(para1: TLLVMBuilderRef; V1: TLLVMValueRef; V2: TLLVMValueRef; Mask: TLLVMValueRef; Name: pchar): TLLVMValueRef;cdecl; -{===-- Module providers --------------------------------------------------=== } -{ Encapsulates the module M in a module provider, taking ownership of the - module. - See the constructor llvm: : ExistingModuleProvider: : ExistingModuleProvider. -} -function LLVMCreateModuleProviderForExistingModule(M: TLLVMModuleRef): TLLVMModuleProviderRef;cdecl; -{ Destroys the module provider MP as well as the contained module. - See the destructor llvm: : ModuleProvider: : ~ModuleProvider. -} -procedure LLVMDisposeModuleProvider(MP: TLLVMModuleProviderRef);cdecl; -{===-- Memory buffers ----------------------------------------------------=== } -function LLVMCreateMemoryBufferWithContentsOfFile(Path: pchar; OutMemBuf: pLLVMMemoryBufferRef; var OutMessage: pchar): longint;cdecl; -function LLVMCreateMemoryBufferWithSTDIN(OutMemBuf: pLLVMMemoryBufferRef; var OutMessage: pchar): longint;cdecl; -procedure LLVMDisposeMemoryBuffer(MemBuf: TLLVMMemoryBufferRef);cdecl; - -function LLVMWriteBitcodeToFile(M: TLLVMModuleRef; path: pchar): int; cdecl; -// Writes a module to the specified path. Returns 0 on success. - -implementation - -end. diff --git a/nim/lookups.pas b/nim/lookups.pas deleted file mode 100755 index e4c07224f..000000000 --- a/nim/lookups.pas +++ /dev/null @@ -1,307 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit lookups; - -// This module implements lookup helpers. - -interface - -uses - nsystem, ast, astalgo, idents, semdata, types, msgs, options, rodread, - rnimsyn; - -{$include 'config.inc'} - -type - TOverloadIterMode = (oimDone, oimNoQualifier, oimSelfModule, oimOtherModule, - oimSymChoice); - TOverloadIter = record - stackPtr: int; - it: TIdentIter; - m: PSym; - mode: TOverloadIterMode; - end; - -function getSymRepr(s: PSym): string; - -procedure CloseScope(var tab: TSymTab); - -procedure AddSym(var t: TStrTable; n: PSym); - -procedure addDecl(c: PContext; sym: PSym); -procedure addDeclAt(c: PContext; sym: PSym; at: Natural); -procedure addOverloadableSymAt(c: PContext; fn: PSym; at: Natural); - -procedure addInterfaceDecl(c: PContext; sym: PSym); -procedure addInterfaceOverloadableSymAt(c: PContext; sym: PSym; at: int); - -function lookUp(c: PContext; n: PNode): PSym; -// Looks up a symbol. Generates an error in case of nil. - -function QualifiedLookUp(c: PContext; n: PNode; ambiguousCheck: bool): PSym; - -function InitOverloadIter(out o: TOverloadIter; c: PContext; n: PNode): PSym; -function nextOverloadIter(var o: TOverloadIter; c: PContext; n: PNode): PSym; - -implementation - -function getSymRepr(s: PSym): string; -begin - case s.kind of - skProc, skMethod, 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, skMethod, skUnknown]) 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 not (check.Kind in OverloadableSyms) 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().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); *) - result := n.sym; - end; - nkIdent: begin - result := SymtabGet(c.Tab, n.ident); - if result = nil then - liMessage(n.info, errUndeclaredIdentifier, n.ident.s); - end - else InternalError(n.info, 'lookUp'); - end; - if IntSetContains(c.AmbiguousSymbols, result.id) then - liMessage(n.info, errUseQualifier, result.name.s); - if result.kind = skStub then loadStub(result); -end; - -function QualifiedLookUp(c: PContext; n: PNode; ambiguousCheck: 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 ambiguousCheck - and IntSetContains(c.AmbiguousSymbols, result.id) 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 *) - result := n.sym; - if ambiguousCheck and IntSetContains(c.AmbiguousSymbols, result.id) then - liMessage(n.info, errUseQualifier, n.sym.name.s) - end; - nkDotExpr: begin - result := nil; - m := qualifiedLookUp(c, n.sons[0], false); - if (m <> nil) and (m.kind = skModule) then begin - ident := nil; - if (n.sons[1].kind = nkIdent) then - ident := n.sons[1].ident - else if (n.sons[1].kind = nkAccQuoted) - and (n.sons[1].sons[0].kind = nkIdent) then - ident := n.sons[1].sons[0].ident; - if ident <> nil then begin - 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, - renderTree(n.sons[1])); - end - end; - nkAccQuoted: result := QualifiedLookup(c, n.sons[0], ambiguousCheck); - else begin - result := nil; - //liMessage(n.info, errIdentifierExpected, '') - end; - end; - if (result <> nil) and (result.kind = skStub) then loadStub(result); -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 - result := n.sym; - o.mode := oimDone; - (* - 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: begin - o.mode := oimOtherModule; - o.m := qualifiedLookUp(c, n.sons[0], false); - if (o.m <> nil) and (o.m.kind = skModule) then begin - ident := nil; - if (n.sons[1].kind = nkIdent) then - ident := n.sons[1].ident - else if (n.sons[1].kind = nkAccQuoted) - and (n.sons[1].sons[0].kind = nkIdent) then - ident := n.sons[1].sons[0].ident; - if ident <> nil then begin - 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, - renderTree(n.sons[1])); - end - end; - nkAccQuoted: result := InitOverloadIter(o, c, n.sons[0]); - nkSymChoice: begin - o.mode := oimSymChoice; - result := n.sons[0].sym; - o.stackPtr := 1 - end; - else begin end - end; - if (result <> nil) and (result.kind = skStub) then loadStub(result); -end; - -function nextOverloadIter(var o: TOverloadIter; c: PContext; n: PNode): PSym; -begin - case o.mode of - oimDone: result := nil; - 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); - oimSymChoice: begin - if o.stackPtr < sonsLen(n) then begin - result := n.sons[o.stackPtr].sym; - inc(o.stackPtr); - end - else - result := nil - end; - end; - if (result <> nil) and (result.kind = skStub) then loadStub(result); -end; - -end. diff --git a/nim/magicsys.pas b/nim/magicsys.pas deleted file mode 100755 index f4e4beafe..000000000 --- a/nim/magicsys.pas +++ /dev/null @@ -1,277 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit magicsys; - -// Built-in types and compilerprocs are registered here. - -interface - -{$include 'config.inc'} - -uses - nsystem, - ast, astalgo, nhashes, msgs, platform, nversion, ntime, idents, rodread; - -var // magic symbols in the system module: - SystemModule: PSym; - -procedure registerSysType(t: PType); -function getSysType(const kind: TTypeKind): PType; - -function getCompilerProc(const name: string): PSym; -procedure registerCompilerProc(s: PSym); - -procedure InitSystem(var tab: TSymTab); -procedure FinishSystem(const tab: TStrTable); - -function getSysSym(const name: string): PSym; - -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 getSysSym(const name: string): PSym; -begin - result := StrTableGet(systemModule.tab, getIdent(name)); - if result = nil then rawMessage(errSystemNeeds, name); - if result.kind = skStub then loadStub(result); -end; - -function sysTypeFromName(const name: string): PType; -begin - result := getSysSym(name).typ; -end; - -function getSysType(const kind: TTypeKind): PType; -begin - result := gSysTypes[kind]; - 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'); - 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 - ident := getIdent(name, getNormalizedHash(name)); - result := StrTableGet(compilerprocs, ident); - if result = nil then begin - result := StrTableGet(rodCompilerProcs, ident); - if result <> nil then begin - strTableAdd(compilerprocs, result); - if result.kind = skStub then loadStub(result); - end; - // 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; -begin - result := InitIdentIter(ti, tab, getIdent(s)); - while result <> nil do begin - if (result.magic = m) then exit; - result := NextIdentIter(ti, tab) - end -end; - -function NewMagic(kind: TSymKind; const name: string; - const info: TLineInfo): PSym; -begin - result := newSym(kind, getIdent(name), SystemModule); - Include(result.loc.Flags, lfNoDecl); - result.info := info; -end; - -function newMagicType(const info: TLineInfo; kind: TTypeKind; - magicSym: PSym): PType; -begin - result := newType(kind, SystemModule); - result.sym := magicSym; -end; - -procedure setSize(t: PType; size: int); -begin - t.align := size; - t.size := size; -end; - -procedure addMagicSym(var tab: TSymTab; sym: PSym; sys: PSym); -begin - SymTabAdd(tab, sym); - StrTableAdd(sys.tab, sym); // add to interface - include(sym.flags, sfInInterface); -end; - -var - fakeInfo: TLineInfo; - -procedure addIntegral(var tab: TSymTab; kind: TTypeKind; const name: string; - size: int); -var - t: PSym; -begin - t := newMagic(skType, name, fakeInfo); - t.typ := newMagicType(fakeInfo, kind, t); - setSize(t.typ, size); - addMagicSym(tab, t, SystemModule); - gSysTypes[kind] := t.typ; -end; - -procedure addMagicTAnyEnum(var tab: TSymTab); -var - s: PSym; -begin - s := newMagic(skType, 'TAnyEnum', fakeInfo); - s.typ := newMagicType(fakeInfo, tyAnyEnum, s); - SymTabAdd(tab, s); -end; -*) -procedure InitSystem(var tab: TSymTab); -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 - - // TAnyEnum: - addMagicTAnyEnum(tab); - - // nil: - gSysTypes[tyNil] := newMagicType(fakeInfo, tyNil, nil); - SetSize(gSysTypes[tyNil], ptrSize); - // no need to add it to symbol table since it is a reserved word - - // boolean type: - addIntegral(tab, tyBool, 'bool', 1); - - // false: - c := NewMagic(skConst, 'false', fakeInfo); - c.typ := gSysTypes[tyBool]; - c.ast := newIntNode(nkIntLit, ord(false)); - c.ast.typ := gSysTypes[tyBool]; - addMagicSym(tab, c, systemModule); - - // true: - c := NewMagic(skConst, 'true', fakeInfo); - c.typ := gSysTypes[tyBool]; - c.ast := newIntNode(nkIntLit, ord(true)); - c.ast.typ := gSysTypes[tyBool]; - addMagicSym(tab, c, systemModule); - - addIntegral(tab, tyFloat32, 'float32', 4); - addIntegral(tab, tyFloat64, 'float64', 8); - addIntegral(tab, tyInt8, 'int8', 1); - addIntegral(tab, tyInt16, 'int16', 2); - addIntegral(tab, tyInt32, 'int32', 4); - addIntegral(tab, tyInt64, 'int64', 8); - - if cpu[targetCPU].bit = 64 then begin - addIntegral(tab, tyFloat128, 'float128', 16); - addIntegral(tab, tyInt, 'int', 8); - addIntegral(tab, tyFloat, 'float', 8); - end - else if cpu[targetCPU].bit = 32 then begin - addIntegral(tab, tyInt, 'int', 4); - addIntegral(tab, tyFloat, 'float', 8); - end - else begin // 16 bit cpu: - addIntegral(tab, tyInt, 'int', 2); - addIntegral(tab, tyFloat, 'float', 4); - end; - - // char type: - addIntegral(tab, tyChar, 'char', 1); - - // string type: - addIntegral(tab, tyString, 'string', ptrSize); - typ := gSysTypes[tyString]; - addSon(typ, gSysTypes[tyChar]); - - // pointer type: - addIntegral(tab, tyPointer, 'pointer', ptrSize); - - - addIntegral(tab, tyCString, 'cstring', ptrSize); - typ := gSysTypes[tyCString]; - addSon(typ, gSysTypes[tyChar]); - - gSysTypes[tyEmptySet] := newMagicType(fakeInfo, tyEmptySet, nil); - - intSetBaseType := newMagicType(fakeInfo, tyRange, nil); - addSon(intSetBaseType, gSysTypes[tyInt]); // base type - setSize(intSetBaseType, int(gSysTypes[tyInt].size)); - 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]; *) -end; - -procedure FinishSystem(const tab: TStrTable); -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'); *) -end; - -initialization - initStrTable(compilerprocs); -end. diff --git a/nim/main.pas b/nim/main.pas deleted file mode 100755 index 4b35513c5..000000000 --- a/nim/main.pas +++ /dev/null @@ -1,423 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit main; - -// implements the command dispatcher and several commands as well as the -// module handling -{$include 'config.inc'} - -interface - -uses - nsystem, llstream, strutils, ast, astalgo, scanner, syntaxes, rnimsyn, - options, msgs, nos, lists, condsyms, paslex, pasparse, rodread, rodwrite, - ropes, trees, wordrecg, sem, semdata, idents, passes, docgen, - extccomp, cgen, ecmasgen, platform, interact, nimconf, importer, - passaux, depends, transf, evals, types; - -procedure MainCommand(const cmd, filename: string); - -implementation - -// ------------------ module handling ----------------------------------------- - -type - TFileModuleRec = record - filename: string; - module: PSym; - end; - TFileModuleMap = array of TFileModuleRec; -var - compMods: TFileModuleMap = {@ignore} nil {@emit @[]}; - // all compiled modules - -procedure registerModule(const filename: string; module: PSym); -var - len: int; -begin - len := length(compMods); - setLength(compMods, len+1); - compMods[len].filename := filename; - compMods[len].module := module; -end; - -function getModule(const filename: string): PSym; -var - i: int; -begin - for i := 0 to high(compMods) do - if sameFile(compMods[i].filename, filename) then begin - result := compMods[i].module; exit end; - result := nil; -end; - -// ---------------------------------------------------------------------------- - -function newModule(const filename: string): PSym; -begin - // 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(splitFile(filename).name); - result.owner := result; // a module belongs to itself - result.info := newLineInfo(filename, 1, 1); - include(result.flags, sfUsed); - initStrTable(result.tab); - RegisterModule(filename, result); - - StrTableAdd(result.tab, result); // a module knows itself -end; - -function CompileModule(const filename: string; - isMainFile, isSystemFile: bool): PSym; forward; - -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 - 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; - isMainFile, isSystemFile: bool): PSym; -var - rd: PRodReader; - f: string; -begin - rd := nil; - f := addFileExt(filename, nimExt); - result := newModule(filename); - 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 - result.id := getID(); - processModule(result, f, nil, rd); -end; - -procedure CompileProject(const filename: string); -begin - {@discard} CompileModule( - JoinPath(options.libpath, addFileExt('system', nimExt)), false, true); - {@discard} CompileModule(addFileExt(filename, nimExt), true, false); -end; - -procedure semanticPasses; -begin - registerPass(verbosePass()); - registerPass(sem.semPass()); - registerPass(transf.transfPass()); -end; - -procedure CommandGenDepend(const filename: string); -begin - semanticPasses(); - registerPass(genDependPass()); - registerPass(cleanupPass()); - compileProject(filename); - generateDot(filename); - execExternalProgram('dot -Tpng -o' +{&} changeFileExt(filename, 'png') +{&} - ' ' +{&} changeFileExt(filename, 'dot')); -end; - -procedure CommandCheck(const filename: string); -begin - semanticPasses(); - // use an empty backend for semantic checking only - compileProject(filename); -end; - -procedure CommandCompileToC(const filename: string); -begin - semanticPasses(); - registerPass(cgen.cgenPass()); - registerPass(rodwrite.rodwritePass()); - //registerPass(cleanupPass()); - compileProject(filename); - //for i := low(TTypeKind) to high(TTypeKind) do - // MessageOut('kind: ' +{&} typeKindToStr[i] +{&} ' = ' +{&} toString(sameTypeA[i])); - extccomp.CallCCompiler(changeFileExt(filename, '')); -end; - -procedure CommandCompileToEcmaScript(const filename: string); -begin - include(gGlobalOptions, optSafeCode); - setTarget(osEcmaScript, cpuEcmaScript); - initDefines(); - - 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, addFileExt('system', nimExt)), false, true); - - m := newModule('stdin'); - m.id := getID(); - include(m.flags, sfMainModule); - processModule(m, 'stdin', LLStreamOpenStdIn(), nil); -end; - -// -------------------------------------------------------------------------- - -procedure exSymbols(n: PNode); -var - i: int; -begin - case n.kind of - nkEmpty..nkNilLit: begin end; // atoms - nkProcDef..nkIteratorDef: begin - exSymbol(n.sons[namePos]); - end; - nkWhenStmt, nkStmtList: begin - for i := 0 to sonsLen(n)-1 do exSymbols(n.sons[i]) - end; - nkVarSection, nkConstSection: begin - for i := 0 to sonsLen(n)-1 do - exSymbol(n.sons[i].sons[0]); - end; - nkTypeSection: begin - for i := 0 to sonsLen(n)-1 do begin - exSymbol(n.sons[i].sons[0]); - if (n.sons[i].sons[2] <> nil) and - (n.sons[i].sons[2].kind = nkObjectTy) then - fixRecordDef(n.sons[i].sons[2]) - end - end; - else begin end - end -end; - -procedure CommandExportSymbols(const filename: string); -// now unused! -var - module: PNode; -begin - module := parseFile(addFileExt(filename, NimExt)); - if module <> nil then begin - exSymbols(module); - renderModule(module, getOutFile(filename, 'pretty.'+NimExt)); - end -end; - -procedure CommandPretty(const filename: string); -var - module: PNode; -begin - module := parseFile(addFileExt(filename, NimExt)); - if module <> nil then - renderModule(module, getOutFile(filename, 'pretty.'+NimExt)); -end; - -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} - f := addFileExt(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); - getPasTok(L, tok); - end - end - else - rawMessage(errCannotOpenFile, f); - closeLexer(L); -end; - -procedure CommandPas(const filename: string); -var - p: TPasParser; - module: PNode; - f: string; - stream: PLLStream; -begin - f := addFileExt(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} - f := addFileExt(filename, nimExt); - stream := LLStreamOpen(f, fmRead); - if stream <> nil then begin - openLexer(L, f, stream); - repeat - rawGetTok(L, tok^); - PrintTok(tok); - until tok.tokType = tkEof; - CloseLexer(L); - end - else - rawMessage(errCannotOpenFile, f); -end; - -procedure WantFile(const filename: string); -begin - if filename = '' then - liMessage(newLineInfo('command line', 1, 1), errCommandExpectsFilename); -end; - -procedure MainCommand(const cmd, filename: string); -begin - appendStr(searchPaths, options.libpath); - if filename <> '' then begin - // current path is always looked first for modules - prependStr(searchPaths, splitFile(filename).dir); - end; - setID(100); - passes.gIncludeFile := syntaxes.parseFile; - passes.gImportModule := importModule; - - case whichKeyword(cmd) of - wCompile, wCompileToC, wC, wCC: begin - // compile means compileToC currently - gCmd := cmdCompileToC; - wantFile(filename); - CommandCompileToC(filename); - end; - wCompileToCpp: begin - gCmd := cmdCompileToCpp; - wantFile(filename); - CommandCompileToC(filename); - end; - wCompileToEcmaScript: begin - gCmd := cmdCompileToEcmaScript; - wantFile(filename); - CommandCompileToEcmaScript(filename); - end; - wCompileToLLVM: begin - gCmd := cmdCompileToLLVM; - wantFile(filename); - CommandCompileToC(filename); - end; - wPretty: begin - gCmd := cmdPretty; - wantFile(filename); - //CommandExportSymbols(filename); - CommandPretty(filename); - end; - wDoc: begin - gCmd := cmdDoc; - LoadSpecialConfig(DocConfig); - wantFile(filename); - CommandDoc(filename); - end; - wRst2html: begin - gCmd := cmdRst2html; - LoadSpecialConfig(DocConfig); - wantFile(filename); - CommandRst2Html(filename); - end; - wRst2tex: begin - gCmd := cmdRst2tex; - LoadSpecialConfig(DocTexConfig); - wantFile(filename); - CommandRst2TeX(filename); - end; - wPas: begin - gCmd := cmdPas; - wantFile(filename); - CommandPas(filename); - end; - wBoot: begin - gCmd := cmdBoot; - wantFile(filename); - CommandPas(filename); - end; - wGenDepend: begin - gCmd := cmdGenDepend; - wantFile(filename); - CommandGenDepend(filename); - end; - wListDef: begin - gCmd := cmdListDef; - condsyms.ListSymbols(); - end; - wCheck: begin - gCmd := cmdCheck; - wantFile(filename); - CommandCheck(filename); - end; - wParse: begin - gCmd := cmdParse; - wantFile(filename); - {@discard} parseFile(addFileExt(filename, nimExt)); - end; - wScan: begin - gCmd := cmdScan; - wantFile(filename); - CommandScan(filename); - MessageOut('Beware: Indentation tokens depend on the parser''s state!'); - end; - wI: begin - gCmd := cmdInteractive; - CommandInteractive(); - end; - else rawMessage(errInvalidCommandX, cmd); - end -end; - -end. diff --git a/nim/msgs.pas b/nim/msgs.pas deleted file mode 100755 index 55ccdda5e..000000000 --- a/nim/msgs.pas +++ /dev/null @@ -1,893 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 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, - errIllFormedAstX, - errCannotOpenFile, - errInternal, - errGenerated, - errXCompilerDoesNotSupportCpp, - errStringLiteralExpected, - errIntLiteralExpected, - errInvalidCharacterConstant, - errClosingTripleQuoteExpected, - errClosingQuoteExpected, - errTabulatorsAreNotAllowed, - errInvalidToken, - errLineTooLong, - errInvalidNumber, - errNumberOutOfRange, - errNnotAllowedInCharacter, - errClosingBracketExpected, - errMissingFinalQuote, - errIdentifierExpected, - errOperatorExpected, - errTokenExpected, - errStringAfterIncludeExpected, - errRecursiveDependencyX, - errOnOrOffExpected, - errNoneSpeedOrSizeExpected, - errInvalidPragma, - errUnknownPragma, - errInvalidDirectiveX, - errAtPopWithoutPush, - errEmptyAsm, - errInvalidIndentation, - errExceptionExpected, - errExceptionAlreadyHandled, - errYieldNotAllowedHere, - errInvalidNumberOfYieldExpr, - errCannotReturnExpr, - errAttemptToRedefine, - errStmtInvalidAfterReturn, - errStmtExpected, - errInvalidLabel, - errInvalidCmdLineOption, - errCmdLineArgExpected, - errCmdLineNoArgExpected, - errInvalidVarSubstitution, - errUnknownVar, - errUnknownCcompiler, - errOnOrOffExpectedButXFound, - errNoneBoehmRefcExpectedButXFound, - errNoneSpeedOrSizeExpectedButXFound, - errGuiConsoleOrLibExpectedButXFound, - errUnknownOS, - errUnknownCPU, - errGenOutExpectedButXFound, - errArgsNeedRunOption, - errInvalidMultipleAsgn, - errColonOrEqualsExpected, - errExprExpected, - errUndeclaredIdentifier, - errUseQualifier, - errTypeExpected, - errSystemNeeds, - errExecutionOfProgramFailed, - errNotOverloadable, - errInvalidArgForX, - errStmtHasNoEffect, - errXExpectsTypeOrValue, - errXExpectsArrayType, - errIteratorCannotBeInstantiated, - errExprXAmbiguous, - errConstantDivisionByZero, - errOrdinalTypeExpected, - errOrdinalOrFloatTypeExpected, - errOverOrUnderflow, - errCannotEvalXBecauseIncompletelyDefined, - errChrExpectsRange0_255, - errDynlibRequiresExportc, - errUndeclaredFieldX, - errNilAccess, - errIndexOutOfBounds, - errIndexTypesDoNotMatch, - errBracketsInvalidForType, - errValueOutOfSetBounds, - errFieldInitTwice, - errFieldNotInit, - errExprXCannotBeCalled, - errExprHasNoType, - errExprXHasNoType, - errCastNotInSafeMode, - errExprCannotBeCastedToX, - errCommaOrParRiExpected, - errCurlyLeOrParLeExpected, - errSectionExpected, - errRangeExpected, - errAttemptToRedefineX, - errMagicOnlyInSystem, - errPowerOfTwoExpected, - errStringMayNotBeEmpty, - errCallConvExpected, - errProcOnlyOneCallConv, - errSymbolMustBeImported, - errExprMustBeBool, - errConstExprExpected, - errDuplicateCaseLabel, - errRangeIsEmpty, - errSelectorMustBeOfCertainTypes, - errSelectorMustBeOrdinal, - errOrdXMustNotBeNegative, - errLenXinvalid, - errWrongNumberOfVariables, - errExprCannotBeRaised, - errBreakOnlyInLoop, - errTypeXhasUnknownSize, - errConstNeedsConstExpr, - errConstNeedsValue, - errResultCannotBeOpenArray, - errSizeTooBig, - errSetTooBig, - errBaseTypeMustBeOrdinal, - errInheritanceOnlyWithNonFinalObjects, - errInheritanceOnlyWithEnums, - errIllegalRecursionInTypeX, - errCannotInstantiateX, - errExprHasNoAddress, - errVarForOutParamNeeded, - errPureTypeMismatch, - errTypeMismatch, - errButExpected, - errButExpectedX, - errAmbiguousCallXYZ, - errWrongNumberOfArguments, - errXCannotBePassedToProcVar, - errXCannotBeInParamDecl, - errPragmaOnlyInHeaderOfProc, - errImplOfXNotAllowed, - errImplOfXexpected, - errNoSymbolToBorrowFromFound, - errDiscardValue, - errInvalidDiscard, - errIllegalConvFromXtoY, - errCannotBindXTwice, - errInvalidOrderInEnumX, - errEnumXHasWholes, - errExceptExpected, - errInvalidTry, - errOptionExpected, - errXisNoLabel, - errNotAllCasesCovered, - errUnkownSubstitionVar, - errComplexStmtRequiresInd, - errXisNotCallable, - errNoPragmasAllowedForX, - errNoGenericParamsAllowedForX, - errInvalidParamKindX, - errDefaultArgumentInvalid, - errNamedParamHasToBeIdent, - errNoReturnTypeForX, - errConvNeedsOneArg, - errInvalidPragmaX, - errXNotAllowedHere, - errInvalidControlFlowX, - errATypeHasNoValue, - errXisNoType, - errCircumNeedsPointer, - errInvalidExpression, - errInvalidExpressionX, - errEnumHasNoValueX, - errNamedExprExpected, - errNamedExprNotAllowed, - errXExpectsOneTypeParam, - errArrayExpectsTwoTypeParams, - errInvalidVisibilityX, - errInitHereNotAllowed, - errXCannotBeAssignedTo, - errIteratorNotAllowed, - errXNeedsReturnType, - errInvalidCommandX, - errXOnlyAtModuleScope, - errTemplateInstantiationTooNested, - errInstantiationFrom, - errInvalidIndexValueForTuple, - errCommandExpectsFilename, - errXExpected, - errInvalidSectionStart, - errGridTableNotImplemented, - errGeneralParseError, - errNewSectionExpected, - errWhitespaceExpected, - errXisNoValidIndexFile, - errCannotRenderX, - errVarVarTypeNotAllowed, - errIsExpectsTwoArguments, - errIsExpectsObjectTypes, - errXcanNeverBeOfThisSubtype, - errTooManyIterations, - errCannotInterpretNodeX, - errFieldXNotFound, - errInvalidConversionFromTypeX, - errAssertionFailed, - errCannotGenerateCodeForX, - errXRequiresOneArgument, - errUnhandledExceptionX, - errCyclicTree, - errXisNoMacroOrTemplate, - errXhasSideEffects, - errIteratorExpected, - errUser, - warnCannotOpenFile, - warnOctalEscape, - warnXIsNeverRead, - warnXmightNotBeenInit, - warnCannotWriteMO2, - warnCannotReadMO2, - warnDeprecated, - warnSmallLshouldNotBeUsed, - warnUnknownMagic, - warnRedefinitionOfLabel, - warnUnknownSubstitutionX, - warnLanguageXNotSupported, - warnCommentXIgnored, - warnXisPassedToProcVar, - warnUser, - hintSuccess, - hintSuccessX, - hintLineTooLong, - hintXDeclaredButNotUsed, - hintConvToBaseNotNeeded, - hintConvFromXtoItselfNotNeeded, - hintExprAlwaysX, - hintQuitCalled, - hintProcessing, - hintCodeBegin, - hintCodeEnd, - hintConf, - hintUser); - -const - MsgKindToStr: array [TMsgKind] of string = ( - 'unknown error', - 'illformed AST: $1', - 'cannot open ''$1''', - 'internal error: $1', - '$1', - '''$1'' compiler does not support C++', - 'string literal expected', - 'integer literal expected', - 'invalid character constant', - 'closing """ expected, but end of file reached', - 'closing " expected', - 'tabulators are not allowed', - 'invalid token: $1', - 'line too long', - '$1 is not a valid number', - 'number $1 out of valid range', - '\n not allowed in character literal', - 'closing '']'' expected, but end of file reached', - 'missing final ''', - 'identifier expected, but found ''$1''', - 'operator expected, but found ''$1''', - '''$1'' expected', - 'string after ''include'' expected', - 'recursive dependency: ''$1''', - '''on'' or ''off'' expected', - '''none'', ''speed'' or ''size'' expected', - 'invalid pragma', - 'unknown pragma: ''$1''', - 'invalid directive: ''$1''', - '''pop'' without a ''push'' pragma', - 'empty asm statement', - 'invalid indentation', - 'exception expected', - 'exception already handled', - '''yield'' only allowed in a loop of an iterator', - 'invalid number of ''yield'' expresions', - 'current routine cannot return an expression', - 'attempt to redefine ''$1''', - 'statement not allowed after ''return'', ''break'' or ''raise''', - 'statement expected', - '''$1'' is no label', - 'invalid command line option: ''$1''', - 'argument for command line option expected: ''$1''', - 'invalid argument for command line option: ''$1''', - 'invalid variable substitution in ''$1''', - 'unknown variable: ''$1''', - 'unknown C compiler: ''$1''', - '''on'' or ''off'' expected, but ''$1'' found', - '''none'', ''boehm'' or ''refc'' expected, but ''$1'' found', - '''none'', ''speed'' or ''size'' expected, but ''$1'' found', - '''gui'', ''console'' or ''lib'' expected, but ''$1'' found', - 'unknown OS: ''$1''', - 'unknown CPU: ''$1''', - '''c'', ''c++'' or ''yaml'' expected, but ''$1'' found', - 'arguments can only be given if the ''--run'' option is selected', - 'multiple assignment is not allowed', - ''':'' or ''='' expected, but found ''$1''', - 'expression expected, but found ''$1''', - 'undeclared identifier: ''$1''', - 'ambiguous identifier: ''$1'' -- use a qualifier', - 'type expected', - 'system module needs ''$1''', - 'execution of an external program failed', - 'overloaded ''$1'' leads to ambiguous calls', - 'invalid argument for ''$1''', - 'statement has no effect', - '''$1'' expects a type or value', - '''$1'' expects an array type', - '''$1'' cannot be instantiated because its body has not been compiled yet', - 'expression ''$1'' ambiguous in this context', - 'constant division by zero', - 'ordinal type expected', - 'ordinal or float type expected', - 'over- or underflow', - 'cannot evalutate ''$1'' because type is not defined completely', - '''chr'' expects an int in the range 0..255', - '''dynlib'' requires ''exportc''', - 'undeclared field: ''$1''', - 'attempt to access a nil address', - 'index out of bounds', - 'index types do not match', - '''[]'' operator invalid for this type', - 'value out of set bounds', - 'field initialized twice: ''$1''', - 'field ''$1'' not initialized', - 'expression ''$1'' cannot be called', - 'expression has no type', - 'expression ''$1'' has no type (or is ambiguous)', - '''cast'' not allowed in safe mode', - 'expression cannot be casted to $1', - ''','' or '')'' expected', - '''{'' or ''('' expected', - 'section (''type'', ''proc'', etc.) expected', - 'range expected', - 'attempt to redefine ''$1''', - '''magic'' only allowed in system module', - 'power of two expected', - 'string literal may not be empty', - 'calling convention expected', - 'a proc can only have one calling convention', - 'symbol must be imported if ''lib'' pragma is used', - 'expression must be of type ''bool''', - 'constant expression expected', - 'duplicate case label', - 'range is empty', - 'selector must be of an ordinal type, real or string', - 'selector must be of an ordinal type', - 'ord($1) must not be negative', - 'len($1) must be less than 32768', - 'wrong number of variables', - 'only objects can be raised', - '''break'' only allowed in loop construct', - 'type ''$1'' has unknown size', - 'a constant can only be initialized with a constant expression', - 'a constant needs a value', - 'the result type cannot be on open array', - 'computing the type''s size produced an overflow', - 'set is too large', - 'base type of a set must be an ordinal', - 'inheritance only works with non-final objects', - 'inheritance only works with an enum', - 'illegal recursion in type ''$1''', - 'cannot instantiate: ''$1''', - 'expression has no address', - 'for a ''var'' type a variable needs to be passed', - 'type mismatch', - 'type mismatch: got (', - 'but expected one of: ', - 'but expected ''$1''', - 'ambiguous call; both $1 and $2 match for: $3', - 'wrong number of arguments', - '''$1'' cannot be passed to a procvar', - '$1 cannot be declared in parameter declaration', - 'pragmas are only in the header of a proc allowed', - 'implementation of ''$1'' is not allowed', - 'implementation of ''$1'' expected', - 'no symbol to borrow from found', - 'value returned by statement has to be discarded', - 'statement returns no value that can be discarded', - 'conversion from $1 to $2 is invalid', - 'cannot bind parameter ''$1'' twice', - 'invalid order in enum ''$1''', - 'enum ''$1'' has wholes', - '''except'' or ''finally'' expected', - 'after catch all ''except'' or ''finally'' no section may follow', - 'option expected, but found ''$1''', - '''$1'' is not a label', - 'not all cases are covered', - 'unknown substitution variable: ''$1''', - 'complex statement requires indentation', - '''$1'' is not callable', - 'no pragmas allowed for $1', - 'no generic parameters allowed for $1', - 'invalid param kind: ''$1''', - 'default argument invalid', - 'named parameter has to be an identifier', - 'no return type for $1 allowed', - 'a type conversion needs exactly one argument', - 'invalid pragma: $1', - '$1 not allowed here', - 'invalid control flow: $1', - 'a type has no value', - 'invalid type: ''$1''', - '''^'' needs a pointer or reference type', - 'invalid expression', - 'invalid expression: ''$1''', - 'enum has no value ''$1''', - 'named expression expected', - 'named expression not allowed here', - '''$1'' expects one type parameter', - 'array expects two type parameters', - 'invalid visibility: ''$1''', - 'initialization not allowed here', - '''$1'' cannot be assigned to', - 'iterators can only be defined at the module''s top level', - '$1 needs a return type', - 'invalid command: ''$1''', - '''$1'' is only allowed at top level', - 'template/macro instantiation too nested', - 'instantiation from here', - 'invalid index value for tuple subscript', - 'command expects a filename argument', - '''$1'' expected', - 'invalid section start', - 'grid table is not implemented', - 'general parse error', - 'new section expected', - 'whitespace expected, got ''$1''', - '''$1'' is no valid index file', - 'cannot render reStructuredText element ''$1''', - 'type ''var var'' is not allowed', - '''is'' expects two arguments', - '''is'' expects object types', - '''$1'' can never be of this subtype', - 'interpretation requires too many iterations', - 'cannot interpret node kind ''$1''', - 'field ''$1'' cannot be found', - 'invalid conversion from type ''$1''', - 'assertion failed', - 'cannot generate code for ''$1''', - '$1 requires one parameter', - 'unhandled exception: $1', - 'macro returned a cyclic abstract syntax tree', - '''$1'' is no macro or template', - '''$1'' can have side effects', - 'iterator within for loop context expected', - '$1', - 'cannot open ''$1'' [CannotOpenFile]', - 'octal escape sequences do not exist; leading zero is ignored [OctalEscape]', - '''$1'' is never read [XIsNeverRead]', - '''$1'' might not have been initialized [XmightNotBeenInit]', - 'cannot write file ''$1'' [CannotWriteMO2]', - 'cannot read file ''$1'' [CannotReadMO2]', - '''$1'' is deprecated [Deprecated]', - '''l'' should not be used as an identifier; may look like ''1'' (one) [SmallLshouldNotBeUsed]', - 'unknown magic ''$1'' might crash the compiler [UnknownMagic]', - 'redefinition of label ''$1'' [RedefinitionOfLabel]', - 'unknown substitution ''$1'' [UnknownSubstitutionX]', - 'language ''$1'' not supported [LanguageXNotSupported]', - 'comment ''$1'' ignored [CommentXIgnored]', - '''$1'' is passed to a procvar; deprecated [XisPassedToProcVar]', - '$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]', - 'quit() called [QuitCalled]', - '$1 [Processing]', - 'generated code listing: [CodeBegin]', - 'end of listing [CodeEnd]', - 'used config file ''$1'' [Conf]', - '$1 [User]' - ); -const - WarningsToStr: array [0..14] of string = ( - 'CannotOpenFile', - 'OctalEscape', - 'XIsNeverRead', - 'XmightNotBeenInit', - 'CannotWriteMO2', - 'CannotReadMO2', - 'Deprecated', - 'SmallLshouldNotBeUsed', - 'UnknownMagic', - 'RedefinitionOfLabel', - 'UnknownSubstitutionX', - 'LanguageXNotSupported', - 'CommentXIgnored', - 'XisPassedToProcVar', - 'User' - ); -const - HintsToStr: array [0..12] of string = ( - 'Success', - 'SuccessX', - 'LineTooLong', - 'XDeclaredButNotUsed', - 'ConvToBaseNotNeeded', - 'ConvFromXtoItselfNotNeeded', - 'ExprAlwaysX', - '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 = ''); 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; - -function includeFilename(const f: string): int; - - -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; - -function sameLineInfo(const a, b: TLineInfo): bool; -begin - result := (a.line = b.line) and (a.fileIndex = b.fileIndex); -end; - -procedure writeContext(const lastinfo: TLineInfo); -var - i: int; - info: TLineInfo; -begin - info := lastInfo; - for i := 0 to length(msgContext)-1 do begin - if not sameLineInfo(msgContext[i], lastInfo) - and not sameLineInfo(msgContext[i], info) then - MessageOut(Format(posErrorFormat, [toFilename(msgContext[i]), - coordToStr(msgContext[i].line), - coordToStr(msgContext[i].col), - getMessageStr(errInstantiationFrom, '')])); - info := msgContext[i]; - end; -end; - -procedure rawMessage(const msg: TMsgKind; const args: array of string); -var - frmt: string; -begin - case msg of - errMin..errMax: begin - writeContext(unknownLineInfo()); - frmt := rawErrorFormat; - end; - warnMin..warnMax: begin - if not (optWarns in gOptions) then exit; - if not (msg in gNotes) then exit; - frmt := rawWarningFormat; - inc(gWarnCounter); - end; - hintMin..hintMax: begin - if not (optHints in gOptions) then exit; - if not (msg in gNotes) then exit; - frmt := rawHintFormat; - inc(gHintCounter); - end; - else assert(false) // cannot happen - end; - MessageOut(Format(frmt, format(msgKindToString(msg), args))); - handleError(msg); -end; - -procedure rawMessage(const msg: TMsgKind; const arg: string = ''); -begin - 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(info); - 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(info); - liMessage(info, errInternal, errMsg); -end; - -procedure InternalError(const errMsg: string); overload; -begin - writeContext(UnknownLineInfo()); - rawMessage(errInternal, errMsg); -end; - -end. diff --git a/nim/nhashes.pas b/nim/nhashes.pas deleted file mode 100755 index 95bfd62f5..000000000 --- a/nim/nhashes.pas +++ /dev/null @@ -1,225 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit nhashes; - -{$include 'config.inc'} - -interface - -uses - charsets, nsystem, strutils; - -const - SmallestSize = (1 shl 3) - 1; - DefaultSize = (1 shl 11) - 1; - BiggestSize = (1 shl 28) - 1; - -type - THash = type int; - PHash = ^THash; - THashFunc = function (str: PChar): THash; - -function GetHash(str: PChar): THash; -function GetHashCI(str: PChar): THash; - -function GetDataHash(Data: Pointer; Size: int): THash; - -function hashPtr(p: Pointer): THash; - -function GetHashStr(const s: string): THash; -function GetHashStrCI(const s: string): THash; - -function getNormalizedHash(const s: string): THash; - -//function nextPowerOfTwo(x: int): int; - -function concHash(h: THash; val: int): THash; -function finishHash(h: THash): THash; - -implementation - -{@ignore} -{$ifopt Q+} { we need Q- here! } - {$define Q_on} - {$Q-} -{$endif} - -{$ifopt R+} - {$define R_on} - {$R-} -{$endif} -{@emit} - -function nextPowerOfTwo(x: int): int; -begin - result := x -{%} 1; - // complicated, to make it a nop if sizeof(int) == 4, - // because shifting more than 31 bits is undefined in C - result := result or (result shr ((sizeof(int)-4)* 8)); - result := result or (result shr 16); - result := result or (result shr 8); - result := result or (result shr 4); - result := result or (result shr 2); - result := result or (result shr 1); - Inc(result) -end; - -function concHash(h: THash; val: int): THash; -begin - result := h +{%} val; - result := result +{%} result shl 10; - result := result xor (result shr 6); -end; - -function finishHash(h: THash): THash; -begin - result := h +{%} h shl 3; - result := result xor (result shr 11); - result := result +{%} result shl 15; -end; - -function GetDataHash(Data: Pointer; Size: int): THash; -var - h: THash; - p: PChar; - i, s: int; -begin - h := 0; - p := {@cast}pchar(Data); - i := 0; - s := size; - while s > 0 do begin - h := h +{%} ord(p[i]); - h := h +{%} h shl 10; - h := h xor (h shr 6); - Inc(i); Dec(s) - end; - h := h +{%} h shl 3; - h := h xor (h shr 11); - h := h +{%} h shl 15; - result := THash(h) -end; - -function hashPtr(p: Pointer): THash; -begin - result := ({@cast}THash(p)) shr 3; // skip the alignment -end; - -function GetHash(str: PChar): THash; -var - h: THash; - i: int; -begin - h := 0; - i := 0; - while str[i] <> #0 do begin - h := h +{%} ord(str[i]); - h := h +{%} h shl 10; - h := h xor (h shr 6); - Inc(i) - end; - h := h +{%} h shl 3; - h := h xor (h shr 11); - h := h +{%} h shl 15; - result := THash(h) -end; - -function GetHashStr(const s: string): THash; -var - h: THash; - i: int; -begin - h := 0; - for i := 1 to Length(s) do begin - h := h +{%} ord(s[i]); - h := h +{%} h shl 10; - h := h xor (h shr 6); - end; - h := h +{%} h shl 3; - h := h xor (h shr 11); - h := h +{%} h shl 15; - result := THash(h) -end; - -function getNormalizedHash(const s: string): THash; -var - h: THash; - c: Char; - i: int; -begin - h := 0; - for i := strStart to length(s)+strStart-1 do begin - c := s[i]; - if c = '_' then continue; // skip _ - if c in ['A'..'Z'] then c := chr(ord(c) + (ord('a')-ord('A'))); // toLower() - h := h +{%} ord(c); - h := h +{%} h shl 10; - h := h xor (h shr 6); - end; - h := h +{%} h shl 3; - h := h xor (h shr 11); - h := h +{%} h shl 15; - result := THash(h) -end; - -function GetHashStrCI(const s: string): THash; -var - h: THash; - c: Char; - i: int; -begin - h := 0; - for i := strStart to length(s)+strStart-1 do begin - c := s[i]; - if c in ['A'..'Z'] then c := chr(ord(c) + (ord('a')-ord('A'))); // toLower() - h := h +{%} ord(c); - h := h +{%} h shl 10; - h := h xor (h shr 6); - end; - h := h +{%} h shl 3; - h := h xor (h shr 11); - h := h +{%} h shl 15; - result := THash(h) -end; - -function GetHashCI(str: PChar): THash; -var - h: THash; - c: Char; - i: int; -begin - h := 0; - i := 0; - while str[i] <> #0 do begin - c := str[i]; - if c in ['A'..'Z'] then c := chr(ord(c) + (ord('a')-ord('A'))); // toLower() - h := h +{%} ord(c); - h := h +{%} h shl 10; - h := h xor (h shr 6); - Inc(i) - end; - h := h +{%} h shl 3; - h := h xor (h shr 11); - h := h +{%} h shl 15; - result := THash(h) -end; - -{@ignore} -{$ifdef Q_on} - {$undef Q_on} - {$Q+} -{$endif} - -{$ifdef R_on} - {$undef R_on} - {$R+} -{$endif} -{@emit} - -end. diff --git a/nim/nimconf.pas b/nim/nimconf.pas deleted file mode 100755 index 69c6f7618..000000000 --- a/nim/nimconf.pas +++ /dev/null @@ -1,361 +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 nimconf; - -// This module handles the reading of the config file. -{$include 'config.inc'} - -interface - -uses - nsystem, llstream, nversion, commands, nos, strutils, msgs, platform, - condsyms, scanner, options, idents, wordrecg; - -procedure LoadConfig(const project: string); - -procedure LoadSpecialConfig(const configfilename: string); - -implementation - - -// ---------------- configuration file parser ----------------------------- -// we use Nimrod's scanner here to safe space and work - -procedure ppGetTok(var L: TLexer; tok: PToken); -begin - // simple filter - rawGetTok(L, tok^); - while (tok.tokType = tkInd) or (tok.tokType = tkSad) - or (tok.tokType = tkDed) or (tok.tokType = tkComment) do - rawGetTok(L, tok^) -end; - -// simple preprocessor: -function parseExpr(var L: TLexer; tok: PToken): bool; forward; - -function parseAtom(var L: TLexer; tok: PToken): bool; -begin - if tok.tokType = tkParLe then begin - ppGetTok(L, tok); - result := parseExpr(L, tok); - if tok.tokType = tkParRi then ppGetTok(L, tok) - else lexMessage(L, errTokenExpected, ''')''') - end - else if tok.ident.id = ord(wNot) then begin - ppGetTok(L, tok); - result := not parseAtom(L, tok) - end - else begin - result := isDefined(tok.ident); - //condsyms.listSymbols(); - //writeln(tok.ident.s + ' has the value: ', result); - ppGetTok(L, tok) - end; -end; - -function parseAndExpr(var L: TLexer; tok: PToken): bool; -var - b: bool; -begin - result := parseAtom(L, tok); - while tok.ident.id = ord(wAnd) do begin - ppGetTok(L, tok); // skip "and" - b := parseAtom(L, tok); - result := result and b; - end -end; - -function parseExpr(var L: TLexer; tok: PToken): bool; -var - b: bool; -begin - result := parseAndExpr(L, tok); - while tok.ident.id = ord(wOr) do begin - ppGetTok(L, tok); // skip "or" - b := parseAndExpr(L, tok); - result := result or b; - end -end; - -function EvalppIf(var L: TLexer; tok: PToken): bool; -begin - ppGetTok(L, tok); // skip 'if' or 'elif' - result := parseExpr(L, tok); - if tok.tokType = tkColon then ppGetTok(L, tok) - else lexMessage(L, errTokenExpected, ''':''') -end; - -var - condStack: array of bool; - -{@emit - condStack := @[]; -} - -procedure doEnd(var L: TLexer; tok: PToken); -begin - if high(condStack) < 0 then lexMessage(L, errTokenExpected, '@if'); - ppGetTok(L, tok); // skip 'end' - setLength(condStack, high(condStack)) -end; - -type - TJumpDest = (jdEndif, jdElseEndif); - -procedure jumpToDirective(var L: TLexer; tok: PToken; dest: TJumpDest); forward; - -procedure doElse(var L: TLexer; tok: PToken); -begin - if high(condStack) < 0 then - lexMessage(L, errTokenExpected, '@if'); - ppGetTok(L, tok); - if tok.tokType = tkColon then ppGetTok(L, tok); - if condStack[high(condStack)] then - jumpToDirective(L, tok, jdEndif) -end; - -procedure doElif(var L: TLexer; tok: PToken); -var - res: bool; -begin - if high(condStack) < 0 then - lexMessage(L, errTokenExpected, '@if'); - res := EvalppIf(L, tok); - if condStack[high(condStack)] or not res then - jumpToDirective(L, tok, jdElseEndif) - else - condStack[high(condStack)] := true -end; - -procedure jumpToDirective(var L: TLexer; tok: PToken; dest: TJumpDest); -var - nestedIfs: int; -begin - nestedIfs := 0; - while True do begin - if (tok.ident <> nil) and (tok.ident.s = '@'+'') then begin - ppGetTok(L, tok); - case whichKeyword(tok.ident) of - wIf: Inc(nestedIfs); - wElse: begin - if (dest = jdElseEndif) and (nestedIfs = 0) then begin - doElse(L, tok); - break - end - end; - wElif: begin - if (dest = jdElseEndif) and (nestedIfs = 0) then begin - doElif(L, tok); - break - end - end; - wEnd: begin - if nestedIfs = 0 then begin - doEnd(L, tok); - break - end; - if nestedIfs > 0 then Dec(nestedIfs) - end; - else begin end; - end; - ppGetTok(L, tok) - end - else if tok.tokType = tkEof then - lexMessage(L, errTokenExpected, '@end') - else - ppGetTok(L, tok) - end -end; - -procedure parseDirective(var L: TLexer; tok: PToken); -var - res: bool; - key: string; -begin - ppGetTok(L, tok); // skip @ - case whichKeyword(tok.ident) of - wIf: begin - setLength(condStack, length(condStack)+1); - res := EvalppIf(L, tok); - condStack[high(condStack)] := res; - if not res then // jump to "else", "elif" or "endif" - jumpToDirective(L, tok, jdElseEndif) - end; - wElif: doElif(L, tok); - wElse: doElse(L, tok); - wEnd: doEnd(L, tok); - wWrite: begin - ppGetTok(L, tok); - msgs.MessageOut(tokToStr(tok)); - ppGetTok(L, tok) - end; - wPutEnv: begin - ppGetTok(L, tok); - key := tokToStr(tok); - ppGetTok(L, tok); - nos.putEnv(key, tokToStr(tok)); - ppGetTok(L, tok) - end; - wPrependEnv: begin - ppGetTok(L, tok); - key := tokToStr(tok); - ppGetTok(L, tok); - nos.putEnv(key, tokToStr(tok) +{&} nos.getenv(key)); - ppGetTok(L, tok) - end; - wAppendenv: begin - ppGetTok(L, tok); - key := tokToStr(tok); - ppGetTok(L, tok); - nos.putEnv(key, nos.getenv(key) +{&} tokToStr(tok)); - ppGetTok(L, tok) - end - else - lexMessage(L, errInvalidDirectiveX, tokToStr(tok)) - end -end; - -procedure confTok(var L: TLexer; tok: PToken); -begin - ppGetTok(L, tok); - while (tok.ident <> nil) and (tok.ident.s = '@'+'') do - parseDirective(L, tok) - // else: give the token to the parser -end; - -// ----------- end of preprocessor ---------------------------------------- - -procedure checkSymbol(const L: TLexer; tok: PToken); -begin - if not (tok.tokType in [tkSymbol..pred(tkIntLit), - tkStrLit..tkTripleStrLit]) then - lexMessage(L, errIdentifierExpected, tokToStr(tok)) -end; - -procedure parseAssignment(var L: TLexer; tok: PToken); -var - s, val: string; - info: TLineInfo; -begin - if (tok.ident.id = getIdent('-'+'').id) - or (tok.ident.id = getIdent('--').id) then - confTok(L, tok); // skip unnecessary prefix - info := getLineInfo(L); // safe for later in case of an error - checkSymbol(L, tok); - s := tokToStr(tok); - confTok(L, tok); // skip symbol - val := ''; - while tok.tokType = tkDot do begin - addChar(s, '.'); - confTok(L, tok); - checkSymbol(L, tok); - add(s, tokToStr(tok)); - confTok(L, tok) - end; - if tok.tokType = tkBracketLe then begin - // BUGFIX: val, not s! - // BUGFIX: do not copy '['! - confTok(L, tok); - checkSymbol(L, tok); - add(val, tokToStr(tok)); - confTok(L, tok); - if tok.tokType = tkBracketRi then confTok(L, tok) - else lexMessage(L, errTokenExpected, ''']'''); - addChar(val, ']'); - end; - if (tok.tokType = tkColon) or (tok.tokType = tkEquals) then begin - if length(val) > 0 then addChar(val, ':'); // BUGFIX - confTok(L, tok); // skip ':' or '=' - checkSymbol(L, tok); - add(val, tokToStr(tok)); - confTok(L, tok); // skip symbol - while (tok.ident <> nil) and (tok.ident.id = getIdent('&'+'').id) do begin - confTok(L, tok); - checkSymbol(L, tok); - add(val, tokToStr(tok)); - confTok(L, tok) - end - end; - processSwitch(s, val, passPP, info) -end; - -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} - 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); - 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, prefix: string; -begin - // set default value (can be overwritten): - if libpath = '' then begin - // choose default libpath: - prefix := getPrefixDir(); - if (prefix = '/usr') then - libpath := '/usr/lib/nimrod' - else if (prefix = '/usr/local') then - libpath := '/usr/local/lib/nimrod' - else - libpath := joinPath(prefix, 'lib') - end; - // read default config file: - LoadSpecialConfig('nimrod.cfg'); - // read project config file: - if not (optSkipProjConfigFile in gGlobalOptions) and (project <> '') then begin - conffile := changeFileExt(project, 'cfg'); - if existsFile(conffile) then - readConfigFile(conffile) - end -end; - -end. diff --git a/nim/nimrod.pas b/nim/nimrod.pas deleted file mode 100755 index 8d7db04b2..000000000 --- a/nim/nimrod.pas +++ /dev/null @@ -1,126 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -program nimrod; - -{$include 'config.inc'} -{@ignore} -{$ifdef windows} -{$apptype console} -{$endif} -{@emit} - -uses - nsystem, ntime, - charsets, sysutils, commands, scanner, condsyms, options, msgs, nversion, - nimconf, ropes, extccomp, strutils, nos, platform, main, parseopt; - -var - arguments: string = ''; // the arguments to be passed to the program that - // should be run - cmdLineInfo: TLineInfo; - -procedure ProcessCmdLine(pass: TCmdLinePass; var command, filename: string); -var - p: TOptParser; - bracketLe: int; - key, val: string; -begin - p := parseopt.init(); - while true do begin - parseopt.next(p); - case p.kind of - cmdEnd: break; - cmdLongOption, cmdShortOption: begin - // hint[X]:off is parsed as (p.key = "hint[X]", p.val = "off") - // we fix this here - bracketLe := strutils.find(p.key, '['); - if bracketLe >= strStart then begin - key := ncopy(p.key, strStart, bracketLe-1); - val := ncopy(p.key, bracketLe+1) +{&} ':' +{&} p.val; - ProcessSwitch(key, val, pass, cmdLineInfo); - end - else - ProcessSwitch(p.key, p.val, pass, cmdLineInfo); - end; - cmdArgument: begin - if command = '' then command := p.key - else if filename = '' then begin - filename := unixToNativePath(p.key); - // BUGFIX for portable build scripts - break - end - end - end - end; - // collect the arguments: - if pass = passCmd2 then begin - arguments := getRestOfCommandLine(p); - if not (optRun in gGlobalOptions) and (arguments <> '') then - rawMessage(errArgsNeedRunOption); - end -end; - -{@ignore} -type - TTime = int; -{@emit} - -procedure HandleCmdLine; -var - command, filename, prog: string; - start: TTime; -begin - {@emit start := getTime(); } - if paramCount() = 0 then - writeCommandLineUsage() - else begin - // Process command line arguments: - command := ''; - filename := ''; - ProcessCmdLine(passCmd1, command, filename); - if filename <> '' then options.projectPath := splitFile(filename).dir; - 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); - {@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 begin - {$ifdef unix} - prog := './' + quoteIfContainsWhite(changeFileExt(filename, '')); - {$else} - prog := quoteIfContainsWhite(changeFileExt(filename, '')); - {$endif} - execExternalProgram(prog +{&} ' ' +{&} arguments) - end - end -end; - -begin -//{@emit -// GC_disableMarkAndSweep(); -//} - cmdLineInfo := newLineInfo('command line', -1, -1); - condsyms.InitDefines(); - HandleCmdLine(); - halt(options.gExitcode); -end. diff --git a/nim/nimsets.pas b/nim/nimsets.pas deleted file mode 100755 index 9795817b8..000000000 --- a/nim/nimsets.pas +++ /dev/null @@ -1,259 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit nimsets; - -// this unit handles Nimrod sets; it implements symbolic sets - -interface - -{$include 'config.inc'} - -uses - nsystem, ast, astalgo, trees, nversion, msgs, platform, - bitsets, types, rnimsyn; - -procedure toBitSet(s: PNode; out b: TBitSet); - -// this function is used for case statement checking: -function overlap(a, b: PNode): Boolean; - -function inSet(s: PNode; const elem: PNode): Boolean; -function someInSet(s: PNode; const a, b: PNode): Boolean; - -function emptyRange(const a, b: PNode): Boolean; - -function SetHasRange(s: PNode): Boolean; -// returns true if set contains a range (needed by the code generator) - -// these are used for constant folding: -function unionSets(a, b: PNode): PNode; -function diffSets(a, b: PNode): PNode; -function intersectSets(a, b: PNode): PNode; -function symdiffSets(a, b: PNode): PNode; - -function containsSets(a, b: PNode): Boolean; -function equalSets(a, b: PNode): Boolean; - -function cardSet(s: PNode): BiggestInt; - -implementation - -function inSet(s: PNode; const elem: PNode): Boolean; -var - i: int; -begin - if s.kind <> nkCurly then InternalError(s.info, 'inSet'); - for i := 0 to sonsLen(s)-1 do - if s.sons[i].kind = nkRange then begin - if leValue(s.sons[i].sons[0], elem) - and leValue(elem, s.sons[i].sons[1]) then begin - result := true; exit - end - end - else begin - if sameValue(s.sons[i], elem) then begin - result := true; exit - end - end; - result := false -end; - -function overlap(a, b: PNode): Boolean; -begin - if a.kind = nkRange then begin - if b.kind = nkRange then begin - result := leValue(a.sons[0], b.sons[1]) - and leValue(b.sons[1], a.sons[1]) - or leValue(a.sons[0], b.sons[0]) - and leValue(b.sons[0], a.sons[1]) - end - else begin - result := leValue(a.sons[0], b) - and leValue(b, a.sons[1]) - end - end - else begin - if b.kind = nkRange then begin - result := leValue(b.sons[0], a) - and leValue(a, b.sons[1]) - end - else begin - result := sameValue(a, b) - end - end -end; - -function SomeInSet(s: PNode; const a, b: PNode): Boolean; -// checks if some element of a..b is in the set s -var - i: int; -begin - if s.kind <> nkCurly then InternalError(s.info, 'SomeInSet'); - for i := 0 to sonsLen(s)-1 do - if s.sons[i].kind = nkRange then begin - if leValue(s.sons[i].sons[0], b) - and leValue(b, s.sons[i].sons[1]) - or leValue(s.sons[i].sons[0], a) - and leValue(a, s.sons[i].sons[1]) then begin - result := true; exit - end - end - else begin - // a <= elem <= b - if leValue(a, s.sons[i]) and leValue(s.sons[i], b) then begin - result := true; exit - end - end; - result := false -end; - -procedure toBitSet(s: PNode; out b: TBitSet); -var - i: int; - first, j: BiggestInt; -begin - first := firstOrd(s.typ.sons[0]); - bitSetInit(b, int(getSize(s.typ))); - for i := 0 to sonsLen(s)-1 do - if s.sons[i].kind = nkRange then begin - j := getOrdValue(s.sons[i].sons[0]); - while j <= getOrdValue(s.sons[i].sons[1]) do begin - BitSetIncl(b, j - first); - inc(j) - end - end - else - BitSetIncl(b, getOrdValue(s.sons[i]) - first) -end; - -function ToTreeSet(const s: TBitSet; settype: PType; - const info: TLineInfo): PNode; -var - a, b, e, first: BiggestInt; // a, b are interval borders - elemType: PType; - n: PNode; -begin - elemType := settype.sons[0]; - first := firstOrd(elemType); - result := newNodeI(nkCurly, info); - result.typ := settype; - result.info := info; - - e := 0; - while e < high(s)*elemSize do begin - if bitSetIn(s, e) then begin - a := e; b := e; - repeat - Inc(b); - until (b > high(s)*elemSize) or not bitSetIn(s, b); - Dec(b); - if a = b then // a single element: - addSon(result, newIntTypeNode(nkIntLit, a + first, elemType)) - else begin - n := newNodeI(nkRange, info); - n.typ := elemType; - addSon(n, newIntTypeNode(nkIntLit, a + first, elemType)); - addSon(n, newIntTypeNode(nkIntLit, b + first, elemType)); - addSon(result, n); - end; - e := b - end; - Inc(e) - end -end; - -type - TSetOP = (soUnion, soDiff, soSymDiff, soIntersect); - -function nodeSetOp(a, b: PNode; op: TSetOp): PNode; -var - x, y: TBitSet; -begin - toBitSet(a, x); - toBitSet(b, y); - case op of - soUnion: BitSetUnion(x, y); - soDiff: BitSetDiff(x, y); - soSymDiff: BitSetSymDiff(x, y); - soIntersect: BitSetIntersect(x, y); - end; - result := toTreeSet(x, a.typ, a.info); -end; - -function unionSets(a, b: PNode): PNode; -begin - result := nodeSetOp(a, b, soUnion); -end; - -function diffSets(a, b: PNode): PNode; -begin - result := nodeSetOp(a, b, soDiff); -end; - -function intersectSets(a, b: PNode): PNode; -begin - result := nodeSetOp(a, b, soIntersect) -end; - -function symdiffSets(a, b: PNode): PNode; -begin - result := nodeSetOp(a, b, soSymDiff); -end; - -function containsSets(a, b: PNode): Boolean; -var - x, y: TBitSet; -begin - toBitSet(a, x); - toBitSet(b, y); - result := bitSetContains(x, y) -end; - -function equalSets(a, b: PNode): Boolean; -var - x, y: TBitSet; -begin - toBitSet(a, x); - toBitSet(b, y); - result := bitSetEquals(x, y) -end; - -function cardSet(s: PNode): BiggestInt; -var - i: int; -begin - // here we can do better than converting it into a compact set - // we just count the elements directly - result := 0; - for i := 0 to sonsLen(s)-1 do - if s.sons[i].kind = nkRange then - result := result + getOrdValue(s.sons[i].sons[1]) - - getOrdValue(s.sons[i].sons[0]) + 1 - else - Inc(result); -end; - -function SetHasRange(s: PNode): Boolean; -var - i: int; -begin - if s.kind <> nkCurly then InternalError(s.info, 'SetHasRange'); - for i := 0 to sonsLen(s)-1 do - if s.sons[i].kind = nkRange then begin - result := true; exit - end; - result := false -end; - -function emptyRange(const a, b: PNode): Boolean; -begin - result := not leValue(a, b) // a > b iff not (a <= b) -end; - -end. diff --git a/nim/nmath.pas b/nim/nmath.pas deleted file mode 100755 index 8b638eb42..000000000 --- a/nim/nmath.pas +++ /dev/null @@ -1,68 +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 nmath; - -interface - -{$include 'config.inc'} - -{@ignore} -uses - nsystem; -{@emit} - -function countBits(n: cardinal): int; -function IsPowerOfTwo(x: int): Boolean; -function nextPowerOfTwo(x: int): int; - -implementation - -function countBits(n: cardinal): int; -const - lookup: array [0..255] of Byte = ( - 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4, 1, 2, 2, 3, - 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5, 1, 2, 2, 3, 2, 3, 3, 4, - 2, 3, 3, 4, 3, 4, 4, 5, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, - 4, 5, 5, 6, 1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, 3, 4, 4, 5, - 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6, 2, 3, 3, 4, - 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6, 3, 4, 4, 5, 4, 5, 5, 6, - 4, 5, 5, 6, 5, 6, 6, 7, 1, 2, 2, 3, 2, 3, 3, 4, 2, 3, 3, 4, - 3, 4, 4, 5, 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6, - 2, 3, 3, 4, 3, 4, 4, 5, 3, 4, 4, 5, 4, 5, 5, 6, 3, 4, 4, 5, - 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7, 2, 3, 3, 4, 3, 4, 4, 5, - 3, 4, 4, 5, 4, 5, 5, 6, 3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, - 5, 6, 6, 7, 3, 4, 4, 5, 4, 5, 5, 6, 4, 5, 5, 6, 5, 6, 6, 7, - 4, 5, 5, 6, 5, 6, 6, 7, 5, 6, 6, 7, 6, 7, 7, 8 - ); -var - i: int; -begin - result := 0; - for i := 0 to sizeof(n)-1 do - Inc(result, lookup[ (n shr (i * 8)) and 255 ]) -end; - -function IsPowerOfTwo(x: int): Boolean; -begin - result := x and -x = x -end; - -function nextPowerOfTwo(x: int): int; -begin - result := x - 1; - result := result or (result shr 16); - result := result or (result shr 8); - result := result or (result shr 4); - result := result or (result shr 2); - result := result or (result shr 1); - Inc(result) -end; - -end. diff --git a/nim/nos.pas b/nim/nos.pas deleted file mode 100755 index 7c74ba1bc..000000000 --- a/nim/nos.pas +++ /dev/null @@ -1,620 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit nos; - -// This module provides Nimrod's os module in Pascal -// Note: Only implement what is really needed here! - -interface - -{$include 'config.inc'} - -uses - sysutils, -{$ifdef mswindows} - windows, -{$else} - dos, - unix, -{$endif} - strutils, - nsystem; - -type - EOSError = class(exception) - end; - - TSplitFileResult = record - dir, name, ext: string; - end; - TSplitPathResult = record - head, tail: string; - end; - -const - curdir = '.'; -{$ifdef mswindows} - dirsep = '\'; // seperator within paths - altsep = '/'; - exeExt = 'exe'; -{$else} - dirsep = '/'; - altsep = #0; // work around fpc bug - exeExt = ''; -{$endif} - pathSep = ';'; // seperator between paths - sep = dirsep; // alternative name - extsep = '.'; - -function executeShellCommand(const cmd: string): int; -// like exec, but gets a command - -function FileNewer(const a, b: string): Boolean; -// returns true if file a is newer than file b -// i.e. a was modified before b -// if a or b does not exist returns false - -function getEnv(const name: string): string; -procedure putEnv(const name, val: string); - -function JoinPath(const head, tail: string): string; overload; -function JoinPath(const parts: array of string): string; overload; - -procedure SplitPath(const path: string; out head, tail: string); overload; - -function extractDir(const f: string): string; -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); - -function ExistsFile(const filename: string): Boolean; -function AddFileExt(const filename, ext: string): string; -function ChangeFileExt(const filename, ext: string): string; - -procedure createDir(const dir: string); -function expandFilename(filename: string): string; - -function UnixToNativePath(const path: string): string; - -function sameFile(const path1, path2: string): boolean; - - -function extractFileTrunk(const filename: string): string; - -function splitFile(const path: string): TSplitFileResult; -function splitPath(const path: string): TSplitPathResult; overload; - - -implementation - -function splitFile(const path: string): TSplitFileResult; -var - sepPos, dotPos, i: int; -begin - if (path = '') or (path[length(path)] in [dirSep, altSep]) then begin - result.dir := path; - result.name := ''; - result.ext := ''; - end - else begin - sepPos := 0; - dotPos := length(path)+1; - for i := length(path) downto 1 do begin - if path[i] = ExtSep then begin - if (dotPos = length(path)+1) and (i > 1) then dotPos := i - end - else if path[i] in [dirsep, altsep] then begin - sepPos := i; break - end - end; - result.dir := ncopy(path, 1, sepPos-1); - result.name := ncopy(path, sepPos+1, dotPos-1); - result.ext := ncopy(path, dotPos) - end -end; - -function extractFileTrunk(const filename: string): string; -var - f, e, dir: string; -begin - splitPath(filename, dir, f); - splitFilename(f, result, e); -end; - -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 - result := replace(path, '/', dirSep) - else - result := path; -end; - -function expandFilename(filename: string): string; -begin - result := sysutils.expandFilename(filename) -end; - -function sameFile(const path1, path2: string): boolean; -begin - result := cmpIgnoreCase(expandFilename(UnixToNativePath(path1)), - expandFilename(UnixToNativePath(path2))) = 0; -end; - -procedure createDir(const dir: string); -var - i: int; -begin - for i := 2 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; -var - i: int; -begin - result := -1; - for i := length(s) downto 2 do - if s[i] = extsep then begin - result := i; - break - end - else if s[i] in [dirsep, altsep] then break -end; - -function normExt(const ext: string): string; -begin - if (ext = '') or (ext[1] = extSep) then - result := ext // no copy needed here - else - result := extSep + ext -end; - -function AddFileExt(const filename, ext: string): string; -var - extPos: int; -begin - extPos := searchExtPos(filename); - if extPos < 0 then - result := filename + normExt(ext) - else - result := filename -end; - -function ChangeFileExt(const filename, ext: string): string; -var - extPos: int; -begin - extPos := searchExtPos(filename); - if extPos < 0 then - result := filename + normExt(ext) - else - result := ncopy(filename, strStart, extPos-1) + normExt(ext) -end; - -procedure SplitFilename(const filename: string; out name, extension: string); -var - extPos: int; -begin - extPos := searchExtPos(filename); - if extPos > 0 then begin - name := ncopy(filename, 1, extPos-1); - extension := ncopy(filename, extPos); - end - else begin - name := filename; - extension := '' - end -end; - -procedure SplitPath(const path: string; out head, tail: string); -var - sepPos, i: int; -begin - sepPos := 0; - for i := length(path) downto 1 do - if path[i] in [sep, altsep] then begin - sepPos := i; - break - end; - if sepPos > 0 then begin - head := ncopy(path, 1, sepPos-1); - tail := ncopy(path, sepPos+1) - end - else begin - head := ''; - tail := path - end -end; - -function SplitPath(const path: string): TSplitPathResult; -begin - SplitPath(path, result.head, result.tail); -end; - -function getApplicationFilename(): string; -{$ifdef darwin} -var - tail: string; - p: int; - paths: TStringSeq; -begin - // little heuristic that may works on Mac OS X: - result := ParamStr(0); // POSIX guaranties that this contains the executable - // as it has been executed by the calling process - if (length(result) > 0) and (result[1] <> '/') then begin - // not an absolute path? - // iterate over any path in the $PATH environment variable - paths := split(getEnv('PATH'), [':']); - for p := 0 to high(paths) do begin - tail := joinPath(paths[p], result); - if ExistsFile(tail) then begin result := tail; exit end - end - end -end; -{$else} -begin - result := ParamStr(0); -end; -{$endif} - -function getApplicationDir(): string; -begin - result := extractDir(getApplicationFilename()); -end; - -function extractDir(const f: string): string; -var - tail: string; -begin - SplitPath(f, result, tail) -end; - -function extractFilename(const f: string): string; -var - head: string; -begin - SplitPath(f, head, result); -end; - -function JoinPath(const head, tail: string): string; -begin - if head = '' then - result := tail - else if head[length(head)] in [sep, altsep] then - if (tail <> '') and (tail[1] in [sep, altsep]) then - result := head + ncopy(tail, 2) - else - result := head + tail - else - if (tail <> '') and (tail[1] in [sep, altsep]) then - result := head + tail - else - result := head + sep + tail -end; - -function JoinPath(const parts: array of string): string; -var - i: int; -begin - result := parts[0]; - for i := 1 to high(parts) do - result := JoinPath(result, parts[i]) -end; - -{$ifdef mswindows} -function getEnv(const name: string): string; -var - len: Cardinal; -begin - // get the length: - len := windows.GetEnvironmentVariable(PChar(name), nil, 0); - if len = 0 then - result := '' - else begin - setLength(result, len-1); - windows.GetEnvironmentVariable(PChar(name), @result[1], len); - end -end; - -procedure putEnv(const name, val: string); -begin - windows.SetEnvironmentVariable(PChar(name), PChar(val)); -end; - -function GetDateStr: string; -var - st: SystemTime; -begin - Windows.GetLocalTime({$ifdef fpc} @ {$endif} st); - result := IntToStr(st.wYear, 4) + '/' + IntToStr(st.wMonth, 2) + '/' - + IntToStr(st.wDay, 2) -end; - -procedure GetDate(var Day, Month, Year: int); -var - st: SystemTime; -begin - Windows.GetLocalTime({$ifdef fpc} @ {$endif} st); - Day := st.wDay; - Month := st.wMonth; - Year := st.wYear -end; - -procedure GetTime(var Hours, Minutes, Seconds, Millisec: int); -var - st: SystemTime; -begin - Windows.GetLocalTime({$ifdef fpc} @ {$endif} st); - Hours := st.wHour; - Minutes := st.wMinute; - Seconds := st.wSecond; - Millisec := st.wMilliseconds -end; -{$else} // not windows - -function setenv(var_name, new_value: PChar; - change_flag: Boolean): Integer; cdecl; external 'libc'; - -type - TPair = record - key, val: string; - end; - TPairs = array of TPair; -var - myEnv: TPairs; // this is a horrible fix for Posix systems! - -function getMyEnvIdx(const key: string): int; -var - i: int; -begin - for i := 0 to high(myEnv) do - if myEnv[i].key = key then begin result := i; exit end; - result := -1 -end; - -function getMyEnv(const key: string): string; -var - i: int; -begin - i := getMyEnvIdx(key); - if i >= 0 then result := myEnv[i].val - else result := '' -end; - -procedure setMyEnv(const key, val: string); -var - i: int; -begin - i := getMyEnvIdx(key); - if i < 0 then begin - i := length(myEnv); - setLength(myEnv, i+1); - myEnv[i].key := key - end; - myEnv[i].val := val -end; - -procedure putEnv(const name, val: string); -begin - setEnv(pchar(name), pchar(val), true); - setMyEnv(name, val); -// writeln('putEnv() is not supported under this OS'); -// halt(3); -end; - -function getEnv(const name: string): string; -begin - result := getMyEnv(name); - if result = '' then result := dos.getEnv(name); -end; - -function GetDateStr: string; -var - wMonth, wYear, wDay: Word; -begin - SysUtils.DecodeDate(Date, wYear, wMonth, wDay); - result := IntToStr(wYear, 4) + '/' + IntToStr(wMonth, 2) + '/' - + IntToStr(wDay, 2) -end; - -procedure GetDate(var Day, Month, Year: int); -var - wMonth, wYear, wDay: Word; -begin - SysUtils.DecodeDate(Date, wYear, wMonth, wDay); - Day := wDay; - Month := wMonth; - Year := wYear -end; - -procedure GetTime(var Hours, Minutes, Seconds, Millisec: int); -var - wHour, wMin, wSec, wMSec: Word; -begin - SysUtils.DecodeTime(Time, wHour, wMin, wSec, wMSec); - Hours := wHour; Minutes := wMin; Seconds := wSec; Millisec := wMSec; -end; -{$endif} - -function GetTimeStr: string; -var - Hour, Min, Sec, MSec: int; -begin - GetTime(Hour, min, sec, msec); - result := IntToStr(Hour, 2) + ':' + IntToStr(min, 2) + ':' + IntToStr(Sec, 2) -end; - -function DateAndTime: string; -begin - result := GetDateStr() + ' ' + getTimeStr() -end; - -{$ifdef windows} - -function executeShellCommand(const cmd: string): int; -var - SI: TStartupInfo; - ProcInfo: TProcessInformation; - process: THandle; - L: DWORD; -begin - FillChar(SI, Sizeof(SI), 0); - SI.cb := SizeOf(SI); - SI.hStdError := GetStdHandle(STD_ERROR_HANDLE); - SI.hStdInput := GetStdHandle(STD_INPUT_HANDLE); - SI.hStdOutput := GetStdHandle(STD_OUTPUT_HANDLE); - if not Windows.CreateProcess(nil, PChar(cmd), nil, nil, false, - NORMAL_PRIORITY_CLASS, nil {Windows.GetEnvironmentStrings()}, - nil, SI, ProcInfo) - then - result := getLastError() - else begin - Process := ProcInfo.hProcess; - CloseHandle(ProcInfo.hThread); - if WaitForSingleObject(Process, INFINITE) <> $ffffffff then begin - GetExitCodeProcess(Process, L); - result := int(L) - end - else - result := -1; - CloseHandle(Process); - end; -end; - -{$else} - {$ifdef windows} -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 executeShellCommand(const cmd: string): int; -begin - result := shell(cmd); -end; - {$endif} -{$endif} - -{$ifdef windows} -type - TFileAge = packed record - Low, High: Longword; - end; -{$else} -type - TFileAge = dos.DateTime; - {DateTime = packed record - Year: Word; - Month: Word; - Day: Word; - Hour: Word; - Min: Word; - Sec: Word; - end;} -{$endif} - -function GetLastWriteTime(Filename: PChar): TFileAge; -{$ifdef windows} -var - Handle: THandle; - FindRec: Win32_Find_Data; -begin - Handle := FindFirstFile(Filename, FindRec); - FindClose(Handle); - result := TFileAge(FindRec.ftLastWriteTime) -end; -{$else} -var - f: file; - time: longint; -begin - AssignFile(f, AnsiString(Filename)); - Reset(f); - GetFTime(f, time); - unpackTime(time, result); - CloseFile(f); -end; -{$endif} - -function Newer(file1, file2: PChar): Boolean; -var - Time1, Time2: TFileAge; -begin - Time1 := GetLastWriteTime(file1); - Time2 := GetLastWriteTime(file2); -{$ifdef windows} - if Time1.High <> Time2.High then - result := Time1.High > Time2.High - else - result := Time1.Low > Time2.Low -{$else} - if time1.year <> time2.year then - result := time1.year > time2.year - else if time1.month <> time2.month then - result := time1.month > time2.month - else if time1.day <> time2.day then - result := time1.day > time2.day - else if time1.hour <> time2.hour then - result := time1.hour > time2.hour - else if time1.min <> time2.min then - result := time1.min > time2.min - else if time1.sec <> time2.sec then - result := time1.sec > time2.sec -{$endif} -end; - -{$ifopt I+} {$define I_on} {$I-} {$endif} -function ExistsFile(const filename: string): Boolean; -var - txt: TextFile; -begin - AssignFile(txt, filename); - Reset(txt); - if IOResult = 0 then begin - result := true; - CloseFile(txt) - end - else result := false -end; -{$ifdef I_on} {$I+} {$endif} - -function FileNewer(const a, b: string): Boolean; -begin - if not ExistsFile(PChar(a)) or not ExistsFile(PChar(b)) then - result := false - else - result := newer(PChar(a), PChar(b)) -end; - -end. diff --git a/nim/nstrtabs.pas b/nim/nstrtabs.pas deleted file mode 100755 index bcb10f2ed..000000000 --- a/nim/nstrtabs.pas +++ /dev/null @@ -1,294 +0,0 @@ -// -// -// Nimrod's Runtime Library -// (c) Copyright 2008 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit nstrtabs; - -// String tables. - -interface - -{$include 'config.inc'} - -uses - nsystem, nos, nhashes, strutils; - -type - TStringTableMode = ( - modeCaseSensitive, // the table is case sensitive - modeCaseInsensitive, // the table is case insensitive - modeStyleInsensitive // the table is style insensitive - ); - TKeyValuePair = record{@tuple} - key, val: string; - end; - TKeyValuePairSeq = array of TKeyValuePair; - TStringTable = object(NObject) - counter: int; - data: TKeyValuePairSeq; - mode: TStringTableMode; - end; - PStringTable = ^TStringTable; - -function newStringTable(const keyValuePairs: array of string; - mode: TStringTableMode = modeCaseSensitive): PStringTable; - -procedure put(t: PStringTable; const key, val: string); -function get(t: PStringTable; const key: string): string; -function hasKey(t: PStringTable; const key: string): bool; -function len(t: PStringTable): int; - -type - TFormatFlag = ( - useEnvironment, // use environment variable if the ``$key`` - // is not found in the table - useEmpty, // use the empty string as a default, thus it - // won't throw an exception if ``$key`` is not - // in the table - useKey // do not replace ``$key`` if it is not found - // in the table (or in the environment) - ); - TFormatFlags = set of TFormatFlag; - -function format(const f: string; t: PStringTable; - flags: TFormatFlags = {@set}[]): string; - -implementation - -const - growthFactor = 2; - startSize = 64; - -{@ignore} -function isNil(const s: string): bool; -begin - result := s = '' -end; -{@emit} - -function newStringTable(const keyValuePairs: array of string; - mode: TStringTableMode = modeCaseSensitive): PStringTable; -var - i: int; -begin - new(result); - result.mode := mode; - result.counter := 0; -{@ignore} - setLength(result.data, startSize); - fillChar(result.data[0], length(result.data)*sizeof(result.data[0]), 0); -{@emit - newSeq(result.data, startSize); } - i := 0; - while i < high(keyValuePairs) do begin - put(result, keyValuePairs[i], keyValuePairs[i+1]); - inc(i, 2); - end -end; - -function myhash(t: PStringTable; const key: string): THash; -begin - case t.mode of - modeCaseSensitive: result := nhashes.GetHashStr(key); - modeCaseInsensitive: result := nhashes.GetHashStrCI(key); - modeStyleInsensitive: result := nhashes.getNormalizedHash(key); - end -end; - -function myCmp(t: PStringTable; const a, b: string): bool; -begin - case t.mode of - modeCaseSensitive: result := cmp(a, b) = 0; - modeCaseInsensitive: result := cmpIgnoreCase(a, b) = 0; - modeStyleInsensitive: result := cmpIgnoreStyle(a, b) = 0; - end -end; - -function mustRehash(len, counter: int): bool; -begin - assert(len > counter); - result := (len * 2 < counter * 3) or (len-counter < 4); -end; - -function len(t: PStringTable): int; -begin - result := t.counter -end; - -{@ignore} -const - EmptySeq = nil; -{@emit -const - EmptySeq = []; -} - -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; - -function RawGet(t: PStringTable; const key: string): int; -var - h: THash; -begin - h := myhash(t, key) and high(t.data); // start with real hash value - while not isNil(t.data[h].key) do begin - if mycmp(t, t.data[h].key, key) then begin - result := h; exit - end; - h := nextTry(h, high(t.data)) - end; - result := -1 -end; - -function get(t: PStringTable; const key: string): string; -var - index: int; -begin - index := RawGet(t, key); - if index >= 0 then result := t.data[index].val - else result := '' -end; - -function hasKey(t: PStringTable; const key: string): bool; -begin - result := rawGet(t, key) >= 0 -end; - -procedure RawInsert(t: PStringTable; - var data: TKeyValuePairSeq; - const key, val: string); -var - h: THash; -begin - h := myhash(t, key) and high(data); - while not isNil(data[h].key) do begin - h := nextTry(h, high(data)) - end; - data[h].key := key; - data[h].val := val; -end; - -procedure Enlarge(t: PStringTable); -var - n: TKeyValuePairSeq; - i: int; -begin -{@ignore} - n := emptySeq; - 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 not isNil(t.data[i].key) then - RawInsert(t, n, t.data[i].key, t.data[i].val); -{@ignore} - t.data := n; -{@emit - swap(t.data, n); -} -end; - -procedure Put(t: PStringTable; const key, val: string); -var - index: int; -begin - index := RawGet(t, key); - if index >= 0 then - t.data[index].val := val - else begin - if mustRehash(length(t.data), t.counter) then Enlarge(t); - RawInsert(t, t.data, key, val); - inc(t.counter) - end; -end; - -{@ignore} -type - EInvalidValue = int; // dummy for the Pascal compiler -{@emit} - -procedure RaiseFormatException(const s: string); -var - e: ^EInvalidValue; -begin -{@ignore} - raise EInvalidFormatStr.create(s); -{@emit - new(e);} -{@emit - e.msg := 'format string: key not found: ' + s;} -{@emit - raise e;} -end; - -function getValue(t: PStringTable; flags: TFormatFlags; - const key: string): string; -begin - if hasKey(t, key) then begin - result := get(t, key); exit - end; - if useEnvironment in flags then - result := nos.getEnv(key) - else - result := ''; - if (result = '') then begin - if useKey in flags then result := '$' + key - else if not (useEmpty in flags) then - raiseFormatException(key) - end -end; - -function format(const f: string; t: PStringTable; - flags: TFormatFlags = {@set}[]): string; -const - PatternChars = ['a'..'z', 'A'..'Z', '0'..'9', '_', #128..#255]; -var - i, j: int; - key: string; -begin - result := ''; - i := strStart; - while i <= length(f)+strStart-1 do - if f[i] = '$' then begin - case f[i+1] of - '$': begin - addChar(result, '$'); - inc(i, 2); - end; - '{': begin - j := i+1; - while (j <= length(f)+strStart-1) and (f[j] <> '}') do inc(j); - key := ncopy(f, i+2+strStart-1, j-1+strStart-1); - add(result, getValue(t, flags, key)); - i := j+1 - end; - 'a'..'z', 'A'..'Z', #128..#255, '_': begin - j := i+1; - while (j <= length(f)+strStart-1) and (f[j] in PatternChars) do inc(j); - key := ncopy(f, i+1+strStart-1, j-1+strStart-1); - add(result, getValue(t, flags, key)); - i := j - end - else begin - addChar(result, f[i]); - inc(i) - end - end - end - else begin - addChar(result, f[i]); - inc(i) - end -end; - -end. diff --git a/nim/nsystem.pas b/nim/nsystem.pas deleted file mode 100755 index 4cdfade93..000000000 --- a/nim/nsystem.pas +++ /dev/null @@ -1,657 +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 nsystem; - -// This module provides things that are in Nimrod's system -// module and not available in Pascal. - -interface - -{$include 'config.inc'} - -uses - sysutils -{$ifdef fpc} - , math -{$endif} - ; - -type - // Generic int like in Nimrod: - // well, no, because of FPC's bugs... -{$ifdef cpu64} - int = int64; - uint = qword; -{$else} - int = longint; - uint = cardinal; -{$endif} - - TResult = Boolean; - EInvalidValue = class(Exception) - end; - -{$ifndef fpc} - EOverflow = class(Exception) - end; -{$endif} - EOutOfRange = class(Exception) - end; - EOS = class(Exception) end; - - float32 = single; - float64 = double; - PFloat32 = ^float32; - PFloat64 = ^float64; -const - Failure = False; - Success = True; - - snil = ''; - -type - TStringSeq = array of string; - TCharSet = set of Char; - - -type - Natural = 0..high(int); - Positive = 1..high(int); - NObject = object // base type for all objects, cannot use - // TObject here, as it would overwrite System.TObject which is - // a class in Object pascal. Anyway, pas2mor has no problems - // to replace NObject by TObject - end; - PObject = ^NObject; - - int16 = smallint; - int8 = shortint; - int32 = longint; - uint16 = word; - uint32 = longword; - uint8 = byte; - - TByteArray = array [0..1024 * 1024] of Byte; - PByteArray = ^TByteArray; - PByte = ^Byte; - cstring = pchar; - bool = boolean; - PInt32 = ^int32; - -{$ifdef bit64clean} // BUGIX: was $ifdef fpc - BiggestUInt = QWord; - BiggestInt = Int64; // biggest integer type available -{$else} - BiggestUInt = Cardinal; // Delphi's Int64 is broken seriously - BiggestInt = Integer; // ditto -{$endif} - BiggestFloat = Double; // biggest floating point type -{$ifdef cpu64} - TAddress = Int64; -{$else} - TAddress = longint; -{$endif} - -var - NaN: float; - inf: float; - NegInf: float; -{$ifdef fpc} -{$else} - {$ifopt Q+} - {$define Q_on} - {$Q-} - {$endif} - {$ifopt R+} - {$define R_on} - {$R-} - {$endif} - const - Inf = 1.0/0.0; - NegInf = (-1.0) / 0.0; - {$ifdef Q_on} - {$Q+} - {$undef Q_on} - {$endif} - {$ifdef R_on} - {$R+} - {$undef R_on} - {$endif} -{$endif} - -function toFloat(i: biggestInt): biggestFloat; -function toInt(r: biggestFloat): biggestInt; - -function min(a, b: int): int; overload; -function max(a, b: int): int; overload; -{$ifndef fpc} // fpc cannot handle these overloads (bug in 64bit version?) -// the Nimrod compiler does not use them anyway, so it does not matter -function max(a, b: real): real; overload; -function min(a, b: real): real; overload; -{$endif} - -procedure zeroMem(p: Pointer; size: int); -procedure copyMem(dest, source: Pointer; size: int); -procedure moveMem(dest, source: Pointer; size: int); -function equalMem(a, b: Pointer; size: int): Boolean; - -function ncopy(s: string; a: int = 1): string; overload; -function ncopy(s: string; a, b: int): string; overload; -// will be replaced by "copy" - -function newString(len: int): string; - -procedure addChar(var s: string; c: Char); - -{@ignore} -function addU(a, b: biggestInt): biggestInt; -function subU(a, b: biggestInt): biggestInt; -function mulU(a, b: biggestInt): biggestInt; -function divU(a, b: biggestInt): biggestInt; -function modU(a, b: biggestInt): biggestInt; -function shlU(a, b: biggestInt): biggestInt; overload; -function shrU(a, b: biggestInt): biggestInt; overload; - -function shlU(a, b: Int32): Int32;overload; -function shrU(a, b: int32): int32;overload; - -function ltU(a, b: biggestInt): bool; -function leU(a, b: biggestInt): bool; - -function toU8(a: biggestInt): byte; -function toU16(a: biggestInt): int16; -function toU32(a: biggestInt): int32; -function ze64(a: byte): biggestInt; -function ze(a: byte): int; -{@emit} - -function alloc(size: int): Pointer; -function realloc(p: Pointer; newsize: int): Pointer; -procedure dealloc(p: Pointer); - -type - TTextFile = record - buf: PChar; - sysFile: system.textFile; - end; - - TBinaryFile = file; - - TFileMode = (fmRead, fmWrite, fmReadWrite, fmReadWriteExisting, fmAppend); - -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; 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: -function OpenFile(var f: tBinaryFile; const filename: string; - mode: TFileMode = fmRead): Boolean; overload; -procedure nimCloseFile(var f: tBinaryFile); overload; - -function ReadBytes(var f: tBinaryFile; out a: array of byte; - start, len: int): int; -function ReadChars(var f: tBinaryFile; out a: array of char; - start, len: int): int; - -function writeBuffer(var f: TBinaryFile; buffer: pointer; len: int): int; -function readBuffer(var f: tBinaryFile; buffer: pointer; len: int): int; -overload; -function readBuffer(var f: tBinaryFile): string; overload; -function getFilePos(var f: tBinaryFile): int; -procedure setFilePos(var f: tBinaryFile; pos: int64); - -function readFile(const filename: string): string; - -procedure nimWrite(var f: tBinaryFile; const str: string); overload; - -procedure add(var x: string; const y: string); overload; -// Pascal version of string appending. Terminating zero is ignored. - -procedure add(var s: TStringSeq; const y: string); overload; - -function isNil(s: string): bool; - -implementation - -function isNil(s: string): bool; -begin - result := s = ''; -end; - -{@ignore} -procedure add(var x: string; const y: string); -// Pascal version of string appending. Terminating zero is ignored. -var - L: int; -begin - L := length(y); - if L > 0 then begin - if y[L] = #0 then x := x + copy(y, 1, L-1) - else x := x + y; - end -end; - -procedure add(var s: TStringSeq; const y: string); overload; -var - L: int; -begin - L := length(s); - setLength(s, L+1); - s[L] := y; -end; -{@emit} - -function alloc(size: int): Pointer; -begin - getMem(result, size); // use standard allocator - FillChar(result^, size, 0); -end; - -function realloc(p: Pointer; newsize: int): Pointer; -begin - reallocMem(p, newsize); // use standard allocator - result := p; -end; - -procedure dealloc(p: pointer); -begin - freeMem(p); -end; - -{@ignore} -function addU(a, b: biggestInt): biggestInt; -begin - result := biggestInt(biggestUInt(a) + biggestUInt(b)); -end; - -function subU(a, b: biggestInt): biggestInt; -begin - result := biggestInt(biggestUInt(a) - biggestUInt(b)); -end; - -function mulU(a, b: biggestInt): biggestInt; -begin - result := biggestInt(biggestUInt(a) * biggestUInt(b)); -end; - -function divU(a, b: biggestInt): biggestInt; -begin - result := biggestInt(biggestUInt(a) div biggestUInt(b)); -end; - -function modU(a, b: biggestInt): biggestInt; -begin - result := biggestInt(biggestUInt(a) mod biggestUInt(b)); -end; - -function shlU(a, b: biggestInt): biggestInt; -begin - result := biggestInt(biggestUInt(a) shl biggestUInt(b)); -end; - -function shrU(a, b: biggestInt): biggestInt; -begin - result := biggestInt(biggestUInt(a) shr biggestUInt(b)); -end; - -function shlU(a, b: Int32): Int32; -begin - result := Int32(UInt32(a) shl UInt32(b)); -end; - -function shrU(a, b: int32): int32; -begin - result := Int32(UInt32(a) shr UInt32(b)); -end; - -function ltU(a, b: biggestInt): bool; -begin - result := biggestUInt(a) < biggestUInt(b); -end; - -function leU(a, b: biggestInt): bool; -begin - result := biggestUInt(a) < biggestUInt(b); -end; - -function toU8(a: biggestInt): byte; -begin - assert(a >= 0); - assert(a <= 255); - result := a; -end; - -function toU32(a: biggestInt): int32; -begin - result := int32(a and $ffffffff); -end; - -function toU16(a: biggestInt): int16; -begin - result := int16(a and $ffff); -end; - -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); -{@ignore} -// delphi produces suboptimal code for "s := s + c" -{$ifndef fpc} -var - len: int; -{$endif} -{@emit} -begin -{@ignore} -{$ifdef fpc} - s := s + c -{$else} - {$ifopt H+} - len := length(s); - setLength(s, len + 1); - PChar(Pointer(s))[len] := c - {$else} - s := s + c - {$endif} -{$endif} -{@emit - s &= c -} -end; - -function newString(len: int): string; -begin - setLength(result, len); - if len > 0 then begin - {@ignore} - fillChar(result[1], length(result), 0); - {@emit} - end -end; - -function toFloat(i: BiggestInt): BiggestFloat; -begin - result := i // conversion automatically in Pascal -end; - -function toInt(r: BiggestFloat): BiggestInt; -begin - result := round(r); -end; - -procedure zeroMem(p: Pointer; size: int); -begin - fillChar(p^, size, 0); -end; - -procedure copyMem(dest, source: Pointer; size: int); -begin - if size > 0 then - move(source^, dest^, size); -end; - -procedure moveMem(dest, source: Pointer; size: int); -begin - if size > 0 then - move(source^, dest^, size); // move handles overlapping regions -end; - -function equalMem(a, b: Pointer; size: int): Boolean; -begin - result := compareMem(a, b, size); -end; - -{$ifndef fpc} -function min(a, b: real): real; overload; -begin - if a < b then result := a else result := b -end; - -function max(a, b: real): real; overload; -begin - if a > b then result := a else result := b -end; -{$endif} - -function min(a, b: int): int; overload; -begin - if a < b then result := a else result := b -end; - -function max(a, b: int): int; overload; -begin - if a > b then result := a else result := b -end; - -function ncopy(s: string; a, b: int): string; -begin - result := copy(s, a, b-a+1); -end; - -function ncopy(s: string; a: int = 1): string; -begin - result := copy(s, a, length(s)) -end; - - -{$ifopt I+} {$define I_on} {$I-} {$endif} -function OpenFile(out f: tTextFile; const filename: string; - mode: TFileMode = fmRead): Boolean; overload; -begin - AssignFile(f.sysFile, filename); - f.buf := alloc(4096); - SetTextBuf(f.sysFile, f.buf^, 4096); - case mode of - fmRead: Reset(f.sysFile); - fmWrite: Rewrite(f.sysFile); - fmReadWrite: Reset(f.sysFile); - fmAppend: Append(f.sysFile); - end; - result := (IOResult = 0); -end; - -function readChar(var f: tTextFile): char; -begin - Read(f.sysFile, result); -end; - -procedure nimWrite(var f: tTextFile; const str: string); -begin - system.write(f.sysFile, str) -end; - -function readLine(var f: tTextFile): string; -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); - dealloc(f.buf) -end; - -procedure nimCloseFile(var f: tBinaryFile); -begin - closeFile(f); -end; - -function OpenFile(var f: TBinaryFile; const filename: string; - mode: TFileMode = fmRead): Boolean; -begin - AssignFile(f, filename); - case mode of - fmRead: Reset(f, 1); - fmWrite: Rewrite(f, 1); - fmReadWrite: Reset(f, 1); - fmAppend: assert(false); - end; - result := (IOResult = 0); -end; - -function ReadBytes(var f: tBinaryFile; out a: array of byte; - start, len: int): int; -begin - result := 0; - BlockRead(f, a[0], len, result) -end; - -function ReadChars(var f: tBinaryFile; out a: array of char; - start, len: int): int; -begin - result := 0; - BlockRead(f, a[0], len, result) -end; - -function readBuffer(var f: tBinaryFile; buffer: pointer; len: int): int; -begin - result := 0; - 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; -var - bytesRead, len, cap: int; -begin - // read the file in 4K chunks - result := newString(bufSize); - cap := bufSize; - len := 0; - while true do begin - bytesRead := readBuffer(f, addr(result[len+1]), bufSize); - inc(len, bytesRead); - if bytesRead <> bufSize then break; - inc(cap, bufSize); - setLength(result, cap); - end; - setLength(result, len); -end; - -function readFile(const filename: string): string; -var - f: tBinaryFile; -begin - if openFile(f, filename) then begin - result := readBuffer(f); - nimCloseFile(f) - end - else - result := ''; -end; - -function writeBuffer(var f: TBinaryFile; buffer: pointer; - len: int): int; -begin - result := 0; - BlockWrite(f, buffer^, len, result); -end; - -function getFilePos(var f: tBinaryFile): int; -begin - result := filePos(f); -end; - -procedure setFilePos(var f: tBinaryFile; pos: int64); -begin - Seek(f, pos); -end; - -{$ifdef I_on} {$undef I_on} {$I+} {$endif} - -{$ifopt R+} {$R-,Q-} {$define R_on} {$endif} -var - zero: float; - Saved8087CW: Word; - savedExcMask: TFPUExceptionMask; -initialization -{$ifdef cpu64} - savedExcMask := SetExceptionMask([exInvalidOp, - exDenormalized, - exPrecision, - exZeroDivide, - exOverflow, - exUnderflow - ]); -{$else} - Saved8087CW := Default8087CW; - Set8087CW($133f); // Disable all fpu exceptions -{$endif} - zero := 0.0; - NaN := 0.0 / zero; - inf := 1.0 / zero; - NegInf := -inf; -finalization -{$ifdef cpu64} - SetExceptionMask(savedExcMask); // set back exception mask -{$else} - Set8087CW(Saved8087CW); -{$endif} -{$ifdef R_on} - {$R+,Q+} -{$endif} -end. diff --git a/nim/ntime.pas b/nim/ntime.pas deleted file mode 100755 index 9135c26c3..000000000 --- a/nim/ntime.pas +++ /dev/null @@ -1,107 +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 ntime; - -interface - -{$include 'config.inc'} - -uses -{$ifdef win32} - windows, -{$else} - sysutils, - {$ifdef fpc} - dos, - {$endif} -{$endif} - nsystem, strutils; - -function DateAndClock: string; -// returns current date and time (format: YYYY-MM-DD Sec:Min:Hour) - -function getDateStr: string; -function getClockStr: string; - -implementation - -{$ifdef mswindows} -function GetDateStr: string; -var - st: SystemTime; -begin - Windows.GetLocalTime({$ifdef fpc} @ {$endif} st); - result := IntToStr(st.wYear, 4) + '-' + IntToStr(st.wMonth, 2) + '-' - + IntToStr(st.wDay, 2) -end; - -procedure GetDate(var Day, Month, Year: int); -var - st: SystemTime; -begin - Windows.GetLocalTime({$ifdef fpc} @ {$endif} st); - Day := st.wDay; - Month := st.wMonth; - Year := st.wYear -end; - -procedure GetTime(var Hours, Minutes, Seconds, Millisec: int); -var - st: SystemTime; -begin - Windows.GetLocalTime({$ifdef fpc} @ {$endif} st); - Hours := st.wHour; - Minutes := st.wMinute; - Seconds := st.wSecond; - Millisec := st.wMilliseconds -end; -{$else} // not windows -function GetDateStr: string; -var - wMonth, wYear, wDay: Word; -begin - SysUtils.DecodeDate(Date, wYear, wMonth, wDay); - result := IntToStr(wYear, 4) + '-' + IntToStr(wMonth, 2) + '-' - + IntToStr(wDay, 2) -end; - -procedure GetDate(var Day, Month, Year: int); -var - wMonth, wYear, wDay: Word; -begin - SysUtils.DecodeDate(Date, wYear, wMonth, wDay); - Day := wDay; - Month := wMonth; - Year := wYear -end; - -procedure GetTime(var Hours, Minutes, Seconds, Millisec: int); -var - wHour, wMin, wSec, wMSec: Word; -begin - SysUtils.DecodeTime(Time, wHour, wMin, wSec, wMSec); - Hours := wHour; Minutes := wMin; Seconds := wSec; Millisec := wMSec; -end; -{$endif} - -function GetClockStr: string; -var - Hour, Min, Sec, MSec: int; -begin - GetTime(Hour, min, sec, msec); - result := IntToStr(Hour, 2) + ':' + IntToStr(min, 2) + ':' + IntToStr(Sec, 2) -end; - -function DateAndClock: string; -begin - result := GetDateStr() + ' ' + getClockStr() -end; - -end. - diff --git a/nim/nversion.pas b/nim/nversion.pas deleted file mode 100755 index c9bdd24fb..000000000 --- a/nim/nversion.pas +++ /dev/null @@ -1,42 +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 nversion; - -// this unit implements the version handling - -interface - -{$include 'config.inc'} - -uses - strutils; - -const - MaxSetElements = 1 shl 16; // (2^16) to support unicode character sets? - defaultAsmMarkerSymbol = '!'; - - //[[[cog - //from koch import NIMROD_VERSION - //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.8.3'; - VersionMajor = 0; - VersionMinor = 8; - VersionPatch = 3; - //[[[[end]]]] - -implementation - -end. diff --git a/nim/options.pas b/nim/options.pas deleted file mode 100755 index 3a7d4a669..000000000 --- a/nim/options.pas +++ /dev/null @@ -1,291 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit options; - -interface - -{$include 'config.inc'} - -uses - nsystem, nos, lists, strutils, nstrtabs; - -type - // please make sure we have under 32 options - // (improves code efficiency a lot!) - TOption = ( // **keep binary compatible** - optNone, - optObjCheck, - optFieldCheck, optRangeCheck, - optBoundsCheck, optOverflowCheck, optNilCheck, optAssert, optLineDir, - optWarns, optHints, - optOptimizeSpeed, - optOptimizeSize, - optStackTrace, // stack tracing support - 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) - optProfiler // profiler turned on - ); - TOptions = set of TOption; - - TGlobalOption = (gloptNone, optForceFullMake, optBoehmGC, - optRefcGC, optDeadCodeElim, optListCmd, optCompileOnly, optNoLinking, - optSafeCode, // only allow safe code - optCDebug, // turn on debugging information - 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 - optSymbolFiles, // use symbol files for speeding up compilation - optSkipConfigFile, // skip the general config file - optSkipProjConfigFile, // skip the project's config file - optNoMain // do not generate a "main" proc - ); - TGlobalOptions = set of TGlobalOption; - - TCommands = ( // Nimrod's commands - cmdNone, - cmdCompileToC, - cmdCompileToCpp, - cmdCompileToEcmaScript, - cmdCompileToLLVM, - cmdInterpret, - cmdPretty, - cmdDoc, - cmdPas, - cmdBoot, - cmdGenDepend, - cmdListDef, - cmdCheck, // semantic checking for whole project - 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 - cmdRst2tex, // convert a reStructuredText file to TeX - cmdInteractive // start interactive session - ); - TStringSeq = array of string; - -const - ChecksOptions = {@set}[optObjCheck, optFieldCheck, optRangeCheck, - optNilCheck, optOverflowCheck, optBoundsCheck, - optAssert]; - optionToStr: array [TOption] of string = ( - 'optNone', 'optObjCheck', 'optFieldCheck', 'optRangeCheck', - 'optBoundsCheck', 'optOverflowCheck', 'optNilCheck', 'optAssert', - 'optLineDir', 'optWarns', 'optHints', 'optOptimizeSpeed', - 'optOptimizeSize', 'optStackTrace', 'optLineTrace', 'optEmdb', - 'optByRef', 'optCheckpoints', 'optProfiler' - ); -var - gOptions: TOptions = {@set}[optObjCheck, optFieldCheck, optRangeCheck, - optBoundsCheck, optOverflowCheck, - optAssert, optWarns, optHints, - optStackTrace, optLineTrace]; - - gGlobalOptions: TGlobalOptions = {@set}[optRefcGC]; - - gExitcode: Byte; - searchPaths: TLinkedList; - outFile: string = ''; - gIndexFile: string = ''; - - gCmd: TCommands = cmdNone; // the command - - gVerbosity: int; // how verbose the compiler is - gNumberOfProcessors: int; // number of processors - -function FindFile(const f: string): string; - -const - genSubDir = 'nimcache'; - NimExt = 'nim'; - RodExt = 'rod'; - HtmlExt = 'html'; - TexExt = 'tex'; - IniExt = 'ini'; - DocConfig = 'nimdoc.cfg'; - DocTexConfig = 'nimdoc.tex.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/nimcache/mymodule.rod" - -function getPrefixDir: string; -// gets the application directory - -// 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 @[]}; - // 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); - -procedure addImplicitMod(const filename: string); - -function getOutFile(const filename, ext: string): string; - -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 := nstrtabs.get(gConfigVars, key); -end; - -procedure setConfigVar(const key, val: string); -begin - nstrtabs.put(gConfigVars, key, val); -end; - -function getOutFile(const filename, ext: string): string; -begin - if options.outFile <> '' then result := options.outFile - else result := changeFileExt(filename, ext) -end; - -procedure addImplicitMod(const filename: string); -var - len: int; -begin - len := length(gImplicitMods); - setLength(gImplicitMods, len+1); - gImplicitMods[len] := filename; -end; - -function getPrefixDir: string; -begin - result := SplitPath(getApplicationDir()).head; -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; - prefix := projectPath +{&} dirSep; - //writeln(output, prefix); - //writeln(output, dir); - if startsWith(dir, prefix) then begin - result := ncopy(dir, length(prefix) + strStart); exit - end; - result := dir; -end; - -function removeTrailingDirSep(const path: string): string; -begin - if (length(path) > 0) and (path[length(path)+strStart-1] = dirSep) then - result := ncopy(path, strStart, length(path)+strStart-2) - else - result := path -end; - -function toGeneratedFile(const path, ext: string): string; -var - head, tail: string; -begin - splitPath(path, head, tail); - if length(head) > 0 then head := shortenDir(head +{&} dirSep); - result := joinPath([projectPath, genSubDir, head, - changeFileExt(tail, ext)]) -end; - -function completeGeneratedFilePath(const f: string; - createSubDir: bool = true): string; -var - head, tail, subdir: string; -begin - splitPath(f, head, tail); - if length(head) > 0 then - head := removeTrailingDirSep(shortenDir(head +{&} dirSep)); - subdir := joinPath([projectPath, genSubDir, head]); - if createSubDir then begin - try - createDir(subdir); - except - on EOS do begin - writeln(output, 'cannot create directory: ' + subdir); - halt(1) - end - end - end; - result := joinPath(subdir, tail) -end; - -function rawFindFile(const f: string): string; -var - it: PStrEntry; -begin - if ExistsFile(f) then result := f - else begin - it := PStrEntry(SearchPaths.head); - while it <> nil do begin - result := JoinPath(it.data, f); - if ExistsFile(result) then exit; - it := PStrEntry(it.Next) - end; - result := '' - 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; -begin - a := 0; - b := length(x)-1; - while a <= b do begin - mid := (a + b) div 2; - c := cmpIgnoreCase(x[mid], y); - if c < 0 then - a := mid + 1 - else if c > 0 then - b := mid - 1 - else begin - result := mid; - exit - end - end; - result := -1 -end; - -initialization - gConfigVars := newStringTable([], modeStyleInsensitive); -end. diff --git a/nim/osproc.pas b/nim/osproc.pas deleted file mode 100755 index 485daaf67..000000000 --- a/nim/osproc.pas +++ /dev/null @@ -1,58 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit osproc; - -// This module provides Nimrod's osproc module in Pascal -// Note: Only implement what is really needed here! - -interface - -{$include 'config.inc'} - -uses - nsystem, nos; - -type - TProcessOption = (poEchoCmd, poUseShell, poStdErrToStdOut, poParentStreams); - TProcessOptions = set of TProcessOption; - -function execCmd(const cmd: string): int; -function execProcesses(const cmds: array of string; - options: TProcessOptions; - n: int): int; - -function countProcessors(): int; - -implementation - -function execCmd(const cmd: string): int; -begin - writeln(output, cmd); - result := executeShellCommand(cmd); -end; - -function execProcesses(const cmds: array of string; - options: TProcessOptions; - n: int): int; -var - i: int; -begin - result := 0; - for i := 0 to high(cmds) do begin - //if poEchoCmd in options then writeln(output, cmds[i]); - result := max(result, execCmd(cmds[i])) - end -end; - -function countProcessors(): int; -begin - result := 1; -end; - -end. diff --git a/nim/parsecfg.pas b/nim/parsecfg.pas deleted file mode 100755 index ba6a98679..000000000 --- a/nim/parsecfg.pas +++ /dev/null @@ -1,424 +0,0 @@ -// -// -// Nimrod's Runtime Library -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit parsecfg; - -// A HIGH-PERFORMANCE configuration file parser; -// the Nimrod version of this file is part of the -// standard library. - -interface - -{$include 'config.inc'} - -uses - nsystem, charsets, llstream, sysutils, nhashes, strutils, lexbase; - -type - TCfgEventKind = ( - cfgEof, // end of file reached - 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 - // error message - ); - TCfgEvent = {@ignore} record - kind: TCfgEventKind; - section: string; - key, value: string; - msg: string; - end; - {@emit object(NObject) - case kind: TCfgEventKind of - cfgEof: (); - cfgSectionStart: (section: string); - cfgKeyValuePair, cfgOption: (key, value: string); - cfgError: (msg: string); - end;} - TTokKind = (tkInvalid, tkEof, // order is important here! - tkSymbol, tkEquals, tkColon, - tkBracketLe, tkBracketRi, tkDashDash - ); - TToken = record // a token - kind: TTokKind; // the type of the token - literal: string; // the parsed (string) literal - end; - TParserState = (startState, commaState); - TCfgParser = object(TBaseLexer) - tok: TToken; - state: TParserState; - filename: string; - end; - -procedure Open(var c: TCfgParser; const filename: string; - inputStream: PLLStream); -procedure Close(var c: TCfgParser); - -function next(var c: TCfgParser): TCfgEvent; - -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 - SymChars: TCharSet = ['a'..'z', 'A'..'Z', '0'..'9', '_', #128..#255]; - -// ---------------------------------------------------------------------------- -procedure rawGetTok(var c: TCfgParser; var tok: TToken); forward; - -procedure open(var c: TCfgParser; const filename: string; - inputStream: PLLStream); -begin -{@ignore} - FillChar(c, sizeof(c), 0); -{@emit} - openBaseLexer(c, inputStream); - c.filename := filename; - c.state := startState; - c.tok.kind := tkInvalid; - c.tok.literal := ''; - rawGetTok(c, c.tok); -end; - -procedure close(var c: TCfgParser); -begin - closeBaseLexer(c); -end; - -function getColumn(const c: TCfgParser): int; -begin - result := getColNumber(c, c.bufPos) -end; - -function getLine(const c: TCfgParser): int; -begin - result := c.linenumber -end; - -function getFilename(const c: TCfgParser): string; -begin - result := c.filename -end; - -// ---------------------------------------------------------------------------- - -procedure handleHexChar(var c: TCfgParser; var xi: int); -begin - case c.buf[c.bufpos] of - '0'..'9': begin - xi := (xi shl 4) or (ord(c.buf[c.bufpos]) - ord('0')); - inc(c.bufpos); - end; - 'a'..'f': begin - xi := (xi shl 4) or (ord(c.buf[c.bufpos]) - ord('a') + 10); - inc(c.bufpos); - end; - 'A'..'F': begin - xi := (xi shl 4) or (ord(c.buf[c.bufpos]) - ord('A') + 10); - inc(c.bufpos); - end; - else begin end // do nothing - end -end; - -procedure handleDecChars(var c: TCfgParser; var xi: int); -begin - while c.buf[c.bufpos] in ['0'..'9'] do begin - xi := (xi * 10) + (ord(c.buf[c.bufpos]) - ord('0')); - inc(c.bufpos); - end; -end; - -procedure getEscapedChar(var c: TCfgParser; var tok: TToken); -var - xi: int; -begin - inc(c.bufpos); // skip '\' - case c.buf[c.bufpos] of - 'n', 'N': begin - tok.literal := tok.literal +{&} nl; - Inc(c.bufpos); - end; - 'r', 'R', 'c', 'C': begin addChar(tok.literal, CR); Inc(c.bufpos); end; - 'l', 'L': begin addChar(tok.literal, LF); Inc(c.bufpos); end; - 'f', 'F': begin addChar(tok.literal, FF); inc(c.bufpos); end; - 'e', 'E': begin addChar(tok.literal, ESC); Inc(c.bufpos); end; - 'a', 'A': begin addChar(tok.literal, BEL); Inc(c.bufpos); end; - 'b', 'B': begin addChar(tok.literal, BACKSPACE); Inc(c.bufpos); end; - 'v', 'V': begin addChar(tok.literal, VT); Inc(c.bufpos); end; - 't', 'T': begin addChar(tok.literal, Tabulator); Inc(c.bufpos); end; - '''', '"': begin addChar(tok.literal, c.buf[c.bufpos]); Inc(c.bufpos); end; - '\': begin addChar(tok.literal, '\'); Inc(c.bufpos) end; - 'x', 'X': begin - inc(c.bufpos); - xi := 0; - handleHexChar(c, xi); - handleHexChar(c, xi); - addChar(tok.literal, Chr(xi)); - end; - '0'..'9': begin - xi := 0; - handleDecChars(c, xi); - if (xi <= 255) then - addChar(tok.literal, Chr(xi)) - else - tok.kind := tkInvalid - end - else tok.kind := tkInvalid - end -end; - -function HandleCRLF(var c: TCfgParser; pos: int): int; -begin - case c.buf[pos] of - CR: result := lexbase.HandleCR(c, pos); - LF: result := lexbase.HandleLF(c, pos); - else result := pos - end -end; - -procedure getString(var c: TCfgParser; var tok: TToken; rawMode: Boolean); -var - pos: int; - ch: Char; - buf: PChar; -begin - pos := c.bufPos + 1; // skip " - buf := c.buf; // put `buf` in a register - tok.kind := tkSymbol; - if (buf[pos] = '"') and (buf[pos+1] = '"') then begin - // long string literal: - inc(pos, 2); // skip "" - // skip leading newline: - pos := HandleCRLF(c, pos); - buf := c.buf; - repeat - case buf[pos] of - '"': begin - if (buf[pos+1] = '"') and (buf[pos+2] = '"') then - break; - addChar(tok.literal, '"'); - Inc(pos) - end; - CR, LF: begin - pos := HandleCRLF(c, pos); - buf := c.buf; - tok.literal := tok.literal +{&} nl; - end; - lexbase.EndOfFile: begin - tok.kind := tkInvalid; - break - end - else begin - addChar(tok.literal, buf[pos]); - Inc(pos) - end - end - until false; - c.bufpos := pos + 3 // skip the three """ - end - else begin // ordinary string literal - repeat - ch := buf[pos]; - if ch = '"' then begin - inc(pos); // skip '"' - break - end; - if ch in [CR, LF, lexbase.EndOfFile] then begin - tok.kind := tkInvalid; - break - end; - if (ch = '\') and not rawMode then begin - c.bufPos := pos; - getEscapedChar(c, tok); - pos := c.bufPos; - end - else begin - addChar(tok.literal, ch); - Inc(pos) - end - until false; - c.bufpos := pos; - end -end; - -procedure getSymbol(var c: TCfgParser; var tok: TToken); -var - pos: int; - buf: pchar; -begin - pos := c.bufpos; - buf := c.buf; - while true do begin - addChar(tok.literal, buf[pos]); - Inc(pos); - if not (buf[pos] in SymChars) then break; - end; - c.bufpos := pos; - tok.kind := tkSymbol -end; - -procedure skip(var c: TCfgParser); -var - buf: PChar; - pos: int; -begin - pos := c.bufpos; - buf := c.buf; - repeat - case buf[pos] of - ' ': Inc(pos); - Tabulator: inc(pos); - '#', ';': while not (buf[pos] in [CR, LF, lexbase.EndOfFile]) do inc(pos); - CR, LF: begin - pos := HandleCRLF(c, pos); - buf := c.buf; - end - else break // EndOfFile also leaves the loop - end - until false; - c.bufpos := pos; -end; - -procedure rawGetTok(var c: TCfgParser; var tok: TToken); -begin - tok.kind := tkInvalid; - setLength(tok.literal, 0); - skip(c); - case c.buf[c.bufpos] of - '=': begin - tok.kind := tkEquals; - inc(c.bufpos); - tok.literal := '='+''; - end; - '-': begin - inc(c.bufPos); - if c.buf[c.bufPos] = '-' then inc(c.bufPos); - tok.kind := tkDashDash; - tok.literal := '--'; - end; - ':': begin - tok.kind := tkColon; - inc(c.bufpos); - tok.literal := ':'+''; - end; - 'r', 'R': begin - if c.buf[c.bufPos+1] = '"' then begin - Inc(c.bufPos); - getString(c, tok, true); - end - else - getSymbol(c, tok); - end; - '[': begin - tok.kind := tkBracketLe; - inc(c.bufpos); - tok.literal := '['+''; - end; - ']': begin - tok.kind := tkBracketRi; - Inc(c.bufpos); - tok.literal := ']'+''; - end; - '"': getString(c, tok, false); - lexbase.EndOfFile: tok.kind := tkEof; - else getSymbol(c, tok); - end -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)), - msg - ]); -end; - -function getKeyValPair(var c: TCfgParser; kind: TCfgEventKind): TCfgEvent; -begin - if c.tok.kind = tkSymbol then begin - result.kind := kind; - 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 - add(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 - result.value := c.tok.literal; - end - else begin - result.kind := cfgError; - result.msg := errorStr(c, 'symbol expected, but found: ' - + c.tok.literal); - end; - rawGetTok(c, c.tok); - end - end - else begin - result.kind := cfgError; - result.msg := errorStr(c, 'symbol expected, but found: ' + c.tok.literal); - rawGetTok(c, c.tok); - end; -end; - -function next(var c: TCfgParser): TCfgEvent; -begin - case c.tok.kind of - tkEof: result.kind := cfgEof; - tkDashDash: begin - rawGetTok(c, c.tok); - result := getKeyValPair(c, cfgOption); - end; - tkSymbol: begin - result := getKeyValPair(c, cfgKeyValuePair); - end; - tkBracketLe: begin - rawGetTok(c, c.tok); - if c.tok.kind = tkSymbol then begin - result.kind := cfgSectionStart; - result.section := c.tok.literal; - end - else begin - result.kind := cfgError; - result.msg := errorStr(c, 'symbol expected, but found: ' + c.tok.literal); - end; - rawGetTok(c, c.tok); - 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); - end - end; - tkInvalid, tkBracketRi, tkEquals, tkColon: begin - result.kind := cfgError; - result.msg := errorStr(c, 'invalid token: ' + c.tok.literal); - rawGetTok(c, c.tok); - end - end -end; - -end. diff --git a/nim/parseopt.pas b/nim/parseopt.pas deleted file mode 100755 index 0ca87bd37..000000000 --- a/nim/parseopt.pas +++ /dev/null @@ -1,153 +0,0 @@ -// -// -// Nimrod's Runtime Library -// (c) Copyright 2008 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit parseopt; - -// A command line parser; the Nimrod version of this file -// will become part of the standard library. - -interface - -{$include 'config.inc'} - -uses - nsystem, charsets, nos, strutils; - -type - TCmdLineKind = ( - cmdEnd, // end of command line reached - cmdArgument, // argument detected - cmdLongoption, // a long option ``--option`` detected - cmdShortOption // a short option ``-c`` detected - ); - TOptParser = object(NObject) - cmd: string; - pos: int; - inShortState: bool; - kind: TCmdLineKind; - key, val: string; - end; - -function init(const cmdline: string = ''): TOptParser; -procedure next(var p: TOptParser); - -function getRestOfCommandLine(const p: TOptParser): string; - -implementation - -function init(const cmdline: string = ''): TOptParser; -var - i: int; -begin - result.pos := strStart; - result.inShortState := false; - if cmdline <> '' then - result.cmd := cmdline - else begin - result.cmd := ''; - for i := 1 to ParamCount() do - result.cmd := result.cmd +{&} quoteIfContainsWhite(paramStr(i)) +{&} ' '; - {@ignore} - result.cmd := result.cmd + #0; - {@emit} - end; - result.kind := cmdEnd; - result.key := ''; - result.val := ''; -end; - -function parseWord(const s: string; const i: int; var w: string; - const delim: TCharSet = {@set}[#9, ' ', #0]): int; -begin - result := i; - if s[result] = '"' then begin - inc(result); - while not (s[result] in [#0, '"']) do begin - addChar(w, s[result]); - inc(result); - end; - if s[result] = '"' then inc(result) - end - else begin - while not (s[result] in delim) do begin - addChar(w, s[result]); - inc(result); - end - end -end; - -procedure handleShortOption(var p: TOptParser); -var - i: int; -begin - i := p.pos; - p.kind := cmdShortOption; - addChar(p.key, p.cmd[i]); - inc(i); - p.inShortState := true; - while p.cmd[i] in [#9, ' '] do begin - inc(i); - p.inShortState := false; - end; - if p.cmd[i] in [':', '='] then begin - inc(i); p.inShortState := false; - while p.cmd[i] in [#9, ' '] do inc(i); - i := parseWord(p.cmd, i, p.val); - end; - if p.cmd[i] = #0 then p.inShortState := false; - p.pos := i; -end; - -procedure next(var p: TOptParser); -var - i: int; -begin - i := p.pos; - while p.cmd[i] in [#9, ' '] do inc(i); - p.pos := i; - setLength(p.key, 0); - setLength(p.val, 0); - if p.inShortState then begin - handleShortOption(p); exit - end; - case p.cmd[i] of - #0: p.kind := cmdEnd; - '-': begin - inc(i); - if p.cmd[i] = '-' then begin - p.kind := cmdLongOption; - inc(i); - i := parseWord(p.cmd, i, p.key, {@set}[#0, ' ', #9, ':', '=']); - while p.cmd[i] in [#9, ' '] do inc(i); - if p.cmd[i] in [':', '='] then begin - inc(i); - while p.cmd[i] in [#9, ' '] do inc(i); - p.pos := parseWord(p.cmd, i, p.val); - end - else - p.pos := i; - end - else begin - p.pos := i; - handleShortOption(p) - end - end; - else begin - p.kind := cmdArgument; - p.pos := parseWord(p.cmd, i, p.key); - end - end -end; - -function getRestOfCommandLine(const p: TOptParser): string; -begin - result := strip(ncopy(p.cmd, p.pos+strStart, length(p.cmd)-1)) - // always -1, because Pascal version uses a trailing zero here -end; - -end. diff --git a/nim/paslex.pas b/nim/paslex.pas deleted file mode 100755 index f3d8daaeb..000000000 --- a/nim/paslex.pas +++ /dev/null @@ -1,738 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit paslex; - -// This module implements a FreePascal scanner. This is a adaption from -// the scanner module. - -interface - -{$include 'config.inc'} - -uses - charsets, nsystem, sysutils, - nhashes, options, msgs, strutils, platform, idents, - lexbase, wordrecg, scanner; - -const - MaxLineLength = 80; // lines longer than this lead to a warning - - numChars: TCharSet = ['0'..'9','a'..'z','A'..'Z']; // we support up to base 36 - SymChars: TCharSet = ['a'..'z', 'A'..'Z', '0'..'9', #128..#255]; - SymStartChars: TCharSet = ['a'..'z', 'A'..'Z', #128..#255]; - OpChars: TCharSet = ['+', '-', '*', '/', '<', '>', '!', '?', '^', '.', - '|', '=', ':', '%', '&', '$', '@', '~', #128..#255]; - -type - // order is important for TPasTokKind - TPasTokKind = (pxInvalid, pxEof, - // keywords: - //[[[cog - //from string import capitalize - //keywords = eval(open("data/pas_keyw.yml").read()) - //idents = "" - //strings = "" - //i = 1 - //for k in keywords: - // 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, - pxBegin, pxCase, pxClass, pxConst, - pxConstructor, pxDestructor, pxDiv, pxDo, - pxDownto, pxElse, pxEnd, pxExcept, - pxExports, pxFinalization, pxFinally, pxFor, - pxFunction, pxGoto, pxIf, pxImplementation, - pxIn, pxInherited, pxInitialization, pxInline, - pxInterface, pxIs, pxLabel, pxLibrary, - pxMod, pxNil, pxNot, pxObject, - pxOf, pxOr, pxOut, pxPacked, - pxProcedure, pxProgram, pxProperty, pxRaise, - pxRecord, pxRepeat, pxResourcestring, pxSet, - pxShl, pxShr, pxThen, pxThreadvar, - pxTo, pxTry, pxType, pxUnit, - pxUntil, pxUses, pxVar, pxWhile, - pxWith, pxXor, - //[[[end]]] - pxComment, // ordinary comment - pxCommand, // {@} - pxAmp, // {&} - pxPer, // {%} - pxStrLit, - pxSymbol, // a symbol - - pxIntLit, - pxInt64Lit, // long constant like 0x00000070fffffff or out of int range - pxFloatLit, - - pxParLe, pxParRi, pxBracketLe, pxBracketRi, - pxComma, pxSemiColon, pxColon, - - // operators - pxAsgn, - pxEquals, pxDot, pxDotDot, pxHat, pxPlus, pxMinus, pxStar, pxSlash, - pxLe, pxLt, pxGe, pxGt, pxNeq, pxAt, - - pxStarDirLe, - pxStarDirRi, - pxCurlyDirLe, - pxCurlyDirRi - ); - TPasTokKinds = set of TPasTokKind; -const - PasTokKindToStr: array [TPasTokKind] of string = ( - 'pxInvalid', '[EOF]', - //[[[cog - //cog.out(strings) - //]]] - 'and', 'array', 'as', 'asm', - 'begin', 'case', 'class', 'const', - 'constructor', 'destructor', 'div', 'do', - 'downto', 'else', 'end', 'except', - 'exports', 'finalization', 'finally', 'for', - 'function', 'goto', 'if', 'implementation', - 'in', 'inherited', 'initialization', 'inline', - 'interface', 'is', 'label', 'library', - 'mod', 'nil', 'not', 'object', - 'of', 'or', 'out', 'packed', - 'procedure', 'program', 'property', 'raise', - 'record', 'repeat', 'resourcestring', 'set', - 'shl', 'shr', 'then', 'threadvar', - 'to', 'try', 'type', 'unit', - 'until', 'uses', 'var', 'while', - 'with', 'xor', - //[[[end]]] - 'pxComment', 'pxCommand', - '{&}', '{%}', 'pxStrLit', '[IDENTIFIER]', 'pxIntLit', 'pxInt64Lit', - 'pxFloatLit', - '('+'', ')'+'', '['+'', ']'+'', - ','+'', ';'+'', ':'+'', - ':=', '='+'', '.'+'', '..', '^'+'', '+'+'', '-'+'', '*'+'', '/'+'', - '<=', '<'+'', '>=', '>'+'', '<>', '@'+'', '(*$', '*)', '{$', '}'+'' - ); - -type - TPasTok = object(TToken) // a Pascal token - xkind: TPasTokKind; // the type of the token - end; - - TPasLex = object(TLexer) - end; - -procedure getPasTok(var L: TPasLex; out tok: TPasTok); - -procedure PrintPasTok(const tok: TPasTok); -function pasTokToStr(const tok: TPasTok): string; - -implementation - -function pastokToStr(const tok: TPasTok): string; -begin - case tok.xkind of - pxIntLit, pxInt64Lit: - result := toString(tok.iNumber); - pxFloatLit: - result := toStringF(tok.fNumber); - pxInvalid, pxComment..pxStrLit: - result := tok.literal; - else if (tok.ident.s <> '') then - result := tok.ident.s - else - result := pasTokKindToStr[tok.xkind]; - end -end; - -procedure PrintPasTok(const tok: TPasTok); -begin - write(output, pasTokKindToStr[tok.xkind]); - write(output, ' '); - writeln(output, pastokToStr(tok)) -end; - -// ---------------------------------------------------------------------------- - -procedure setKeyword(var L: TPasLex; var tok: TPasTok); -begin - case tok.ident.id of - //[[[cog - //for k in keywords: - // m = capitalize(k) - // cog.outl("ord(w%s):%s tok.xkind := px%s;" % (m, ' '*(18-len(m)), m)) - //]]] - ord(wAnd): tok.xkind := pxAnd; - ord(wArray): tok.xkind := pxArray; - ord(wAs): tok.xkind := pxAs; - ord(wAsm): tok.xkind := pxAsm; - ord(wBegin): tok.xkind := pxBegin; - ord(wCase): tok.xkind := pxCase; - ord(wClass): tok.xkind := pxClass; - ord(wConst): tok.xkind := pxConst; - ord(wConstructor): tok.xkind := pxConstructor; - ord(wDestructor): tok.xkind := pxDestructor; - ord(wDiv): tok.xkind := pxDiv; - ord(wDo): tok.xkind := pxDo; - ord(wDownto): tok.xkind := pxDownto; - ord(wElse): tok.xkind := pxElse; - ord(wEnd): tok.xkind := pxEnd; - ord(wExcept): tok.xkind := pxExcept; - ord(wExports): tok.xkind := pxExports; - ord(wFinalization): tok.xkind := pxFinalization; - ord(wFinally): tok.xkind := pxFinally; - ord(wFor): tok.xkind := pxFor; - ord(wFunction): tok.xkind := pxFunction; - ord(wGoto): tok.xkind := pxGoto; - ord(wIf): tok.xkind := pxIf; - ord(wImplementation): tok.xkind := pxImplementation; - ord(wIn): tok.xkind := pxIn; - ord(wInherited): tok.xkind := pxInherited; - ord(wInitialization): tok.xkind := pxInitialization; - ord(wInline): tok.xkind := pxInline; - ord(wInterface): tok.xkind := pxInterface; - ord(wIs): tok.xkind := pxIs; - ord(wLabel): tok.xkind := pxLabel; - ord(wLibrary): tok.xkind := pxLibrary; - ord(wMod): tok.xkind := pxMod; - ord(wNil): tok.xkind := pxNil; - ord(wNot): tok.xkind := pxNot; - ord(wObject): tok.xkind := pxObject; - ord(wOf): tok.xkind := pxOf; - ord(wOr): tok.xkind := pxOr; - ord(wOut): tok.xkind := pxOut; - ord(wPacked): tok.xkind := pxPacked; - ord(wProcedure): tok.xkind := pxProcedure; - ord(wProgram): tok.xkind := pxProgram; - ord(wProperty): tok.xkind := pxProperty; - ord(wRaise): tok.xkind := pxRaise; - ord(wRecord): tok.xkind := pxRecord; - ord(wRepeat): tok.xkind := pxRepeat; - ord(wResourcestring): tok.xkind := pxResourcestring; - ord(wSet): tok.xkind := pxSet; - ord(wShl): tok.xkind := pxShl; - ord(wShr): tok.xkind := pxShr; - ord(wThen): tok.xkind := pxThen; - ord(wThreadvar): tok.xkind := pxThreadvar; - ord(wTo): tok.xkind := pxTo; - ord(wTry): tok.xkind := pxTry; - ord(wType): tok.xkind := pxType; - ord(wUnit): tok.xkind := pxUnit; - ord(wUntil): tok.xkind := pxUntil; - ord(wUses): tok.xkind := pxUses; - ord(wVar): tok.xkind := pxVar; - ord(wWhile): tok.xkind := pxWhile; - ord(wWith): tok.xkind := pxWith; - ord(wXor): tok.xkind := pxXor; - //[[[end]]] - else tok.xkind := pxSymbol - end -end; - - -// ---------------------------------------------------------------------------- - -procedure matchUnderscoreChars(var L: TPasLex; var tok: TPasTok; - const chars: TCharSet); -// matches ([chars]_)* -var - pos: int; - buf: PChar; -begin - pos := L.bufpos; // use registers for pos, buf - buf := L.buf; - repeat - if buf[pos] in chars then begin - addChar(tok.literal, buf[pos]); - Inc(pos) - end - else break; - if buf[pos] = '_' then begin - addChar(tok.literal, '_'); - Inc(pos); - end; - until false; - L.bufPos := pos; -end; - -function isFloatLiteral(const s: string): boolean; -var - i: int; -begin - for i := strStart to length(s)+strStart-1 do - if s[i] in ['.','e','E'] then begin - result := true; exit - end; - result := false -end; - -procedure getNumber2(var L: TPasLex; var tok: TPasTok); -var - pos, bits: int; - xi: biggestInt; -begin - pos := L.bufpos+1; // skip % - if not (L.buf[pos] in ['0'..'1']) then begin // BUGFIX for %date% - tok.xkind := pxInvalid; - addChar(tok.literal, '%'); - inc(L.bufpos); - exit; - end; - - tok.base := base2; - xi := 0; - bits := 0; - while true do begin - case L.buf[pos] of - 'A'..'Z', 'a'..'z', '2'..'9', '.': begin - lexMessage(L, errInvalidNumber); - inc(pos) - end; - '_': inc(pos); - '0', '1': begin - xi := shlu(xi, 1) or (ord(L.buf[pos]) - ord('0')); - inc(pos); - inc(bits); - end; - else break; - end - end; - tok.iNumber := xi; - if (bits > 32) then //or (xi < low(int32)) or (xi > high(int32)) then - tok.xkind := pxInt64Lit - else - tok.xkind := pxIntLit; - L.bufpos := pos; -end; - -procedure getNumber16(var L: TPasLex; var tok: TPasTok); -var - pos, bits: int; - xi: biggestInt; -begin - pos := L.bufpos+1; // skip $ - tok.base := base16; - xi := 0; - bits := 0; - while true do begin - case L.buf[pos] of - 'G'..'Z', 'g'..'z', '.': begin - lexMessage(L, errInvalidNumber); - inc(pos); - end; - '_': inc(pos); - '0'..'9': begin - xi := shlu(xi, 4) or (ord(L.buf[pos]) - ord('0')); - inc(pos); - inc(bits, 4); - end; - 'a'..'f': begin - xi := shlu(xi, 4) or (ord(L.buf[pos]) - ord('a') + 10); - inc(pos); - inc(bits, 4); - end; - 'A'..'F': begin - xi := shlu(xi, 4) or (ord(L.buf[pos]) - ord('A') + 10); - inc(pos); - inc(bits, 4); - end; - else break; - end - end; - tok.iNumber := xi; - if (bits > 32) then // (xi < low(int32)) or (xi > high(int32)) then - tok.xkind := pxInt64Lit - else - tok.xkind := pxIntLit; - L.bufpos := pos; -end; - -procedure getNumber10(var L: TPasLex; var tok: TPasTok); -begin - tok.base := base10; - matchUnderscoreChars(L, tok, ['0'..'9']); - if (L.buf[L.bufpos] = '.') and (L.buf[L.bufpos+1] in ['0'..'9']) then begin - addChar(tok.literal, '.'); - inc(L.bufpos); - matchUnderscoreChars(L, tok, ['e', 'E', '+', '-', '0'..'9']) - end; - try - if isFloatLiteral(tok.literal) then begin - tok.fnumber := parseFloat(tok.literal); - tok.xkind := pxFloatLit; - end - else begin - tok.iNumber := ParseInt(tok.literal); - if (tok.iNumber < low(int32)) or (tok.iNumber > high(int32)) then - tok.xkind := pxInt64Lit - else - tok.xkind := pxIntLit; - end; - except - on EInvalidValue do - lexMessage(L, errInvalidNumber, tok.literal); - on EOverflow do - lexMessage(L, errNumberOutOfRange, tok.literal); - {@ignore} - on sysutils.EIntOverflow do - lexMessage(L, errNumberOutOfRange, tok.literal); - {@emit} - end; -end; - -function HandleCRLF(var L: TLexer; pos: int): int; -begin - case L.buf[pos] of - CR: result := lexbase.HandleCR(L, pos); - LF: result := lexbase.HandleLF(L, pos); - else result := pos - end -end; - -procedure getString(var L: TPasLex; var tok: TPasTok); -var - pos, xi: int; - buf: PChar; -begin - pos := L.bufPos; - buf := L.buf; - while true do begin - if buf[pos] = '''' then begin - inc(pos); - while true do begin - case buf[pos] of - CR, LF, lexbase.EndOfFile: begin - lexMessage(L, errClosingQuoteExpected); - break - end; - '''': begin - inc(pos); - if buf[pos] = '''' then begin - inc(pos); - addChar(tok.literal, ''''); - end - else break; - end; - else begin - addChar(tok.literal, buf[pos]); - inc(pos); - end - end - end - end - else if buf[pos] = '#' then begin - inc(pos); - xi := 0; - case buf[pos] of - '$': begin - inc(pos); - xi := 0; - while true do begin - case buf[pos] of - '0'..'9': xi := (xi shl 4) or (ord(buf[pos]) - ord('0')); - 'a'..'f': xi := (xi shl 4) or (ord(buf[pos]) - ord('a') + 10); - 'A'..'F': xi := (xi shl 4) or (ord(buf[pos]) - ord('A') + 10); - else break; - end; - inc(pos) - end - end; - '0'..'9': begin - xi := 0; - while buf[pos] in ['0'..'9'] do begin - xi := (xi * 10) + (ord(buf[pos]) - ord('0')); - inc(pos); - end; - end - else lexMessage(L, errInvalidCharacterConstant) - end; - if (xi <= 255) then - addChar(tok.literal, Chr(xi)) - else - lexMessage(L, errInvalidCharacterConstant) - end - else break - end; - tok.xkind := pxStrLit; - L.bufpos := pos; -end; - -{@ignore} -{$ifopt Q+} {$define Q_on} {$Q-} {$endif} -{$ifopt R+} {$define R_on} {$R-} {$endif} -{@emit} -procedure getSymbol(var L: TPasLex; var tok: TPasTok); -var - pos: int; - c: Char; - buf: pchar; - h: THash; // hashing algorithm inlined -begin - h := 0; - pos := L.bufpos; - buf := L.buf; - while true do begin - c := buf[pos]; - case c of - 'a'..'z', '0'..'9', #128..#255: begin - h := h +{%} Ord(c); - h := h +{%} h shl 10; - h := h xor (h shr 6) - end; - 'A'..'Z': begin - c := chr(ord(c) + (ord('a')-ord('A'))); // toLower() - h := h +{%} Ord(c); - h := h +{%} h shl 10; - h := h xor (h shr 6) - end; - '_': begin end; - else break - end; - Inc(pos) - end; - h := h +{%} h shl 3; - h := h xor (h shr 11); - h := h +{%} h shl 15; - tok.ident := getIdent(addr(L.buf[L.bufpos]), pos-L.bufpos, h); - L.bufpos := pos; - setKeyword(L, tok); -end; -{@ignore} -{$ifdef Q_on} {$undef Q_on} {$Q+} {$endif} -{$ifdef R_on} {$undef R_on} {$R+} {$endif} -{@emit} - -procedure scanLineComment(var L: TPasLex; var tok: TPasTok); -var - buf: PChar; - pos, col: int; - indent: int; -begin - pos := L.bufpos; - buf := L.buf; - // a comment ends if the next line does not start with the // on the same - // column after only whitespace - tok.xkind := pxComment; - col := getColNumber(L, pos); - while true do begin - inc(pos, 2); // skip // - addChar(tok.literal, '#'); - while not (buf[pos] in [CR, LF, lexbase.EndOfFile]) do begin - addChar(tok.literal, buf[pos]); inc(pos); - end; - pos := handleCRLF(L, pos); - buf := L.buf; - indent := 0; - while buf[pos] = ' ' do begin inc(pos); inc(indent) end; - if (col = indent) and (buf[pos] = '/') and (buf[pos+1] = '/') then - tok.literal := tok.literal +{&} nl - else - break - end; - L.bufpos := pos; -end; - -procedure scanCurlyComment(var L: TPasLex; var tok: TPasTok); -var - buf: PChar; - pos: int; -begin - pos := L.bufpos; - buf := L.buf; - tok.literal := '#'+''; - tok.xkind := pxComment; - repeat - case buf[pos] of - CR, LF: begin - pos := HandleCRLF(L, pos); - buf := L.buf; - tok.literal := tok.literal +{&} nl + '#'; - end; - '}': begin inc(pos); break end; - lexbase.EndOfFile: lexMessage(L, errTokenExpected, '}'+''); - else begin - addChar(tok.literal, buf[pos]); - inc(pos) - end - end - until false; - L.bufpos := pos; -end; - -procedure scanStarComment(var L: TPasLex; var tok: TPasTok); -var - buf: PChar; - pos: int; -begin - pos := L.bufpos; - buf := L.buf; - tok.literal := '#'+''; - tok.xkind := pxComment; - repeat - case buf[pos] of - CR, LF: begin - pos := HandleCRLF(L, pos); - buf := L.buf; - tok.literal := tok.literal +{&} nl + '#'; - end; - '*': begin - inc(pos); - if buf[pos] = ')' then begin inc(pos); break end - else addChar(tok.literal, '*') - end; - lexbase.EndOfFile: lexMessage(L, errTokenExpected, '*)'); - else begin - addChar(tok.literal, buf[pos]); - inc(pos) - end - end - until false; - L.bufpos := pos; -end; - -procedure skip(var L: TPasLex; var tok: TPasTok); -var - buf: PChar; - pos: int; -begin - pos := L.bufpos; - buf := L.buf; - repeat - case buf[pos] of - ' ', Tabulator: Inc(pos); - // newline is special: - CR, LF: begin - pos := HandleCRLF(L, pos); - buf := L.buf; - end - else break // EndOfFile also leaves the loop - end - until false; - L.bufpos := pos; -end; - -procedure getPasTok(var L: TPasLex; out tok: TPasTok); -var - c: Char; -begin - tok.xkind := pxInvalid; - fillToken(tok); - skip(L, tok); - c := L.buf[L.bufpos]; - if c in SymStartChars then // common case first - getSymbol(L, tok) - else if c in ['0'..'9'] then - getNumber10(L, tok) - else begin - case c of - ';': begin tok.xkind := pxSemicolon; Inc(L.bufpos) end; - '/': begin - if L.buf[L.bufpos+1] = '/' then scanLineComment(L, tok) - else begin tok.xkind := pxSlash; inc(L.bufpos) end; - end; - ',': begin tok.xkind := pxComma; Inc(L.bufpos) end; - '(': begin - Inc(L.bufpos); - if (L.buf[L.bufPos] = '*') then begin - if (L.buf[L.bufPos+1] = '$') then begin - Inc(L.bufpos, 2); - skip(L, tok); - getSymbol(L, tok); - tok.xkind := pxStarDirLe; - end - else begin - inc(L.bufpos); - scanStarComment(L, tok) - end - end - else - tok.xkind := pxParLe; - end; - '*': begin - inc(L.bufpos); - if L.buf[L.bufpos] = ')' then begin - inc(L.bufpos); tok.xkind := pxStarDirRi - end - else tok.xkind := pxStar - end; - ')': begin tok.xkind := pxParRi; Inc(L.bufpos) end; - '[': begin Inc(L.bufpos); tok.xkind := pxBracketLe end; - ']': begin Inc(L.bufpos); tok.xkind := pxBracketRi end; - '.': begin - inc(L.bufpos); - if L.buf[L.bufpos] = '.' then begin - tok.xkind := pxDotDot; inc(L.bufpos) - end - else tok.xkind := pxDot - end; - '{': begin - Inc(L.bufpos); - case L.buf[L.bufpos] of - '$': begin - Inc(L.bufpos); - skip(L, tok); - getSymbol(L, tok); - tok.xkind := pxCurlyDirLe - end; - '&': begin Inc(L.bufpos); tok.xkind := pxAmp end; - '%': begin Inc(L.bufpos); tok.xkind := pxPer end; - '@': begin Inc(L.bufpos); tok.xkind := pxCommand end; - else scanCurlyComment(L, tok); - end; - end; - '+': begin tok.xkind := pxPlus; inc(L.bufpos) end; - '-': begin tok.xkind := pxMinus; inc(L.bufpos) end; - ':': begin - inc(L.bufpos); - if L.buf[L.bufpos] = '=' then begin - inc(L.bufpos); tok.xkind := pxAsgn; - end - else tok.xkind := pxColon - end; - '<': begin - inc(L.bufpos); - if L.buf[L.bufpos] = '>' then begin - inc(L.bufpos); - tok.xkind := pxNeq - end - else if L.buf[L.bufpos] = '=' then begin - inc(L.bufpos); - tok.xkind := pxLe - end - else tok.xkind := pxLt - end; - '>': begin - inc(L.bufpos); - if L.buf[L.bufpos] = '=' then begin - inc(L.bufpos); - tok.xkind := pxGe - end - else tok.xkind := pxGt - end; - '=': begin tok.xkind := pxEquals; inc(L.bufpos) end; - '@': begin tok.xkind := pxAt; inc(L.bufpos) end; - '^': begin tok.xkind := pxHat; inc(L.bufpos) end; - '}': begin tok.xkind := pxCurlyDirRi; Inc(L.bufpos) end; - '''', '#': getString(L, tok); - '$': getNumber16(L, tok); - '%': getNumber2(L, tok); - lexbase.EndOfFile: tok.xkind := pxEof; - else begin - tok.literal := c + ''; - tok.xkind := pxInvalid; - lexMessage(L, errInvalidToken, c + ' (\' +{&} toString(ord(c)) + ')'); - Inc(L.bufpos); - end - end - end -end; - -end. diff --git a/nim/pasparse.pas b/nim/pasparse.pas deleted file mode 100755 index dbfbf0437..000000000 --- a/nim/pasparse.pas +++ /dev/null @@ -1,1998 +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 pasparse; - -// This module implements the parser of the Pascal variant Nimrod is written in. -// It transfers a Pascal module into a Nimrod AST. Then the renderer can be -// used to generate the Nimrod version of the compiler. - -{$include config.inc} - -interface - -uses - nsystem, nos, llstream, charsets, scanner, paslex, idents, wordrecg, strutils, - ast, astalgo, msgs, options; - -type - TPasSection = (seImplementation, seInterface); - TPasContext = (conExpr, conStmt, conTypeDesc); - TPasParser = record - section: TPasSection; - inParamList: boolean; - context: TPasContext; // needed for the @emit command - lastVarSection: PNode; - lex: TPasLex; - tok: TPasTok; - repl: TIdTable; // replacements - end; - - TReplaceTuple = array [0..1] of string; - -const - ImportBlackList: array [1..3] of string = ( - 'nsystem', 'sysutils', 'charsets' - ); - stdReplacements: array [1..19] of TReplaceTuple = ( - ('include', 'incl'), - ('exclude', 'excl'), - ('pchar', 'cstring'), - ('assignfile', 'open'), - ('integer', 'int'), - ('longword', 'int32'), - ('cardinal', 'int'), - ('boolean', 'bool'), - ('shortint', 'int8'), - ('smallint', 'int16'), - ('longint', 'int32'), - ('byte', 'int8'), - ('word', 'int16'), - ('single', 'float32'), - ('double', 'float64'), - ('real', 'float'), - ('length', 'len'), - ('len', 'length'), - ('setlength', 'setlen') - ); - nimReplacements: array [1..35] of TReplaceTuple = ( - ('nimread', 'read'), - ('nimwrite', 'write'), - ('nimclosefile', 'close'), - ('closefile', 'close'), - ('openfile', 'open'), - ('nsystem', 'system'), - ('ntime', 'times'), - ('nos', 'os'), - ('nmath', 'math'), - - ('ncopy', 'copy'), - ('addChar', 'add'), - ('halt', 'quit'), - ('nobject', 'TObject'), - ('eof', 'EndOfFile'), - - ('input', 'stdin'), - ('output', 'stdout'), - ('addu', '`+%`'), - ('subu', '`-%`'), - ('mulu', '`*%`'), - ('divu', '`/%`'), - ('modu', '`%%`'), - ('ltu', '`<%`'), - ('leu', '`<=%`'), - ('shlu', '`shl`'), - ('shru', '`shr`'), - ('assigned', 'not isNil'), - - ('eintoverflow', 'EOverflow'), - ('format', '`%`'), - ('snil', 'nil'), - ('tostringf', '$'+''), - ('ttextfile', 'tfile'), - ('tbinaryfile', 'tfile'), - ('strstart', '0'+''), - ('nl', '"\n"'), - ('tostring', '$'+'') - {, - ('NL', '"\n"'), - ('tabulator', '''\t'''), - ('esc', '''\e'''), - ('cr', '''\r'''), - ('lf', '''\l'''), - ('ff', '''\f'''), - ('bel', '''\a'''), - ('backspace', '''\b'''), - ('vt', '''\v''') } - ); - -function ParseUnit(var p: TPasParser): PNode; - -procedure openPasParser(var p: TPasParser; const filename: string; - inputStream: PLLStream); -procedure closePasParser(var p: TPasParser); - -procedure exSymbol(var n: PNode); -procedure fixRecordDef(var n: PNode); -// XXX: move these two to an auxiliary module - -implementation - -procedure OpenPasParser(var p: TPasParser; const filename: string; - inputStream: PLLStream); -var - i: int; -begin -{@ignore} - FillChar(p, sizeof(p), 0); -{@emit} - OpenLexer(p.lex, filename, inputStream); - initIdTable(p.repl); - for i := low(stdReplacements) to high(stdReplacements) do - IdTablePut(p.repl, getIdent(stdReplacements[i][0]), - getIdent(stdReplacements[i][1])); - if gCmd = cmdBoot then - for i := low(nimReplacements) to high(nimReplacements) do - IdTablePut(p.repl, getIdent(nimReplacements[i][0]), - getIdent(nimReplacements[i][1])); -end; - -procedure ClosePasParser(var p: TPasParser); -begin - CloseLexer(p.lex); -end; - -// ---------------- parser helpers -------------------------------------------- - -procedure getTok(var p: TPasParser); -begin - getPasTok(p.lex, p.tok) -end; - -procedure parMessage(const p: TPasParser; const msg: TMsgKind; - const arg: string = ''); -begin - lexMessage(p.lex, msg, arg); -end; - -function parLineInfo(const p: TPasParser): TLineInfo; -begin - result := getLineInfo(p.lex) -end; - -procedure skipCom(var p: TPasParser; n: PNode); -begin - while p.tok.xkind = pxComment do begin - if (n <> nil) then begin - if n.comment = snil then n.comment := p.tok.literal - else n.comment := n.comment +{&} nl +{&} p.tok.literal; - end - else - parMessage(p, warnCommentXIgnored, p.tok.literal); - getTok(p); - end -end; - -procedure ExpectIdent(const p: TPasParser); -begin - if p.tok.xkind <> pxSymbol then - lexMessage(p.lex, errIdentifierExpected, pasTokToStr(p.tok)); -end; - -procedure Eat(var p: TPasParser; xkind: TPasTokKind); -begin - if p.tok.xkind = xkind then getTok(p) - else lexMessage(p.lex, errTokenExpected, PasTokKindToStr[xkind]) -end; - -procedure Opt(var p: TPasParser; xkind: TPasTokKind); -begin - if p.tok.xkind = xkind then getTok(p) -end; -// ---------------------------------------------------------------------------- - -function newNodeP(kind: TNodeKind; const p: TPasParser): PNode; -begin - result := newNodeI(kind, getLineInfo(p.lex)); -end; - -function newIntNodeP(kind: TNodeKind; const intVal: BiggestInt; - const p: TPasParser): PNode; -begin - result := newNodeP(kind, p); - result.intVal := intVal; -end; - -function newFloatNodeP(kind: TNodeKind; const floatVal: BiggestFloat; - const p: TPasParser): PNode; -begin - result := newNodeP(kind, p); - result.floatVal := floatVal; -end; - -function newStrNodeP(kind: TNodeKind; const strVal: string; - const p: TPasParser): PNode; -begin - result := newNodeP(kind, p); - result.strVal := strVal; -end; - -function newIdentNodeP(ident: PIdent; const p: TPasParser): PNode; -begin - result := newNodeP(nkIdent, p); - result.ident := ident; -end; - -function createIdentNodeP(ident: PIdent; const p: TPasParser): PNode; -var - x: PIdent; -begin - result := newNodeP(nkIdent, p); - x := PIdent(IdTableGet(p.repl, ident)); - if x <> nil then result.ident := x - else result.ident := ident; -end; - -// ------------------- Expression parsing ------------------------------------ - -function parseExpr(var p: TPasParser): PNode; forward; -function parseStmt(var p: TPasParser): PNode; forward; -function parseTypeDesc(var p: TPasParser; - definition: PNode=nil): PNode; forward; - -function parseEmit(var p: TPasParser; definition: PNode): PNode; -var - a: PNode; -begin - getTok(p); // skip 'emit' - result := nil; - if p.tok.xkind <> pxCurlyDirRi then - case p.context of - conExpr: result := parseExpr(p); - conStmt: begin - result := parseStmt(p); - if p.tok.xkind <> pxCurlyDirRi then begin - a := result; - result := newNodeP(nkStmtList, p); - addSon(result, a); - while p.tok.xkind <> pxCurlyDirRi do begin - addSon(result, parseStmt(p)); - end - end - end; - conTypeDesc: result := parseTypeDesc(p, definition); - end; - eat(p, pxCurlyDirRi); -end; - -function parseCommand(var p: TPasParser; definition: PNode=nil): PNode; -var - a: PNode; -begin - result := nil; - getTok(p); - if p.tok.ident.id = getIdent('discard').id then begin - result := newNodeP(nkDiscardStmt, p); - getTok(p); eat(p, pxCurlyDirRi); - addSon(result, parseExpr(p)); - end - else if p.tok.ident.id = getIdent('set').id then begin - getTok(p); eat(p, pxCurlyDirRi); - result := parseExpr(p); - result.kind := nkCurly; - assert(sonsNotNil(result)); - end - else if p.tok.ident.id = getIdent('cast').id then begin - getTok(p); eat(p, pxCurlyDirRi); - a := parseExpr(p); - if (a.kind = nkCall) and (sonsLen(a) = 2) then begin - result := newNodeP(nkCast, p); - addSon(result, a.sons[0]); - addSon(result, a.sons[1]); - end - else begin - parMessage(p, errInvalidDirectiveX, pasTokToStr(p.tok)); - result := a - end - end - else if p.tok.ident.id = getIdent('emit').id then begin - result := parseEmit(p, definition); - end - else if p.tok.ident.id = getIdent('ignore').id then begin - getTok(p); eat(p, pxCurlyDirRi); - while true do begin - case p.tok.xkind of - pxEof: parMessage(p, errTokenExpected, '{@emit}'); - pxCommand: begin - getTok(p); - if p.tok.ident.id = getIdent('emit').id then begin - result := parseEmit(p, definition); - break - end - else begin - while (p.tok.xkind <> pxCurlyDirRi) and (p.tok.xkind <> pxEof) do - getTok(p); - eat(p, pxCurlyDirRi); - end; - end; - else getTok(p) // skip token - end - end - end - else if p.tok.ident.id = getIdent('ptr').id then begin - result := newNodeP(nkPtrTy, p); - getTok(p); eat(p, pxCurlyDirRi); - end - else if p.tok.ident.id = getIdent('tuple').id then 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, errInvalidDirectiveX, pasTokToStr(p.tok)); - while true do begin - getTok(p); - if (p.tok.xkind = pxCurlyDirRi) or (p.tok.xkind = pxEof) then break; - end; - eat(p, pxCurlyDirRi); - result := nil - end; -end; - -function getPrecedence(const kind: TPasTokKind): int; -begin - case kind of - pxDiv, pxMod, pxStar, pxSlash, pxShl, pxShr, pxAnd: result := 5; // highest - pxPlus, pxMinus, pxOr, pxXor: result := 4; - pxIn, pxEquals, pxLe, pxLt, pxGe, pxGt, pxNeq, pxIs: result := 3; - else result := -1; - end; -end; - -function rangeExpr(var p: TPasParser): PNode; -var - a: PNode; -begin - a := parseExpr(p); - if p.tok.xkind = pxDotDot then begin - result := newNodeP(nkRange, p); - addSon(result, a); - getTok(p); skipCom(p, result); - addSon(result, parseExpr(p)) - end - else result := a -end; - -function bracketExprList(var p: TPasParser; first: PNode): PNode; -var - a: PNode; -begin - result := newNodeP(nkBracketExpr, p); - addSon(result, first); - getTok(p); - skipCom(p, result); - while true do begin - if p.tok.xkind = pxBracketRi then begin - getTok(p); break - end; - if p.tok.xkind = pxEof then begin - parMessage(p, errTokenExpected, PasTokKindToStr[pxBracketRi]); break - end; - a := rangeExpr(p); - skipCom(p, a); - if p.tok.xkind = pxComma then begin - getTok(p); - skipCom(p, a) - end; - addSon(result, a); - end; -end; - -function exprColonEqExpr(var p: TPasParser; kind: TNodeKind; - tok: TPasTokKind): PNode; -var - a: PNode; -begin - a := parseExpr(p); - if p.tok.xkind = tok then begin - result := newNodeP(kind, p); - getTok(p); - skipCom(p, result); - addSon(result, a); - addSon(result, parseExpr(p)); - end - else - result := a -end; - -procedure exprListAux(var p: TPasParser; elemKind: TNodeKind; - endTok, sepTok: TPasTokKind; result: PNode); -var - a: PNode; -begin - getTok(p); - skipCom(p, result); - while true do begin - if p.tok.xkind = endTok then begin - getTok(p); break - end; - if p.tok.xkind = pxEof then begin - parMessage(p, errTokenExpected, PasTokKindToStr[endtok]); break - end; - a := exprColonEqExpr(p, elemKind, sepTok); - skipCom(p, a); - if (p.tok.xkind = pxComma) or (p.tok.xkind = pxSemicolon) then begin - getTok(p); - skipCom(p, a) - end; - addSon(result, a); - end; -end; - -function qualifiedIdent(var p: TPasParser): PNode; -var - a: PNode; -begin - if p.tok.xkind = pxSymbol then - result := createIdentNodeP(p.tok.ident, p) - else begin - parMessage(p, errIdentifierExpected, pasTokToStr(p.tok)); - result := nil; - exit - end; - getTok(p); - skipCom(p, result); - if p.tok.xkind = pxDot then begin - getTok(p); - skipCom(p, result); - if p.tok.xkind = pxSymbol then begin - a := result; - result := newNodeI(nkDotExpr, a.info); - addSon(result, a); - addSon(result, createIdentNodeP(p.tok.ident, p)); - getTok(p); - end - else parMessage(p, errIdentifierExpected, pasTokToStr(p.tok)) - end; -end; - -procedure qualifiedIdentListAux(var p: TPasParser; endTok: TPasTokKind; - result: PNode); -var - a: PNode; -begin - getTok(p); - skipCom(p, result); - while true do begin - if p.tok.xkind = endTok then begin - getTok(p); break - end; - if p.tok.xkind = pxEof then begin - parMessage(p, errTokenExpected, PasTokKindToStr[endtok]); break - end; - a := qualifiedIdent(p); - skipCom(p, a); - if p.tok.xkind = pxComma then begin - getTok(p); skipCom(p, a) - end; - addSon(result, a); - end -end; - -function exprColonEqExprList(var p: TPasParser; kind, elemKind: TNodeKind; - endTok, sepTok: TPasTokKind): PNode; -begin - result := newNodeP(kind, p); - exprListAux(p, elemKind, endTok, sepTok, result); -end; - -procedure setBaseFlags(n: PNode; base: TNumericalBase); -begin - case base of - base10: begin end; - base2: include(n.flags, nfBase2); - base8: include(n.flags, nfBase8); - base16: include(n.flags, nfBase16); - end -end; - -function identOrLiteral(var p: TPasParser): PNode; -var - a: PNode; -begin - case p.tok.xkind of - pxSymbol: begin - result := createIdentNodeP(p.tok.ident, p); - getTok(p) - end; - // literals - pxIntLit: begin - result := newIntNodeP(nkIntLit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - pxInt64Lit: begin - result := newIntNodeP(nkInt64Lit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - pxFloatLit: begin - result := newFloatNodeP(nkFloatLit, p.tok.fNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - pxStrLit: begin - if length(p.tok.literal) <> 1 then - result := newStrNodeP(nkStrLit, p.tok.literal, p) - else - result := newIntNodeP(nkCharLit, ord(p.tok.literal[strStart]), p); - getTok(p); - end; - pxNil: begin - result := newNodeP(nkNilLit, p); - getTok(p); - end; - - pxParLe: begin // () constructor - result := exprColonEqExprList(p, nkPar, nkExprColonExpr, pxParRi, - pxColon); - //if hasSonWith(result, nkExprColonExpr) then - // replaceSons(result, nkExprColonExpr, nkExprEqExpr) - if (sonsLen(result) > 1) and not hasSonWith(result, nkExprColonExpr) then - result.kind := nkBracket; // is an array constructor - end; - pxBracketLe: begin // [] constructor - result := newNodeP(nkBracket, p); - getTok(p); - skipCom(p, result); - while (p.tok.xkind <> pxBracketRi) and (p.tok.xkind <> pxEof) do begin - a := rangeExpr(p); - if a.kind = nkRange then - result.kind := nkCurly; // it is definitely a set literal - opt(p, pxComma); - skipCom(p, a); - assert(a <> nil); - addSon(result, a); - end; - eat(p, pxBracketRi); - end; - pxCommand: result := parseCommand(p); - else begin - parMessage(p, errExprExpected, pasTokToStr(p.tok)); - getTok(p); // we must consume a token here to prevend endless loops! - result := nil - end - end; - if result <> nil then - skipCom(p, result); -end; - -function primary(var p: TPasParser): PNode; -var - a: PNode; -begin - // prefix operator? - if (p.tok.xkind = pxNot) or (p.tok.xkind = pxMinus) - or (p.tok.xkind = pxPlus) then begin - result := newNodeP(nkPrefix, p); - a := newIdentNodeP(getIdent(pasTokToStr(p.tok)), p); - addSon(result, a); - getTok(p); - skipCom(p, a); - addSon(result, primary(p)); - exit - end - else if p.tok.xkind = pxAt then begin - result := newNodeP(nkAddr, p); - a := newIdentNodeP(getIdent(pasTokToStr(p.tok)), p); - getTok(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); - while true do begin - case p.tok.xkind of - pxParLe: begin - a := result; - result := newNodeP(nkCall, p); - addSon(result, a); - exprListAux(p, nkExprEqExpr, pxParRi, pxEquals, result); - end; - pxDot: begin - a := result; - result := newNodeP(nkDotExpr, p); - addSon(result, a); - getTok(p); // skip '.' - skipCom(p, result); - if p.tok.xkind = pxSymbol then begin - addSon(result, createIdentNodeP(p.tok.ident, p)); - getTok(p); - end - else - parMessage(p, errIdentifierExpected, pasTokToStr(p.tok)); - end; - pxHat: begin - a := result; - result := newNodeP(nkDerefExpr, p); - addSon(result, a); - getTok(p); - end; - pxBracketLe: result := bracketExprList(p, result); - else break - end - end -end; - -function lowestExprAux(var p: TPasParser; out v: PNode; - limit: int): TPasTokKind; -var - op, nextop: TPasTokKind; - opPred: int; - v2, node, opNode: PNode; -begin - v := primary(p); - // expand while operators have priorities higher than 'limit' - op := p.tok.xkind; - opPred := getPrecedence(op); - while (opPred > limit) do begin - node := newNodeP(nkInfix, p); - opNode := newIdentNodeP(getIdent(pasTokToStr(p.tok)), p); - // skip operator: - getTok(p); - case op of - pxPlus: begin - case p.tok.xkind of - pxPer: begin getTok(p); eat(p, pxCurlyDirRi); - opNode.ident := getIdent('+%') end; - pxAmp: begin getTok(p); eat(p, pxCurlyDirRi); - opNode.ident := getIdent('&'+'') end; - else begin end - end - end; - pxMinus: begin - if p.tok.xkind = pxPer then begin - getTok(p); eat(p, pxCurlyDirRi); - opNode.ident := getIdent('-%') - end; - end; - pxEquals: opNode.ident := getIdent('=='); - pxNeq: opNode.ident := getIdent('!='); - else begin end - end; - - skipCom(p, opNode); - - // read sub-expression with higher priority - nextop := lowestExprAux(p, v2, opPred); - addSon(node, opNode); - addSon(node, v); - addSon(node, v2); - v := node; - op := nextop; - opPred := getPrecedence(nextop); - end; - result := op; // return first untreated operator -end; - -function fixExpr(n: PNode): PNode; -var - i: int; -begin - result := n; - if n = nil then exit; - case n.kind of - nkInfix: begin - if n.sons[1].kind = nkBracket then // binary expression with [] is a set - n.sons[1].kind := nkCurly; - if n.sons[2].kind = nkBracket then // binary expression with [] is a set - n.sons[2].kind := nkCurly; - if (n.sons[0].kind = nkIdent) then begin - if (n.sons[0].ident.id = getIdent('+'+'').id) then begin - if (n.sons[1].kind = nkCharLit) - and (n.sons[2].kind = nkStrLit) and (n.sons[2].strVal = '') then - begin - result := newStrNode(nkStrLit, chr(int(n.sons[1].intVal))+''); - result.info := n.info; - exit; // do not process sons as they don't exist anymore - end - else if (n.sons[1].kind in [nkCharLit, nkStrLit]) - or (n.sons[2].kind in [nkCharLit, nkStrLit]) then begin - n.sons[0].ident := getIdent('&'+''); // fix operator - end - end - end - end - else begin end - end; - if not (n.kind in [nkEmpty..nkNilLit]) then - for i := 0 to sonsLen(n)-1 do - result.sons[i] := fixExpr(n.sons[i]) -end; - -function parseExpr(var p: TPasParser): PNode; -var - oldcontext: TPasContext; -begin - oldcontext := p.context; - p.context := conExpr; - if p.tok.xkind = pxCommand then begin - result := parseCommand(p) - end - else begin - {@discard} lowestExprAux(p, result, -1); - result := fixExpr(result) - end; - //if result = nil then - // internalError(parLineInfo(p), 'parseExpr() returned nil'); - p.context := oldcontext; -end; - -// ---------------------- statement parser ------------------------------------ -function parseExprStmt(var p: TPasParser): PNode; -var - a, b: PNode; - info: TLineInfo; -begin - info := parLineInfo(p); - a := parseExpr(p); - if p.tok.xkind = pxAsgn then begin - getTok(p); - skipCom(p, a); - b := parseExpr(p); - result := newNodeI(nkAsgn, info); - addSon(result, a); - addSon(result, b); - end - else - result := a -end; - -function inImportBlackList(ident: PIdent): bool; -var - i: int; -begin - for i := low(ImportBlackList) to high(ImportBlackList) do - if ident.id = getIdent(ImportBlackList[i]).id then begin - result := true; exit - end; - result := false -end; - -function parseUsesStmt(var p: TPasParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkImportStmt, p); - getTok(p); // skip `import` - skipCom(p, result); - while true do begin - case p.tok.xkind of - pxEof: break; - pxSymbol: a := newIdentNodeP(p.tok.ident, p); - else begin - parMessage(p, errIdentifierExpected, pasTokToStr(p.tok)); - break - end; - end; - getTok(p); // skip identifier, string - skipCom(p, a); - if (gCmd <> cmdBoot) or not inImportBlackList(a.ident) then - addSon(result, createIdentNodeP(a.ident, p)); - if p.tok.xkind = pxComma then begin - getTok(p); - skipCom(p, a) - end - else break - end; - if sonsLen(result) = 0 then result := nil; -end; - -function parseIncludeDir(var p: TPasParser): PNode; -var - filename: string; -begin - result := newNodeP(nkIncludeStmt, p); - getTok(p); // skip `include` - filename := ''; - while true do begin - case p.tok.xkind of - pxSymbol, pxDot, pxDotDot, pxSlash: begin - filename := filename +{&} pasTokToStr(p.tok); - getTok(p); - end; - pxStrLit: begin - filename := p.tok.literal; - getTok(p); - break - end; - pxCurlyDirRi: break; - else begin - parMessage(p, errIdentifierExpected, pasTokToStr(p.tok)); - break - end; - end; - end; - addSon(result, newStrNodeP(nkStrLit, changeFileExt(filename, 'nim'), p)); - if filename = 'config.inc' then result := nil; -end; - -function definedExprAux(var p: TPasParser): PNode; -begin - result := newNodeP(nkCall, p); - addSon(result, newIdentNodeP(getIdent('defined'), p)); - ExpectIdent(p); - addSon(result, createIdentNodeP(p.tok.ident, p)); - getTok(p); -end; - -function isHandledDirective(const p: TPasParser): bool; -begin - result := false; - if p.tok.xkind in [pxCurlyDirLe, pxStarDirLe] then - case whichKeyword(p.tok.ident) of - wElse, wEndif: result := false - else result := true - end -end; - -function parseStmtList(var p: TPasParser): PNode; -begin - result := newNodeP(nkStmtList, p); - while true do begin - case p.tok.xkind of - pxEof: break; - pxCurlyDirLe, pxStarDirLe: begin - if not isHandledDirective(p) then break; - end - else begin end - end; - addSon(result, parseStmt(p)) - end; - if sonsLen(result) = 1 then result := result.sons[0]; -end; - -procedure parseIfDirAux(var p: TPasParser; result: PNode); -var - s: PNode; - endMarker: TPasTokKind; -begin - addSon(result.sons[0], parseStmtList(p)); - if p.tok.xkind in [pxCurlyDirLe, pxStarDirLe] then begin - endMarker := succ(p.tok.xkind); - if whichKeyword(p.tok.ident) = wElse then begin - s := newNodeP(nkElse, p); - while (p.tok.xkind <> pxEof) and (p.tok.xkind <> endMarker) do getTok(p); - eat(p, endMarker); - addSon(s, parseStmtList(p)); - addSon(result, s); - end; - if p.tok.xkind in [pxCurlyDirLe, pxStarDirLe] then begin - endMarker := succ(p.tok.xkind); - if whichKeyword(p.tok.ident) = wEndif then begin - while (p.tok.xkind <> pxEof) and (p.tok.xkind <> endMarker) do getTok(p); - eat(p, endMarker); - end - else parMessage(p, errXExpected, '{$endif}'); - end - end - else - parMessage(p, errXExpected, '{$endif}'); -end; - -function parseIfdefDir(var p: TPasParser; endMarker: TPasTokKind): PNode; -begin - result := newNodeP(nkWhenStmt, p); - addSon(result, newNodeP(nkElifBranch, p)); - getTok(p); - addSon(result.sons[0], definedExprAux(p)); - eat(p, endMarker); - parseIfDirAux(p, result); -end; - -function parseIfndefDir(var p: TPasParser; endMarker: TPasTokKind): PNode; -var - e: PNode; -begin - result := newNodeP(nkWhenStmt, p); - addSon(result, newNodeP(nkElifBranch, p)); - getTok(p); - e := newNodeP(nkCall, p); - addSon(e, newIdentNodeP(getIdent('not'), p)); - addSon(e, definedExprAux(p)); - eat(p, endMarker); - addSon(result.sons[0], e); - parseIfDirAux(p, result); -end; - -function parseIfDir(var p: TPasParser; endMarker: TPasTokKind): PNode; -begin - result := newNodeP(nkWhenStmt, p); - addSon(result, newNodeP(nkElifBranch, p)); - getTok(p); - addSon(result.sons[0], parseExpr(p)); - eat(p, endMarker); - parseIfDirAux(p, result); -end; - -function parseDirective(var p: TPasParser): PNode; -var - endMarker: TPasTokKind; -begin - result := nil; - if not (p.tok.xkind in [pxCurlyDirLe, pxStarDirLe]) then exit; - endMarker := succ(p.tok.xkind); - if p.tok.ident <> nil then - case whichKeyword(p.tok.ident) of - wInclude: begin - result := parseIncludeDir(p); - eat(p, endMarker); - end; - wIf: result := parseIfDir(p, endMarker); - wIfdef: result := parseIfdefDir(p, endMarker); - wIfndef: result := parseIfndefDir(p, endMarker); - else begin - // skip unknown compiler directive - while (p.tok.xkind <> pxEof) and (p.tok.xkind <> endMarker) do - getTok(p); - eat(p, endMarker); - end - end - else eat(p, endMarker); -end; - -function parseRaise(var p: TPasParser): PNode; -begin - result := newNodeP(nkRaiseStmt, p); - getTok(p); - skipCom(p, result); - if p.tok.xkind <> pxSemicolon then addSon(result, parseExpr(p)) - else addSon(result, nil); -end; - -function parseIf(var p: TPasParser): PNode; -var - branch: PNode; -begin - result := newNodeP(nkIfStmt, p); - while true do begin - getTok(p); // skip ``if`` - branch := newNodeP(nkElifBranch, p); - skipCom(p, branch); - addSon(branch, parseExpr(p)); - eat(p, pxThen); - skipCom(p, branch); - addSon(branch, parseStmt(p)); - skipCom(p, branch); - addSon(result, branch); - if p.tok.xkind = pxElse then begin - getTok(p); - if p.tok.xkind <> pxIf then begin - // ordinary else part: - branch := newNodeP(nkElse, p); - skipCom(p, result); // BUGFIX - addSon(branch, parseStmt(p)); - addSon(result, branch); - break - end - // else: next iteration - end - else break - end -end; - -function parseWhile(var p: TPasParser): PNode; -begin - result := newNodeP(nkWhileStmt, p); - getTok(p); - skipCom(p, result); - addSon(result, parseExpr(p)); - eat(p, pxDo); - skipCom(p, result); - addSon(result, parseStmt(p)); -end; - -function parseRepeat(var p: TPasParser): PNode; -var - a, b, c, s: PNode; -begin - result := newNodeP(nkWhileStmt, p); - getTok(p); - skipCom(p, result); - addSon(result, newIdentNodeP(getIdent('true'), p)); - s := newNodeP(nkStmtList, p); - while (p.tok.xkind <> pxEof) and (p.tok.xkind <> pxUntil) do begin - addSon(s, parseStmt(p)) - end; - eat(p, pxUntil); - a := newNodeP(nkIfStmt, p); - skipCom(p, a); - b := newNodeP(nkElifBranch, p); - c := newNodeP(nkBreakStmt, p); - addSon(c, nil); - addSon(b, parseExpr(p)); - skipCom(p, a); - addSon(b, c); - addSon(a, b); - - if (b.sons[0].kind = nkIdent) and (b.sons[0].ident.id = getIdent('false').id) - then begin end // do not add an ``if false: break`` statement - else addSon(s, a); - addSon(result, s); -end; - -function parseCase(var p: TPasParser): PNode; -var - b: PNode; -begin - result := newNodeP(nkCaseStmt, p); - getTok(p); - addSon(result, parseExpr(p)); - eat(p, pxOf); - skipCom(p, result); - while (p.tok.xkind <> pxEnd) and (p.tok.xkind <> pxEof) do begin - if p.tok.xkind = pxElse then begin - b := newNodeP(nkElse, p); - getTok(p); - end - else begin - b := newNodeP(nkOfBranch, p); - while (p.tok.xkind <> pxEof) and (p.tok.xkind <> pxColon) do begin - addSon(b, rangeExpr(p)); - opt(p, pxComma); - skipcom(p, b); - end; - eat(p, pxColon); - end; - skipCom(p, b); - addSon(b, parseStmt(p)); - addSon(result, b); - if b.kind = nkElse then break; - end; - eat(p, pxEnd); -end; - -function parseTry(var p: TPasParser): PNode; -var - b, e: PNode; -begin - result := newNodeP(nkTryStmt, p); - getTok(p); - skipCom(p, result); - b := newNodeP(nkStmtList, p); - while not (p.tok.xkind in [pxFinally, pxExcept, pxEof, pxEnd]) do - addSon(b, parseStmt(p)); - addSon(result, b); - if p.tok.xkind = pxExcept then begin - getTok(p); - while p.tok.ident.id = getIdent('on').id do begin - b := newNodeP(nkExceptBranch, p); - getTok(p); - e := qualifiedIdent(p); - if p.tok.xkind = pxColon then begin - getTok(p); - e := qualifiedIdent(p); - end; - addSon(b, e); - eat(p, pxDo); - addSon(b, parseStmt(p)); - addSon(result, b); - if p.tok.xkind = pxCommand then {@discard} parseCommand(p); - end; - if p.tok.xkind = pxElse then begin - b := newNodeP(nkExceptBranch, p); - getTok(p); - addSon(b, parseStmt(p)); - addSon(result, b); - end - end; - if p.tok.xkind = pxFinally then begin - b := newNodeP(nkFinally, p); - getTok(p); - e := newNodeP(nkStmtList, p); - while (p.tok.xkind <> pxEof) and (p.tok.xkind <> pxEnd) do begin - addSon(e, parseStmt(p)) - end; - if sonsLen(e) = 0 then - addSon(e, newNodeP(nkNilLit, p)); - addSon(result, e); - end; - eat(p, pxEnd); -end; - -function parseFor(var p: TPasParser): PNode; -var - a, b, c: PNode; -begin - result := newNodeP(nkForStmt, p); - getTok(p); - skipCom(p, result); - expectIdent(p); - addSon(result, createIdentNodeP(p.tok.ident, p)); - getTok(p); - eat(p, pxAsgn); - a := parseExpr(p); - b := nil; - c := newNodeP(nkCall, p); - if p.tok.xkind = pxTo then begin - addSon(c, newIdentNodeP(getIdent('countup'), p)); - getTok(p); - b := parseExpr(p); - end - else if p.tok.xkind = pxDownto then begin - addSon(c, newIdentNodeP(getIdent('countdown'), p)); - getTok(p); - b := parseExpr(p); - end - else - parMessage(p, errTokenExpected, PasTokKindToStr[pxTo]); - addSon(c, a); - addSon(c, b); - - eat(p, pxDo); - skipCom(p, result); - addSon(result, c); - addSon(result, parseStmt(p)) -end; - -function parseParam(var p: TPasParser): PNode; -var - a, v: PNode; -begin - result := newNodeP(nkIdentDefs, p); - v := nil; - case p.tok.xkind of - pxConst: getTok(p); - pxVar: begin getTok(p); v := newNodeP(nkVarTy, p); end; - pxOut: begin getTok(p); v := newNodeP(nkVarTy, p); end; - else begin end - end; - while true do begin - case p.tok.xkind of - pxSymbol: a := createIdentNodeP(p.tok.ident, p); - pxColon, pxEof, pxParRi, pxEquals: break; - else begin - parMessage(p, errIdentifierExpected, pasTokToStr(p.tok)); - exit; - end; - end; - getTok(p); // skip identifier - skipCom(p, a); - if p.tok.xkind = pxComma then begin - getTok(p); skipCom(p, a) - end; - addSon(result, a); - end; - if p.tok.xkind = pxColon then begin - getTok(p); skipCom(p, result); - if v <> nil then addSon(v, parseTypeDesc(p)) - else v := parseTypeDesc(p); - addSon(result, v); - end - else begin - addSon(result, nil); - if p.tok.xkind <> pxEquals then - parMessage(p, errColonOrEqualsExpected, pasTokToStr(p.tok)) - end; - if p.tok.xkind = pxEquals then begin - getTok(p); skipCom(p, result); - addSon(result, parseExpr(p)); - end - else - addSon(result, nil); -end; - -function parseParamList(var p: TPasParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkFormalParams, p); - addSon(result, nil); // return type - if p.tok.xkind = pxParLe then begin - p.inParamList := true; - getTok(p); - skipCom(p, result); - while true do begin - case p.tok.xkind of - pxSymbol, pxConst, pxVar, pxOut: a := parseParam(p); - pxParRi: begin getTok(p); break end; - else begin parMessage(p, errTokenExpected, ')'+''); break; end; - end; - skipCom(p, a); - if p.tok.xkind = pxSemicolon then begin - getTok(p); skipCom(p, a) - end; - addSon(result, a) - end; - p.inParamList := false - end; - if p.tok.xkind = pxColon then begin - getTok(p); - skipCom(p, result); - result.sons[0] := parseTypeDesc(p) - end -end; - -function parseCallingConvention(var p: TPasParser): PNode; -begin - result := nil; - if p.tok.xkind = pxSymbol then begin - case whichKeyword(p.tok.ident) of - wStdcall, wCDecl, wSafeCall, wSysCall, wInline, wFastCall: begin - result := newNodeP(nkPragma, p); - addSon(result, newIdentNodeP(p.tok.ident, p)); - getTok(p); - opt(p, pxSemicolon); - end; - wRegister: begin - result := newNodeP(nkPragma, p); - addSon(result, newIdentNodeP(getIdent('fastcall'), p)); - getTok(p); - opt(p, pxSemicolon); - end - else begin end - end - end -end; - -function parseRoutineSpecifiers(var p: TPasParser; out noBody: boolean): PNode; -var - e: PNode; -begin - result := parseCallingConvention(p); - noBody := false; - while p.tok.xkind = pxSymbol do begin - case whichKeyword(p.tok.ident) of - wAssembler, wOverload, wFar: begin - getTok(p); opt(p, pxSemicolon); - end; - wForward: begin - noBody := true; - getTok(p); opt(p, pxSemicolon); - end; - wImportc: begin - // This is a fake for platform module. There is no ``importc`` - // directive in Pascal. - if result = nil then result := newNodeP(nkPragma, p); - addSon(result, newIdentNodeP(getIdent('importc'), p)); - noBody := true; - getTok(p); opt(p, pxSemicolon); - end; - wNoConv: begin - // This is a fake for platform module. There is no ``noconv`` - // directive in Pascal. - if result = nil then result := newNodeP(nkPragma, p); - addSon(result, newIdentNodeP(getIdent('noconv'), p)); - noBody := true; - getTok(p); opt(p, pxSemicolon); - end; - wProcVar: begin - // This is a fake for the Nimrod compiler. There is no ``procvar`` - // directive in Pascal. - if result = nil then result := newNodeP(nkPragma, p); - addSon(result, newIdentNodeP(getIdent('procvar'), p)); - getTok(p); opt(p, pxSemicolon); - end; - wVarargs: begin - if result = nil then result := newNodeP(nkPragma, p); - addSon(result, newIdentNodeP(getIdent('varargs'), p)); - getTok(p); opt(p, pxSemicolon); - end; - wExternal: begin - if result = nil then result := newNodeP(nkPragma, p); - getTok(p); - noBody := true; - e := newNodeP(nkExprColonExpr, p); - addSon(e, newIdentNodeP(getIdent('dynlib'), p)); - 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); - getTok(p); - addSon(e, newIdentNodeP(getIdent('importc'), p)); - addSon(e, parseExpr(p)); - addSon(result, e); - end - else - addSon(result, newIdentNodeP(getIdent('importc'), p)); - opt(p, pxSemicolon); - end - else begin - e := parseCallingConvention(p); - if e = nil then break; - if result = nil then result := newNodeP(nkPragma, p); - addSon(result, e.sons[0]); - end; - end - end -end; - -function parseRoutineType(var p: TPasParser): PNode; -begin - result := newNodeP(nkProcTy, p); - getTok(p); skipCom(p, result); - addSon(result, parseParamList(p)); - opt(p, pxSemicolon); - addSon(result, parseCallingConvention(p)); - skipCom(p, result); -end; - -function parseEnum(var p: TPasParser): PNode; -var - a, b: PNode; -begin - result := newNodeP(nkEnumTy, p); - getTok(p); - skipCom(p, result); - addSon(result, nil); // it does not inherit from any enumeration - - while true do begin - case p.tok.xkind of - pxEof, pxParRi: break; - pxSymbol: a := newIdentNodeP(p.tok.ident, p); - else begin - parMessage(p, errIdentifierExpected, pasTokToStr(p.tok)); - break - end; - end; - getTok(p); // skip identifier - skipCom(p, a); - if (p.tok.xkind = pxEquals) or (p.tok.xkind = pxAsgn) then begin - getTok(p); - skipCom(p, a); - b := a; - a := newNodeP(nkEnumFieldDef, p); - addSon(a, b); - addSon(a, parseExpr(p)); - end; - if p.tok.xkind = pxComma then begin - getTok(p); skipCom(p, a) - end; - addSon(result, a); - end; - eat(p, pxParRi) -end; - -function identVis(var p: TPasParser): PNode; // identifier with visability -var - a: PNode; -begin - a := createIdentNodeP(p.tok.ident, p); - if p.section = seInterface then begin - result := newNodeP(nkPostfix, p); - addSon(result, newIdentNodeP(getIdent('*'+''), p)); - addSon(result, a); - end - else - result := a; - getTok(p) -end; - -type - TSymbolParser = function (var p: TPasParser): PNode; - -function rawIdent(var p: TPasParser): PNode; -begin - result := createIdentNodeP(p.tok.ident, p); - getTok(p); -end; - -function parseIdentColonEquals(var p: TPasParser; - identParser: TSymbolParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkIdentDefs, p); - while true do begin - case p.tok.xkind of - pxSymbol: a := identParser(p); - pxColon, pxEof, pxParRi, pxEquals: break; - else begin - parMessage(p, errIdentifierExpected, pasTokToStr(p.tok)); - exit; - end; - end; - skipCom(p, a); - if p.tok.xkind = pxComma then begin - getTok(p); - skipCom(p, a) - end; - addSon(result, a); - end; - if p.tok.xkind = pxColon then begin - getTok(p); skipCom(p, result); - addSon(result, parseTypeDesc(p)); - end - else begin - addSon(result, nil); - if p.tok.xkind <> pxEquals then - parMessage(p, errColonOrEqualsExpected, pasTokToStr(p.tok)) - end; - if p.tok.xkind = pxEquals then begin - getTok(p); skipCom(p, result); - addSon(result, parseExpr(p)); - end - else - addSon(result, nil); - if p.tok.xkind = pxSemicolon then begin - getTok(p); skipCom(p, result); - end -end; - -function parseRecordCase(var p: TPasParser): PNode; -var - a, b, c: PNode; -begin - result := newNodeP(nkRecCase, p); - getTok(p); - a := newNodeP(nkIdentDefs, p); - addSon(a, rawIdent(p)); - eat(p, pxColon); - addSon(a, parseTypeDesc(p)); - addSon(a, nil); - addSon(result, a); - eat(p, pxOf); - skipCom(p, result); - - while true do begin - case p.tok.xkind of - pxEof, pxEnd: break; - pxElse: begin - b := newNodeP(nkElse, p); - getTok(p); - end; - else begin - b := newNodeP(nkOfBranch, p); - while (p.tok.xkind <> pxEof) and (p.tok.xkind <> pxColon) do begin - addSon(b, rangeExpr(p)); - opt(p, pxComma); - skipcom(p, b); - end; - eat(p, pxColon); - end - end; - skipCom(p, b); - c := newNodeP(nkRecList, p); - eat(p, pxParLe); - while (p.tok.xkind <> pxParRi) and (p.tok.xkind <> pxEof) do begin - addSon(c, parseIdentColonEquals(p, rawIdent)); - opt(p, pxSemicolon); - skipCom(p, lastSon(c)); - end; - eat(p, pxParRi); - opt(p, pxSemicolon); - 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; - end -end; - -function parseRecordPart(var p: TPasParser): PNode; -begin - result := nil; - while (p.tok.xkind <> pxEof) and (p.tok.xkind <> pxEnd) do begin - if result = nil then result := newNodeP(nkRecList, p); - case p.tok.xkind of - pxSymbol: begin - addSon(result, parseIdentColonEquals(p, rawIdent)); - opt(p, pxSemicolon); - skipCom(p, lastSon(result)); - end; - pxCase: begin - addSon(result, parseRecordCase(p)); - end; - pxComment: skipCom(p, lastSon(result)); - else begin - parMessage(p, errIdentifierExpected, pasTokToStr(p.tok)); - break - end - end - end -end; - -procedure exSymbol(var n: PNode); -var - a: PNode; -begin - case n.kind of - nkPostfix: begin end; // already an export marker - nkPragmaExpr: exSymbol(n.sons[0]); - nkIdent, nkAccQuoted: begin - a := newNodeI(nkPostFix, n.info); - addSon(a, newIdentNode(getIdent('*'+''), n.info)); - addSon(a, n); - n := a - end; - else internalError(n.info, 'exSymbol(): ' + nodekindtostr[n.kind]); - end -end; - -procedure fixRecordDef(var n: PNode); -var - i, len: int; -begin - if n = nil then exit; - case n.kind of - nkRecCase: begin - fixRecordDef(n.sons[0]); - for i := 1 to sonsLen(n)-1 do begin - len := sonsLen(n.sons[i]); - fixRecordDef(n.sons[i].sons[len-1]) - end - end; - nkRecList, nkRecWhen, nkElse, nkOfBranch, nkElifBranch, - nkObjectTy: begin - for i := 0 to sonsLen(n)-1 do fixRecordDef(n.sons[i]) - end; - 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 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 - skipCom(p, result); - a := parseRecordPart(p); - 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); -end; - -function parseRecordOrObject(var p: TPasParser; kind: TNodeKind; - definition: PNode): PNode; -var - a: PNode; -begin - result := newNodeP(kind, p); - getTok(p); - addSon(result, nil); - if p.tok.xkind = pxParLe then begin - a := newNodeP(nkOfInherit, p); - getTok(p); - addSon(a, parseTypeDesc(p)); - addSon(result, a); - eat(p, pxParRi); - end - else addSon(result, nil); - parseRecordBody(p, result, definition); -end; - -function parseTypeDesc(var p: TPasParser; definition: PNode=nil): PNode; -var - oldcontext: TPasContext; - a, r: PNode; - i: int; -begin - oldcontext := p.context; - p.context := conTypeDesc; - if p.tok.xkind = pxPacked then getTok(p); - case p.tok.xkind of - 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 - InternalError(result.info, 'parseTypeDesc'); - parseRecordBody(p, result, definition); - a := lastSon(result); - // embed nkRecList directly into nkTupleTy - for i := 0 to sonsLen(a)-1 do - if i = 0 then result.sons[sonsLen(result)-1] := a.sons[0] - else addSon(result, a.sons[i]); - end - else begin - result := newNodeP(nkObjectTy, p); - addSon(result, nil); - addSon(result, nil); - 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, definition); - pxParLe: result := parseEnum(p); - pxArray: begin - result := newNodeP(nkBracketExpr, p); - getTok(p); - if p.tok.xkind = pxBracketLe then begin - addSon(result, newIdentNodeP(getIdent('array'), p)); - getTok(p); - addSon(result, rangeExpr(p)); - eat(p, pxBracketRi); - end - else begin - if p.inParamList then - addSon(result, newIdentNodeP(getIdent('openarray'), p)) - else - addSon(result, newIdentNodeP(getIdent('seq'), p)); - end; - eat(p, pxOf); - addSon(result, parseTypeDesc(p)); - end; - pxSet: begin - result := newNodeP(nkBracketExpr, p); - getTok(p); - eat(p, pxOf); - addSon(result, newIdentNodeP(getIdent('set'), p)); - addSon(result, parseTypeDesc(p)); - end; - pxHat: begin - getTok(p); - if p.tok.xkind = pxCommand then - result := parseCommand(p) - else if gCmd = cmdBoot then - result := newNodeP(nkRefTy, p) - else - result := newNodeP(nkPtrTy, p); - addSon(result, parseTypeDesc(p)) - end; - pxType: begin - getTok(p); - result := parseTypeDesc(p); - end; - else begin - a := primary(p); - if p.tok.xkind = pxDotDot then begin - result := newNodeP(nkBracketExpr, p); - r := newNodeP(nkRange, p); - addSon(result, newIdentNodeP(getIdent('range'), p)); - getTok(p); - addSon(r, a); - addSon(r, parseExpr(p)); - addSon(result, r); - end - else - result := a - end - end; - p.context := oldcontext; -end; - -function parseTypeDef(var p: TPasParser): PNode; -var - 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, result); - addSon(result, a); - end - else - addSon(result, nil); - if p.tok.xkind = pxSemicolon then begin - getTok(p); skipCom(p, result); - end; -end; - -function parseTypeSection(var p: TPasParser): PNode; -begin - result := newNodeP(nkTypeSection, p); - getTok(p); - skipCom(p, result); - while p.tok.xkind = pxSymbol do begin - addSon(result, parseTypeDef(p)) - end -end; - -function parseConstant(var p: TPasParser): PNode; -begin - result := newNodeP(nkConstDef, p); - addSon(result, identVis(p)); - if p.tok.xkind = pxColon then begin - getTok(p); skipCom(p, result); - addSon(result, parseTypeDesc(p)); - end - else begin - addSon(result, nil); - if p.tok.xkind <> pxEquals then - parMessage(p, errColonOrEqualsExpected, pasTokToStr(p.tok)); - end; - if p.tok.xkind = pxEquals then begin - getTok(p); skipCom(p, result); - addSon(result, parseExpr(p)); - end - else - addSon(result, nil); - if p.tok.xkind = pxSemicolon then begin - getTok(p); skipCom(p, result); - end; -end; - -function parseConstSection(var p: TPasParser): PNode; -begin - result := newNodeP(nkConstSection, p); - getTok(p); - skipCom(p, result); - while p.tok.xkind = pxSymbol do begin - addSon(result, parseConstant(p)) - end -end; - -function parseVar(var p: TPasParser): PNode; -begin - result := newNodeP(nkVarSection, p); - getTok(p); - skipCom(p, result); - while p.tok.xkind = pxSymbol do begin - addSon(result, parseIdentColonEquals(p, identVis)); - end; - p.lastVarSection := result -end; - -function parseRoutine(var p: TPasParser): PNode; -var - a, stmts: PNode; - noBody: boolean; - i: int; -begin - result := newNodeP(nkProcDef, p); - getTok(p); - skipCom(p, result); - expectIdent(p); - addSon(result, identVis(p)); - addSon(result, nil); // generic parameters - addSon(result, parseParamList(p)); - opt(p, pxSemicolon); - addSon(result, parseRoutineSpecifiers(p, noBody)); - if (p.section = seInterface) or noBody then - addSon(result, nil) - else begin - stmts := newNodeP(nkStmtList, p); - while true do begin - case p.tok.xkind of - pxVar: addSon(stmts, parseVar(p)); - pxConst: addSon(stmts, parseConstSection(p)); - pxType: addSon(stmts, parseTypeSection(p)); - pxComment: skipCom(p, result); - pxBegin: break; - else begin - parMessage(p, errTokenExpected, 'begin'); - break - end - end - end; - a := parseStmt(p); - for i := 0 to sonsLen(a)-1 do addSon(stmts, a.sons[i]); - addSon(result, stmts); - end -end; - -function fixExit(var p: TPasParser; n: PNode): boolean; -var - len: int; - a: PNode; -begin - result := false; - if (p.tok.ident.id = getIdent('exit').id) then begin - len := sonsLen(n); - if (len <= 0) then exit; - a := n.sons[len-1]; - if (a.kind = nkAsgn) - and (a.sons[0].kind = nkIdent) - and (a.sons[0].ident.id = getIdent('result').id) then begin - delSon(a, 0); - a.kind := nkReturnStmt; - result := true; - getTok(p); opt(p, pxSemicolon); - skipCom(p, a); - end - end -end; - -procedure fixVarSection(var p: TPasParser; counter: PNode); -var - i, j: int; - v: PNode; -begin - if p.lastVarSection = nil then exit; - assert(counter.kind = nkIdent); - for i := 0 to sonsLen(p.lastVarSection)-1 do begin - v := p.lastVarSection.sons[i]; - for j := 0 to sonsLen(v)-3 do begin - if v.sons[j].ident.id = counter.ident.id then begin - delSon(v, j); - if sonsLen(v) <= 2 then // : type = int remains --> delete it - delSon(p.lastVarSection, i); - exit - end - end - end -end; - -procedure parseBegin(var p: TPasParser; result: PNode); -begin - getTok(p); - while true do begin - case p.tok.xkind of - pxComment: addSon(result, parseStmt(p)); - pxSymbol: begin - if not fixExit(p, result) then addSon(result, parseStmt(p)) - end; - pxEnd: begin getTok(p); break end; - pxSemicolon: begin getTok(p); end; - pxEof: parMessage(p, errExprExpected); - else addSonIfNotNil(result, parseStmt(p)); - end - end; - if sonsLen(result) = 0 then - addSon(result, newNodeP(nkNilLit, p)); -end; - -function parseStmt(var p: TPasParser): PNode; -var - oldcontext: TPasContext; -begin - oldcontext := p.context; - p.context := conStmt; - result := nil; - case p.tok.xkind of - pxBegin: begin - result := newNodeP(nkStmtList, p); - parseBegin(p, result); - end; - pxCommand: result := parseCommand(p); - pxCurlyDirLe, pxStarDirLe: begin - if isHandledDirective(p) then - result := parseDirective(p); - end; - pxIf: result := parseIf(p); - pxWhile: result := parseWhile(p); - pxRepeat: result := parseRepeat(p); - pxCase: result := parseCase(p); - pxTry: result := parseTry(p); - pxProcedure, pxFunction: result := parseRoutine(p); - pxType: result := parseTypeSection(p); - pxConst: result := parseConstSection(p); - pxVar: result := parseVar(p); - pxFor: begin - result := parseFor(p); - fixVarSection(p, result.sons[0]); - end; - pxRaise: result := parseRaise(p); - pxUses: result := parseUsesStmt(p); - pxProgram, pxUnit, pxLibrary: begin - // skip the pointless header - while not (p.tok.xkind in [pxSemicolon, pxEof]) do getTok(p); - getTok(p); - end; - pxInitialization: begin - getTok(p); // just skip the token - end; - pxImplementation: begin - p.section := seImplementation; - result := newNodeP(nkCommentStmt, p); - result.comment := '# implementation'; - getTok(p); - end; - pxInterface: begin - p.section := seInterface; - getTok(p); - end; - pxComment: begin - result := newNodeP(nkCommentStmt, p); - skipCom(p, result); - end; - pxSemicolon: getTok(p); - pxSymbol: begin - if p.tok.ident.id = getIdent('break').id then begin - result := newNodeP(nkBreakStmt, p); - getTok(p); skipCom(p, result); - addSon(result, nil); - end - else if p.tok.ident.id = getIdent('continue').id then begin - result := newNodeP(nkContinueStmt, p); - getTok(p); skipCom(p, result); - addSon(result, nil); - end - else if p.tok.ident.id = getIdent('exit').id then begin - result := newNodeP(nkReturnStmt, p); - getTok(p); skipCom(p, result); - addSon(result, nil); - end - else result := parseExprStmt(p) - end; - pxDot: getTok(p); // BUGFIX for ``end.`` in main program - else result := parseExprStmt(p) - end; - opt(p, pxSemicolon); - if result <> nil then skipCom(p, result); - p.context := oldcontext; -end; - -function parseUnit(var p: TPasParser): PNode; -begin - result := newNodeP(nkStmtList, p); - getTok(p); // read first token - while true do begin - case p.tok.xkind of - pxEof, pxEnd: break; - pxBegin: parseBegin(p, result); - pxCurlyDirLe, pxStarDirLe: begin - if isHandledDirective(p) then - addSon(result, parseDirective(p)) - else - parMessage(p, errXNotAllowedHere, p.tok.ident.s) - end - else addSon(result, parseStmt(p)) - end; - end; - opt(p, pxEnd); - opt(p, pxDot); - if p.tok.xkind <> pxEof then - addSon(result, parseStmt(p)); // comments after final 'end.' -end; - -end. diff --git a/nim/passaux.pas b/nim/passaux.pas deleted file mode 100755 index 7898d8278..000000000 --- a/nim/passaux.pas +++ /dev/null @@ -1,77 +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 passaux; - -// implements some little helper passes -{$include 'config.inc'} - -interface - -uses - nsystem, strutils, ast, astalgo, passes, msgs, options; - -function verbosePass: TPass; -function cleanupPass: TPass; - -implementation - -function verboseOpen(s: PSym; const filename: string): PPassContext; -begin - //MessageOut('compiling ' + s.name.s); - result := nil; // we don't need a context - if gVerbosity > 0 then - rawMessage(hintProcessing, s.name.s); -end; - -function verboseProcess(context: PPassContext; n: PNode): PNode; -begin - result := n; - if context <> nil then InternalError('logpass: context is not nil'); - if gVerbosity = 3 then - liMessage(n.info, hintProcessing, toString(ast.gid)); -end; - -function verbosePass: TPass; -begin - initPass(result); - result.open := verboseOpen; - result.process := verboseProcess; -end; - -function cleanUp(c: PPassContext; n: PNode): PNode; -var - i: int; - s: PSym; -begin - result := n; - // we cannot clean up if dead code elimination is activated - if (optDeadCodeElim in gGlobalOptions) then exit; - case n.kind of - nkStmtList: begin - for i := 0 to sonsLen(n)-1 do {@discard} cleanup(c, n.sons[i]); - end; - nkProcDef, nkMethodDef: begin - if (n.sons[namePos].kind = nkSym) then begin - s := n.sons[namePos].sym; - if not (sfDeadCodeElim in getModule(s).flags) and - not astNeeded(s) then s.ast.sons[codePos] := nil; // free the memory - end - end - else begin end; - end -end; - -function cleanupPass: TPass; -begin - initPass(result); - result.process := cleanUp; - result.close := cleanUp; -end; - -end. diff --git a/nim/passes.pas b/nim/passes.pas deleted file mode 100755 index c280a75b1..000000000 --- a/nim/passes.pas +++ /dev/null @@ -1,215 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit passes; - -// This module implements the passes functionality. A pass must implement the -// `TPass` interface. - -interface - -{$include 'config.inc'} - -uses - nsystem, charsets, strutils, - lists, options, ast, astalgo, llstream, - msgs, platform, nos, condsyms, idents, rnimsyn, types, - extccomp, nmath, magicsys, nversion, nimsets, syntaxes, ntime, rodread; - -type - TPassContext = object(NObject) // the pass's context - end; - PPassContext = ^TPassContext; - - TPass = record {@tuple} // a pass is a tuple of procedure vars - open: function (module: PSym; const filename: string): PPassContext; - openCached: function (module: PSym; const filename: string; - rd: PRodReader): PPassContext; - close: function (p: PPassContext; n: PNode): PNode; - process: function (p: PPassContext; topLevelStmt: PNode): PNode; - end; - -// ``TPass.close`` may produce additional nodes. These are passed to the other -// close procedures. This mechanism is needed for the instantiation of -// generics. - -procedure registerPass(const p: TPass); - -procedure initPass(var p: TPass); - -// This implements a memory preserving scheme: Top level statements are -// processed in a pipeline. The compiler never looks at a whole module -// any longer. However, this is simple to change, as new passes may perform -// whole program optimizations. For now, we avoid it to save a lot of memory. - -procedure processModule(module: PSym; const filename: string; - stream: PLLStream; rd: PRodReader); - - -function astNeeded(s: PSym): bool; - // The ``rodwrite`` module uses this to determine if the body of a proc - // needs to be stored. The passes manager frees s.sons[codePos] when - // appropriate to free the procedure body's memory. This is important - // to keep memory usage down. - -// the semantic checker needs these: -var - gImportModule: function (const filename: string): PSym; - gIncludeFile: function (const filename: string): PNode; - -implementation - -function astNeeded(s: PSym): bool; -begin - if (s.kind in [skMethod, skProc]) - and ([sfCompilerProc, sfCompileTime] * s.flags = []) - and (s.typ.callConv <> ccInline) - and (s.ast.sons[genericParamsPos] = nil) then - result := false - else - result := true -end; - -const - maxPasses = 10; - -type - TPassContextArray = array [0..maxPasses-1] of PPassContext; -var - gPasses: array [0..maxPasses-1] of TPass; - gPassesLen: int; - -procedure registerPass(const p: TPass); -begin - gPasses[gPassesLen] := p; - inc(gPassesLen); -end; - -procedure openPasses(var a: TPassContextArray; module: PSym; - const filename: string); -var - i: int; -begin - for i := 0 to gPassesLen-1 do - if assigned(gPasses[i].open) then - a[i] := gPasses[i].open(module, filename) - else - a[i] := nil -end; - -procedure openPassesCached(var a: TPassContextArray; module: PSym; - const filename: string; rd: PRodReader); -var - i: int; -begin - for i := 0 to gPassesLen-1 do - if assigned(gPasses[i].openCached) then - a[i] := gPasses[i].openCached(module, filename, rd) - else - a[i] := nil -end; - -procedure closePasses(var a: TPassContextArray); -var - i: int; - m: PNode; -begin - m := nil; - for i := 0 to gPassesLen-1 do begin - if assigned(gPasses[i].close) then m := gPasses[i].close(a[i], m); - a[i] := nil; // free the memory here - end -end; - -procedure processTopLevelStmt(n: PNode; var a: TPassContextArray); -var - i: int; - m: PNode; -begin - // this implements the code transformation pipeline - m := n; - for i := 0 to gPassesLen-1 do - if assigned(gPasses[i].process) then m := gPasses[i].process(a[i], m); -end; - -procedure processTopLevelStmtCached(n: PNode; var a: TPassContextArray); -var - i: int; - m: PNode; -begin - // this implements the code transformation pipeline - m := n; - for i := 0 to gPassesLen-1 do - if assigned(gPasses[i].openCached) then m := gPasses[i].process(a[i], m); -end; - -procedure closePassesCached(var a: TPassContextArray); -var - i: int; - m: PNode; -begin - m := nil; - for i := 0 to gPassesLen-1 do begin - if assigned(gPasses[i].openCached) and assigned(gPasses[i].close) then - m := gPasses[i].close(a[i], m); - a[i] := nil; // free the memory here - end -end; - -procedure processModule(module: PSym; const filename: string; - stream: PLLStream; rd: PRodReader); -var - p: TParsers; - n: PNode; - a: TPassContextArray; - s: PLLStream; - i: int; -begin - if rd = nil then begin - openPasses(a, module, filename); - if stream = nil then begin - s := LLStreamOpen(filename, fmRead); - if s = nil then begin - rawMessage(errCannotOpenFile, filename); - exit - end; - end - else - s := stream; - while true do begin - openParsers(p, filename, s); - while true do begin - n := parseTopLevelStmt(p); - if n = nil then break; - processTopLevelStmt(n, a) - end; - closeParsers(p); - if s.kind <> llsStdIn then break; - end; - closePasses(a); - // id synchronization point for more consistent code generation: - IDsynchronizationPoint(1000); - end - else begin - openPassesCached(a, module, filename, rd); - n := loadInitSection(rd); - //MessageOut('init section' + renderTree(n)); - for i := 0 to sonsLen(n)-1 do processTopLevelStmtCached(n.sons[i], a); - closePassesCached(a); - end; -end; - -procedure initPass(var p: TPass); -begin - p.open := nil; - p.openCached := nil; - p.close := nil; - p.process := nil; -end; - -end. diff --git a/nim/pbraces.pas b/nim/pbraces.pas deleted file mode 100755 index d1cb84096..000000000 --- a/nim/pbraces.pas +++ /dev/null @@ -1,1484 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit pbraces; - -{$include config.inc} - -interface - -uses - nsystem, llstream, scanner, idents, strutils, ast, msgs, pnimsyn; - -function ParseAll(var p: TParser): PNode; - -function parseTopLevelStmt(var p: TParser): PNode; -// implements an iterator. Returns the next top-level statement or nil if end -// of stream. - -implementation - -// ------------------- Expression parsing ------------------------------------ - -function parseExpr(var p: TParser): PNode; forward; -function parseStmt(var p: TParser): PNode; forward; - -function parseTypeDesc(var p: TParser): PNode; forward; -function parseParamList(var p: TParser): PNode; forward; - -function optExpr(var p: TParser): PNode; // [expr] -begin - if (p.tok.tokType <> tkComma) and (p.tok.tokType <> tkBracketRi) - and (p.tok.tokType <> tkDotDot) then - result := parseExpr(p) - else - result := nil; -end; - -function dotdotExpr(var p: TParser; first: PNode = nil): PNode; -begin - result := newNodeP(nkRange, p); - addSon(result, first); - getTok(p); - optInd(p, result); - addSon(result, optExpr(p)); -end; - -function indexExpr(var p: TParser): PNode; -// indexExpr ::= '..' [expr] | expr ['=' expr | '..' expr] -var - a, b: PNode; -begin - if p.tok.tokType = tkDotDot then - result := dotdotExpr(p) - else begin - a := parseExpr(p); - case p.tok.tokType of - tkEquals: begin - result := newNodeP(nkExprEqExpr, p); - addSon(result, a); - getTok(p); - if p.tok.tokType = tkDotDot then - addSon(result, dotdotExpr(p)) - else begin - b := parseExpr(p); - if p.tok.tokType = tkDotDot then b := dotdotExpr(p, b); - addSon(result, b); - end - end; - tkDotDot: result := dotdotExpr(p, a); - else result := a - end - end -end; - -function indexExprList(var p: TParser; first: PNode): PNode; -var - a: PNode; -begin - result := newNodeP(nkBracketExpr, p); - addSon(result, first); - getTok(p); - optInd(p, result); - while (p.tok.tokType <> tkBracketRi) and (p.tok.tokType <> tkEof) - and (p.tok.tokType <> tkSad) do begin - a := indexExpr(p); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, tkBracketRi); -end; - -function exprColonEqExpr(var p: TParser; kind: TNodeKind; - tok: TTokType): PNode; -var - a: PNode; -begin - a := parseExpr(p); - if p.tok.tokType = tok then begin - result := newNodeP(kind, p); - getTok(p); - //optInd(p, result); - addSon(result, a); - addSon(result, parseExpr(p)); - end - else - result := a -end; - -procedure exprListAux(var p: TParser; elemKind: TNodeKind; - endTok, sepTok: TTokType; result: PNode); -var - a: PNode; -begin - getTok(p); - optInd(p, result); - while (p.tok.tokType <> endTok) and (p.tok.tokType <> tkEof) do begin - a := exprColonEqExpr(p, elemKind, sepTok); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - eat(p, endTok); -end; - -function qualifiedIdent(var p: TParser): PNode; -var - a: PNode; -begin - result := parseSymbol(p); - if p.tok.tokType = tkDot then begin - getTok(p); - optInd(p, result); - a := result; - result := newNodeI(nkDotExpr, a.info); - addSon(result, a); - addSon(result, parseSymbol(p)); - end; -end; - -procedure qualifiedIdentListAux(var p: TParser; endTok: TTokType; result: PNode); -var - a: PNode; -begin - getTok(p); - optInd(p, result); - while (p.tok.tokType <> endTok) and (p.tok.tokType <> tkEof) do begin - a := qualifiedIdent(p); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - eat(p, endTok); -end; - -procedure exprColonEqExprListAux(var p: TParser; elemKind: TNodeKind; - endTok, sepTok: TTokType; result: PNode); -var - a: PNode; -begin - getTok(p); - optInd(p, result); - while (p.tok.tokType <> endTok) and (p.tok.tokType <> tkEof) - and (p.tok.tokType <> tkSad) do begin - a := exprColonEqExpr(p, elemKind, sepTok); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, endTok); -end; - -function exprColonEqExprList(var p: TParser; kind, elemKind: TNodeKind; - endTok, sepTok: TTokType): PNode; -begin - result := newNodeP(kind, p); - exprColonEqExprListAux(p, elemKind, endTok, sepTok, result); -end; - -function parseCast(var p: TParser): PNode; -begin - result := newNodeP(nkCast, p); - getTok(p); - eat(p, tkBracketLe); - optInd(p, result); - addSon(result, parseTypeDesc(p)); - optSad(p); - eat(p, tkBracketRi); - eat(p, tkParLe); - optInd(p, result); - addSon(result, parseExpr(p)); - optSad(p); - eat(p, tkParRi); -end; - -function parseAddr(var p: TParser): PNode; -begin - result := newNodeP(nkAddr, p); - getTok(p); - eat(p, tkParLe); - optInd(p, result); - addSon(result, parseExpr(p)); - optSad(p); - eat(p, tkParRi); -end; - -function identOrLiteral(var p: TParser): PNode; -begin - case p.tok.tokType of - tkSymbol: begin - result := newIdentNodeP(p.tok.ident, p); - getTok(p) - end; - tkAccent: result := accExpr(p); - // literals - tkIntLit: begin - result := newIntNodeP(nkIntLit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkInt8Lit: begin - result := newIntNodeP(nkInt8Lit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkInt16Lit: begin - result := newIntNodeP(nkInt16Lit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkInt32Lit: begin - result := newIntNodeP(nkInt32Lit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkInt64Lit: begin - result := newIntNodeP(nkInt64Lit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkFloatLit: begin - result := newFloatNodeP(nkFloatLit, p.tok.fNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkFloat32Lit: begin - result := newFloatNodeP(nkFloat32Lit, p.tok.fNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkFloat64Lit: begin - result := newFloatNodeP(nkFloat64Lit, p.tok.fNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkStrLit: begin - result := newStrNodeP(nkStrLit, p.tok.literal, p); - getTok(p); - end; - tkRStrLit: begin - result := newStrNodeP(nkRStrLit, p.tok.literal, p); - getTok(p); - end; - tkTripleStrLit: begin - result := newStrNodeP(nkTripleStrLit, p.tok.literal, p); - getTok(p); - end; - tkCallRStrLit: begin - result := newNodeP(nkCallStrLit, p); - addSon(result, newIdentNodeP(p.tok.ident, p)); - addSon(result, newStrNodeP(nkRStrLit, p.tok.literal, p)); - getTok(p); - end; - tkCallTripleStrLit: begin - result := newNodeP(nkCallStrLit, p); - addSon(result, newIdentNodeP(p.tok.ident, p)); - addSon(result, newStrNodeP(nkTripleStrLit, p.tok.literal, p)); - getTok(p); - end; - tkCharLit: begin - result := newIntNodeP(nkCharLit, ord(p.tok.literal[strStart]), p); - getTok(p); - end; - tkNil: begin - result := newNodeP(nkNilLit, p); - getTok(p); - end; - tkParLe: begin // () constructor - result := exprColonEqExprList(p, nkPar, nkExprColonExpr, tkParRi, - tkColon); - end; - tkCurlyLe: begin // {} constructor - result := exprColonEqExprList(p, nkCurly, nkRange, tkCurlyRi, tkDotDot); - end; - tkBracketLe: begin // [] constructor - result := exprColonEqExprList(p, nkBracket, nkExprColonExpr, tkBracketRi, - tkColon); - end; - tkCast: result := parseCast(p); - tkAddr: result := parseAddr(p); - else begin - parMessage(p, errExprExpected, tokToStr(p.tok)); - getTok(p); // we must consume a token here to prevend endless loops! - result := nil - end - end -end; - -function primary(var p: TParser): PNode; -var - a: PNode; -begin - // prefix operator? - if (p.tok.tokType = tkNot) or (p.tok.tokType = tkOpr) then begin - result := newNodeP(nkPrefix, p); - a := newIdentNodeP(p.tok.ident, p); - addSon(result, a); - getTok(p); - optInd(p, a); - addSon(result, primary(p)); - exit - end - else if p.tok.tokType = tkBind then begin - result := newNodeP(nkBind, p); - getTok(p); - optInd(p, result); - addSon(result, primary(p)); - exit - end; - result := identOrLiteral(p); - while true do begin - case p.tok.tokType of - tkParLe: begin - a := result; - result := newNodeP(nkCall, p); - addSon(result, a); - exprColonEqExprListAux(p, nkExprEqExpr, tkParRi, tkEquals, result); - end; - tkDot: begin - a := result; - result := newNodeP(nkDotExpr, p); - addSon(result, a); - getTok(p); // skip '.' - optInd(p, result); - addSon(result, parseSymbol(p)); - end; - tkHat: begin - a := result; - result := newNodeP(nkDerefExpr, p); - addSon(result, a); - getTok(p); - end; - tkBracketLe: result := indexExprList(p, result); - else break - end - end -end; - -function lowestExprAux(var p: TParser; out v: PNode; limit: int): PToken; -var - op, nextop: PToken; - opPred: int; - v2, node, opNode: PNode; -begin - v := primary(p); - // expand while operators have priorities higher than 'limit' - op := p.tok; - opPred := getPrecedence(p.tok); - while (opPred > limit) do begin - node := newNodeP(nkInfix, p); - opNode := newIdentNodeP(op.ident, p); - // skip operator: - getTok(p); - optInd(p, opNode); - - // read sub-expression with higher priority - nextop := lowestExprAux(p, v2, opPred); - addSon(node, opNode); - addSon(node, v); - addSon(node, v2); - v := node; - op := nextop; - opPred := getPrecedence(nextop); - end; - result := op; // return first untreated operator -end; - -function lowestExpr(var p: TParser): PNode; -begin -{@discard} lowestExprAux(p, result, -1); -end; - -function parseIfExpr(var p: TParser): PNode; -// if (expr) expr else expr -var - branch: PNode; -begin - result := newNodeP(nkIfExpr, p); - while true do begin - getTok(p); // skip `if`, `elif` - branch := newNodeP(nkElifExpr, p); - eat(p, tkParLe); - addSon(branch, parseExpr(p)); - eat(p, tkParRi); - addSon(branch, parseExpr(p)); - addSon(result, branch); - if p.tok.tokType <> tkElif then break - end; - branch := newNodeP(nkElseExpr, p); - eat(p, tkElse); - addSon(branch, parseExpr(p)); - addSon(result, branch); -end; - -function parsePragma(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkPragma, p); - getTok(p); - optInd(p, result); - while (p.tok.tokType <> tkCurlyDotRi) and (p.tok.tokType <> tkCurlyRi) - and (p.tok.tokType <> tkEof) and (p.tok.tokType <> tkSad) do begin - a := exprColonEqExpr(p, nkExprColonExpr, tkColon); - addSon(result, a); - if p.tok.tokType = tkComma then begin - getTok(p); - optInd(p, a) - end - end; - optSad(p); - if (p.tok.tokType = tkCurlyDotRi) or (p.tok.tokType = tkCurlyRi) then - getTok(p) - else - parMessage(p, errTokenExpected, '.}'); -end; - -function identVis(var p: TParser): PNode; // identifier with visability -var - a: PNode; -begin - a := parseSymbol(p); - if p.tok.tokType = tkOpr then begin - result := newNodeP(nkPostfix, p); - addSon(result, newIdentNodeP(p.tok.ident, p)); - addSon(result, a); - getTok(p); - end - else - result := a; -end; - -function identWithPragma(var p: TParser): PNode; -var - a: PNode; -begin - a := identVis(p); - if p.tok.tokType = tkCurlyDotLe then begin - result := newNodeP(nkPragmaExpr, p); - addSon(result, a); - addSon(result, parsePragma(p)); - end - else - result := a -end; - -type - TDeclaredIdentFlag = ( - withPragma, // identifier may have pragma - withBothOptional // both ':' and '=' parts are optional - ); - TDeclaredIdentFlags = set of TDeclaredIdentFlag; - -function parseIdentColonEquals(var p: TParser; - flags: TDeclaredIdentFlags): PNode; -var - a: PNode; -begin - result := newNodeP(nkIdentDefs, p); - while true do begin - case p.tok.tokType of - tkSymbol, tkAccent: begin - if withPragma in flags then - a := identWithPragma(p) - else - a := parseSymbol(p); - if a = nil then exit; - end; - else break; - end; - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - if p.tok.tokType = tkColon then begin - getTok(p); optInd(p, result); - addSon(result, parseTypeDesc(p)); - end - else begin - addSon(result, nil); - if (p.tok.tokType <> tkEquals) and not (withBothOptional in flags) then - parMessage(p, errColonOrEqualsExpected, tokToStr(p.tok)) - end; - if p.tok.tokType = tkEquals then begin - getTok(p); optInd(p, result); - addSon(result, parseExpr(p)); - end - else - addSon(result, nil); -end; - -function parseTuple(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkTupleTy, p); - getTok(p); - eat(p, tkBracketLe); - optInd(p, result); - while (p.tok.tokType = tkSymbol) or (p.tok.tokType = tkAccent) do begin - a := parseIdentColonEquals(p, {@set}[]); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, tkBracketRi); -end; - -function parseParamList(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkFormalParams, p); - addSon(result, nil); // return type - if p.tok.tokType = tkParLe then begin - getTok(p); - optInd(p, result); - while true do begin - case p.tok.tokType of - tkSymbol, tkAccent: a := parseIdentColonEquals(p, {@set}[]); - tkParRi: break; - else begin parMessage(p, errTokenExpected, ')'+''); break; end; - end; - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, tkParRi); - end; - if p.tok.tokType = tkColon then begin - getTok(p); - optInd(p, result); - result.sons[0] := parseTypeDesc(p) - end -end; - -function parseProcExpr(var p: TParser; isExpr: bool): PNode; -// either a proc type or a anonymous proc -var - pragmas, params: PNode; - info: TLineInfo; -begin - info := parLineInfo(p); - getTok(p); - params := parseParamList(p); - if p.tok.tokType = tkCurlyDotLe then pragmas := parsePragma(p) - else pragmas := nil; - if (p.tok.tokType = tkCurlyLe) and isExpr then begin - result := newNodeI(nkLambda, info); - addSon(result, nil); // no name part - addSon(result, nil); // no generic parameters - addSon(result, params); - addSon(result, pragmas); - //getTok(p); skipComment(p, result); - addSon(result, parseStmt(p)); - end - else begin - result := newNodeI(nkProcTy, info); - addSon(result, params); - addSon(result, pragmas); - end -end; - -function parseTypeDescKAux(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - addSon(result, parseTypeDesc(p)); -end; - -function parseExpr(var p: TParser): PNode; -(* -expr ::= lowestExpr - | 'if' expr ':' expr ('elif' expr ':' expr)* 'else' ':' expr - | 'var' expr - | 'ref' expr - | 'ptr' expr - | 'type' expr - | 'tuple' tupleDesc - | 'proc' paramList [pragma] ['=' stmt] -*) -begin - case p.tok.toktype of - tkVar: result := parseTypeDescKAux(p, nkVarTy); - tkRef: result := parseTypeDescKAux(p, nkRefTy); - tkPtr: result := parseTypeDescKAux(p, nkPtrTy); - tkType: result := parseTypeDescKAux(p, nkTypeOfExpr); - tkTuple: result := parseTuple(p); - tkProc: result := parseProcExpr(p, true); - tkIf: result := parseIfExpr(p); - else result := lowestExpr(p); - end -end; - -function parseTypeDesc(var p: TParser): PNode; -begin - if p.tok.toktype = tkProc then result := parseProcExpr(p, false) - else result := parseExpr(p); -end; - -// ---------------------- statement parser ------------------------------------ -function isExprStart(const p: TParser): bool; -begin - case p.tok.tokType of - tkSymbol, tkAccent, tkOpr, tkNot, tkNil, tkCast, tkIf, tkProc, tkBind, - tkParLe, tkBracketLe, tkCurlyLe, tkIntLit..tkCharLit, - tkVar, tkRef, tkPtr, tkTuple, tkType: result := true; - else result := false; - end; -end; - -function parseExprStmt(var p: TParser): PNode; -var - a, b, e: PNode; -begin - a := lowestExpr(p); - if p.tok.tokType = tkEquals then begin - getTok(p); - optInd(p, result); - b := parseExpr(p); - result := newNodeI(nkAsgn, a.info); - addSon(result, a); - addSon(result, b); - end - else begin - result := newNodeP(nkCommand, p); - result.info := a.info; - addSon(result, a); - while true do begin - if not isExprStart(p) then break; - e := parseExpr(p); - addSon(result, e); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a); - end; - if sonsLen(result) <= 1 then result := a - else a := result; - if p.tok.tokType = tkCurlyLe then begin // macro statement - result := newNodeP(nkMacroStmt, p); - result.info := a.info; - addSon(result, a); - getTok(p); - skipComment(p, result); - if (p.tok.tokType = tkInd) - or not (p.tok.TokType in [tkOf, tkElif, tkElse, tkExcept]) then - addSon(result, parseStmt(p)); - while true do begin - if p.tok.tokType = tkSad then getTok(p); - case p.tok.tokType of - tkOf: begin - b := newNodeP(nkOfBranch, p); - exprListAux(p, nkRange, tkCurlyLe, tkDotDot, b); - end; - tkElif: begin - b := newNodeP(nkElifBranch, p); - getTok(p); - optInd(p, b); - addSon(b, parseExpr(p)); - eat(p, tkCurlyLe); - end; - tkExcept: begin - b := newNodeP(nkExceptBranch, p); - qualifiedIdentListAux(p, tkCurlyLe, b); - skipComment(p, b); - end; - tkElse: begin - b := newNodeP(nkElse, p); - getTok(p); - eat(p, tkCurlyLe); - end; - else break; - end; - addSon(b, parseStmt(p)); - eat(p, tkCurlyRi); - addSon(result, b); - if b.kind = nkElse then break; - end; - eat(p, tkCurlyRi); - end - end -end; - -function parseImportOrIncludeStmt(var p: TParser; kind: TNodeKind): PNode; -var - a: PNode; -begin - result := newNodeP(kind, p); - getTok(p); // skip `import` or `include` - optInd(p, result); - while true do begin - case p.tok.tokType of - tkEof, tkSad, tkDed: break; - tkSymbol, tkAccent: a := parseSymbol(p); - tkRStrLit: begin - a := newStrNodeP(nkRStrLit, p.tok.literal, p); - getTok(p) - end; - tkStrLit: begin - a := newStrNodeP(nkStrLit, p.tok.literal, p); - getTok(p); - end; - tkTripleStrLit: begin - a := newStrNodeP(nkTripleStrLit, p.tok.literal, p); - getTok(p) - end; - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - break - end - end; - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; -end; - -function parseFromStmt(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkFromStmt, p); - getTok(p); // skip `from` - optInd(p, result); - case p.tok.tokType of - tkSymbol, tkAccent: a := parseSymbol(p); - tkRStrLit: begin - a := newStrNodeP(nkRStrLit, p.tok.literal, p); - getTok(p) - end; - tkStrLit: begin - a := newStrNodeP(nkStrLit, p.tok.literal, p); - getTok(p); - end; - tkTripleStrLit: begin - a := newStrNodeP(nkTripleStrLit, p.tok.literal, p); - getTok(p) - end; - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); exit - end - end; - addSon(result, a); - //optInd(p, a); - eat(p, tkImport); - optInd(p, result); - while true do begin - case p.tok.tokType of - tkEof, tkSad, tkDed: break; - tkSymbol, tkAccent: a := parseSymbol(p); - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - break - end; - end; - //optInd(p, a); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; -end; - -function parseReturnOrRaise(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - case p.tok.tokType of - tkEof, tkSad, tkDed: addSon(result, nil); - else addSon(result, parseExpr(p)); - end; -end; - -function parseYieldOrDiscard(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - addSon(result, parseExpr(p)); -end; - -function parseBreakOrContinue(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - case p.tok.tokType of - tkEof, tkSad, tkDed: addSon(result, nil); - else addSon(result, parseSymbol(p)); - end; -end; - -function parseIfOrWhen(var p: TParser; kind: TNodeKind): PNode; -var - branch: PNode; -begin - result := newNodeP(kind, p); - while true do begin - getTok(p); // skip `if`, `when`, `elif` - branch := newNodeP(nkElifBranch, p); - optInd(p, branch); - eat(p, tkParLe); - addSon(branch, parseExpr(p)); - eat(p, tkParRi); - skipComment(p, branch); - addSon(branch, parseStmt(p)); - skipComment(p, branch); - addSon(result, branch); - if p.tok.tokType <> tkElif then break - end; - if p.tok.tokType = tkElse then begin - branch := newNodeP(nkElse, p); - eat(p, tkElse); - skipComment(p, branch); - addSon(branch, parseStmt(p)); - addSon(result, branch); - end -end; - -function parseWhile(var p: TParser): PNode; -begin - result := newNodeP(nkWhileStmt, p); - getTok(p); - optInd(p, result); - eat(p, tkParLe); - addSon(result, parseExpr(p)); - eat(p, tkParRi); - skipComment(p, result); - addSon(result, parseStmt(p)); -end; - -function parseCase(var p: TParser): PNode; -var - b: PNode; - inElif: bool; -begin - result := newNodeP(nkCaseStmt, p); - getTok(p); - eat(p, tkParLe); - addSon(result, parseExpr(p)); - eat(p, tkParRi); - skipComment(p, result); - inElif := false; - while true do begin - if p.tok.tokType = tkSad then getTok(p); - case p.tok.tokType of - tkOf: begin - if inElif then break; - b := newNodeP(nkOfBranch, p); - exprListAux(p, nkRange, tkColon, tkDotDot, b); - end; - tkElif: begin - inElif := true; - b := newNodeP(nkElifBranch, p); - getTok(p); - optInd(p, b); - addSon(b, parseExpr(p)); - eat(p, tkColon); - end; - tkElse: begin - b := newNodeP(nkElse, p); - getTok(p); - eat(p, tkColon); - end; - else break; - end; - skipComment(p, b); - addSon(b, parseStmt(p)); - addSon(result, b); - if b.kind = nkElse then break; - end -end; - -function parseTry(var p: TParser): PNode; -var - b: PNode; -begin - result := newNodeP(nkTryStmt, p); - getTok(p); - eat(p, tkColon); - skipComment(p, result); - addSon(result, parseStmt(p)); - b := nil; - while true do begin - if p.tok.tokType = tkSad then getTok(p); - case p.tok.tokType of - tkExcept: begin - b := newNodeP(nkExceptBranch, p); - qualifiedIdentListAux(p, tkColon, b); - end; - tkFinally: begin - b := newNodeP(nkFinally, p); - getTok(p); - eat(p, tkColon); - end; - else break; - end; - skipComment(p, b); - addSon(b, parseStmt(p)); - addSon(result, b); - if b.kind = nkFinally then break; - end; - if b = nil then parMessage(p, errTokenExpected, 'except'); -end; - -function parseFor(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkForStmt, p); - getTok(p); - optInd(p, result); - a := parseSymbol(p); - addSon(result, a); - while p.tok.tokType = tkComma do begin - getTok(p); - optInd(p, a); - a := parseSymbol(p); - addSon(result, a); - end; - eat(p, tkIn); - addSon(result, exprColonEqExpr(p, nkRange, tkDotDot)); - eat(p, tkColon); - skipComment(p, result); - addSon(result, parseStmt(p)) -end; - -function parseBlock(var p: TParser): PNode; -begin - result := newNodeP(nkBlockStmt, p); - getTok(p); - optInd(p, result); - case p.tok.tokType of - tkEof, tkSad, tkDed, tkColon: addSon(result, nil); - else addSon(result, parseSymbol(p)); - end; - eat(p, tkColon); - skipComment(p, result); - addSon(result, parseStmt(p)); -end; - -function parseAsm(var p: TParser): PNode; -begin - result := newNodeP(nkAsmStmt, p); - getTok(p); - optInd(p, result); - if p.tok.tokType = tkCurlyDotLe then addSon(result, parsePragma(p)) - else addSon(result, nil); - case p.tok.tokType of - tkStrLit: addSon(result, newStrNodeP(nkStrLit, p.tok.literal, p)); - tkRStrLit: addSon(result, newStrNodeP(nkRStrLit, p.tok.literal, p)); - tkTripleStrLit: - addSon(result, newStrNodeP(nkTripleStrLit, p.tok.literal, p)); - else begin - parMessage(p, errStringLiteralExpected); - addSon(result, nil); exit - end; - end; - getTok(p); -end; - -function parseGenericParamList(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkGenericParams, p); - getTok(p); - optInd(p, result); - while (p.tok.tokType = tkSymbol) or (p.tok.tokType = tkAccent) do begin - a := parseIdentColonEquals(p, {@set}[withBothOptional]); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, tkBracketRi); -end; - -function parseRoutine(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - addSon(result, identVis(p)); - if p.tok.tokType = tkBracketLe then addSon(result, parseGenericParamList(p)) - else addSon(result, nil); - addSon(result, parseParamList(p)); - if p.tok.tokType = tkCurlyDotLe then addSon(result, parsePragma(p)) - else addSon(result, nil); - if p.tok.tokType = tkEquals then begin - getTok(p); skipComment(p, result); - addSon(result, parseStmt(p)); - end - else - addSon(result, nil); - indAndComment(p, result); // XXX: document this in the grammar! -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; - -function parseSection(var p: TParser; kind: TNodeKind; - defparser: TDefParser): PNode; -var - a: PNode; -begin - result := newNodeP(kind, p); - getTok(p); - skipComment(p, result); - case p.tok.tokType of - tkInd: begin - pushInd(p.lex^, p.tok.indent); - getTok(p); skipComment(p, result); - while true do begin - case p.tok.tokType of - tkSad: getTok(p); - tkSymbol, tkAccent: begin - a := defparser(p); - skipComment(p, a); - addSon(result, a); - end; - tkDed: begin getTok(p); break end; - tkEof: break; // BUGFIX - tkComment: begin - a := newCommentStmt(p); - skipComment(p, a); - addSon(result, a); - end; - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - break - end - end - end; - popInd(p.lex^); - end; - tkSymbol, tkAccent, tkParLe: begin - // tkParLe is allowed for ``var (x, y) = ...`` tuple parsing - addSon(result, defparser(p)); - end - else parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - end -end; - -function parseConstant(var p: TParser): PNode; -begin - result := newNodeP(nkConstDef, p); - addSon(result, identWithPragma(p)); - if p.tok.tokType = tkColon then begin - getTok(p); optInd(p, result); - addSon(result, parseTypeDesc(p)); - end - else - addSon(result, nil); - eat(p, tkEquals); - optInd(p, result); - addSon(result, parseExpr(p)); - indAndComment(p, result); // XXX: special extension! -end; - -function parseConstSection(var p: TParser): PNode; -begin - result := newNodeP(nkConstSection, p); - getTok(p); - skipComment(p, result); - if p.tok.tokType = tkCurlyLe then begin - getTok(p); - skipComment(p, result); - while (p.tok.tokType <> tkCurlyRi) and (p.tok.tokType <> tkEof) do begin - addSon(result, parseConstant(p)) - end; - eat(p, tkCurlyRi); - end - else - addSon(result, parseConstant(p)); -end; - - -function parseEnum(var p: TParser): PNode; -var - a, b: PNode; -begin - result := newNodeP(nkEnumTy, p); - a := nil; - getTok(p); - optInd(p, result); - if p.tok.tokType = tkOf then begin - a := newNodeP(nkOfInherit, p); - getTok(p); optInd(p, a); - addSon(a, parseTypeDesc(p)); - addSon(result, a) - end - else addSon(result, nil); - - while true do begin - case p.tok.tokType of - tkEof, tkSad, tkDed: break; - else a := parseSymbol(p); - end; - optInd(p, a); - if p.tok.tokType = tkEquals then begin - getTok(p); - optInd(p, a); - b := a; - a := newNodeP(nkEnumFieldDef, p); - addSon(a, b); - addSon(a, parseExpr(p)); - skipComment(p, a); - end; - if p.tok.tokType = tkComma then begin - getTok(p); - optInd(p, a) - end; - addSon(result, a); - end -end; - -function parseObjectPart(var p: TParser): PNode; forward; - -function parseObjectWhen(var p: TParser): PNode; -var - branch: PNode; -begin - result := newNodeP(nkRecWhen, p); - while true do begin - getTok(p); // skip `when`, `elif` - branch := newNodeP(nkElifBranch, p); - optInd(p, branch); - addSon(branch, parseExpr(p)); - eat(p, tkColon); - skipComment(p, branch); - addSon(branch, parseObjectPart(p)); - skipComment(p, branch); - addSon(result, branch); - if p.tok.tokType <> tkElif then break - end; - if p.tok.tokType = tkElse then begin - branch := newNodeP(nkElse, p); - eat(p, tkElse); eat(p, tkColon); - skipComment(p, branch); - addSon(branch, parseObjectPart(p)); - addSon(result, branch); - end -end; - -function parseObjectCase(var p: TParser): PNode; -var - a, b: PNode; -begin - result := newNodeP(nkRecCase, p); - getTok(p); - a := newNodeP(nkIdentDefs, p); - addSon(a, identWithPragma(p)); - eat(p, tkColon); - addSon(a, parseTypeDesc(p)); - addSon(a, nil); - addSon(result, a); - skipComment(p, result); - while true do begin - if p.tok.tokType = tkSad then getTok(p); - case p.tok.tokType of - tkOf: begin - b := newNodeP(nkOfBranch, p); - exprListAux(p, nkRange, tkColon, tkDotDot, b); - end; - tkElse: begin - b := newNodeP(nkElse, p); - getTok(p); - eat(p, tkColon); - end; - else break; - end; - skipComment(p, b); - addSon(b, parseObjectPart(p)); - addSon(result, b); - if b.kind = nkElse then break; - end -end; - -function parseObjectPart(var p: TParser): PNode; -begin - case p.tok.tokType of - tkInd: begin - result := newNodeP(nkRecList, p); - pushInd(p.lex^, p.tok.indent); - getTok(p); skipComment(p, result); - while true do begin - case p.tok.tokType of - tkSad: getTok(p); - tkCase, tkWhen, tkSymbol, tkAccent, tkNil: begin - addSon(result, parseObjectPart(p)); - end; - tkDed: begin getTok(p); break end; - tkEof: break; - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - break - end - end - end; - popInd(p.lex^); - end; - tkWhen: result := parseObjectWhen(p); - tkCase: result := parseObjectCase(p); - tkSymbol, tkAccent: begin - result := parseIdentColonEquals(p, {@set}[withPragma]); - skipComment(p, result); - end; - tkNil: begin - result := newNodeP(nkNilLit, p); - getTok(p); - end; - else result := nil - end -end; - -function parseObject(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkObjectTy, p); - getTok(p); - if p.tok.tokType = tkCurlyDotLe then addSon(result, parsePragma(p)) - else addSon(result, nil); - if p.tok.tokType = tkOf then begin - a := newNodeP(nkOfInherit, p); - getTok(p); - addSon(a, parseTypeDesc(p)); - addSon(result, a); - end - else addSon(result, nil); - skipComment(p, result); - addSon(result, parseObjectPart(p)); -end; - -function parseDistinct(var p: TParser): PNode; -begin - result := newNodeP(nkDistinctTy, p); - getTok(p); - optInd(p, result); - addSon(result, parseTypeDesc(p)); -end; - -function parseTypeDef(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkTypeDef, p); - addSon(result, identWithPragma(p)); - if p.tok.tokType = tkBracketLe then addSon(result, parseGenericParamList(p)) - else addSon(result, nil); - if p.tok.tokType = tkEquals then begin - getTok(p); optInd(p, result); - case p.tok.tokType of - tkObject: a := parseObject(p); - tkEnum: a := parseEnum(p); - tkDistinct: a := parseDistinct(p); - else a := parseTypeDesc(p); - end; - addSon(result, a); - end - else - addSon(result, nil); - indAndComment(p, result); // special extension! -end; - -function parseVarTuple(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkVarTuple, p); - getTok(p); // skip '(' - optInd(p, result); - while (p.tok.tokType = tkSymbol) or (p.tok.tokType = tkAccent) do begin - a := identWithPragma(p); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - addSon(result, nil); // no type desc - optSad(p); - eat(p, tkParRi); - eat(p, tkEquals); - optInd(p, result); - addSon(result, parseExpr(p)); -end; - -function parseVariable(var p: TParser): PNode; -begin - if p.tok.tokType = tkParLe then - result := parseVarTuple(p) - else - result := parseIdentColonEquals(p, {@set}[withPragma]); - indAndComment(p, result); // special extension! -end; - -function simpleStmt(var p: TParser): PNode; -begin - case p.tok.tokType of - tkReturn: result := parseReturnOrRaise(p, nkReturnStmt); - tkRaise: result := parseReturnOrRaise(p, nkRaiseStmt); - tkYield: result := parseYieldOrDiscard(p, nkYieldStmt); - tkDiscard: result := parseYieldOrDiscard(p, nkDiscardStmt); - tkBreak: result := parseBreakOrContinue(p, nkBreakStmt); - tkContinue: result := parseBreakOrContinue(p, nkContinueStmt); - tkCurlyDotLe: result := parsePragma(p); - tkImport: result := parseImportOrIncludeStmt(p, nkImportStmt); - tkFrom: result := parseFromStmt(p); - tkInclude: result := parseImportOrIncludeStmt(p, nkIncludeStmt); - tkComment: result := newCommentStmt(p); - else begin - if isExprStart(p) then - result := parseExprStmt(p) - else - result := nil; - end - end; - if result <> nil then - skipComment(p, result); -end; - -function parseType(var p: TParser): PNode; -begin - result := newNodeP(nkTypeSection, p); - while true do begin - case p.tok.tokType of - tkComment: skipComment(p, result); - tkType: begin - // type alias: - - end; - tkEnum: begin end; - tkObject: begin end; - tkTuple: begin end; - else break; - end - end -end; - -function complexOrSimpleStmt(var p: TParser): PNode; -begin - case p.tok.tokType of - tkIf: result := parseIfOrWhen(p, nkIfStmt); - tkWhile: result := parseWhile(p); - tkCase: result := parseCase(p); - tkTry: result := parseTry(p); - tkFor: result := parseFor(p); - tkBlock: result := parseBlock(p); - tkAsm: result := parseAsm(p); - tkProc: result := parseRoutine(p, nkProcDef); - tkMethod: result := parseRoutine(p, nkMethodDef); - tkIterator: result := parseRoutine(p, nkIteratorDef); - tkMacro: result := parseRoutine(p, nkMacroDef); - tkTemplate: result := parseRoutine(p, nkTemplateDef); - tkConverter: result := parseRoutine(p, nkConverterDef); - tkType, tkEnum, tkObject, tkTuple: - result := nil; - //result := parseTypeAlias(p, nkTypeSection, parseTypeDef); - tkConst: result := parseConstSection(p); - tkWhen: result := parseIfOrWhen(p, nkWhenStmt); - tkVar: result := parseSection(p, nkVarSection, parseVariable); - else result := simpleStmt(p); - end -end; - -function parseStmt(var p: TParser): PNode; -var - a: PNode; -begin - if p.tok.tokType = tkCurlyLe then begin - result := newNodeP(nkStmtList, p); - getTok(p); - while true do begin - case p.tok.tokType of - tkSad, tkInd, tkDed: getTok(p); - tkEof, tkCurlyRi: break; - else begin - a := complexOrSimpleStmt(p); - if a = nil then break; - addSon(result, a); - end - end - end; - eat(p, tkCurlyRi); - end - else begin - // the case statement is only needed for better error messages: - case p.tok.tokType of - tkIf, tkWhile, tkCase, tkTry, tkFor, tkBlock, tkAsm, - tkProc, tkIterator, tkMacro, tkType, tkConst, tkWhen, tkVar: begin - parMessage(p, errComplexStmtRequiresInd); - result := nil - end - else begin - result := simpleStmt(p); - if result = nil then parMessage(p, errExprExpected, tokToStr(p.tok)); - if p.tok.tokType in [tkInd, tkDed, tkSad] then getTok(p); - end - end - end -end; - -function parseAll(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkStmtList, p); - while true do begin - case p.tok.tokType of - tkDed, tkInd, tkSad: getTok(p); - tkEof: break; - else begin - a := complexOrSimpleStmt(p); - if a = nil then parMessage(p, errExprExpected, tokToStr(p.tok)); - addSon(result, a); - end - end - end -end; - -function parseTopLevelStmt(var p: TParser): PNode; -begin - result := nil; - while true do begin - case p.tok.tokType of - tkDed, tkInd, tkSad: getTok(p); - tkEof: break; - else begin - result := complexOrSimpleStmt(p); - if result = nil then parMessage(p, errExprExpected, tokToStr(p.tok)); - break - end - end - end -end; - -end. diff --git a/nim/pendx.pas b/nim/pendx.pas deleted file mode 100755 index e23229e28..000000000 --- a/nim/pendx.pas +++ /dev/null @@ -1,36 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit pendx; - -{$include config.inc} - -interface - -uses - nsystem, llstream, scanner, idents, strutils, ast, msgs, pnimsyn; - -function ParseAll(var p: TParser): PNode; - -function parseTopLevelStmt(var p: TParser): PNode; -// implements an iterator. Returns the next top-level statement or nil if end -// of stream. - -implementation - -function ParseAll(var p: TParser): PNode; -begin - result := nil -end; - -function parseTopLevelStmt(var p: TParser): PNode; -begin - result := nil -end; - -end. diff --git a/nim/platform.pas b/nim/platform.pas deleted file mode 100755 index c2fa711b9..000000000 --- a/nim/platform.pas +++ /dev/null @@ -1,662 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit platform; - -// This module contains data about the different processors -// 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 excentric platform! - -interface - -{$include 'config.inc'} - -uses - nsystem, strutils; - -type - TSystemOS = ( - // Also add OS in initialization section and alias conditionals to - // condsyms (end of module). - osNone, - osDos, - osWindows, - osOs2, - osLinux, - osMorphos, - osSkyos, - osSolaris, - osIrix, - osNetbsd, - osFreebsd, - osOpenbsd, - osAix, - osPalmos, - osQnx, - osAmiga, - osAtari, - osNetware, - osMacos, - osMacosx, - osEcmaScript, - osNimrodVM - ); -type - TInfoOSProp = ( - ospNeedsPIC, // OS needs PIC for libraries - ospCaseInsensitive, // OS filesystem is case insensitive - ospPosix // OS is posix-like - ); - - TInfoOSProps = set of TInfoOSProp; - TInfoOS = record{@tuple} - name: string; - parDir: string; - dllFrmt: string; - altDirSep: string; - objExt: string; - newLine: string; - pathSep: string; - dirSep: string; - scriptExt: string; - curDir: string; - exeExt: string; - extSep: string; - props: TInfoOSProps; - end; -const - OS: array [succ(low(TSystemOS))..high(TSystemOS)] of TInfoOS = ( - ( - name: 'DOS'; - parDir: '..'; - dllFrmt: '$1.dll'; - altDirSep: '/'+''; - objExt: '.obj'; - newLine: #13#10; - pathSep: ';'+''; - dirSep: '\'+''; - scriptExt: '.bat'; - curDir: '.'+''; - exeExt: '.exe'; - extSep: '.'+''; - props: {@set}[ospCaseInsensitive]; - ), - ( - name: 'Windows'; - parDir: '..'; - dllFrmt: '$1.dll'; - altDirSep: '/'+''; - objExt: '.obj'; - newLine: #13#10; - pathSep: ';'+''; - dirSep: '\'+''; - scriptExt: '.bat'; - curDir: '.'+''; - exeExt: '.exe'; - extSep: '.'+''; - props: {@set}[ospCaseInsensitive]; - ), - ( - name: 'OS2'; - parDir: '..'; - dllFrmt: '$1.dll'; - altDirSep: '/'+''; - objExt: '.obj'; - newLine: #13#10; - pathSep: ';'+''; - dirSep: '\'+''; - scriptExt: '.bat'; - curDir: '.'+''; - exeExt: '.exe'; - extSep: '.'+''; - props: {@set}[ospCaseInsensitive]; - ), - ( - name: 'Linux'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'MorphOS'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'SkyOS'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'Solaris'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'Irix'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'NetBSD'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'FreeBSD'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'OpenBSD'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'AIX'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'PalmOS'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC]; - ), - ( - name: 'QNX'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'Amiga'; - parDir: '..'; - dllFrmt: '$1.library'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC]; - ), - ( - name: 'Atari'; - parDir: '..'; - dllFrmt: '$1.dll'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: ''; - curDir: '.'+''; - exeExt: '.tpp'; - extSep: '.'+''; - props: {@set}[ospNeedsPIC]; - ), - ( - name: 'Netware'; - parDir: '..'; - dllFrmt: '$1.nlm'; - altDirSep: '/'+''; - objExt: ''; - newLine: #13#10; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: '.nlm'; - extSep: '.'+''; - props: {@set}[ospCaseInsensitive]; - ), - ( - name: 'MacOS'; - parDir: '::'; - dllFrmt: '$1Lib'; - altDirSep: ':'+''; - objExt: '.o'; - newLine: #13+''; - pathSep: ','+''; - dirSep: ':'+''; - scriptExt: ''; - curDir: ':'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospCaseInsensitive]; - ), - ( - name: 'MacOSX'; - parDir: '..'; - dllFrmt: 'lib$1.dylib'; - altDirSep: ':'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[ospNeedsPIC, ospPosix]; - ), - ( - name: 'EcmaScript'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[]; - ), - ( - name: 'NimrodVM'; - parDir: '..'; - dllFrmt: 'lib$1.so'; - altDirSep: '/'+''; - objExt: '.o'; - newLine: #10+''; - pathSep: ':'+''; - dirSep: '/'+''; - scriptExt: '.sh'; - curDir: '.'+''; - exeExt: ''; - extSep: '.'+''; - props: {@set}[]; - ) -); -type - TSystemCPU = ( - // Also add CPU for in initialization section and alias conditionals to - // condsyms (end of module). - cpuNone, - cpuI386, - cpuM68k, - cpuAlpha, - cpuPowerpc, - cpuSparc, - cpuVm, - cpuIa64, - cpuAmd64, - cpuMips, - cpuArm, - cpuEcmaScript, - cpuNimrodVM - ); -type - TEndian = (littleEndian, bigEndian); - TInfoCPU = record{@tuple} - name: string; - intSize: int; - endian: TEndian; - floatSize: int; - bit: int; - end; -const - EndianToStr: array [TEndian] of string = ('littleEndian', 'bigEndian'); - CPU: array [succ(low(TSystemCPU))..high(TSystemCPU)] of TInfoCPU = ( - ( - name: 'i386'; - intSize: 32; - endian: littleEndian; - floatSize: 64; - bit: 32; - ), - ( - name: 'm68k'; - intSize: 32; - endian: bigEndian; - floatSize: 64; - bit: 32; - ), - ( - name: 'alpha'; - intSize: 64; - endian: littleEndian; - floatSize: 64; - bit: 64; - ), - ( - name: 'powerpc'; - intSize: 32; - endian: bigEndian; - floatSize: 64; - bit: 32; - ), - ( - name: 'sparc'; - intSize: 32; - endian: bigEndian; - floatSize: 64; - bit: 32; - ), - ( - name: 'vm'; - intSize: 32; - endian: littleEndian; - floatSize: 64; - bit: 32; - ), - ( - name: 'ia64'; - intSize: 64; - endian: littleEndian; - floatSize: 64; - bit: 64; - ), - ( - name: 'amd64'; - intSize: 64; - endian: littleEndian; - floatSize: 64; - bit: 64; - ), - ( - name: 'mips'; - intSize: 32; - endian: bigEndian; - floatSize: 64; - bit: 32; - ), - ( - name: 'arm'; - intSize: 32; - endian: littleEndian; - floatSize: 64; - bit: 32; - ), - ( - name: 'ecmascript'; - intSize: 32; - endian: bigEndian; - floatSize: 64; - bit: 32; - ), - ( - name: 'nimrodvm'; - intSize: 32; - endian: bigEndian; - floatSize: 64; - bit: 32; - ) -); - -var - targetCPU, hostCPU: TSystemCPU; - targetOS, hostOS: TSystemOS; - -function NameToOS(const name: string): TSystemOS; -function NameToCPU(const name: string): TSystemCPU; - -var - IntSize: int; - floatSize: int; - PtrSize: int; - tnl: string; // target newline - -procedure setTarget(o: TSystemOS; c: TSystemCPU); - -implementation - -procedure setTarget(o: TSystemOS; c: TSystemCPU); -begin - assert(c <> cpuNone); - assert(o <> osNone); - targetCPU := c; - targetOS := o; - intSize := cpu[c].intSize div 8; - floatSize := cpu[c].floatSize div 8; - ptrSize := cpu[c].bit div 8; - tnl := os[o].newLine; -end; - -function NameToOS(const name: string): TSystemOS; -var - i: TSystemOS; -begin - for i := succ(osNone) to high(TSystemOS) do - if cmpIgnoreStyle(name, OS[i].name) = 0 then begin - result := i; exit - end; - result := osNone -end; - -function NameToCPU(const name: string): TSystemCPU; -var - i: TSystemCPU; -begin - for i := succ(cpuNone) to high(TSystemCPU) do - if cmpIgnoreStyle(name, CPU[i].name) = 0 then begin - result := i; exit - end; - result := cpuNone -end; - -// this is Ok for the Pascal version, but the Nimrod version needs a different -// mechanism -{@emit -procedure nimCPU(): cstring; importc; noconv;} -{@emit -procedure nimOS(): cstring; importc; noconv;} - -{@ignore} -initialization -{$ifdef i386} - hostCPU := cpuI386; -{$endif} -{$ifdef m68k} - hostCPU := cpuM68k; -{$endif} -{$ifdef alpha} - hostCPU := cpuAlpha; -{$endif} -{$ifdef powerpc} - hostCPU := cpuPowerpc; -{$endif} -{$ifdef sparc} - hostCPU := cpuSparc; -{$endif} -{$ifdef vm} - hostCPU := cpuVm; -{$endif} -{$ifdef ia64} - hostCPU := cpuIa64; -{$endif} -{$ifdef amd64} - hostCPU := cpuAmd64; -{$endif} -{$ifdef mips} - hostCPU := cpuMips; -{$endif} -{$ifdef arm} - hostCPU := cpuArm; -{$endif} -{$ifdef DOS} - hostOS := osDOS; -{$endif} -{$ifdef Windows} - hostOS := osWindows; -{$endif} -{$ifdef OS2} - hostOS := osOS2; -{$endif} -{$ifdef Linux} - hostOS := osLinux; -{$endif} -{$ifdef MorphOS} - hostOS := osMorphOS; -{$endif} -{$ifdef SkyOS} - hostOS := osSkyOS; -{$endif} -{$ifdef Solaris} - hostOS := osSolaris; -{$endif} -{$ifdef Irix} - hostOS := osIrix; -{$endif} -{$ifdef NetBSD} - hostOS := osNetBSD; -{$endif} -{$ifdef FreeBSD} - hostOS := osFreeBSD; -{$endif} -{$ifdef OpenBSD} - hostOS := osOpenBSD; -{$endif} -{$ifdef PalmOS} - hostOS := osPalmOS; -{$endif} -{$ifdef QNX} - hostOS := osQNX; -{$endif} -{$ifdef Amiga} - hostOS := osAmiga; -{$endif} -{$ifdef Atari} - hostOS := osAtari; -{$endif} -{$ifdef Netware} - hostOS := osNetware; -{$endif} -{$ifdef MacOS} - hostOS := osMacOS; -{$endif} -{$ifdef MacOSX} - hostOS := osMacOSX; -{$endif} -{$ifdef darwin} // BUGFIX - hostOS := osMacOSX; -{$endif} -{@emit - hostCPU := nameToCPU(toString(nimCPU())); -} -{@emit - hostOS := nameToOS(toString(nimOS())); -} - setTarget(hostOS, hostCPU); // assume no cross-compiling -end. diff --git a/nim/pnimsyn.pas b/nim/pnimsyn.pas deleted file mode 100755 index 260d1e5a5..000000000 --- a/nim/pnimsyn.pas +++ /dev/null @@ -1,1802 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// 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. -// The parser strictly reflects the grammar ("doc/grammar.txt"); however -// it uses several helper routines to keep the parser small. A special -// efficient algorithm is used for the precedence levels. The parser here can -// be seen as a refinement of the grammar, as it specifies how the AST is build -// from the grammar and how comments belong to the AST. - -{$include config.inc} - -interface - -uses - 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; // the lexer that is used for parsing - tok: PToken; // the current token - end; - -function ParseAll(var p: TParser): PNode; - -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. - - -// helpers for the other parsers -function getPrecedence(tok: PToken): int; -function isOperator(tok: PToken): bool; - -procedure getTok(var p: TParser); - -procedure parMessage(const p: TParser; const msg: TMsgKind; - const arg: string = ''); -procedure skipComment(var p: TParser; node: PNode); - -function newNodeP(kind: TNodeKind; const p: TParser): PNode; -function newIntNodeP(kind: TNodeKind; const intVal: BiggestInt; - const p: TParser): PNode; -function newFloatNodeP(kind: TNodeKind; const floatVal: BiggestFloat; - const p: TParser): PNode; -function newStrNodeP(kind: TNodeKind; const strVal: string; - const p: TParser): PNode; -function newIdentNodeP(ident: PIdent; const p: TParser): PNode; - -procedure expectIdentOrKeyw(const p: TParser); -procedure ExpectIdent(const p: TParser); -procedure expectIdentOrOpr(const p: TParser); -function parLineInfo(const p: TParser): TLineInfo; -procedure Eat(var p: TParser; TokType: TTokType); - -procedure skipInd(var p: TParser); -procedure optSad(var p: TParser); -procedure optInd(var p: TParser; n: PNode); -procedure indAndComment(var p: TParser; n: PNode); - -procedure setBaseFlags(n: PNode; base: TNumericalBase); - -function parseSymbol(var p: TParser): PNode; -function accExpr(var p: TParser): PNode; - - -implementation - -procedure initParser(var p: TParser); -begin -{@ignore} - FillChar(p, sizeof(p), 0); -{@emit} - new(p.lex); -{@ignore} - fillChar(p.lex^, sizeof(p.lex^), 0); -{@emit} - new(p.tok); -{@ignore} - fillChar(p.tok^, sizeof(p.tok^), 0); -{@emit} -end; - -procedure getTok(var p: TParser); -begin - rawGetTok(p.lex^, p.tok^); -end; - -procedure OpenParser(var p: TParser; const filename: string; - inputStream: PLLStream); -begin - initParser(p); - OpenLexer(p.lex^, filename, inputstream); - getTok(p); // read the first token -end; - -procedure CloseParser(var p: TParser); -begin - CloseLexer(p.lex^); -{@ignore} - dispose(p.lex); -{@emit} -end; - -// ---------------- parser helpers -------------------------------------------- - -procedure parMessage(const p: TParser; const msg: TMsgKind; - const arg: string = ''); -begin - lexMessage(p.lex^, msg, arg); -end; - -procedure skipComment(var p: TParser; node: PNode); -begin - if p.tok.tokType = tkComment then begin - if node <> nil then begin - if node.comment = snil then node.comment := ''; - add(node.comment, p.tok.literal); - end - else - parMessage(p, errInternal, 'skipComment'); - getTok(p); - end -end; - -procedure skipInd(var p: TParser); -begin - if p.tok.tokType = tkInd then getTok(p) -end; - -procedure optSad(var p: TParser); -begin - if p.tok.tokType = tkSad then getTok(p) -end; - -procedure optInd(var p: TParser; n: PNode); -begin - skipComment(p, n); - skipInd(p); -end; - -procedure expectIdentOrKeyw(const p: TParser); -begin - if (p.tok.tokType <> tkSymbol) and not isKeyword(p.tok.tokType) then - lexMessage(p.lex^, errIdentifierExpected, tokToStr(p.tok)); -end; - -procedure ExpectIdent(const p: TParser); -begin - if p.tok.tokType <> tkSymbol then - lexMessage(p.lex^, errIdentifierExpected, tokToStr(p.tok)); -end; - -procedure expectIdentOrOpr(const p: TParser); -begin - if not (p.tok.tokType in tokOperators) then - lexMessage(p.lex^, errOperatorExpected, tokToStr(p.tok)); -end; - -procedure Eat(var p: TParser; TokType: TTokType); -begin - if p.tok.TokType = TokType then getTok(p) - else lexMessage(p.lex^, errTokenExpected, TokTypeToStr[tokType]) -end; - -function parLineInfo(const p: TParser): TLineInfo; -begin - result := getLineInfo(p.lex^) -end; - -procedure indAndComment(var p: TParser; n: PNode); -var - info: TLineInfo; -begin - if p.tok.tokType = tkInd then begin - info := parLineInfo(p); - getTok(p); - if p.tok.tokType = tkComment then skipComment(p, n) - else liMessage(info, errInvalidIndentation); - end - else skipComment(p, n); -end; - -// ---------------------------------------------------------------------------- - -function newNodeP(kind: TNodeKind; const p: TParser): PNode; -begin - result := newNodeI(kind, getLineInfo(p.lex^)); -end; - -function newIntNodeP(kind: TNodeKind; const intVal: BiggestInt; - const p: TParser): PNode; -begin - result := newNodeP(kind, p); - result.intVal := intVal; -end; - -function newFloatNodeP(kind: TNodeKind; const floatVal: BiggestFloat; - const p: TParser): PNode; -begin - result := newNodeP(kind, p); - result.floatVal := floatVal; -end; - -function newStrNodeP(kind: TNodeKind; const strVal: string; - const p: TParser): PNode; -begin - result := newNodeP(kind, p); - result.strVal := strVal; -end; - -function newIdentNodeP(ident: PIdent; const p: TParser): PNode; -begin - result := newNodeP(nkIdent, p); - result.ident := ident; -end; - -// ------------------- Expression parsing ------------------------------------ - -function parseExpr(var p: TParser): PNode; forward; -function parseStmt(var p: TParser): PNode; forward; - -function parseTypeDesc(var p: TParser): PNode; forward; -function parseParamList(var p: TParser): PNode; forward; - -function getPrecedence(tok: PToken): int; -begin - case tok.tokType of - tkOpr: begin - case tok.ident.s[strStart] of - '$': result := 7; - '*', '%', '/', '\': result := 6; - '+', '-', '~', '|': result := 5; - '&': result := 4; - '=', '<', '>', '!': result := 3; - else result := 0 - end - end; - tkDiv, tkMod, tkShl, tkShr: result := 6; - tkIn, tkNotIn, tkIs, tkIsNot: result := 3; - tkAnd: result := 2; - tkOr, tkXor: result := 1; - else result := -1; - end; -end; - -function isOperator(tok: PToken): bool; -begin - result := getPrecedence(tok) >= 0 -end; - -function parseSymbol(var p: TParser): PNode; -var - s: string; - id: PIdent; -begin - case p.tok.tokType of - tkSymbol: begin - result := newIdentNodeP(p.tok.ident, p); - getTok(p); - end; - tkAccent: begin - result := newNodeP(nkAccQuoted, p); - getTok(p); - case p.tok.tokType of - tkBracketLe: begin - s := '['+''; - getTok(p); - if (p.tok.tokType = tkOpr) and (p.tok.ident.s = '$'+'') then begin - s := s + '$..'; - getTok(p); - eat(p, tkDotDot); - if (p.tok.tokType = tkOpr) and (p.tok.ident.s = '$'+'') then begin - 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 - addChar(s, '$'); - getTok(p); - end; - end; - eat(p, tkBracketRi); - addChar(s, ']'); - if p.tok.tokType = tkEquals then begin - addChar(s, '='); getTok(p); - end; - addSon(result, newIdentNodeP(getIdent(s), p)); - end; - tkParLe: begin - addSon(result, newIdentNodeP(getIdent('()'), p)); - getTok(p); - eat(p, tkParRi); - end; - tokKeywordLow..tokKeywordHigh, tkSymbol, tkOpr: begin - id := p.tok.ident; - getTok(p); - if p.tok.tokType = tkEquals then begin - addSon(result, newIdentNodeP(getIdent(id.s + '='), p)); - getTok(p); - end - else - addSon(result, newIdentNodeP(id, p)); - end; - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - result := nil - end - end; - eat(p, tkAccent); - end - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - result := nil - end - end -end; - -function accExpr(var p: TParser): PNode; -var - x, y: PNode; -begin - result := newNodeP(nkAccQuoted, p); - getTok(p); // skip ` - x := nil; - y := nil; - case p.tok.tokType of - tkSymbol, tkOpr, tokKeywordLow..tokKeywordHigh: begin - x := newIdentNodeP(p.tok.ident, p); - getTok(p); - end - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - end - end; - if p.tok.tokType = tkDot then begin - getTok(p); - case p.tok.tokType of - tkSymbol, tkOpr, tokKeywordLow..tokKeywordHigh: begin - y := newNodeP(nkDotExpr, p); - addSon(y, x); - addSon(y, newIdentNodeP(p.tok.ident, p)); - getTok(p); - x := y; - end - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - end - end; - end; - addSon(result, x); - eat(p, tkAccent); -end; - -function optExpr(var p: TParser): PNode; // [expr] -begin - if (p.tok.tokType <> tkComma) and (p.tok.tokType <> tkBracketRi) - and (p.tok.tokType <> tkDotDot) then - result := parseExpr(p) - else - result := nil; -end; - -function dotdotExpr(var p: TParser; first: PNode = nil): PNode; -begin - result := newNodeP(nkRange, p); - addSon(result, first); - getTok(p); - optInd(p, result); - addSon(result, optExpr(p)); -end; - -function indexExpr(var p: TParser): PNode; -// indexExpr ::= '..' [expr] | expr ['=' expr | '..' expr] -var - a, b: PNode; -begin - if p.tok.tokType = tkDotDot then - result := dotdotExpr(p) - else begin - a := parseExpr(p); - case p.tok.tokType of - tkEquals: begin - result := newNodeP(nkExprEqExpr, p); - addSon(result, a); - getTok(p); - if p.tok.tokType = tkDotDot then - addSon(result, dotdotExpr(p)) - else begin - b := parseExpr(p); - if p.tok.tokType = tkDotDot then b := dotdotExpr(p, b); - addSon(result, b); - end - end; - tkDotDot: result := dotdotExpr(p, a); - else result := a - end - end -end; - -function indexExprList(var p: TParser; first: PNode): PNode; -var - a: PNode; -begin - result := newNodeP(nkBracketExpr, p); - addSon(result, first); - getTok(p); - optInd(p, result); - while (p.tok.tokType <> tkBracketRi) and (p.tok.tokType <> tkEof) - and (p.tok.tokType <> tkSad) do begin - a := indexExpr(p); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, tkBracketRi); -end; - -function exprColonEqExpr(var p: TParser; kind: TNodeKind; - tok: TTokType): PNode; -var - a: PNode; -begin - a := parseExpr(p); - if p.tok.tokType = tok then begin - result := newNodeP(kind, p); - getTok(p); - //optInd(p, result); - addSon(result, a); - addSon(result, parseExpr(p)); - end - else - result := a -end; - -procedure exprListAux(var p: TParser; elemKind: TNodeKind; - endTok, sepTok: TTokType; result: PNode); -var - a: PNode; -begin - getTok(p); - optInd(p, result); - while (p.tok.tokType <> endTok) and (p.tok.tokType <> tkEof) do begin - a := exprColonEqExpr(p, elemKind, sepTok); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - eat(p, endTok); -end; - -function qualifiedIdent(var p: TParser): PNode; -var - a: PNode; -begin - result := parseSymbol(p); - //optInd(p, result); - if p.tok.tokType = tkDot then begin - getTok(p); - optInd(p, result); - a := result; - result := newNodeI(nkDotExpr, a.info); - addSon(result, a); - addSon(result, parseSymbol(p)); - end; -end; - -procedure qualifiedIdentListAux(var p: TParser; endTok: TTokType; - result: PNode); -var - a: PNode; -begin - getTok(p); - optInd(p, result); - while (p.tok.tokType <> endTok) and (p.tok.tokType <> tkEof) do begin - a := qualifiedIdent(p); - addSon(result, a); - //optInd(p, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - eat(p, endTok); -end; - -procedure exprColonEqExprListAux(var p: TParser; elemKind: TNodeKind; - endTok, sepTok: TTokType; result: PNode); -var - a: PNode; -begin - getTok(p); - optInd(p, result); - while (p.tok.tokType <> endTok) and (p.tok.tokType <> tkEof) - and (p.tok.tokType <> tkSad) do begin - a := exprColonEqExpr(p, elemKind, sepTok); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, endTok); -end; - -function exprColonEqExprList(var p: TParser; kind, elemKind: TNodeKind; - endTok, sepTok: TTokType): PNode; -begin - result := newNodeP(kind, p); - exprColonEqExprListAux(p, elemKind, endTok, sepTok, result); -end; - -function parseCast(var p: TParser): PNode; -begin - result := newNodeP(nkCast, p); - getTok(p); - eat(p, tkBracketLe); - optInd(p, result); - addSon(result, parseTypeDesc(p)); - optSad(p); - eat(p, tkBracketRi); - eat(p, tkParLe); - optInd(p, result); - addSon(result, parseExpr(p)); - optSad(p); - eat(p, tkParRi); -end; - -function parseAddr(var p: TParser): PNode; -begin - result := newNodeP(nkAddr, p); - getTok(p); - eat(p, tkParLe); - optInd(p, result); - addSon(result, parseExpr(p)); - optSad(p); - eat(p, tkParRi); -end; - -procedure setBaseFlags(n: PNode; base: TNumericalBase); -begin - case base of - base10: begin end; - base2: include(n.flags, nfBase2); - base8: include(n.flags, nfBase8); - base16: include(n.flags, nfBase16); - end -end; - -function identOrLiteral(var p: TParser): PNode; -begin - case p.tok.tokType of - tkSymbol: begin - result := newIdentNodeP(p.tok.ident, p); - getTok(p) - end; - tkAccent: result := accExpr(p); - // literals - tkIntLit: begin - result := newIntNodeP(nkIntLit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkInt8Lit: begin - result := newIntNodeP(nkInt8Lit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkInt16Lit: begin - result := newIntNodeP(nkInt16Lit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkInt32Lit: begin - result := newIntNodeP(nkInt32Lit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkInt64Lit: begin - result := newIntNodeP(nkInt64Lit, p.tok.iNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkFloatLit: begin - result := newFloatNodeP(nkFloatLit, p.tok.fNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkFloat32Lit: begin - result := newFloatNodeP(nkFloat32Lit, p.tok.fNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkFloat64Lit: begin - result := newFloatNodeP(nkFloat64Lit, p.tok.fNumber, p); - setBaseFlags(result, p.tok.base); - getTok(p); - end; - tkStrLit: begin - result := newStrNodeP(nkStrLit, p.tok.literal, p); - getTok(p); - end; - tkRStrLit: begin - result := newStrNodeP(nkRStrLit, p.tok.literal, p); - getTok(p); - end; - tkTripleStrLit: begin - result := newStrNodeP(nkTripleStrLit, p.tok.literal, p); - getTok(p); - end; - tkCallRStrLit: begin - result := newNodeP(nkCallStrLit, p); - addSon(result, newIdentNodeP(p.tok.ident, p)); - addSon(result, newStrNodeP(nkRStrLit, p.tok.literal, p)); - getTok(p); - end; - tkCallTripleStrLit: begin - result := newNodeP(nkCallStrLit, p); - addSon(result, newIdentNodeP(p.tok.ident, p)); - addSon(result, newStrNodeP(nkTripleStrLit, p.tok.literal, p)); - getTok(p); - end; - tkCharLit: begin - result := newIntNodeP(nkCharLit, ord(p.tok.literal[strStart]), p); - getTok(p); - end; - tkNil: begin - result := newNodeP(nkNilLit, p); - getTok(p); - end; - tkParLe: begin // () constructor - result := exprColonEqExprList(p, nkPar, nkExprColonExpr, tkParRi, - tkColon); - end; - tkCurlyLe: begin // {} constructor - result := exprColonEqExprList(p, nkCurly, nkRange, tkCurlyRi, tkDotDot); - end; - tkBracketLe: begin // [] constructor - result := exprColonEqExprList(p, nkBracket, nkExprColonExpr, tkBracketRi, - tkColon); - end; - tkCast: result := parseCast(p); - tkAddr: result := parseAddr(p); - else begin - parMessage(p, errExprExpected, tokToStr(p.tok)); - getTok(p); // we must consume a token here to prevend endless loops! - result := nil - end - end -end; - -function primary(var p: TParser): PNode; -var - a: PNode; -begin - // prefix operator? - if (p.tok.tokType = tkNot) or (p.tok.tokType = tkOpr) then begin - result := newNodeP(nkPrefix, p); - a := newIdentNodeP(p.tok.ident, p); - addSon(result, a); - getTok(p); - optInd(p, a); - addSon(result, primary(p)); - exit - end - else if p.tok.tokType = tkBind then begin - result := newNodeP(nkBind, p); - getTok(p); - optInd(p, result); - addSon(result, primary(p)); - exit - end; - result := identOrLiteral(p); - while true do begin - case p.tok.tokType of - tkParLe: begin - a := result; - result := newNodeP(nkCall, p); - addSon(result, a); - exprColonEqExprListAux(p, nkExprEqExpr, tkParRi, tkEquals, result); - end; - tkDot: begin - a := result; - result := newNodeP(nkDotExpr, p); - addSon(result, a); - getTok(p); // skip '.' - optInd(p, result); - addSon(result, parseSymbol(p)); - end; - tkHat: begin - a := result; - result := newNodeP(nkDerefExpr, p); - addSon(result, a); - getTok(p); - end; - tkBracketLe: result := indexExprList(p, result); - else break - end - end -end; - -function lowestExprAux(var p: TParser; out v: PNode; limit: int): PToken; -var - op, nextop: PToken; - opPred: int; - v2, node, opNode: PNode; -begin - v := primary(p); - // expand while operators have priorities higher than 'limit' - op := p.tok; - opPred := getPrecedence(p.tok); - while (opPred > limit) do begin - node := newNodeP(nkInfix, p); - opNode := newIdentNodeP(op.ident, p); - // skip operator: - getTok(p); - optInd(p, opNode); - - // read sub-expression with higher priority - nextop := lowestExprAux(p, v2, opPred); - addSon(node, opNode); - addSon(node, v); - addSon(node, v2); - v := node; - op := nextop; - opPred := getPrecedence(nextop); - end; - result := op; // return first untreated operator -end; - -function lowestExpr(var p: TParser): PNode; -begin -{@discard} lowestExprAux(p, result, -1); -end; - -function parseIfExpr(var p: TParser): PNode; -var - branch: PNode; -begin - result := newNodeP(nkIfExpr, p); - while true do begin - getTok(p); // skip `if`, `elif` - branch := newNodeP(nkElifExpr, p); - addSon(branch, parseExpr(p)); - eat(p, tkColon); - addSon(branch, parseExpr(p)); - addSon(result, branch); - if p.tok.tokType <> tkElif then break - end; - branch := newNodeP(nkElseExpr, p); - eat(p, tkElse); eat(p, tkColon); - addSon(branch, parseExpr(p)); - addSon(result, branch); -end; - -function parsePragma(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkPragma, p); - getTok(p); - optInd(p, result); - while (p.tok.tokType <> tkCurlyDotRi) and (p.tok.tokType <> tkCurlyRi) - and (p.tok.tokType <> tkEof) and (p.tok.tokType <> tkSad) do begin - a := exprColonEqExpr(p, nkExprColonExpr, tkColon); - addSon(result, a); - if p.tok.tokType = tkComma then begin - getTok(p); - optInd(p, a) - end - end; - optSad(p); - if (p.tok.tokType = tkCurlyDotRi) or (p.tok.tokType = tkCurlyRi) then - getTok(p) - else - parMessage(p, errTokenExpected, '.}'); -end; - -function identVis(var p: TParser): PNode; // identifier with visability -var - a: PNode; -begin - a := parseSymbol(p); - if p.tok.tokType = tkOpr then begin - result := newNodeP(nkPostfix, p); - addSon(result, newIdentNodeP(p.tok.ident, p)); - addSon(result, a); - getTok(p); - end - else - result := a; -end; - -function identWithPragma(var p: TParser): PNode; -var - a: PNode; -begin - a := identVis(p); - if p.tok.tokType = tkCurlyDotLe then begin - result := newNodeP(nkPragmaExpr, p); - addSon(result, a); - addSon(result, parsePragma(p)); - end - else - result := a -end; - -type - TDeclaredIdentFlag = ( - withPragma, // identifier may have pragma - withBothOptional // both ':' and '=' parts are optional - ); - TDeclaredIdentFlags = set of TDeclaredIdentFlag; - -function parseIdentColonEquals(var p: TParser; - flags: TDeclaredIdentFlags): PNode; -var - a: PNode; -begin - result := newNodeP(nkIdentDefs, p); - while true do begin - case p.tok.tokType of - tkSymbol, tkAccent: begin - if withPragma in flags then - a := identWithPragma(p) - else - a := parseSymbol(p); - if a = nil then exit; - end; - else break; - end; - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - if p.tok.tokType = tkColon then begin - getTok(p); optInd(p, result); - addSon(result, parseTypeDesc(p)); - end - else begin - addSon(result, nil); - if (p.tok.tokType <> tkEquals) and not (withBothOptional in flags) then - parMessage(p, errColonOrEqualsExpected, tokToStr(p.tok)) - end; - if p.tok.tokType = tkEquals then begin - getTok(p); optInd(p, result); - addSon(result, parseExpr(p)); - end - else - addSon(result, nil); -end; - -function parseTuple(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkTupleTy, p); - getTok(p); - eat(p, tkBracketLe); - optInd(p, result); - while (p.tok.tokType = tkSymbol) or (p.tok.tokType = tkAccent) do begin - a := parseIdentColonEquals(p, {@set}[]); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, tkBracketRi); -end; - -function parseParamList(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkFormalParams, p); - addSon(result, nil); // return type - if p.tok.tokType = tkParLe then begin - getTok(p); - optInd(p, result); - while true do begin - case p.tok.tokType of - tkSymbol, tkAccent: a := parseIdentColonEquals(p, {@set}[]); - tkParRi: break; - else begin parMessage(p, errTokenExpected, ')'+''); break; end; - end; - //optInd(p, a); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, tkParRi); - end; - if p.tok.tokType = tkColon then begin - getTok(p); - optInd(p, result); - result.sons[0] := parseTypeDesc(p) - end -end; - -function parseProcExpr(var p: TParser; isExpr: bool): PNode; -// either a proc type or a anonymous proc -var - pragmas, params: PNode; - info: TLineInfo; -begin - info := parLineInfo(p); - getTok(p); - params := parseParamList(p); - if p.tok.tokType = tkCurlyDotLe then pragmas := parsePragma(p) - else pragmas := nil; - if (p.tok.tokType = tkEquals) and isExpr then begin - result := newNodeI(nkLambda, info); - addSon(result, nil); // no name part - addSon(result, nil); // no generic parameters - addSon(result, params); - addSon(result, pragmas); - getTok(p); skipComment(p, result); - addSon(result, parseStmt(p)); - end - else begin - result := newNodeI(nkProcTy, info); - addSon(result, params); - addSon(result, pragmas); - end -end; - -function parseTypeDescKAux(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - addSon(result, parseTypeDesc(p)); -end; - -function parseExpr(var p: TParser): PNode; -(* -expr ::= lowestExpr - | 'if' expr ':' expr ('elif' expr ':' expr)* 'else' ':' expr - | 'var' expr - | 'ref' expr - | 'ptr' expr - | 'type' expr - | 'tuple' tupleDesc - | 'proc' paramList [pragma] ['=' stmt] -*) -begin - case p.tok.toktype of - tkVar: result := parseTypeDescKAux(p, nkVarTy); - tkRef: result := parseTypeDescKAux(p, nkRefTy); - tkPtr: result := parseTypeDescKAux(p, nkPtrTy); - tkType: result := parseTypeDescKAux(p, nkTypeOfExpr); - tkTuple: result := parseTuple(p); - tkProc: result := parseProcExpr(p, true); - tkIf: result := parseIfExpr(p); - else result := lowestExpr(p); - end -end; - -function parseTypeDesc(var p: TParser): PNode; -begin - if p.tok.toktype = tkProc then result := parseProcExpr(p, false) - else result := parseExpr(p); -end; - -// ---------------------- statement parser ------------------------------------ -function isExprStart(const p: TParser): bool; -begin - case p.tok.tokType of - tkSymbol, tkAccent, tkOpr, tkNot, tkNil, tkCast, tkIf, tkProc, tkBind, - tkParLe, tkBracketLe, tkCurlyLe, tkIntLit..tkCharLit, - tkVar, tkRef, tkPtr, tkTuple, tkType: result := true; - else result := false; - end; -end; - -function parseExprStmt(var p: TParser): PNode; -var - a, b, e: PNode; -begin - a := lowestExpr(p); - if p.tok.tokType = tkEquals then begin - getTok(p); - optInd(p, result); - b := parseExpr(p); - result := newNodeI(nkAsgn, a.info); - addSon(result, a); - addSon(result, b); - end - else begin - result := newNodeP(nkCommand, p); - result.info := a.info; - addSon(result, a); - while true do begin - (*case p.tok.tokType of - tkColon, tkInd, tkSad, tkDed, tkEof, tkComment: break; - else begin end - end;*) - if not isExprStart(p) then break; - e := parseExpr(p); - addSon(result, e); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a); - end; - if sonsLen(result) <= 1 then result := a - else a := result; - if p.tok.tokType = tkColon then begin // macro statement - result := newNodeP(nkMacroStmt, p); - result.info := a.info; - addSon(result, a); - getTok(p); - skipComment(p, result); - if (p.tok.tokType = tkInd) - or not (p.tok.TokType in [tkOf, tkElif, tkElse, tkExcept]) then - addSon(result, parseStmt(p)); - while true do begin - if p.tok.tokType = tkSad then getTok(p); - case p.tok.tokType of - tkOf: begin - b := newNodeP(nkOfBranch, p); - exprListAux(p, nkRange, tkColon, tkDotDot, b); - end; - tkElif: begin - b := newNodeP(nkElifBranch, p); - getTok(p); - optInd(p, b); - addSon(b, parseExpr(p)); - eat(p, tkColon); - end; - tkExcept: begin - b := newNodeP(nkExceptBranch, p); - qualifiedIdentListAux(p, tkColon, b); - skipComment(p, b); - end; - tkElse: begin - b := newNodeP(nkElse, p); - getTok(p); - eat(p, tkColon); - end; - else break; - end; - addSon(b, parseStmt(p)); - addSon(result, b); - if b.kind = nkElse then break; - end - end - end -end; - -function parseImportOrIncludeStmt(var p: TParser; kind: TNodeKind): PNode; -var - a: PNode; -begin - result := newNodeP(kind, p); - getTok(p); // skip `import` or `include` - optInd(p, result); - while true do begin - case p.tok.tokType of - tkEof, tkSad, tkDed: break; - tkSymbol, tkAccent: a := parseSymbol(p); - tkRStrLit: begin - a := newStrNodeP(nkRStrLit, p.tok.literal, p); - getTok(p) - end; - tkStrLit: begin - a := newStrNodeP(nkStrLit, p.tok.literal, p); - getTok(p); - end; - tkTripleStrLit: begin - a := newStrNodeP(nkTripleStrLit, p.tok.literal, p); - getTok(p) - end; - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - break - end - end; - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; -end; - -function parseFromStmt(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkFromStmt, p); - getTok(p); // skip `from` - optInd(p, result); - case p.tok.tokType of - tkSymbol, tkAccent: a := parseSymbol(p); - tkRStrLit: begin - a := newStrNodeP(nkRStrLit, p.tok.literal, p); - getTok(p) - end; - tkStrLit: begin - a := newStrNodeP(nkStrLit, p.tok.literal, p); - getTok(p); - end; - tkTripleStrLit: begin - a := newStrNodeP(nkTripleStrLit, p.tok.literal, p); - getTok(p) - end; - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); exit - end - end; - addSon(result, a); - //optInd(p, a); - eat(p, tkImport); - optInd(p, result); - while true do begin - case p.tok.tokType of - tkEof, tkSad, tkDed: break; - tkSymbol, tkAccent: a := parseSymbol(p); - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - break - end; - end; - //optInd(p, a); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; -end; - -function parseReturnOrRaise(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - case p.tok.tokType of - tkEof, tkSad, tkDed: addSon(result, nil); - else addSon(result, parseExpr(p)); - end; -end; - -function parseYieldOrDiscard(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - addSon(result, parseExpr(p)); -end; - -function parseBreakOrContinue(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - case p.tok.tokType of - tkEof, tkSad, tkDed: addSon(result, nil); - else addSon(result, parseSymbol(p)); - end; -end; - -function parseIfOrWhen(var p: TParser; kind: TNodeKind): PNode; -var - branch: PNode; -begin - result := newNodeP(kind, p); - while true do begin - getTok(p); // skip `if`, `when`, `elif` - branch := newNodeP(nkElifBranch, p); - optInd(p, branch); - addSon(branch, parseExpr(p)); - eat(p, tkColon); - skipComment(p, branch); - addSon(branch, parseStmt(p)); - skipComment(p, branch); - addSon(result, branch); - if p.tok.tokType <> tkElif then break - end; - if p.tok.tokType = tkElse then begin - branch := newNodeP(nkElse, p); - eat(p, tkElse); eat(p, tkColon); - skipComment(p, branch); - addSon(branch, parseStmt(p)); - addSon(result, branch); - end -end; - -function parseWhile(var p: TParser): PNode; -begin - result := newNodeP(nkWhileStmt, p); - getTok(p); - optInd(p, result); - addSon(result, parseExpr(p)); - eat(p, tkColon); - skipComment(p, result); - addSon(result, parseStmt(p)); -end; - -function parseCase(var p: TParser): PNode; -var - b: PNode; - inElif: bool; -begin - result := newNodeP(nkCaseStmt, p); - getTok(p); - addSon(result, parseExpr(p)); - if p.tok.tokType = tkColon then getTok(p); - skipComment(p, result); - inElif := false; - while true do begin - if p.tok.tokType = tkSad then getTok(p); - case p.tok.tokType of - tkOf: begin - if inElif then break; - b := newNodeP(nkOfBranch, p); - exprListAux(p, nkRange, tkColon, tkDotDot, b); - end; - tkElif: begin - inElif := true; - b := newNodeP(nkElifBranch, p); - getTok(p); - optInd(p, b); - addSon(b, parseExpr(p)); - eat(p, tkColon); - end; - tkElse: begin - b := newNodeP(nkElse, p); - getTok(p); - eat(p, tkColon); - end; - else break; - end; - skipComment(p, b); - addSon(b, parseStmt(p)); - addSon(result, b); - if b.kind = nkElse then break; - end -end; - -function parseTry(var p: TParser): PNode; -var - b: PNode; -begin - result := newNodeP(nkTryStmt, p); - getTok(p); - eat(p, tkColon); - skipComment(p, result); - addSon(result, parseStmt(p)); - b := nil; - while true do begin - if p.tok.tokType = tkSad then getTok(p); - case p.tok.tokType of - tkExcept: begin - b := newNodeP(nkExceptBranch, p); - qualifiedIdentListAux(p, tkColon, b); - end; - tkFinally: begin - b := newNodeP(nkFinally, p); - getTok(p); - eat(p, tkColon); - end; - else break; - end; - skipComment(p, b); - addSon(b, parseStmt(p)); - addSon(result, b); - if b.kind = nkFinally then break; - end; - if b = nil then parMessage(p, errTokenExpected, 'except'); -end; - -function parseFor(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkForStmt, p); - getTok(p); - optInd(p, result); - a := parseSymbol(p); - addSon(result, a); - while p.tok.tokType = tkComma do begin - getTok(p); - optInd(p, a); - a := parseSymbol(p); - addSon(result, a); - end; - eat(p, tkIn); - addSon(result, exprColonEqExpr(p, nkRange, tkDotDot)); - eat(p, tkColon); - skipComment(p, result); - addSon(result, parseStmt(p)) -end; - -function parseBlock(var p: TParser): PNode; -begin - result := newNodeP(nkBlockStmt, p); - getTok(p); - optInd(p, result); - case p.tok.tokType of - tkEof, tkSad, tkDed, tkColon: addSon(result, nil); - else addSon(result, parseSymbol(p)); - end; - eat(p, tkColon); - skipComment(p, result); - addSon(result, parseStmt(p)); -end; - -function parseAsm(var p: TParser): PNode; -begin - result := newNodeP(nkAsmStmt, p); - getTok(p); - optInd(p, result); - if p.tok.tokType = tkCurlyDotLe then addSon(result, parsePragma(p)) - else addSon(result, nil); - case p.tok.tokType of - tkStrLit: addSon(result, newStrNodeP(nkStrLit, p.tok.literal, p)); - tkRStrLit: addSon(result, newStrNodeP(nkRStrLit, p.tok.literal, p)); - tkTripleStrLit: - addSon(result, newStrNodeP(nkTripleStrLit, p.tok.literal, p)); - else begin - parMessage(p, errStringLiteralExpected); - addSon(result, nil); exit - end; - end; - getTok(p); -end; - -function parseGenericParamList(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkGenericParams, p); - getTok(p); - optInd(p, result); - while (p.tok.tokType = tkSymbol) or (p.tok.tokType = tkAccent) do begin - a := parseIdentColonEquals(p, {@set}[withBothOptional]); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - optSad(p); - eat(p, tkBracketRi); -end; - -function parseRoutine(var p: TParser; kind: TNodeKind): PNode; -begin - result := newNodeP(kind, p); - getTok(p); - optInd(p, result); - addSon(result, identVis(p)); - if p.tok.tokType = tkBracketLe then addSon(result, parseGenericParamList(p)) - else addSon(result, nil); - addSon(result, parseParamList(p)); - if p.tok.tokType = tkCurlyDotLe then addSon(result, parsePragma(p)) - else addSon(result, nil); - if p.tok.tokType = tkEquals then begin - getTok(p); skipComment(p, result); - addSon(result, parseStmt(p)); - end - else - addSon(result, nil); - indAndComment(p, result); // XXX: document this in the grammar! -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; - -function parseSection(var p: TParser; kind: TNodeKind; - defparser: TDefParser): PNode; -var - a: PNode; -begin - result := newNodeP(kind, p); - getTok(p); - skipComment(p, result); - case p.tok.tokType of - tkInd: begin - pushInd(p.lex^, p.tok.indent); - getTok(p); skipComment(p, result); - while true do begin - case p.tok.tokType of - tkSad: getTok(p); - tkSymbol, tkAccent: begin - a := defparser(p); - skipComment(p, a); - addSon(result, a); - end; - tkDed: begin getTok(p); break end; - tkEof: break; // BUGFIX - tkComment: begin - a := newCommentStmt(p); - skipComment(p, a); - addSon(result, a); - end; - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - break - end - end - end; - popInd(p.lex^); - end; - tkSymbol, tkAccent, tkParLe: begin - // tkParLe is allowed for ``var (x, y) = ...`` tuple parsing - addSon(result, defparser(p)); - end - else parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - end -end; - -function parseConstant(var p: TParser): PNode; -begin - result := newNodeP(nkConstDef, p); - addSon(result, identWithPragma(p)); - if p.tok.tokType = tkColon then begin - getTok(p); optInd(p, result); - addSon(result, parseTypeDesc(p)); - end - else - addSon(result, nil); - eat(p, tkEquals); - optInd(p, result); - addSon(result, parseExpr(p)); - indAndComment(p, result); // XXX: special extension! -end; - -function parseEnum(var p: TParser): PNode; -var - a, b: PNode; -begin - result := newNodeP(nkEnumTy, p); - a := nil; - getTok(p); - if p.tok.tokType = tkOf then begin - a := newNodeP(nkOfInherit, p); - getTok(p); optInd(p, a); - addSon(a, parseTypeDesc(p)); - addSon(result, a) - end - else addSon(result, nil); - optInd(p, result); - - while true do begin - case p.tok.tokType of - tkEof, tkSad, tkDed: break; - else a := parseSymbol(p); - end; - optInd(p, a); - if p.tok.tokType = tkEquals then begin - getTok(p); - optInd(p, a); - b := a; - a := newNodeP(nkEnumFieldDef, p); - addSon(a, b); - addSon(a, parseExpr(p)); - skipComment(p, a); - end; - if p.tok.tokType = tkComma then begin - getTok(p); - optInd(p, a) - end; - addSon(result, a); - end -end; - -function parseObjectPart(var p: TParser): PNode; forward; - -function parseObjectWhen(var p: TParser): PNode; -var - branch: PNode; -begin - result := newNodeP(nkRecWhen, p); - while true do begin - getTok(p); // skip `when`, `elif` - branch := newNodeP(nkElifBranch, p); - optInd(p, branch); - addSon(branch, parseExpr(p)); - eat(p, tkColon); - skipComment(p, branch); - addSon(branch, parseObjectPart(p)); - skipComment(p, branch); - addSon(result, branch); - if p.tok.tokType <> tkElif then break - end; - if p.tok.tokType = tkElse then begin - branch := newNodeP(nkElse, p); - eat(p, tkElse); eat(p, tkColon); - skipComment(p, branch); - addSon(branch, parseObjectPart(p)); - addSon(result, branch); - end -end; - -function parseObjectCase(var p: TParser): PNode; -var - a, b: PNode; -begin - result := newNodeP(nkRecCase, p); - getTok(p); - a := newNodeP(nkIdentDefs, p); - addSon(a, identWithPragma(p)); - eat(p, tkColon); - addSon(a, parseTypeDesc(p)); - addSon(a, nil); - addSon(result, a); - skipComment(p, result); - while true do begin - if p.tok.tokType = tkSad then getTok(p); - case p.tok.tokType of - tkOf: begin - b := newNodeP(nkOfBranch, p); - exprListAux(p, nkRange, tkColon, tkDotDot, b); - end; - tkElse: begin - b := newNodeP(nkElse, p); - getTok(p); - eat(p, tkColon); - end; - else break; - end; - skipComment(p, b); - addSon(b, parseObjectPart(p)); - addSon(result, b); - if b.kind = nkElse then break; - end -end; - -function parseObjectPart(var p: TParser): PNode; -begin - case p.tok.tokType of - tkInd: begin - result := newNodeP(nkRecList, p); - pushInd(p.lex^, p.tok.indent); - getTok(p); skipComment(p, result); - while true do begin - case p.tok.tokType of - tkSad: getTok(p); - tkCase, tkWhen, tkSymbol, tkAccent, tkNil: begin - addSon(result, parseObjectPart(p)); - end; - tkDed: begin getTok(p); break end; - tkEof: break; - else begin - parMessage(p, errIdentifierExpected, tokToStr(p.tok)); - break - end - end - end; - popInd(p.lex^); - end; - tkWhen: result := parseObjectWhen(p); - tkCase: result := parseObjectCase(p); - tkSymbol, tkAccent: begin - result := parseIdentColonEquals(p, {@set}[withPragma]); - skipComment(p, result); - end; - tkNil: begin - result := newNodeP(nkNilLit, p); - getTok(p); - end; - else result := nil - end -end; - -function parseObject(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkObjectTy, p); - getTok(p); - if p.tok.tokType = tkCurlyDotLe then addSon(result, parsePragma(p)) - else addSon(result, nil); - if p.tok.tokType = tkOf then begin - a := newNodeP(nkOfInherit, p); - getTok(p); - addSon(a, parseTypeDesc(p)); - addSon(result, a); - end - else addSon(result, nil); - skipComment(p, result); - addSon(result, parseObjectPart(p)); -end; - -function parseDistinct(var p: TParser): PNode; -begin - result := newNodeP(nkDistinctTy, p); - getTok(p); - optInd(p, result); - addSon(result, parseTypeDesc(p)); -end; - -function parseTypeDef(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkTypeDef, p); - addSon(result, identWithPragma(p)); - if p.tok.tokType = tkBracketLe then addSon(result, parseGenericParamList(p)) - else addSon(result, nil); - if p.tok.tokType = tkEquals then begin - getTok(p); optInd(p, result); - case p.tok.tokType of - tkObject: a := parseObject(p); - tkEnum: a := parseEnum(p); - tkDistinct: a := parseDistinct(p); - else a := parseTypeDesc(p); - end; - addSon(result, a); - end - else - addSon(result, nil); - indAndComment(p, result); // special extension! -end; - -function parseVarTuple(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkVarTuple, p); - getTok(p); // skip '(' - optInd(p, result); - while (p.tok.tokType = tkSymbol) or (p.tok.tokType = tkAccent) do begin - a := identWithPragma(p); - addSon(result, a); - if p.tok.tokType <> tkComma then break; - getTok(p); - optInd(p, a) - end; - addSon(result, nil); // no type desc - optSad(p); - eat(p, tkParRi); - eat(p, tkEquals); - optInd(p, result); - addSon(result, parseExpr(p)); -end; - -function parseVariable(var p: TParser): PNode; -begin - if p.tok.tokType = tkParLe then - result := parseVarTuple(p) - else - result := parseIdentColonEquals(p, {@set}[withPragma]); - indAndComment(p, result); // special extension! -end; - -function simpleStmt(var p: TParser): PNode; -begin - case p.tok.tokType of - tkReturn: result := parseReturnOrRaise(p, nkReturnStmt); - tkRaise: result := parseReturnOrRaise(p, nkRaiseStmt); - tkYield: result := parseYieldOrDiscard(p, nkYieldStmt); - tkDiscard: result := parseYieldOrDiscard(p, nkDiscardStmt); - tkBreak: result := parseBreakOrContinue(p, nkBreakStmt); - tkContinue: result := parseBreakOrContinue(p, nkContinueStmt); - tkCurlyDotLe: result := parsePragma(p); - tkImport: result := parseImportOrIncludeStmt(p, nkImportStmt); - tkFrom: result := parseFromStmt(p); - tkInclude: result := parseImportOrIncludeStmt(p, nkIncludeStmt); - tkComment: result := newCommentStmt(p); - else begin - if isExprStart(p) then - result := parseExprStmt(p) - else - result := nil; - end - end; - if result <> nil then - skipComment(p, result); -end; - -function complexOrSimpleStmt(var p: TParser): PNode; -begin - case p.tok.tokType of - tkIf: result := parseIfOrWhen(p, nkIfStmt); - tkWhile: result := parseWhile(p); - tkCase: result := parseCase(p); - tkTry: result := parseTry(p); - tkFor: result := parseFor(p); - tkBlock: result := parseBlock(p); - tkAsm: result := parseAsm(p); - tkProc: result := parseRoutine(p, nkProcDef); - tkMethod: result := parseRoutine(p, nkMethodDef); - tkIterator: result := parseRoutine(p, nkIteratorDef); - tkMacro: result := parseRoutine(p, nkMacroDef); - tkTemplate: result := parseRoutine(p, nkTemplateDef); - tkConverter: result := parseRoutine(p, nkConverterDef); - tkType: result := parseSection(p, nkTypeSection, parseTypeDef); - tkConst: result := parseSection(p, nkConstSection, parseConstant); - tkWhen: result := parseIfOrWhen(p, nkWhenStmt); - tkVar: result := parseSection(p, nkVarSection, parseVariable); - else result := simpleStmt(p); - end -end; - -function parseStmt(var p: TParser): PNode; -var - a: PNode; -begin - if p.tok.tokType = tkInd then begin - result := newNodeP(nkStmtList, p); - pushInd(p.lex^, p.tok.indent); - getTok(p); - while true do begin - case p.tok.tokType of - tkSad: getTok(p); - tkEof: break; - tkDed: begin getTok(p); break end; - else begin - a := complexOrSimpleStmt(p); - if a = nil then break; - addSon(result, a); - end - end - end; - popInd(p.lex^); - end - else begin - // the case statement is only needed for better error messages: - case p.tok.tokType of - tkIf, tkWhile, tkCase, tkTry, tkFor, tkBlock, tkAsm, - tkProc, tkIterator, tkMacro, tkType, tkConst, tkWhen, tkVar: begin - parMessage(p, errComplexStmtRequiresInd); - result := nil - end - else begin - result := simpleStmt(p); - if result = nil then parMessage(p, errExprExpected, tokToStr(p.tok)); - if p.tok.tokType = tkSad then getTok(p); - end - end - end -end; - -function parseAll(var p: TParser): PNode; -var - a: PNode; -begin - result := newNodeP(nkStmtList, p); - while true do begin - case p.tok.tokType of - tkSad: getTok(p); - tkDed, tkInd: parMessage(p, errInvalidIndentation); - tkEof: break; - else begin - a := complexOrSimpleStmt(p); - if a = nil then parMessage(p, errExprExpected, tokToStr(p.tok)); - addSon(result, a); - end - end - 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); - if result = nil then parMessage(p, errExprExpected, tokToStr(p.tok)); - break - end - end - end -end; - -end. diff --git a/nim/pragmas.pas b/nim/pragmas.pas deleted file mode 100755 index 7a0fd2468..000000000 --- a/nim/pragmas.pas +++ /dev/null @@ -1,627 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// 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; - -const - FirstCallConv = wNimcall; - LastCallConv = wNoconv; - -const - procPragmas = {@set}[FirstCallConv..LastCallConv, - wImportc, wExportc, wNodecl, wMagic, wNosideEffect, wSideEffect, - wNoreturn, wDynLib, wHeader, wCompilerProc, wPure, - wProcVar, wDeprecated, wVarargs, wCompileTime, wMerge, - wBorrow]; - converterPragmas = procPragmas; - methodPragmas = procPragmas; - macroPragmas = {@set}[FirstCallConv..LastCallConv, - wImportc, wExportc, wNodecl, wMagic, wNosideEffect, - wCompilerProc, wDeprecated, wTypeCheck]; - iteratorPragmas = {@set}[FirstCallConv..LastCallConv, - wNosideEffect, wSideEffect, - wImportc, wExportc, wNodecl, wMagic, wDeprecated, wBorrow]; - stmtPragmas = {@set}[wChecks, wObjChecks, wFieldChecks, wRangechecks, - wBoundchecks, wOverflowchecks, wNilchecks, wAssertions, wWarnings, - wHints, wLinedir, wStacktrace, wLinetrace, wOptimization, - wHint, wWarning, wError, wFatal, wDefine, wUndef, - wCompile, wLink, wLinkSys, wPure, - wPush, wPop, wBreakpoint, wCheckpoint, - wPassL, wPassC, wDeadCodeElim, wDeprecated]; - lambdaPragmas = {@set}[FirstCallConv..LastCallConv, - wImportc, wExportc, wNodecl, wNosideEffect, wSideEffect, - wNoreturn, wDynLib, wHeader, wPure, wDeprecated]; - typePragmas = {@set}[wImportc, wExportc, wDeprecated, wMagic, wAcyclic, - wNodecl, wPure, wHeader, wCompilerProc, wFinal]; - fieldPragmas = {@set}[wImportc, wExportc, wDeprecated]; - varPragmas = {@set}[wImportc, wExportc, wVolatile, wRegister, wThreadVar, - wNodecl, wMagic, wHeader, wDeprecated, wCompilerProc, - wDynLib]; - constPragmas = {@set}[wImportc, wExportc, wHeader, wDeprecated, - wMagic, wNodecl]; - procTypePragmas = [FirstCallConv..LastCallConv, wVarargs, wNosideEffect]; - -procedure pragma(c: PContext; sym: PSym; n: PNode; - const validPragmas: TSpecialWords); - -function pragmaAsm(c: PContext; n: PNode): char; - -implementation - -procedure invalidPragma(n: PNode); -begin - liMessage(n.info, errInvalidPragmaX, renderTree(n, {@set}[renderNoComments])); -end; - -function pragmaAsm(c: PContext; n: PNode): char; -var - i: int; - it: PNode; -begin - result := #0; - if n <> nil then begin - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if (it.kind = nkExprColonExpr) and (it.sons[0].kind = nkIdent) then begin - case whichKeyword(it.sons[0].ident) of - wSubsChar: begin - if it.sons[1].kind = nkCharLit then - result := chr(int(it.sons[1].intVal)) - else invalidPragma(it) - end - else - invalidPragma(it) - end - end - else - invalidPragma(it); - end - end -end; - -const - FirstPragmaWord = wMagic; - LastPragmaWord = wNoconv; - -procedure MakeExternImport(s: PSym; const extname: string); -begin - s.loc.r := toRope(extname); - Include(s.flags, sfImportc); - Exclude(s.flags, sfForward); -end; - -procedure MakeExternExport(s: PSym; const extname: string); -begin - s.loc.r := toRope(extname); - Include(s.flags, sfExportc); -end; - -function expectStrLit(c: PContext; n: PNode): string; -begin - if n.kind <> nkExprColonExpr then begin - liMessage(n.info, errStringLiteralExpected); - result := '' - end - else begin - 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 - liMessage(n.info, errStringLiteralExpected); - result := '' - end - end - end -end; - -function expectIntLit(c: PContext; n: PNode): int; -begin - if n.kind <> nkExprColonExpr then begin - liMessage(n.info, errIntLiteralExpected); - result := 0 - end - else begin - 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 - liMessage(n.info, errIntLiteralExpected); - result := 0 - end - end - end -end; - -function getOptionalStr(c: PContext; n: PNode; - const defaultStr: string): string; -begin - if n.kind = nkExprColonExpr then - result := expectStrLit(c, n) - else - result := defaultStr -end; - -procedure processMagic(c: PContext; n: PNode; s: PSym); -var - v: string; - m: TMagic; -begin - //if not (sfSystemModule in c.module.flags) then - // liMessage(n.info, errMagicOnlyInSystem); - 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 - // BUGFIX: magic does not imply ``lfNoDecl`` anymore! - for m := low(TMagic) to high(TMagic) do - if magicToStr[m] = v then begin - s.magic := m; exit - end; - // else: no magic found; make this a warning! - liMessage(n.info, warnUnknownMagic, v); -end; - -function wordToCallConv(sw: TSpecialWord): TCallingConvention; -begin - // this assumes that the order of special words and calling conventions is - // the same - result := TCallingConvention(ord(ccDefault) + ord(sw) - ord(wNimcall)); -end; - -procedure onOff(c: PContext; n: PNode; op: TOptions); -begin - if (n.kind = nkExprColonExpr) and (n.sons[1].kind = nkIdent) then begin - case whichKeyword(n.sons[1].ident) of - wOn: gOptions := gOptions + op; - wOff: gOptions := gOptions - op; - else liMessage(n.info, errOnOrOffExpected) - end - end - else - liMessage(n.info, errOnOrOffExpected) -end; - -procedure pragmaDeadCodeElim(c: PContext; n: PNode); -begin - if (n.kind = nkExprColonExpr) and (n.sons[1].kind = nkIdent) then begin - case whichKeyword(n.sons[1].ident) of - wOn: include(c.module.flags, sfDeadCodeElim); - wOff: exclude(c.module.flags, sfDeadCodeElim); - else liMessage(n.info, errOnOrOffExpected) - end - end - else - liMessage(n.info, errOnOrOffExpected) -end; - -procedure processCallConv(c: PContext; n: PNode); -var - sw: TSpecialWord; -begin - if (n.kind = nkExprColonExpr) and (n.sons[1].kind = nkIdent) then begin - sw := whichKeyword(n.sons[1].ident); - case sw of - firstCallConv..lastCallConv: - POptionEntry(c.optionStack.tail).defaultCC := wordToCallConv(sw); - else - liMessage(n.info, errCallConvExpected) - end - end - else - liMessage(n.info, errCallConvExpected) -end; - -function getLib(c: PContext; kind: TLibKind; const path: string): PLib; -var - it: PLib; -begin - it := PLib(c.libs.head); - while it <> nil do begin - if it.kind = kind then begin - if ospCaseInsensitive in platform.OS[targetOS].props then begin - if cmpIgnoreCase(it.path, path) = 0 then begin result := it; exit end; - end - else begin - if it.path = path then begin result := it; exit end; - end - end; - it := PLib(it.next) - end; - // not found --> we need a new one: - result := newLib(kind); - result.path := path; - Append(c.libs, result) -end; - -procedure processDynLib(c: PContext; n: PNode; sym: PSym); -var - lib: PLib; -begin - if (sym = nil) or (sym.kind = skModule) then - POptionEntry(c.optionStack.tail).dynlib := getLib(c, libDynamic, - expectStrLit(c, n)) - else if n.kind = nkExprColonExpr then begin - lib := getLib(c, libDynamic, expectStrLit(c, n)); - addToLib(lib, sym); - include(sym.loc.flags, lfDynamicLib) - end - else - include(sym.loc.flags, lfExportLib) -end; - -procedure processNote(c: PContext; n: PNode); -var - x: int; - nk: TNoteKind; -begin - if (n.kind = nkExprColonExpr) and (sonsLen(n) = 2) - and (n.sons[0].kind = nkBracketExpr) and (n.sons[0].sons[1].kind = nkIdent) - and (n.sons[0].sons[0].kind = nkIdent) and (n.sons[1].kind = nkIdent) then begin - case whichKeyword(n.sons[0].sons[0].ident) of - wHint: begin - x := findStr(msgs.HintsToStr, n.sons[0].sons[1].ident.s); - if x >= 0 then nk := TNoteKind(x + ord(hintMin)) - else invalidPragma(n) - end; - wWarning: begin - x := findStr(msgs.WarningsToStr, n.sons[0].sons[1].ident.s); - if x >= 0 then nk := TNoteKind(x + ord(warnMin)) - else InvalidPragma(n) - end; - else begin - invalidPragma(n); exit - end - end; - case whichKeyword(n.sons[1].ident) of - wOn: include(gNotes, nk); - wOff: exclude(gNotes, nk); - else liMessage(n.info, errOnOrOffExpected) - end - end - else - invalidPragma(n); -end; - -procedure processOption(c: PContext; n: PNode); -var - sw: TSpecialWord; -begin - if n.kind <> nkExprColonExpr then invalidPragma(n) - else if n.sons[0].kind = nkBracketExpr then - processNote(c, n) - else if n.sons[0].kind <> nkIdent then - invalidPragma(n) - else begin - sw := whichKeyword(n.sons[0].ident); - case sw of - wChecks: OnOff(c, n, checksOptions); - wObjChecks: OnOff(c, n, {@set}[optObjCheck]); - wFieldchecks: OnOff(c, n, {@set}[optFieldCheck]); - wRangechecks: OnOff(c, n, {@set}[optRangeCheck]); - wBoundchecks: OnOff(c, n, {@set}[optBoundsCheck]); - wOverflowchecks: OnOff(c, n, {@set}[optOverflowCheck]); - wNilchecks: OnOff(c, n, {@set}[optNilCheck]); - wAssertions: OnOff(c, n, {@set}[optAssert]); - wWarnings: OnOff(c, n, {@set}[optWarns]); - wHints: OnOff(c, n, {@set}[optHints]); - wCallConv: processCallConv(c, n); - // ------ these are not in the Nimrod spec: ------------- - wLinedir: OnOff(c, n, {@set}[optLineDir]); - 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); - // ------------------------------------------------------- - wOptimization: begin - if n.sons[1].kind <> nkIdent then - invalidPragma(n) - else begin - case whichKeyword(n.sons[1].ident) of - wSpeed: begin - include(gOptions, optOptimizeSpeed); - exclude(gOptions, optOptimizeSize); - end; - wSize: begin - exclude(gOptions, optOptimizeSpeed); - include(gOptions, optOptimizeSize); - end; - wNone: begin - exclude(gOptions, optOptimizeSpeed); - exclude(gOptions, optOptimizeSize); - end; - else - liMessage(n.info, errNoneSpeedOrSizeExpected); - end - end - end; - else liMessage(n.info, errOptionExpected); - end - end; - // BUGFIX this is a little hack, but at least it works: - //getCurrOwner(c).options := gOptions; -end; - -procedure processPush(c: PContext; n: PNode; start: int); -var - i: int; - x, y: POptionEntry; -begin - x := newOptionEntry(); - y := POptionEntry(c.optionStack.tail); - x.options := gOptions; - x.defaultCC := y.defaultCC; - x.dynlib := y.dynlib; - x.notes := gNotes; - append(c.optionStack, x); - for i := start to sonsLen(n)-1 do - processOption(c, n.sons[i]); - //liMessage(n.info, warnUser, ropeToStr(optionsToStr(gOptions))); -end; - -procedure processPop(c: PContext; n: PNode); -begin - if c.optionStack.counter <= 1 then - liMessage(n.info, errAtPopWithoutPush) - else begin - gOptions := POptionEntry(c.optionStack.tail).options; - //liMessage(n.info, warnUser, ropeToStr(optionsToStr(gOptions))); - gNotes := POptionEntry(c.optionStack.tail).notes; - remove(c.optionStack, c.optionStack.tail); - end -end; - -procedure processDefine(c: PContext; n: PNode); -begin - 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 begin - UndefSymbol(n.sons[1].ident.s); - liMessage(n.info, warnDeprecated, 'undef'); - end - else - invalidPragma(n) -end; - -type - TLinkFeature = (linkNormal, linkSys); - -procedure processCompile(c: PContext; n: PNode); -var - s, found, trunc: string; -begin - s := expectStrLit(c, n); - found := findFile(s); - if found = '' then found := s; - trunc := ChangeFileExt(found, ''); - extccomp.addExternalFileToCompile(trunc); - extccomp.addFileToLink(completeCFilePath(trunc, false)); -end; - -procedure processCommonLink(c: PContext; n: PNode; feature: TLinkFeature); -var - f, found: string; -begin - f := expectStrLit(c, n); - if splitFile(f).ext = '' then - f := toObjFile(f); - found := findFile(f); - if found = '' then - found := f; // use the default - case feature of - linkNormal: extccomp.addFileToLink(found); - linkSys: begin - extccomp.addFileToLink(joinPath(libpath, - completeCFilePath(found, false))); - end - else internalError(n.info, 'processCommonLink'); - end -end; - -procedure PragmaBreakpoint(c: PContext; n: PNode); -begin - {@discard} getOptionalStr(c, n, ''); -end; - -procedure PragmaCheckpoint(c: PContext; n: PNode); -// checkpoints can be used to debug the compiler; they are not documented -var - info: TLineInfo; -begin - info := n.info; - inc(info.line); // next line is affected! - msgs.addCheckpoint(info); -end; - -procedure noVal(n: PNode); -begin - if n.kind = nkExprColonExpr then invalidPragma(n) -end; - -procedure pragma(c: PContext; sym: PSym; n: PNode; - const validPragmas: TSpecialWords); -var - i: int; - key, it: PNode; - k: TSpecialWord; - lib: PLib; -begin - if n = nil then exit; - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if it.kind = nkExprColonExpr then key := it.sons[0] else key := it; - if key.kind = nkIdent then begin - k := whichKeyword(key.ident); - if k in validPragmas then begin - case k of - wExportc: begin - makeExternExport(sym, getOptionalStr(c, it, sym.name.s)); - include(sym.flags, sfUsed); // avoid wrong hints - end; - wImportc: 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); - end; - wNodecl: begin noVal(it); Include(sym.loc.Flags, lfNoDecl); end; - wPure: begin - noVal(it); - if sym <> nil then include(sym.flags, sfPure); - 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; - wDeadCodeElim: pragmaDeadCodeElim(c, it); - wMagic: processMagic(c, it, sym); - 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); - include(sym.flags, sfImportc); - include(sym.loc.flags, lfHeader); - include(sym.loc.Flags, lfNoDecl); // implies nodecl, because - // otherwise header would not make sense - if sym.loc.r = nil then sym.loc.r := toRope(sym.name.s) - end; - wNosideeffect: begin - noVal(it); Include(sym.flags, sfNoSideEffect); - if sym.typ <> nil then include(sym.typ.flags, tfNoSideEffect); - end; - wSideEffect: begin noVal(it); Include(sym.flags, sfSideEffect); end; - wNoReturn: begin noVal(it); Include(sym.flags, sfNoReturn); end; - wDynLib: processDynLib(c, it, sym); - wCompilerProc: begin - noVal(it); // compilerproc may not get a string! - makeExternExport(sym, sym.name.s); - include(sym.flags, sfCompilerProc); - include(sym.flags, sfUsed); // suppress all those stupid warnings - registerCompilerProc(sym); - end; - wProcvar: begin - noVal(it); - include(sym.flags, sfProcVar); - end; - wDeprecated: begin - noVal(it); - if sym <> nil then include(sym.flags, sfDeprecated) - else include(c.module.flags, sfDeprecated); - end; - wVarargs: begin - noVal(it); - if sym.typ = nil then invalidPragma(it); - include(sym.typ.flags, tfVarargs); - end; - wBorrow: begin - noVal(it); - include(sym.flags, sfBorrow); - 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); - end; - - // statement pragmas: - wHint: liMessage(it.info, hintUser, expectStrLit(c, it)); - wWarning: liMessage(it.info, warnUser, expectStrLit(c, it)); - wError: liMessage(it.info, errUser, expectStrLit(c, it)); - wFatal: begin - liMessage(it.info, errUser, expectStrLit(c, it)); - halt(1); - end; - wDefine: processDefine(c, it); - wUndef: processUndef(c, it); - wCompile: processCompile(c, it); - wLink: processCommonLink(c, it, linkNormal); - wLinkSys: processCommonLink(c, it, linkSys); - wPassL: extccomp.addLinkOption(expectStrLit(c, it)); - wPassC: extccomp.addCompileOption(expectStrLit(c, it)); - - wBreakpoint: PragmaBreakpoint(c, it); - wCheckpoint: PragmaCheckpoint(c, it); - - wPush: begin processPush(c, n, i+1); break end; - wPop: processPop(c, it); - wChecks, wObjChecks, wFieldChecks, - wRangechecks, wBoundchecks, wOverflowchecks, wNilchecks, - wAssertions, wWarnings, wHints, wLinedir, wStacktrace, - 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); - end - end - else invalidPragma(it); - end - else begin - processNote(c, it) - end; - end; - if (sym <> nil) and (sym.kind <> skModule) then begin - if (lfExportLib in sym.loc.flags) and not (sfExportc in sym.flags) then - liMessage(n.info, errDynlibRequiresExportc); - lib := POptionEntry(c.optionstack.tail).dynlib; - if ([lfDynamicLib, lfHeader] * sym.loc.flags = []) and - (sfImportc in sym.flags) and - (lib <> nil) then begin - include(sym.loc.flags, lfDynamicLib); - addToLib(lib, sym); - if sym.loc.r = nil then sym.loc.r := toRope(sym.name.s) - end - end -end; - -end. diff --git a/nim/procfind.pas b/nim/procfind.pas deleted file mode 100755 index e93820ab3..000000000 --- a/nim/procfind.pas +++ /dev/null @@ -1,120 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// 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, trees; - -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. - -function SearchForBorrowProc(c: PContext; fn: PSym; tos: int): PSym; -// Searchs for the fn in the symbol table. If the parameter lists are suitable -// for borrowing the sym in the symbol table is returned, else nil. - -implementation - -function equalGenericParams(procA, procB: PNode): Boolean; -var - a, b: PSym; - i: int; -begin - result := procA = procB; - if result then exit; - if (procA = nil) or (procB = nil) then exit; - - if sonsLen(procA) <> sonsLen(procB) then exit; - for i := 0 to sonsLen(procA)-1 do begin - 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 sameTypeOrNil(a.typ, b.typ) then exit; - if (a.ast <> nil) and (b.ast <> nil) then - if not ExprStructuralEquivalent(a.ast, b.ast) then exit; - end; - result := true -end; - -function SearchForProc(c: PContext; fn: PSym; tos: int): PSym; -var - it: TIdentIter; -begin - result := initIdentIter(it, c.tab.stack[tos], fn.Name); - while result <> nil do begin - if (result.Kind = fn.kind) then begin - if equalGenericParams(result.ast.sons[genericParamsPos], - fn.ast.sons[genericParamsPos]) then begin - case equalParams(result.typ.n, fn.typ.n) of - paramsEqual: exit; - paramsIncompatible: begin - liMessage(fn.info, errNotOverloadable, fn.name.s); - exit - end; - paramsNotEqual: begin end; // continue search - end; - end - end; - result := NextIdentIter(it, c.tab.stack[tos]) - end -end; - -function paramsFitBorrow(a, b: PNode): bool; -var - i, len: int; - m, n: PSym; -begin - len := sonsLen(a); - result := false; - if len = sonsLen(b) then begin - for i := 1 to len-1 do begin - m := a.sons[i].sym; - n := b.sons[i].sym; - assert((m.kind = skParam) and (n.kind = skParam)); - if not equalOrDistinctOf(m.typ, n.typ) then exit; - end; - // return type: - if not equalOrDistinctOf(a.sons[0].typ, b.sons[0].typ) then exit; - result := true - end -end; - -function SearchForBorrowProc(c: PContext; fn: PSym; tos: int): PSym; -// Searchs for the fn in the symbol table. If the parameter lists are suitable -// for borrowing the sym in the symbol table is returned, else nil. -var - it: TIdentIter; - scope: int; -begin - for scope := tos downto 0 do begin - result := initIdentIter(it, c.tab.stack[scope], fn.Name); - while result <> nil do begin - // watchout! result must not be the same as fn! - if (result.Kind = fn.kind) and (result.id <> fn.id) then begin - if equalGenericParams(result.ast.sons[genericParamsPos], - fn.ast.sons[genericParamsPos]) then begin - if paramsFitBorrow(fn.typ.n, result.typ.n) then exit; - end - end; - result := NextIdentIter(it, c.tab.stack[scope]) - end - end -end; - -end. diff --git a/nim/ptmplsyn.pas b/nim/ptmplsyn.pas deleted file mode 100755 index 717da6ee0..000000000 --- a/nim/ptmplsyn.pas +++ /dev/null @@ -1,222 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit ptmplsyn; - -// This module implements Nimrod's standard template filter. - -{$include config.inc} - -interface - -uses - nsystem, llstream, nos, charsets, wordrecg, idents, strutils, - ast, astalgo, msgs, options, rnimsyn, filters; - -function filterTmpl(input: PLLStream; const filename: string; - call: PNode): PLLStream; -// #! template(subsChar='$', metaChar='#') | standard(version="0.7.2") - -implementation - -type - TParseState = (psDirective, psTempl); - TTmplParser = record - inp: PLLStream; - state: TParseState; - info: TLineInfo; - indent, par: int; - x: string; // the current input line - outp: PLLStream; // the ouput will be parsed by pnimsyn - subsChar, NimDirective: Char; - emit, conc, toStr: string; - end; - -const - PatternChars = ['a'..'z', 'A'..'Z', '0'..'9', #128..#255, '.', '_']; - -procedure newLine(var p: TTmplParser); -begin - LLStreamWrite(p.outp, repeatChar(p.par, ')')); - p.par := 0; - if p.info.line > int16(1) then LLStreamWrite(p.outp, nl); -end; - -procedure parseLine(var p: TTmplParser); -var - d, j, curly: int; - keyw: string; -begin - j := strStart; - while p.x[j] = ' ' do inc(j); - if (p.x[strStart] = p.NimDirective) and (p.x[strStart+1] = '!') then - newLine(p) - else if (p.x[j] = p.NimDirective) then begin - newLine(p); - inc(j); - while p.x[j] = ' ' do inc(j); - d := j; - keyw := ''; - while p.x[j] in PatternChars do begin - addChar(keyw, p.x[j]); - inc(j); - end; - case whichKeyword(keyw) of - wEnd: begin - if p.indent >= 2 then - dec(p.indent, 2) - else begin - p.info.col := int16(j); - liMessage(p.info, errXNotAllowedHere, 'end'); - end; - LLStreamWrite(p.outp, repeatChar(p.indent)); - LLStreamWrite(p.outp, '#end'); - end; - wIf, wWhen, wTry, wWhile, wFor, wBlock, wCase, wProc, wIterator, - wConverter, wMacro, wTemplate, wMethod: begin - LLStreamWrite(p.outp, repeatChar(p.indent)); - LLStreamWrite(p.outp, ncopy(p.x, d)); - inc(p.indent, 2); - end; - wElif, wOf, wElse, wExcept, wFinally: begin - LLStreamWrite(p.outp, repeatChar(p.indent-2)); - LLStreamWrite(p.outp, ncopy(p.x, d)); - end - else begin - LLStreamWrite(p.outp, repeatChar(p.indent)); - LLStreamWrite(p.outp, ncopy(p.x, d)); - end - end; - p.state := psDirective - end - else begin - // data line - j := strStart; - case p.state of - psTempl: begin - // next line of string literal: - LLStreamWrite(p.outp, p.conc); - LLStreamWrite(p.outp, nl); - LLStreamWrite(p.outp, repeatChar(p.indent + 2)); - LLStreamWrite(p.outp, '"'+''); - end; - psDirective: begin - newLine(p); - LLStreamWrite(p.outp, repeatChar(p.indent)); - LLStreamWrite(p.outp, p.emit); - LLStreamWrite(p.outp, '("'); - inc(p.par); - end - end; - p.state := psTempl; - while true do begin - case p.x[j] of - #0: break; - #1..#31, #128..#255: begin - LLStreamWrite(p.outp, '\x'); - LLStreamWrite(p.outp, toHex(ord(p.x[j]), 2)); - inc(j); - end; - '\': begin LLStreamWrite(p.outp, '\\'); inc(j); end; - '''': begin LLStreamWrite(p.outp, '\'''); inc(j); end; - '"': begin LLStreamWrite(p.outp, '\"'); inc(j); end; - else if p.x[j] = p.subsChar then begin // parse Nimrod expression: - inc(j); - case p.x[j] of - '{': begin - p.info.col := int16(j); - LLStreamWrite(p.outp, '"'); - LLStreamWrite(p.outp, p.conc); - LLStreamWrite(p.outp, p.toStr); - LLStreamWrite(p.outp, '('); - inc(j); - curly := 0; - while true do begin - case p.x[j] of - #0: liMessage(p.info, errXExpected, '}'+''); - '{': begin - inc(j); - inc(curly); - LLStreamWrite(p.outp, '{'); - end; - '}': begin - inc(j); - if curly = 0 then break; - if curly > 0 then dec(curly); - LLStreamWrite(p.outp, '}'); - end; - else begin - LLStreamWrite(p.outp, p.x[j]); - inc(j) - end - end - end; - LLStreamWrite(p.outp, ')'); - LLStreamWrite(p.outp, p.conc); - LLStreamWrite(p.outp, '"'); - end; - 'a'..'z', 'A'..'Z', #128..#255: begin - LLStreamWrite(p.outp, '"'); - LLStreamWrite(p.outp, p.conc); - LLStreamWrite(p.outp, p.toStr); - LLStreamWrite(p.outp, '('); - while p.x[j] in PatternChars do begin - LLStreamWrite(p.outp, p.x[j]); - inc(j) - end; - LLStreamWrite(p.outp, ')'); - LLStreamWrite(p.outp, p.conc); - LLStreamWrite(p.outp, '"') - end; - else if p.x[j] = p.subsChar then begin - LLStreamWrite(p.outp, p.subsChar); - inc(j); - end - else begin - p.info.col := int16(j); - liMessage(p.info, errInvalidExpression, '$'+''); - end - end - end - else begin - LLStreamWrite(p.outp, p.x[j]); - inc(j); - end - end - end; - LLStreamWrite(p.outp, '\n"'); - end -end; - -function filterTmpl(input: PLLStream; const filename: string; - call: PNode): PLLStream; -var - p: TTmplParser; -begin -{@ignore} - FillChar(p, sizeof(p), 0); -{@emit} - p.info := newLineInfo(filename, 0, 0); - p.outp := LLStreamOpen(''); - p.inp := input; - p.subsChar := charArg(call, 'subschar', 1, '$'); - p.nimDirective := charArg(call, 'metachar', 2, '#'); - p.emit := strArg(call, 'emit', 3, 'result.add'); - p.conc := strArg(call, 'conc', 4, ' & '); - p.toStr := strArg(call, 'tostring', 5, '$'+''); - while not LLStreamAtEnd(p.inp) do begin - p.x := LLStreamReadLine(p.inp) {@ignore} + #0 {@emit}; - p.info.line := p.info.line + int16(1); - parseLine(p); - end; - newLine(p); - result := p.outp; - LLStreamClose(p.inp); -end; - -end. diff --git a/nim/readme.txt b/nim/readme.txt deleted file mode 100755 index 258192543..000000000 --- a/nim/readme.txt +++ /dev/null @@ -1,4 +0,0 @@ -This is the Pascal version of the sources. The Nimrod version has been -generated automatically from it. DO NOT MODIFY THIS OLD VERSION, BUT THE -UP-TO-DATE VERSION IN NIMROD! - diff --git a/nim/rnimsyn.pas b/nim/rnimsyn.pas deleted file mode 100755 index ec1e9571e..000000000 --- a/nim/rnimsyn.pas +++ /dev/null @@ -1,1458 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -unit rnimsyn; - -// This module implements the renderer of the standard Nimrod representation. - -{$include config.inc} - -interface - -uses - nsystem, charsets, scanner, options, idents, strutils, ast, msgs, - lists; - -type - TRenderFlag = (renderNone, renderNoBody, renderNoComments, - renderDocComments, renderNoPragmas, renderIds); - TRenderFlags = set of TRenderFlag; - - TRenderTok = record - kind: TTokType; - len: int16; - end; - TRenderTokSeq = array of TRenderTok; - - TSrcGen = record - indent: int; - lineLen: int; - pos: int; // current position for iteration over the buffer - idx: int; // current token index for iteration over the buffer - tokens: TRenderTokSeq; - buf: string; - pendingNL: int; // negative if not active; else contains the - // indentation value - comStack: array of PNode; // comment stack - flags: TRenderFlags; - end; - -procedure renderModule(n: PNode; const filename: string; - renderFlags: TRenderFlags = {@set}[]); - -function renderTree(n: PNode; renderFlags: TRenderFlags = {@set}[]): string; - -procedure initTokRender(var r: TSrcGen; n: PNode; - renderFlags: TRenderFlags = {@set}[]); -procedure getNextTok(var r: TSrcGen; var kind: TTokType; var literal: string); - -implementation - -// We render the source code in a two phases: The first -// determines how long the subtree will likely be, the second -// phase appends to a buffer that will be the output. - -const - IndentWidth = 2; - longIndentWid = 4; - MaxLineLen = 80; - LineCommentColumn = 30; - -procedure InitSrcGen(out g: TSrcGen; renderFlags: TRenderFlags); -begin -{@ignore} - fillChar(g, sizeof(g), 0); - g.comStack := nil; - g.tokens := nil; -{@emit - g.comStack := @[];} -{@emit - g.tokens := @[];} - g.indent := 0; - g.lineLen := 0; - g.pos := 0; - g.idx := 0; - g.buf := ''; - g.flags := renderFlags; - g.pendingNL := -1; -end; - -{@ignore} -procedure add(var dest: string; const src: string); -begin - dest := dest +{&} src; -end; -{@emit} - -procedure addTok(var g: TSrcGen; kind: TTokType; const s: string); -var - len: int; -begin - len := length(g.tokens); - setLength(g.tokens, len+1); - g.tokens[len].kind := kind; - g.tokens[len].len := int16(length(s)); - add(g.buf, s); -end; - -procedure addPendingNL(var g: TSrcGen); -begin - if g.pendingNL >= 0 then begin - addTok(g, tkInd, NL+{&}repeatChar(g.pendingNL)); - g.lineLen := g.pendingNL; - g.pendingNL := -1; - end -end; - -procedure putNL(var g: TSrcGen; indent: int); overload; -begin - if g.pendingNL >= 0 then - addPendingNL(g) - else - addTok(g, tkInd, NL); - g.pendingNL := indent; - g.lineLen := indent; -end; - -procedure putNL(var g: TSrcGen); overload; -begin - putNL(g, g.indent); -end; - -procedure optNL(var g: TSrcGen; indent: int); overload; -begin - g.pendingNL := indent; - g.lineLen := indent; // BUGFIX -end; - -procedure optNL(var g: TSrcGen); overload; -begin - optNL(g, g.indent) -end; - -procedure indentNL(var g: TSrcGen); -begin - inc(g.indent, indentWidth); - g.pendingNL := g.indent; - g.lineLen := g.indent; -end; - -procedure Dedent(var g: TSrcGen); -begin - dec(g.indent, indentWidth); - assert(g.indent >= 0); - if g.pendingNL > indentWidth then begin - Dec(g.pendingNL, indentWidth); - Dec(g.lineLen, indentWidth) - end -end; - -procedure put(var g: TSrcGen; const kind: TTokType; const s: string); -begin - addPendingNL(g); - if length(s) > 0 then begin - addTok(g, kind, s); - inc(g.lineLen, length(s)); - end -end; - -procedure putLong(var g: TSrcGen; const kind: TTokType; const s: string; - lineLen: int); -// use this for tokens over multiple lines. -begin - addPendingNL(g); - addTok(g, kind, s); - g.lineLen := lineLen; -end; - -// ----------------------- helpers -------------------------------------------- - -function toNimChar(c: Char): string; -begin - case c of - #0: result := '\0'; - #1..#31, #128..#255: result := '\x' + strutils.toHex(ord(c), 2); - '''', '"', '\': result := '\' + c; - else result := c + '' - end; -end; - -function makeNimString(const s: string): string; -var - i: int; -begin - result := '"' + ''; - for i := strStart to length(s)+strStart-1 do add(result, toNimChar(s[i])); - addChar(result, '"'); -end; - -procedure putComment(var g: TSrcGen; s: string); -var - i, j, ind, comIndent: int; - isCode: bool; - com: string; -begin - {@ignore} s := s + #0; {@emit} - i := strStart; - comIndent := 1; - isCode := (length(s) >= 2) and (s[strStart+1] <> ' '); - ind := g.lineLen; - com := ''; - while true do begin - case s[i] of - #0: break; - #13: begin - put(g, tkComment, com); - com := ''; - inc(i); - if s[i] = #10 then inc(i); - optNL(g, ind); - end; - #10: begin - put(g, tkComment, com); - com := ''; - inc(i); - optNL(g, ind); - end; - '#': begin - addChar(com, s[i]); - inc(i); - comIndent := 0; - while s[i] = ' ' do begin - addChar(com, s[i]); - inc(i); inc(comIndent); - end - end; - ' ', #9: begin - addChar(com, s[i]); - inc(i); - end - else begin - // we may break the comment into a multi-line comment if the line - // gets too long: - - // compute length of the following word: - j := i; - while s[j] > ' ' do inc(j); - if not isCode and (g.lineLen + (j-i) > MaxLineLen) then begin - put(g, tkComment, com); - com := ''; - optNL(g, ind); - com := com +{&} '#' +{&} repeatChar(comIndent); - end; - while s[i] > ' ' do begin - addChar(com, s[i]); - inc(i); - end - end - end - end; - put(g, tkComment, com); - optNL(g); -end; - -function maxLineLength(s: string): int; -var - i, linelen: int; -begin - {@ignore} s := s + #0; {@emit} - result := 0; - i := strStart; - lineLen := 0; - while true do begin - case s[i] of - #0: break; - #13: begin - inc(i); - if s[i] = #10 then inc(i); - result := max(result, lineLen); - lineLen := 0; - end; - #10: begin - inc(i); - result := max(result, lineLen); - lineLen := 0; - end; - else begin - inc(lineLen); inc(i); - end - end - end -end; - -procedure putRawStr(var g: TSrcGen; kind: TTokType; const s: string); -var - i, hi: int; - str: string; -begin - i := strStart; - hi := length(s)+strStart-1; - str := ''; - while i <= hi do begin - case s[i] of - #13: begin - put(g, kind, str); - str := ''; - inc(i); - if (i <= hi) and (s[i] = #10) then inc(i); - optNL(g, 0); - end; - #10: begin - put(g, kind, str); - str := ''; - inc(i); - optNL(g, 0); - end; - else begin - addChar(str, s[i]); - inc(i) - end - end - end; - put(g, kind, str); -end; - -function containsNL(const s: string): bool; -var - i: int; -begin - for i := strStart to length(s)+strStart-1 do - case s[i] of - #13, #10: begin result := true; exit end; - else begin end - end; - result := false -end; - -procedure pushCom(var g: TSrcGen; n: PNode); -var - len: int; -begin - len := length(g.comStack); - setLength(g.comStack, len+1); - g.comStack[len] := n; -end; - -procedure popAllComs(var g: TSrcGen); -begin - setLength(g.comStack, 0); -end; - -procedure popCom(var g: TSrcGen); -begin - setLength(g.comStack, length(g.comStack)-1); -end; - -const - Space = ' '+''; - -function shouldRenderComment(var g: TSrcGen; n: PNode): bool; -begin - result := false; - if n.comment <> snil then - result := not (renderNoComments in g.flags) or - (renderDocComments in g.flags) and startsWith(n.comment, '##'); -end; - -procedure gcom(var g: TSrcGen; n: PNode); -var - ml: int; -begin - assert(n <> nil); - if shouldRenderComment(g, n) then begin - if (g.pendingNL < 0) and (length(g.buf) > 0) - and (g.buf[length(g.buf)] <> ' ') then - put(g, tkSpaces, Space); - // Before long comments we cannot make sure that a newline is generated, - // because this might be wrong. But it is no problem in practice. - if (g.pendingNL < 0) and (length(g.buf) > 0) - and (g.lineLen < LineCommentColumn) then begin - ml := maxLineLength(n.comment); - if ml+LineCommentColumn <= maxLineLen then - put(g, tkSpaces, repeatChar(LineCommentColumn - g.lineLen)); - end; - putComment(g, n.comment); - //assert(g.comStack[high(g.comStack)] = n); - end -end; - -procedure gcoms(var g: TSrcGen); -var - i: int; -begin - for i := 0 to high(g.comStack) do gcom(g, g.comStack[i]); - popAllComs(g); -end; - -// ---------------------------------------------------------------------------- - -function lsub(n: PNode): int; forward; - -function litAux(n: PNode; x: biggestInt; size: int): string; -begin - if nfBase2 in n.flags then result := '0b' + toBin(x, size*8) - else if nfBase8 in n.flags then result := '0o' + toOct(x, size*3) - else if nfBase16 in n.flags then result := '0x' + toHex(x, size*2) - else result := toString(x) -end; - -function atom(n: PNode): string; -var - f: float32; -begin - case n.kind of - nkEmpty: result := ''; - nkIdent: result := n.ident.s; - nkSym: result := n.sym.name.s; - nkStrLit: result := makeNimString(n.strVal); - nkRStrLit: result := 'r"' + n.strVal + '"'; - nkTripleStrLit: result := '"""' + n.strVal + '"""'; - nkCharLit: result := '''' + toNimChar(chr(int(n.intVal))) + ''''; - nkIntLit: result := litAux(n, n.intVal, 4); - nkInt8Lit: result := litAux(n, n.intVal, 1) + '''i8'; - nkInt16Lit: result := litAux(n, n.intVal, 2) + '''i16'; - nkInt32Lit: result := litAux(n, n.intVal, 4) + '''i32'; - nkInt64Lit: result := litAux(n, n.intVal, 8) + '''i64'; - nkFloatLit: begin - if n.flags * [nfBase2, nfBase8, nfBase16] = [] then - result := toStringF(n.floatVal) - else - result := litAux(n, ({@cast}PInt64(addr(n.floatVal)))^, 8); - end; - nkFloat32Lit: begin - if n.flags * [nfBase2, nfBase8, nfBase16] = [] then - result := toStringF(n.floatVal) + '''f32' - else begin - f := n.floatVal; - result := litAux(n, ({@cast}PInt32(addr(f)))^, 4) + '''f32' - end; - end; - nkFloat64Lit: begin - if n.flags * [nfBase2, nfBase8, nfBase16] = [] then - result := toStringF(n.floatVal) + '''f64' - else - result := litAux(n, ({@cast}PInt64(addr(n.floatVal)))^, 8) + '''f64'; - end; - nkNilLit: result := 'nil'; - nkType: begin - if (n.typ <> nil) and (n.typ.sym <> nil) then result := n.typ.sym.name.s - else result := '[type node]'; - end; - else InternalError('rnimsyn.atom ' + nodeKindToStr[n.kind]); - end -end; - -// --------------------------------------------------------------------------- - -function lcomma(n: PNode; start: int = 0; theEnd: int = -1): int; -var - i: int; -begin - assert(theEnd < 0); - result := 0; - for i := start to sonsLen(n)+theEnd do begin - inc(result, lsub(n.sons[i])); - inc(result, 2); // for ``, `` - end; - if result > 0 then dec(result, 2); // last does not get a comma! -end; - -function lsons(n: PNode; start: int = 0; theEnd: int = -1): int; -var - i: int; -begin - assert(theEnd < 0); - result := 0; - for i := start to sonsLen(n)+theEnd do inc(result, lsub(n.sons[i])); -end; - -function lsub(n: PNode): int; -// computes the length of a tree -var - L: int; -begin - if n = nil then begin result := 0; exit end; - if n.comment <> snil then begin result := maxLineLen+1; exit end; - case n.kind of - nkTripleStrLit: begin - if containsNL(n.strVal) then result := maxLineLen+1 - else result := length(atom(n)); - end; - nkEmpty..pred(nkTripleStrLit), succ(nkTripleStrLit)..nkNilLit: - result := length(atom(n)); - nkCall, nkBracketExpr, nkConv: result := lsub(n.sons[0])+lcomma(n, 1)+2; - nkHiddenStdConv, nkHiddenSubConv, nkHiddenCallConv: begin - result := lsub(n.sons[1]); - end; - nkCast: result := lsub(n.sons[0])+lsub(n.sons[1])+length('cast[]()'); - nkAddr: result := lsub(n.sons[0])+length('addr()'); - nkHiddenAddr, nkHiddenDeref: result := lsub(n.sons[0]); - nkCommand: result := lsub(n.sons[0])+lcomma(n, 1)+1; - nkExprEqExpr, nkAsgn, nkFastAsgn: result := lsons(n)+3; - nkPar, nkCurly, nkBracket: result := lcomma(n)+2; - nkSymChoice: result := lsons(n) + length('()') + sonsLen(n)-1; - nkTupleTy: result := lcomma(n)+length('tuple[]'); - nkDotExpr: result := lsons(n)+1; - nkBind: result := lsons(n)+length('bind_'); - nkCheckedFieldExpr: result := lsub(n.sons[0]); - nkLambda: result := lsons(n)+length('lambda__=_'); - nkConstDef, nkIdentDefs: begin - result := lcomma(n, 0, -3); - L := sonsLen(n); - if n.sons[L-2] <> nil then - result := result + lsub(n.sons[L-2]) + 2; - if n.sons[L-1] <> nil then - result := result + lsub(n.sons[L-1]) + 3; - end; - nkVarTuple: result := lcomma(n, 0, -3) + length('() = ') + lsub(lastSon(n)); - nkChckRangeF: result := length('chckRangeF') + 2 + lcomma(n); - nkChckRange64: result := length('chckRange64') + 2 + lcomma(n); - nkChckRange: result := length('chckRange') + 2 + lcomma(n); - - nkObjDownConv, nkObjUpConv, - nkStringToCString, nkCStringToString, nkPassAsOpenArray: begin - result := 2; - if sonsLen(n) >= 1 then - result := result + lsub(n.sons[0]); - result := result + lcomma(n, 1); - end; - nkExprColonExpr: result := lsons(n) + 2; - nkInfix: result := lsons(n) + 2; - nkPrefix: result := lsons(n) + 1; - nkPostfix: result := lsons(n); - nkCallStrLit: result := lsons(n); - nkPragmaExpr: result := lsub(n.sons[0])+lcomma(n, 1); - nkRange: result := lsons(n) + 2; - nkDerefExpr: result := lsub(n.sons[0])+2; - nkAccQuoted: result := lsub(n.sons[0]) + 2; - - nkIfExpr: result := lsub(n.sons[0].sons[0])+lsub(n.sons[0].sons[1]) - + lsons(n, 1) + length('if_:_'); - nkElifExpr: result := lsons(n) + length('_elif_:_'); - nkElseExpr: result := lsub(n.sons[0])+ length('_else:_'); - - // type descriptions - nkTypeOfExpr: result := lsub(n.sons[0])+length('type_'); - nkRefTy: result := lsub(n.sons[0])+length('ref_'); - nkPtrTy: result := lsub(n.sons[0])+length('ptr_'); - nkVarTy: result := lsub(n.sons[0])+length('var_'); - nkDistinctTy: result := lsub(n.sons[0])+length('Distinct_'); - nkTypeDef: result := lsons(n)+3; - nkOfInherit: result := lsub(n.sons[0])+length('of_'); - nkProcTy: result := lsons(n)+length('proc_'); - nkEnumTy: result := lsub(n.sons[0])+lcomma(n,1)+length('enum_'); - nkEnumFieldDef: result := lsons(n)+3; - - nkVarSection: if sonsLen(n) > 1 then result := maxLineLen+1 - else result := lsons(n) + length('var_'); - nkReturnStmt: result := lsub(n.sons[0])+length('return_'); - nkRaiseStmt: result := lsub(n.sons[0])+length('raise_'); - nkYieldStmt: result := lsub(n.sons[0])+length('yield_'); - nkDiscardStmt: result := lsub(n.sons[0])+length('discard_'); - nkBreakStmt: result := lsub(n.sons[0])+length('break_'); - nkContinueStmt: result := lsub(n.sons[0])+length('continue_'); - nkPragma: result := lcomma(n) + 4; - nkCommentStmt: result := length(n.comment); - - nkOfBranch: result := lcomma(n, 0, -2) + lsub(lastSon(n)) - + length('of_:_'); - nkElifBranch: result := lsons(n)+length('elif_:_'); - nkElse: result := lsub(n.sons[0]) + length('else:_'); - nkFinally: result := lsub(n.sons[0]) + length('finally:_'); - nkGenericParams: result := lcomma(n) + 2; - nkFormalParams: begin - result := lcomma(n, 1) + 2; - if n.sons[0] <> nil then result := result + lsub(n.sons[0]) + 2 - end; - nkExceptBranch: result := lcomma(n, 0, -2) + lsub(lastSon(n)) - + length('except_:_'); - else result := maxLineLen+1 - end -end; - -function fits(const g: TSrcGen; x: int): bool; -begin - result := x + g.lineLen <= maxLineLen -end; - -// ------------------------- render part -------------------------------------- - -type - TSubFlag = (rfLongMode, rfNoIndent, rfInConstExpr); - TSubFlags = set of TSubFlag; - TContext = record{@tuple} - spacing: int; - flags: TSubFlags; - end; - -const - emptyContext: TContext = (spacing: 0; flags: {@set}[]); - -procedure initContext(out c: TContext); -begin - c.spacing := 0; - c.flags := {@set}[]; -end; - -procedure gsub(var g: TSrcGen; n: PNode; const c: TContext); overload; forward; - -procedure gsub(var g: TSrcGen; n: PNode); overload; -var - c: TContext; -begin - initContext(c); - gsub(g, n, c); -end; - -function hasCom(n: PNode): bool; -var - i: int; -begin - result := false; - if n = nil then exit; - if n.comment <> snil then begin result := true; exit end; - case n.kind of - nkEmpty..nkNilLit: begin end; - else begin - for i := 0 to sonsLen(n)-1 do - if hasCom(n.sons[i]) then begin - result := true; exit - end - end - end -end; - -procedure putWithSpace(var g: TSrcGen; kind: TTokType; const s: string); -begin - put(g, kind, s); - put(g, tkSpaces, Space); -end; - -procedure gcommaAux(var g: TSrcGen; n: PNode; ind: int; - start: int = 0; theEnd: int = -1); -var - i, sublen: int; - c: bool; -begin - for i := start to sonsLen(n)+theEnd do begin - c := i < sonsLen(n)+theEnd; - sublen := lsub(n.sons[i])+ord(c); - if not fits(g, sublen) and (ind+sublen < maxLineLen) then optNL(g, ind); - gsub(g, n.sons[i]); - if c then begin - putWithSpace(g, tkComma, ','+''); - if hasCom(n.sons[i]) then begin - gcoms(g); - optNL(g, ind); - end - end - end -end; - -procedure gcomma(var g: TSrcGen; n: PNode; const c: TContext; - start: int = 0; theEnd: int = -1); overload; -var - ind: int; -begin - if rfInConstExpr in c.flags then - ind := g.indent + indentWidth - else begin - ind := g.lineLen; - if ind > maxLineLen div 2 then ind := g.indent + longIndentWid - end; - gcommaAux(g, n, ind, start, theEnd); -end; - -procedure gcomma(var g: TSrcGen; n: PNode; - start: int = 0; theEnd: int = -1); overload; -var - ind: int; -begin - ind := g.lineLen; - if ind > maxLineLen div 2 then ind := g.indent + longIndentWid; - gcommaAux(g, n, ind, start, theEnd); -end; - -procedure gsons(var g: TSrcGen; n: PNode; const c: TContext; - start: int = 0; theEnd: int = -1); -var - i: int; -begin - for i := start to sonsLen(n)+theEnd do begin - gsub(g, n.sons[i], c); - end -end; - -procedure gsection(var g: TSrcGen; n: PNode; const c: TContext; kind: TTokType; - const k: string); -var - i: int; -begin - if sonsLen(n) = 0 then exit; // empty var sections are possible - putWithSpace(g, kind, k); - gcoms(g); - indentNL(g); - for i := 0 to sonsLen(n)-1 do begin - optNL(g); - gsub(g, n.sons[i], c); - gcoms(g); - end; - dedent(g); -end; - - -function longMode(n: PNode; start: int = 0; theEnd: int = -1): bool; -var - i: int; -begin - result := n.comment <> snil; - if not result then begin - // check further - for i := start to sonsLen(n)+theEnd do begin - if (lsub(n.sons[i]) > maxLineLen) then begin - result := true; break end; - end - end -end; - -procedure gstmts(var g: TSrcGen; n: PNode; const c: TContext); -var - i: int; -begin - if n = nil then exit; - if (n.kind = nkStmtList) or (n.kind = nkStmtListExpr) then begin - indentNL(g); - for i := 0 to sonsLen(n)-1 do begin - optNL(g); - gsub(g, n.sons[i]); - gcoms(g); - end; - dedent(g); - end - else begin - if rfLongMode in c.flags then indentNL(g); - gsub(g, n); - gcoms(g); - optNL(g); - if rfLongMode in c.flags then dedent(g); - end -end; - -procedure gif(var g: TSrcGen; n: PNode); -var - c: TContext; - i, len: int; -begin - gsub(g, n.sons[0].sons[0]); - initContext(c); - putWithSpace(g, tkColon, ':'+''); - if longMode(n) or (lsub(n.sons[0].sons[1])+g.lineLen > maxLineLen) then - include(c.flags, rfLongMode); - gcoms(g); // a good place for comments - gstmts(g, n.sons[0].sons[1], c); - len := sonsLen(n); - for i := 1 to len-1 do begin - optNL(g); - gsub(g, n.sons[i], c) - end; -end; - -procedure gwhile(var g: TSrcGen; n: PNode); -var - c: TContext; -begin - putWithSpace(g, tkWhile, 'while'); - gsub(g, n.sons[0]); - putWithSpace(g, tkColon, ':'+''); - initContext(c); - if longMode(n) or (lsub(n.sons[1])+g.lineLen > maxLineLen) then - include(c.flags, rfLongMode); - gcoms(g); // a good place for comments - gstmts(g, n.sons[1], c); -end; - -procedure gtry(var g: TSrcGen; n: PNode); -var - c: TContext; -begin - put(g, tkTry, 'try'); - putWithSpace(g, tkColon, ':'+''); - initContext(c); - if longMode(n) or (lsub(n.sons[0])+g.lineLen > maxLineLen) then - include(c.flags, rfLongMode); - gcoms(g); // a good place for comments - gstmts(g, n.sons[0], c); - gsons(g, n, c, 1); -end; - -procedure gfor(var g: TSrcGen; n: PNode); -var - c: TContext; - len: int; -begin - len := sonsLen(n); - putWithSpace(g, tkFor, 'for'); - initContext(c); - if longMode(n) - or (lsub(n.sons[len-1]) - + lsub(n.sons[len-2]) + 6 + g.lineLen > maxLineLen) then - include(c.flags, rfLongMode); - gcomma(g, n, c, 0, -3); - put(g, tkSpaces, Space); - putWithSpace(g, tkIn, 'in'); - gsub(g, n.sons[len-2], c); - putWithSpace(g, tkColon, ':'+''); - gcoms(g); - gstmts(g, n.sons[len-1], c); -end; - -procedure gmacro(var g: TSrcGen; n: PNode); -var - c: TContext; -begin - initContext(c); - gsub(g, n.sons[0]); - putWithSpace(g, tkColon, ':'+''); - if longMode(n) or (lsub(n.sons[1])+g.lineLen > maxLineLen) then - include(c.flags, rfLongMode); - gcoms(g); - gsons(g, n, c, 1); -end; - -procedure gcase(var g: TSrcGen; n: PNode); -var - c: TContext; - len, last: int; -begin - initContext(c); - len := sonsLen(n); - if n.sons[len-1].kind = nkElse then last := -2 - else last := -1; - if longMode(n, 0, last) then include(c.flags, rfLongMode); - putWithSpace(g, tkCase, 'case'); - gsub(g, n.sons[0]); - gcoms(g); - optNL(g); - gsons(g, n, c, 1, last); - if last = -2 then begin - initContext(c); - if longMode(n.sons[len-1]) then include(c.flags, rfLongMode); - gsub(g, n.sons[len-1], c); - end -end; - -procedure gproc(var g: TSrcGen; n: PNode); -var - c: TContext; -begin - gsub(g, n.sons[0]); - gsub(g, n.sons[1]); - gsub(g, n.sons[2]); - gsub(g, n.sons[3]); - if not (renderNoBody in g.flags) then begin - if n.sons[4] <> nil then begin - put(g, tkSpaces, Space); - putWithSpace(g, tkEquals, '='+''); - indentNL(g); - gcoms(g); - dedent(g); - initContext(c); - gstmts(g, n.sons[4], c); - putNL(g); - end - else begin - indentNL(g); - gcoms(g); - dedent(g); - end - end; -end; - -procedure gblock(var g: TSrcGen; n: PNode); -var - c: TContext; -begin - initContext(c); - putWithSpace(g, tkBlock, 'block'); - gsub(g, n.sons[0]); - putWithSpace(g, tkColon, ':'+''); - if longMode(n) or (lsub(n.sons[1])+g.lineLen > maxLineLen) then - include(c.flags, rfLongMode); - gcoms(g); - gstmts(g, n.sons[1], c); -end; - -procedure gasm(var g: TSrcGen; n: PNode); -begin - putWithSpace(g, tkAsm, 'asm'); - gsub(g, n.sons[0]); - gcoms(g); - gsub(g, n.sons[1]); -end; - -procedure gident(var g: TSrcGen; n: PNode); -var - s: string; - t: TTokType; -begin - s := atom(n); - if (s[strStart] in scanner.SymChars) then begin - if (n.kind = nkIdent) then begin - if (n.ident.id < ord(tokKeywordLow)-ord(tkSymbol)) or - (n.ident.id > ord(tokKeywordHigh)-ord(tkSymbol)) then - t := tkSymbol - else - t := TTokType(n.ident.id+ord(tkSymbol)) - end - else - t := tkSymbol; - end - else - t := tkOpr; - put(g, t, s); - if (n.kind = nkSym) and (renderIds in g.flags) then - put(g, tkIntLit, toString(n.sym.id)); -end; - -procedure gsub(var g: TSrcGen; n: PNode; const c: TContext); -var - L, i: int; - a: TContext; -begin - if n = nil then exit; - if n.comment <> snil then pushCom(g, n); - case n.kind of - // atoms: - nkTripleStrLit: putRawStr(g, tkTripleStrLit, n.strVal); - nkEmpty, nkType: put(g, tkInvalid, atom(n)); - nkSym, nkIdent: gident(g, n); - nkIntLit: put(g, tkIntLit, atom(n)); - nkInt8Lit: put(g, tkInt8Lit, atom(n)); - nkInt16Lit: put(g, tkInt16Lit, atom(n)); - nkInt32Lit: put(g, tkInt32Lit, atom(n)); - nkInt64Lit: put(g, tkInt64Lit, atom(n)); - nkFloatLit: put(g, tkFloatLit, atom(n)); - nkFloat32Lit: put(g, tkFloat32Lit, atom(n)); - nkFloat64Lit: put(g, tkFloat64Lit, atom(n)); - nkStrLit: put(g, tkStrLit, atom(n)); - nkRStrLit: put(g, tkRStrLit, atom(n)); - nkCharLit: put(g, tkCharLit, atom(n)); - nkNilLit: put(g, tkNil, atom(n)); - // complex expressions - nkCall, nkConv, nkDotCall: begin - if sonsLen(n) >= 1 then - gsub(g, n.sons[0]); - put(g, tkParLe, '('+''); - gcomma(g, n, 1); - put(g, tkParRi, ')'+''); - end; - nkCallStrLit: begin - gsub(g, n.sons[0]); - if n.sons[1].kind = nkRStrLit then - put(g, tkRStrLit, '"' + n.sons[1].strVal + '"') - else - gsub(g, n.sons[0]); - end; - nkHiddenStdConv, nkHiddenSubConv, nkHiddenCallConv: begin - gsub(g, n.sons[0]); - end; - nkCast: begin - put(g, tkCast, 'cast'); - put(g, tkBracketLe, '['+''); - gsub(g, n.sons[0]); - put(g, tkBracketRi, ']'+''); - put(g, tkParLe, '('+''); - gsub(g, n.sons[1]); - put(g, tkParRi, ')'+''); - end; - nkAddr: begin - put(g, tkAddr, 'addr'); - put(g, tkParLe, '('+''); - gsub(g, n.sons[0]); - put(g, tkParRi, ')'+''); - end; - nkBracketExpr: begin - gsub(g, n.sons[0]); - put(g, tkBracketLe, '['+''); - gcomma(g, n, 1); - put(g, tkBracketRi, ']'+''); - end; - nkPragmaExpr: begin - gsub(g, n.sons[0]); - gcomma(g, n, 1); - end; - nkCommand: begin - gsub(g, n.sons[0]); - put(g, tkSpaces, space); - gcomma(g, n, 1); - end; - nkExprEqExpr, nkAsgn, nkFastAsgn: begin - gsub(g, n.sons[0]); - put(g, tkSpaces, Space); - putWithSpace(g, tkEquals, '='+''); - gsub(g, n.sons[1]); - end; - nkChckRangeF: begin - put(g, tkSymbol, 'chckRangeF'); - put(g, tkParLe, '('+''); - gcomma(g, n); - put(g, tkParRi, ')'+''); - end; - nkChckRange64: begin - put(g, tkSymbol, 'chckRange64'); - put(g, tkParLe, '('+''); - gcomma(g, n); - put(g, tkParRi, ')'+''); - end; - nkChckRange: begin - put(g, tkSymbol, 'chckRange'); - put(g, tkParLe, '('+''); - gcomma(g, n); - put(g, tkParRi, ')'+''); - end; - nkObjDownConv, nkObjUpConv, - nkStringToCString, nkCStringToString, nkPassAsOpenArray: begin - if sonsLen(n) >= 1 then - gsub(g, n.sons[0]); - put(g, tkParLe, '('+''); - gcomma(g, n, 1); - put(g, tkParRi, ')'+''); - end; - nkSymChoice: begin - put(g, tkParLe, '('+''); - for i := 0 to sonsLen(n)-1 do begin - if i > 0 then put(g, tkOpr, '|'+''); - gsub(g, n.sons[i], c); - end; - put(g, tkParRi, ')'+''); - end; - nkPar: begin - put(g, tkParLe, '('+''); - gcomma(g, n, c); - put(g, tkParRi, ')'+''); - end; - nkCurly: begin - put(g, tkCurlyLe, '{'+''); - gcomma(g, n, c); - put(g, tkCurlyRi, '}'+''); - end; - nkBracket: begin - put(g, tkBracketLe, '['+''); - gcomma(g, n, c); - put(g, tkBracketRi, ']'+''); - end; - nkDotExpr: begin - gsub(g, n.sons[0]); - put(g, tkDot, '.'+''); - gsub(g, n.sons[1]); - end; - nkBind: begin - putWithSpace(g, tkBind, 'bind'); - gsub(g, n.sons[0]); - end; - nkCheckedFieldExpr, nkHiddenAddr, nkHiddenDeref: gsub(g, n.sons[0]); - nkLambda: begin - assert(n.sons[genericParamsPos] = nil); - putWithSpace(g, tkLambda, 'lambda'); - gsub(g, n.sons[paramsPos]); - gsub(g, n.sons[pragmasPos]); - put(g, tkSpaces, Space); - putWithSpace(g, tkEquals, '='+''); - gsub(g, n.sons[codePos]); - end; - nkConstDef, nkIdentDefs: begin - gcomma(g, n, 0, -3); - L := sonsLen(n); - if n.sons[L-2] <> nil then begin - putWithSpace(g, tkColon, ':'+''); - gsub(g, n.sons[L-2]) - end; - if n.sons[L-1] <> nil then begin - put(g, tkSpaces, Space); - putWithSpace(g, tkEquals, '='+''); - gsub(g, n.sons[L-1], c) - end; - end; - nkVarTuple: begin - put(g, tkParLe, '('+''); - gcomma(g, n, 0, -3); - put(g, tkParRi, ')'+''); - put(g, tkSpaces, Space); - putWithSpace(g, tkEquals, '='+''); - gsub(g, lastSon(n), c); - end; - nkExprColonExpr: begin - gsub(g, n.sons[0]); - putWithSpace(g, tkColon, ':'+''); - gsub(g, n.sons[1]); - end; - nkInfix: begin - gsub(g, n.sons[1]); - put(g, tkSpaces, Space); - gsub(g, n.sons[0]); // binary operator - if not fits(g, lsub(n.sons[2])+ lsub(n.sons[0]) + 1) then - optNL(g, g.indent+longIndentWid) - else put(g, tkSpaces, Space); - gsub(g, n.sons[2]); - end; - nkPrefix: begin - gsub(g, n.sons[0]); - put(g, tkSpaces, space); - gsub(g, n.sons[1]); - end; - nkPostfix: begin - gsub(g, n.sons[1]); - gsub(g, n.sons[0]); - end; - nkRange: begin - gsub(g, n.sons[0]); - put(g, tkDotDot, '..'); - gsub(g, n.sons[1]); - end; - nkDerefExpr: begin - gsub(g, n.sons[0]); - putWithSpace(g, tkHat, '^'+''); - // unfortunately this requires a space, because ^. would be - // only one operator - end; - nkAccQuoted: begin - put(g, tkAccent, '`'+''); - gsub(g, n.sons[0]); - put(g, tkAccent, '`'+''); - end; - nkIfExpr: begin - putWithSpace(g, tkIf, 'if'); - gsub(g, n.sons[0].sons[0]); - putWithSpace(g, tkColon, ':'+''); - gsub(g, n.sons[0].sons[1]); - gsons(g, n, emptyContext, 1); - end; - nkElifExpr: begin - putWithSpace(g, tkElif, ' elif'); - gsub(g, n.sons[0]); - putWithSpace(g, tkColon, ':'+''); - gsub(g, n.sons[1]); - end; - nkElseExpr: begin - put(g, tkElse, ' else'); - putWithSpace(g, tkColon, ':'+''); - gsub(g, n.sons[0]); - end; - - nkTypeOfExpr: begin - putWithSpace(g, tkType, 'type'); - gsub(g, n.sons[0]); - end; - nkRefTy: begin - putWithSpace(g, tkRef, 'ref'); - gsub(g, n.sons[0]); - end; - nkPtrTy: begin - putWithSpace(g, tkPtr, 'ptr'); - gsub(g, n.sons[0]); - end; - nkVarTy: begin - putWithSpace(g, tkVar, 'var'); - gsub(g, n.sons[0]); - end; - nkDistinctTy: begin - putWithSpace(g, tkDistinct, 'distinct'); - gsub(g, n.sons[0]); - end; - nkTypeDef: begin - gsub(g, n.sons[0]); - gsub(g, n.sons[1]); - put(g, tkSpaces, Space); - if n.sons[2] <> nil then begin - putWithSpace(g, tkEquals, '='+''); - gsub(g, n.sons[2]); - end - end; - nkObjectTy: begin - putWithSpace(g, tkObject, 'object'); - gsub(g, n.sons[0]); - gsub(g, n.sons[1]); - gcoms(g); - gsub(g, n.sons[2]); - end; - nkRecList: begin - indentNL(g); - for i := 0 to sonsLen(n)-1 do begin - optNL(g); - gsub(g, n.sons[i], c); - gcoms(g); - end; - dedent(g); - putNL(g); - end; - nkOfInherit: begin - putWithSpace(g, tkOf, 'of'); - gsub(g, n.sons[0]); - end; - nkProcTy: begin - putWithSpace(g, tkProc, 'proc'); - gsub(g, n.sons[0]); - gsub(g, n.sons[1]); - end; - nkEnumTy: begin - putWithSpace(g, tkEnum, 'enum'); - gsub(g, n.sons[0]); - gcoms(g); - indentNL(g); - gcommaAux(g, n, g.indent, 1); - gcoms(g); // BUGFIX: comment for the last enum field - dedent(g); - end; - nkEnumFieldDef: begin - gsub(g, n.sons[0]); - put(g, tkSpaces, Space); - putWithSpace(g, tkEquals, '='+''); - gsub(g, n.sons[1]); - end; - nkStmtList, nkStmtListExpr: gstmts(g, n, emptyContext); - nkIfStmt: begin - putWithSpace(g, tkIf, 'if'); - gif(g, n); - end; - nkWhenStmt, nkRecWhen: begin - putWithSpace(g, tkWhen, 'when'); - gif(g, n); - end; - nkWhileStmt: gwhile(g, n); - nkCaseStmt, nkRecCase: gcase(g, n); - nkMacroStmt: gmacro(g, n); - nkTryStmt: gtry(g, n); - nkForStmt: gfor(g, n); - nkBlockStmt, nkBlockExpr: gblock(g, n); - nkAsmStmt: gasm(g, n); - nkProcDef: begin - putWithSpace(g, tkProc, 'proc'); - gproc(g, n); - end; - nkMethodDef: begin - putWithSpace(g, tkMethod, 'method'); - gproc(g, n); - end; - nkIteratorDef: begin - putWithSpace(g, tkIterator, 'iterator'); - gproc(g, n); - end; - nkMacroDef: begin - putWithSpace(g, tkMacro, 'macro'); - gproc(g, n); - end; - nkTemplateDef: begin - putWithSpace(g, tkTemplate, 'template'); - gproc(g, n); - end; - nkTypeSection: gsection(g, n, emptyContext, tkType, 'type'); - nkConstSection: begin - initContext(a); - include(a.flags, rfInConstExpr); - gsection(g, n, a, tkConst, 'const') - end; - nkVarSection: begin - L := sonsLen(n); - if L = 0 then exit; - putWithSpace(g, tkVar, 'var'); - if L > 1 then begin - gcoms(g); - indentNL(g); - for i := 0 to L-1 do begin - optNL(g); - gsub(g, n.sons[i]); - gcoms(g); - end; - dedent(g); - end - else - gsub(g, n.sons[0]); - end; - nkReturnStmt: begin - putWithSpace(g, tkReturn, 'return'); - gsub(g, n.sons[0]); - end; - nkRaiseStmt: begin - putWithSpace(g, tkRaise, 'raise'); - gsub(g, n.sons[0]); - end; - nkYieldStmt: begin - putWithSpace(g, tkYield, 'yield'); - gsub(g, n.sons[0]); - end; - nkDiscardStmt: begin - putWithSpace(g, tkDiscard, 'discard'); - gsub(g, n.sons[0]); - end; - nkBreakStmt: begin - putWithSpace(g, tkBreak, 'break'); - gsub(g, n.sons[0]); - end; - nkContinueStmt: begin - putWithSpace(g, tkContinue, 'continue'); - gsub(g, n.sons[0]); - end; - nkPragma: begin - if not (renderNoPragmas in g.flags) then begin - put(g, tkCurlyDotLe, '{.'); - gcomma(g, n, emptyContext); - put(g, tkCurlyDotRi, '.}') - end; - end; - nkImportStmt: begin - putWithSpace(g, tkImport, 'import'); - gcoms(g); - indentNL(g); - gcommaAux(g, n, g.indent); - dedent(g); - putNL(g); - end; - nkFromStmt: begin - putWithSpace(g, tkFrom, 'from'); - gsub(g, n.sons[0]); - put(g, tkSpaces, Space); - putWithSpace(g, tkImport, 'import'); - gcomma(g, n, emptyContext, 1); - putNL(g); - end; - nkIncludeStmt: begin - putWithSpace(g, tkInclude, 'include'); - gcoms(g); - indentNL(g); - gcommaAux(g, n, g.indent); - dedent(g); - putNL(g); - end; - nkCommentStmt: begin - gcoms(g); - optNL(g); - end; - nkOfBranch: begin - optNL(g); - putWithSpace(g, tkOf, 'of'); - gcomma(g, n, c, 0, -2); - putWithSpace(g, tkColon, ':'+''); - gcoms(g); - gstmts(g, lastSon(n), c); - end; - nkElifBranch: begin - optNL(g); - putWithSpace(g, tkElif, 'elif'); - gsub(g, n.sons[0]); - putWithSpace(g, tkColon, ':'+''); - gcoms(g); - gstmts(g, n.sons[1], c) - end; - nkElse: begin - optNL(g); - put(g, tkElse, 'else'); - putWithSpace(g, tkColon, ':'+''); - gcoms(g); - gstmts(g, n.sons[0], c) - end; - nkFinally: begin - optNL(g); - put(g, tkFinally, 'finally'); - putWithSpace(g, tkColon, ':'+''); - gcoms(g); - gstmts(g, n.sons[0], c) - end; - nkExceptBranch: begin - optNL(g); - putWithSpace(g, tkExcept, 'except'); - gcomma(g, n, 0, -2); - putWithSpace(g, tkColon, ':'+''); - gcoms(g); - gstmts(g, lastSon(n), c) - end; - nkGenericParams: begin - put(g, tkBracketLe, '['+''); - gcomma(g, n); - put(g, tkBracketRi, ']'+''); - end; - nkFormalParams: begin - put(g, tkParLe, '('+''); - gcomma(g, n, 1); - put(g, tkParRi, ')'+''); - if n.sons[0] <> nil then begin - putWithSpace(g, tkColon, ':'+''); - gsub(g, n.sons[0]); - end; - // XXX: gcomma(g, n, 1, -2); - end; - nkTupleTy: begin - put(g, tkTuple, 'tuple'); - put(g, tkBracketLe, '['+''); - gcomma(g, n); - put(g, tkBracketRi, ']'+''); - end; - else begin - //nkNone, nkMetaNode, nkTableConstr, nkExplicitTypeListCall: begin - InternalError(n.info, 'rnimsyn.gsub(' +{&} nodeKindToStr[n.kind] +{&} ')') - end - end -end; - -function renderTree(n: PNode; renderFlags: TRenderFlags = {@set}[]): string; -var - g: TSrcGen; -begin - initSrcGen(g, renderFlags); - gsub(g, n); - result := g.buf -end; - -procedure renderModule(n: PNode; const filename: string; - renderFlags: TRenderFlags = {@set}[]); -var - i: int; - f: tTextFile; - g: TSrcGen; -begin - initSrcGen(g, renderFlags); - for i := 0 to sonsLen(n)-1 do begin - gsub(g, n.sons[i]); - optNL(g); - if n.sons[i] <> nil then - case n.sons[i].kind of - nkTypeSection, nkConstSection, nkVarSection, nkCommentStmt: - putNL(g); - else begin end - end - end; - gcoms(g); - if OpenFile(f, filename, fmWrite) then begin - nimWrite(f, g.buf); - nimCloseFile(f); - end; -end; - -procedure initTokRender(var r: TSrcGen; n: PNode; - renderFlags: TRenderFlags = {@set}[]); -begin - initSrcGen(r, renderFlags); - gsub(r, n); -end; - -procedure getNextTok(var r: TSrcGen; var kind: TTokType; var literal: string); -var - len: int; -begin - if r.idx < length(r.tokens) then begin - kind := r.tokens[r.idx].kind; - len := r.tokens[r.idx].len; - literal := ncopy(r.buf, r.pos+strStart, r.pos+strStart+len-1); - inc(r.pos, len); - inc(r.idx); - end - else - kind := tkEof; -end; - -end. diff --git a/nim/rodread.pas b/nim/rodread.pas deleted file mode 100755 index 457ad6cc2..000000000 --- a/nim/rodread.pas +++ /dev/null @@ -1,1137 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit rodread; - -// This module is responsible for loading of rod files. -(* - Reading and writing binary files are really hard to debug. Therefore we use - a special text format. ROD-files only describe the interface of a module. - Thus they are smaller than the source files most of the time. Even if they - are bigger, they are more efficient to process because symbols are only - loaded on demand. - It consists of: - - - a header: - NIM:$fileversion\n - - the module's id (even if the module changed, its ID will not!): - ID:Ax3\n - - CRC value of this module: - CRC:CRC-val\n - - a section containing the compiler options and defines this - module has been compiled with: - OPTIONS:options\n - DEFINES:defines\n - - FILES( - myfile.inc - lib/mymodA - ) - - a include file dependency section: - INCLUDES( - <fileidx> <CRC of myfile.inc>\n # fileidx is the LINE in the file section! - ) - - a module dependency section: - DEPS: <fileidx> <fileidx>\n - - an interface section: - INTERF( - identifier1 id\n # id is the symbol's id - identifier2 id\n - ) - - a compiler proc section: - COMPILERPROCS( - identifier1 id\n # id is the symbol's id - ) - - an index consisting of (ID, linenumber)-pairs: - INDEX( - id-diff idx-diff\n - id-diff idx-diff\n - ) - - an import index consisting of (ID, moduleID)-pairs: - IMPORTS( - id-diff moduleID-diff\n - id-diff moduleID-diff\n - ) - - a list of all exported type converters because they are needed for correct - semantic checking: - CONVERTERS:id id\n # position of the symbol in the DATA section - - an AST section that contains the module's AST: - INIT( - idx\n # position of the node in the DATA section - idx\n - ) - - a data section, where each type, symbol or AST is stored. - DATA( - type - (node) - sym - ) - - We now also do index compression, because an index always needs to be read. -*) - -interface - -{$include 'config.inc'} - -uses - sysutils, nsystem, nos, options, strutils, nversion, ast, astalgo, msgs, - platform, condsyms, ropes, idents, crc; - -type - TReasonForRecompile = ( - rrEmpty, // used by moddeps module - rrNone, // no need to recompile - rrRodDoesNotExist, // rod file does not exist - rrRodInvalid, // rod file is invalid - rrCrcChange, // file has been edited since last recompilation - rrDefines, // defines have changed - rrOptions, // options have changed - rrInclDeps, // an include has changed - rrModDeps // a module this module depends on has been changed - ); -const - reasonToFrmt: array [TReasonForRecompile] of string = ( - '', - 'no need to recompile: $1', - 'symbol file for $1 does not exist', - 'symbol file for $1 has the wrong version', - 'file edited since last compilation: $1', - 'list of conditional symbols changed for: $1', - 'list of options changed for: $1', - 'an include file edited: $1', - 'a module $1 depends on has changed' - ); - -type - TIndex = record // an index with compression - lastIdxKey, lastIdxVal: int; - tab: TIITable; - r: PRope; // writers use this - offset: int; // readers use this - end; - TRodReader = object(NObject) - pos: int; // position; used for parsing - s: string; // the whole file in memory - options: TOptions; - reason: TReasonForRecompile; - modDeps: TStringSeq; - files: TStringSeq; - dataIdx: int; // offset of start of data section - convertersIdx: int; // offset of start of converters section - initIdx, interfIdx, compilerProcsIdx, cgenIdx: int; - filename: string; - index, imports: TIndex; - readerIndex: int; - line: int; // only used for debugging, but is always in the code - moduleID: int; - syms: TIdTable; // already processed symbols - end; - PRodReader = ^TRodReader; - -const - FileVersion = '1012'; // modify this if the rod-format changes! - -var - rodCompilerprocs: TStrTable; // global because this is needed by magicsys - - -function handleSymbolFile(module: PSym; const filename: string): PRodReader; -function GetCRC(const filename: string): TCrc32; - -function loadInitSection(r: PRodReader): PNode; - -procedure loadStub(s: PSym); - -function encodeInt(x: BiggestInt): PRope; -function encode(const s: string): PRope; - -implementation - -var - gTypeTable: TIdTable; - -function rrGetSym(r: PRodReader; id: int; const info: TLineInfo): PSym; forward; - // `info` is only used for debugging purposes - -function rrGetType(r: PRodReader; id: int; const info: TLineInfo): PType; forward; - -function decode(r: PRodReader): string; forward; -function decodeInt(r: PRodReader): int; forward; -function decodeBInt(r: PRodReader): biggestInt; forward; - -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 - 'a'..'z', 'A'..'Z', '0'..'9', '_': - addChar(res, s[i]); - else - res := res +{&} '\' +{&} toHex(ord(s[i]), 2) - end - end; - result := toRope(res); -end; - -procedure encodeIntAux(var str: string; x: BiggestInt); -const - chars: string = - '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'; -var - v, rem: biggestInt; - d: char; - idx: int; -begin - v := x; - rem := v mod 190; - if (rem < 0) then begin - str := str + '-'; - v := -(v div 190); - rem := -rem; - end - else - v := v div 190; - idx := int(rem); - if idx < 62 then d := chars[idx+strStart] - else d := chr(idx - 62 + 128); - if (v <> 0) then encodeIntAux(str, v); - addChar(str, d); -end; - -function encodeInt(x: BiggestInt): PRope; -var - res: string; -begin - res := ''; - encodeIntAux(res, x); - result := toRope(res); -end; - - -procedure decodeLineInfo(r: PRodReader; var info: TLineInfo); -begin - if r.s[r.pos] = '?' then begin - inc(r.pos); - if r.s[r.pos] = ',' then - info.col := int16(-1) - else - info.col := int16(decodeInt(r)); - if r.s[r.pos] = ',' then begin - inc(r.pos); - if r.s[r.pos] = ',' then info.line := int16(-1) - else info.line := int16(decodeInt(r)); - if r.s[r.pos] = ',' then begin - inc(r.pos); - info := newLineInfo(r.files[decodeInt(r)], info.line, info.col); - end - end - end -end; - -function decodeNode(r: PRodReader; const fInfo: TLineInfo): PNode; -var - id: int; - fl: string; -begin - result := nil; - if r.s[r.pos] = '(' then begin - inc(r.pos); - if r.s[r.pos] = ')' then begin - inc(r.pos); exit; // nil node - end; - result := newNodeI(TNodeKind(decodeInt(r)), fInfo); - decodeLineInfo(r, result.info); - if r.s[r.pos] = '$' then begin - inc(r.pos); - result.flags := {@cast}TNodeFlags(int32(decodeInt(r))); - end; - if r.s[r.pos] = '^' then begin - inc(r.pos); - id := decodeInt(r); - result.typ := rrGetType(r, id, result.info); - end; - case result.kind of - nkCharLit..nkInt64Lit: begin - if r.s[r.pos] = '!' then begin - inc(r.pos); - result.intVal := decodeBInt(r); - end - end; - nkFloatLit..nkFloat64Lit: begin - if r.s[r.pos] = '!' then begin - inc(r.pos); - fl := decode(r); - result.floatVal := parseFloat(fl); - end - end; - nkStrLit..nkTripleStrLit: begin - if r.s[r.pos] = '!' then begin - inc(r.pos); - result.strVal := decode(r); - end - else - result.strVal := ''; // BUGFIX - end; - nkIdent: begin - if r.s[r.pos] = '!' then begin - inc(r.pos); - fl := decode(r); - result.ident := getIdent(fl); - end - else - internalError(result.info, 'decodeNode: nkIdent'); - end; - nkSym: begin - if r.s[r.pos] = '!' then begin - inc(r.pos); - id := decodeInt(r); - result.sym := rrGetSym(r, id, result.info); - end - else - internalError(result.info, 'decodeNode: nkSym'); - end; - else begin - while r.s[r.pos] <> ')' do - addSon(result, decodeNode(r, result.info)); - end - end; - if r.s[r.pos] = ')' then inc(r.pos) - else internalError(result.info, 'decodeNode'); - end - else InternalError(result.info, 'decodeNode ' + r.s[r.pos]) -end; - -procedure decodeLoc(r: PRodReader; var loc: TLoc; const info: TLineInfo); -begin - if r.s[r.pos] = '<' then begin - inc(r.pos); - if r.s[r.pos] in ['0'..'9', 'a'..'z', 'A'..'Z'] then - loc.k := TLocKind(decodeInt(r)) - else - loc.k := low(loc.k); - if r.s[r.pos] = '*' then begin - inc(r.pos); - loc.s := TStorageLoc(decodeInt(r)); - end - else - loc.s := low(loc.s); - if r.s[r.pos] = '$' then begin - inc(r.pos); - loc.flags := {@cast}TLocFlags(int32(decodeInt(r))); - end - else - loc.flags := {@set}[]; - if r.s[r.pos] = '^' then begin - inc(r.pos); - loc.t := rrGetType(r, decodeInt(r), info); - end - else - loc.t := nil; - if r.s[r.pos] = '!' then begin - inc(r.pos); - loc.r := toRope(decode(r)); - end - else - loc.r := nil; - if r.s[r.pos] = '?' then begin - inc(r.pos); - loc.a := decodeInt(r); - end - else - loc.a := 0; - if r.s[r.pos] = '>' then inc(r.pos) - else InternalError(info, 'decodeLoc ' + r.s[r.pos]); - end -end; - -function decodeType(r: PRodReader; const info: TLineInfo): PType; -var - d: int; -begin - result := nil; - if r.s[r.pos] = '[' then begin - inc(r.pos); - if r.s[r.pos] = ']' then begin - inc(r.pos); exit; // nil type - end; - end; - new(result); -{@ignore} - FillChar(result^, sizeof(result^), 0); -{@emit} - result.kind := TTypeKind(decodeInt(r)); - if r.s[r.pos] = '+' then begin - inc(r.pos); - result.id := decodeInt(r); - setId(result.id); - if debugIds then registerID(result); - end - else - InternalError(info, 'decodeType: no id'); - IdTablePut(gTypeTable, result, result); // here this also - // avoids endless recursion for recursive type - if r.s[r.pos] = '(' then - result.n := decodeNode(r, UnknownLineInfo()); - if r.s[r.pos] = '$' then begin - inc(r.pos); - result.flags := {@cast}TTypeFlags(int32(decodeInt(r))); - end; - if r.s[r.pos] = '?' then begin - inc(r.pos); - result.callConv := TCallingConvention(decodeInt(r)); - end; - if r.s[r.pos] = '*' then begin - inc(r.pos); - result.owner := rrGetSym(r, decodeInt(r), info); - end; - if r.s[r.pos] = '&' then begin - inc(r.pos); - result.sym := rrGetSym(r, decodeInt(r), info); - end; - if r.s[r.pos] = '/' then begin - inc(r.pos); - result.size := decodeInt(r); - end - else result.size := -1; - if r.s[r.pos] = '=' then begin - inc(r.pos); - result.align := decodeInt(r); - end - else result.align := 2; - if r.s[r.pos] = '@' then begin - inc(r.pos); - result.containerID := decodeInt(r); - end; - decodeLoc(r, result.loc, info); - while r.s[r.pos] = '^' do begin - inc(r.pos); - if r.s[r.pos] = '(' then begin - inc(r.pos); - if r.s[r.pos] = ')' then inc(r.pos) - else InternalError(info, 'decodeType ^(' + r.s[r.pos]); - addSon(result, nil); - end - else begin - d := decodeInt(r); - addSon(result, rrGetType(r, d, info)); - end; - end -end; - -function decodeLib(r: PRodReader): PLib; -begin - result := nil; - if r.s[r.pos] = '|' then begin - new(result); - {@ignore} - fillChar(result^, sizeof(result^), 0); - {@emit} - inc(r.pos); - result.kind := TLibKind(decodeInt(r)); - if r.s[r.pos] <> '|' then InternalError('decodeLib: 1'); - inc(r.pos); - result.name := toRope(decode(r)); - if r.s[r.pos] <> '|' then InternalError('decodeLib: 2'); - inc(r.pos); - result.path := decode(r); - end -end; - -function decodeSym(r: PRodReader; const info: TLineInfo): PSym; -var - k: TSymKind; - id: int; - ident: PIdent; -begin - result := nil; - if r.s[r.pos] = '{' then begin - inc(r.pos); - if r.s[r.pos] = '}' then begin - inc(r.pos); exit; // nil sym - end - end; - k := TSymKind(decodeInt(r)); - if r.s[r.pos] = '+' then begin - inc(r.pos); - id := decodeInt(r); - setId(id); - end - else - InternalError(info, 'decodeSym: no id'); - if r.s[r.pos] = '&' then begin - inc(r.pos); - ident := getIdent(decode(r)); - end - else - InternalError(info, 'decodeSym: no ident'); - result := PSym(IdTableGet(r.syms, id)); - if result = nil then begin - new(result); - {@ignore} - FillChar(result^, sizeof(result^), 0); - {@emit} - result.id := id; - IdTablePut(r.syms, result, result); - if debugIds then registerID(result); - end - else if (result.id <> id) then - InternalError(info, 'decodeSym: wrong id'); - result.kind := k; - result.name := ident; - // read the rest of the symbol description: - if r.s[r.pos] = '^' then begin - inc(r.pos); - result.typ := rrGetType(r, decodeInt(r), info); - end; - decodeLineInfo(r, result.info); - if r.s[r.pos] = '*' then begin - inc(r.pos); - result.owner := rrGetSym(r, decodeInt(r), result.info); - end; - if r.s[r.pos] = '$' then begin - inc(r.pos); - result.flags := {@cast}TSymFlags(int32(decodeInt(r))); - end; - if r.s[r.pos] = '@' then begin - inc(r.pos); - result.magic := TMagic(decodeInt(r)); - end; - if r.s[r.pos] = '(' then - result.ast := decodeNode(r, result.info); - if r.s[r.pos] = '!' then begin - inc(r.pos); - result.options := {@cast}TOptions(int32(decodeInt(r))); - end - else - result.options := r.options; - if r.s[r.pos] = '%' then begin - inc(r.pos); - result.position := decodeInt(r); - end - else - result.position := 0; // BUGFIX: this may have been misused as reader index! - if r.s[r.pos] = '`' then begin - inc(r.pos); - result.offset := decodeInt(r); - end - else - result.offset := -1; - decodeLoc(r, result.loc, result.info); - result.annex := decodeLib(r); -end; - -function decodeInt(r: PRodReader): int; // base 190 numbers -var - i: int; - sign: int; -begin - i := r.pos; - sign := -1; - assert(r.s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '-', #128..#255]); - if r.s[i] = '-' then begin - inc(i); - sign := 1 - end; - result := 0; - while true do begin - case r.s[i] of - '0'..'9': result := result * 190 - (ord(r.s[i]) - ord('0')); - 'a'..'z': result := result * 190 - (ord(r.s[i]) - ord('a') + 10); - 'A'..'Z': result := result * 190 - (ord(r.s[i]) - ord('A') + 36); - #128..#255: result := result * 190 - (ord(r.s[i]) - 128 + 62); - else break; - end; - inc(i) - end; - result := result * sign; - r.pos := i -end; - -function decodeBInt(r: PRodReader): biggestInt; -var - i: int; - sign: biggestInt; -begin - i := r.pos; - sign := -1; - assert(r.s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '-', #128..#255]); - if r.s[i] = '-' then begin - inc(i); - sign := 1 - end; - result := 0; - while true do begin - case r.s[i] of - '0'..'9': result := result * 190 - (ord(r.s[i]) - ord('0')); - 'a'..'z': result := result * 190 - (ord(r.s[i]) - ord('a') + 10); - 'A'..'Z': result := result * 190 - (ord(r.s[i]) - ord('A') + 36); - #128..#255: result := result * 190 - (ord(r.s[i]) - 128 + 62); - else break; - end; - inc(i) - end; - result := result * sign; - r.pos := i -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(r: PRodReader): string; -var - i, xi: int; -begin - i := r.pos; - result := ''; - while true do begin - case r.s[i] of - '\': begin - inc(i, 3); xi := 0; - hexChar(r.s[i-2], xi); - hexChar(r.s[i-1], xi); - addChar(result, chr(xi)); - end; - 'a'..'z', 'A'..'Z', '0'..'9', '_': begin - addChar(result, r.s[i]); - inc(i); - end - else break - end - end; - r.pos := i; -end; - -procedure skipSection(r: PRodReader); -var - c: int; -begin - if r.s[r.pos] = ':' then begin - while r.s[r.pos] > #10 do inc(r.pos); - end - else if r.s[r.pos] = '(' then begin - c := 0; // count () pairs - inc(r.pos); - while true do begin - case r.s[r.pos] of - #10: inc(r.line); - '(': inc(c); - ')': begin - if c = 0 then begin inc(r.pos); break end - else if c > 0 then dec(c); - end; - #0: break; // end of file - else begin end; - end; - inc(r.pos); - end - end - else - InternalError('skipSection ' + toString(r.line)); -end; - -function rdWord(r: PRodReader): string; -begin - result := ''; - while r.s[r.pos] in ['A'..'Z', '_', 'a'..'z', '0'..'9'] do begin - addChar(result, r.s[r.pos]); - inc(r.pos); - end; -end; - -function newStub(r: PRodReader; const name: string; id: int): PSym; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - result.kind := skStub; - result.id := id; - result.name := getIdent(name); - result.position := r.readerIndex; - setID(id); - //MessageOut(result.name.s); - if debugIds then registerID(result); -end; - -procedure processInterf(r: PRodReader; module: PSym); -var - s: PSym; - w: string; - key: int; -begin - if r.interfIdx = 0 then InternalError('processInterf'); - r.pos := r.interfIdx; - while (r.s[r.pos] > #10) and (r.s[r.pos] <> ')') do begin - w := decode(r); - inc(r.pos); - key := decodeInt(r); - inc(r.pos); // #10 - s := newStub(r, w, key); - s.owner := module; - StrTableAdd(module.tab, s); - IdTablePut(r.syms, s, s); - end; -end; - -procedure processCompilerProcs(r: PRodReader; module: PSym); -var - s: PSym; - w: string; - key: int; -begin - if r.compilerProcsIdx = 0 then InternalError('processCompilerProcs'); - r.pos := r.compilerProcsIdx; - while (r.s[r.pos] > #10) and (r.s[r.pos] <> ')') do begin - w := decode(r); - inc(r.pos); - key := decodeInt(r); - inc(r.pos); // #10 - s := PSym(IdTableGet(r.syms, key)); - if s = nil then begin - s := newStub(r, w, key); - s.owner := module; - IdTablePut(r.syms, s, s); - end; - StrTableAdd(rodCompilerProcs, s); - end; -end; - -procedure processIndex(r: PRodReader; var idx: TIndex); -var - key, val, tmp: int; -begin - inc(r.pos, 2); // skip "(\10" - inc(r.line); - while (r.s[r.pos] > #10) and (r.s[r.pos] <> ')') do begin - tmp := decodeInt(r); - if r.s[r.pos] = ' ' then begin - inc(r.pos); - key := idx.lastIdxKey + tmp; - val := decodeInt(r) + idx.lastIdxVal; - end - else begin - key := idx.lastIdxKey + 1; - val := tmp + idx.lastIdxVal; - end; - IITablePut(idx.tab, key, val); - idx.lastIdxKey := key; - idx.lastIdxVal := val; - setID(key); // ensure that this id will not be used - if r.s[r.pos] = #10 then begin inc(r.pos); inc(r.line) end; - end; - if r.s[r.pos] = ')' then inc(r.pos); -end; - -procedure processRodFile(r: PRodReader; crc: TCrc32); -var - section, w: string; - d, L, inclCrc: int; -begin - while r.s[r.pos] <> #0 do begin - section := rdWord(r); - if r.reason <> rrNone then break; // no need to process this file further - if section = 'CRC' then begin - inc(r.pos); // skip ':' - if int(crc) <> decodeInt(r) then - r.reason := rrCrcChange - end - else if section = 'ID' then begin - inc(r.pos); // skip ':' - r.moduleID := decodeInt(r); - setID(r.moduleID); - end - else if section = 'OPTIONS' then begin - inc(r.pos); // skip ':' - r.options := {@cast}TOptions(int32(decodeInt(r))); - if options.gOptions <> r.options then r.reason := rrOptions - end - else if section = 'DEFINES' then begin - inc(r.pos); // skip ':' - d := 0; - while r.s[r.pos] > #10 do begin - w := decode(r); - inc(d); - if not condsyms.isDefined(getIdent(w)) then begin - r.reason := rrDefines; - //MessageOut('not defined, but should: ' + w); - end; - if r.s[r.pos] = ' ' then inc(r.pos); - end; - if (d <> countDefinedSymbols()) then - r.reason := rrDefines - end - else if section = 'FILES' then begin - inc(r.pos, 2); // skip "(\10" - inc(r.line); - L := 0; - while (r.s[r.pos] > #10) and (r.s[r.pos] <> ')') do begin - setLength(r.files, L+1); - r.files[L] := decode(r); - inc(r.pos); // skip #10 - inc(r.line); - inc(L); - end; - if r.s[r.pos] = ')' then inc(r.pos); - end - else if section = 'INCLUDES' then begin - inc(r.pos, 2); // skip "(\10" - inc(r.line); - while (r.s[r.pos] > #10) and (r.s[r.pos] <> ')') do begin - w := r.files[decodeInt(r)]; - inc(r.pos); // skip ' ' - inclCrc := decodeInt(r); - if r.reason = rrNone then begin - if not ExistsFile(w) or (inclCrc <> int(crcFromFile(w))) then - r.reason := rrInclDeps - end; - if r.s[r.pos] = #10 then begin inc(r.pos); inc(r.line) end; - end; - if r.s[r.pos] = ')' then inc(r.pos); - end - else if section = 'DEPS' then begin - inc(r.pos); // skip ':' - L := 0; - while (r.s[r.pos] > #10) do begin - setLength(r.modDeps, L+1); - r.modDeps[L] := r.files[decodeInt(r)]; - inc(L); - if r.s[r.pos] = ' ' then inc(r.pos); - end; - end - else if section = 'INTERF' then begin - r.interfIdx := r.pos+2; - skipSection(r); - end - else if section = 'COMPILERPROCS' then begin - r.compilerProcsIdx := r.pos+2; - skipSection(r); - end - else if section = 'INDEX' then begin - processIndex(r, r.index); - end - else if section = 'IMPORTS' then begin - processIndex(r, r.imports); - end - else if section = 'CONVERTERS' then begin - r.convertersIdx := r.pos+1; - skipSection(r); - end - else if section = 'DATA' then begin - r.dataIdx := r.pos+2; // "(\10" - // We do not read the DATA section here! We read the needed objects on - // demand. - skipSection(r); - end - else if section = 'INIT' then begin - r.initIdx := r.pos+2; // "(\10" - skipSection(r); - end - else if section = 'CGEN' then begin - r.cgenIdx := r.pos+2; - skipSection(r); - end - else begin - MessageOut('skipping section: ' + toString(r.pos)); - skipSection(r); - end; - if r.s[r.pos] = #10 then begin inc(r.pos); inc(r.line) end; - end -end; - -function newRodReader(const modfilename: string; crc: TCrc32; - readerIndex: int): PRodReader; -var - version: string; - r: PRodReader; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit result.files := @[];} -{@emit result.modDeps := @[];} - r := result; - r.reason := rrNone; - r.pos := strStart; - r.line := 1; - r.readerIndex := readerIndex; - r.filename := modfilename; - InitIdTable(r.syms); - r.s := readFile(modfilename) {@ignore} + #0 {@emit}; - if startsWith(r.s, 'NIM:') then begin - initIITable(r.index.tab); - initIITable(r.imports.tab); - // looks like a ROD file - inc(r.pos, 4); - version := ''; - while not (r.s[r.pos] in [#0,#10]) do begin - addChar(version, r.s[r.pos]); - inc(r.pos); - end; - if r.s[r.pos] = #10 then inc(r.pos); - if version = FileVersion then begin - // since ROD files are only for caching, no backwarts compability is - // needed - processRodFile(r, crc); - end - else - result := nil - end - else - result := nil; -end; - -function rrGetType(r: PRodReader; id: int; const info: TLineInfo): PType; -var - oldPos, d: int; -begin - result := PType(IdTableGet(gTypeTable, id)); - if result = nil then begin - // load the type: - oldPos := r.pos; - d := IITableGet(r.index.tab, id); - if d = invalidKey then InternalError(info, 'rrGetType'); - r.pos := d + r.dataIdx; - result := decodeType(r, info); - r.pos := oldPos; - end; -end; - -type - TFileModuleRec = record - filename: string; - reason: TReasonForRecompile; - rd: PRodReader; - crc: TCrc32; - end; - TFileModuleMap = array of TFileModuleRec; -var - gMods: TFileModuleMap = {@ignore} nil {@emit @[]}; // all compiled modules - -function decodeSymSafePos(rd: PRodReader; offset: int; - const info: TLineInfo): PSym; -var - oldPos: int; -begin - if rd.dataIdx = 0 then InternalError(info, 'dataIdx == 0'); - oldPos := rd.pos; - rd.pos := offset + rd.dataIdx; - result := decodeSym(rd, info); - rd.pos := oldPos; -end; - -function rrGetSym(r: PRodReader; id: int; const info: TLineInfo): PSym; -var - d, i, moduleID: int; - rd: PRodReader; -begin - result := PSym(IdTableGet(r.syms, id)); - if result = nil then begin - // load the symbol: - d := IITableGet(r.index.tab, id); - if d = invalidKey then begin - moduleID := IiTableGet(r.imports.tab, id); - if moduleID < 0 then - InternalError(info, - 'missing from both indexes: +' + ropeToStr(encodeInt(id))); - // find the reader with the correct moduleID: - for i := 0 to high(gMods) do begin - rd := gMods[i].rd; - if (rd <> nil) then begin - if (rd.moduleID = moduleID) then begin - d := IITableGet(rd.index.tab, id); - if d <> invalidKey then begin - result := decodeSymSafePos(rd, d, info); - break - end - else - InternalError(info, - 'rrGetSym: no reader found: +' + ropeToStr(encodeInt(id))); - end - else begin - //if IiTableGet(rd.index.tab, id) <> invalidKey then - // XXX expensive check! - //InternalError(info, - //'id found in other module: +' + ropeToStr(encodeInt(id))) - end - end - end; - end - else begin - // own symbol: - result := decodeSymSafePos(r, d, info); - end; - end; - if (result <> nil) and (result.kind = skStub) then loadStub(result); -end; - -function loadInitSection(r: PRodReader): PNode; -var - d, oldPos, p: int; -begin - if (r.initIdx = 0) or (r.dataIdx = 0) then InternalError('loadInitSection'); - oldPos := r.pos; - r.pos := r.initIdx; - result := newNode(nkStmtList); - while (r.s[r.pos] > #10) and (r.s[r.pos] <> ')') do begin - d := decodeInt(r); - inc(r.pos); // #10 - p := r.pos; - r.pos := d + r.dataIdx; - addSon(result, decodeNode(r, UnknownLineInfo())); - r.pos := p; - end; - r.pos := oldPos; -end; - -procedure loadConverters(r: PRodReader); -var - d: int; -begin - // We have to ensure that no exported converter is a stub anymore. - if (r.convertersIdx = 0) or (r.dataIdx = 0) then - InternalError('importConverters'); - r.pos := r.convertersIdx; - while (r.s[r.pos] > #10) do begin - d := decodeInt(r); - {@discard} rrGetSym(r, d, UnknownLineInfo()); - if r.s[r.pos] = ' ' then inc(r.pos) - end; -end; - -function getModuleIdx(const filename: string): int; -var - i: int; -begin - for i := 0 to high(gMods) do - if sameFile(gMods[i].filename, filename) then begin - result := i; exit - end; - // not found, reserve space: - result := length(gMods); - setLength(gMods, result+1); -end; - -function checkDep(const filename: string): TReasonForRecompile; -var - crc: TCrc32; - r: PRodReader; - rodfile: string; - idx, i: int; - res: TReasonForRecompile; -begin - idx := getModuleIdx(filename); - if gMods[idx].reason <> rrEmpty then begin - // reason has already been computed for this module: - result := gMods[idx].reason; exit - end; - crc := crcFromFile(filename); - gMods[idx].reason := rrNone; // we need to set it here to avoid cycles - gMods[idx].filename := filename; - gMods[idx].crc := crc; - result := rrNone; - r := nil; - rodfile := toGeneratedFile(filename, RodExt); - if ExistsFile(rodfile) then begin - r := newRodReader(rodfile, crc, idx); - if r = nil then - result := rrRodInvalid - else begin - result := r.reason; - if result = rrNone then begin - // check modules it depends on - // NOTE: we need to process the entire module graph so that no ID will - // be used twice! However, compilation speed does not suffer much from - // this, since results are cached. - res := checkDep(JoinPath(options.libpath, addFileExt('system', nimExt))); - if res <> rrNone then result := rrModDeps; - for i := 0 to high(r.modDeps) do begin - res := checkDep(r.modDeps[i]); - if res <> rrNone then begin - result := rrModDeps; - //break // BUGFIX: cannot break here! - end - end - end - end - end - else - result := rrRodDoesNotExist; - if (result <> rrNone) and (gVerbosity > 0) then - MessageOut(format(reasonToFrmt[result], [filename])); - if (result <> rrNone) or (optForceFullMake in gGlobalOptions) then begin - // recompilation is necessary: - r := nil; - end; - gMods[idx].rd := r; - gMods[idx].reason := result; // now we know better -end; - -function handleSymbolFile(module: PSym; const filename: string): PRodReader; -var - idx: int; -begin - if not (optSymbolFiles in gGlobalOptions) then begin - module.id := getID(); - result := nil; - exit - end; - {@discard} checkDep(filename); - idx := getModuleIdx(filename); - if gMods[idx].reason = rrEmpty then InternalError('handleSymbolFile'); - result := gMods[idx].rd; - if result <> nil then begin - module.id := result.moduleID; - IdTablePut(result.syms, module, module); - processInterf(result, module); - processCompilerProcs(result, module); - loadConverters(result); - end - else - module.id := getID(); -end; - -function GetCRC(const filename: string): TCrc32; -var - idx: int; -begin - idx := getModuleIdx(filename); - result := gMods[idx].crc; -end; - -procedure loadStub(s: PSym); -var - rd: PRodReader; - d, theId: int; - rs: PSym; -begin - if s.kind <> skStub then InternalError('loadStub'); - //MessageOut('loading stub: ' + s.name.s); - rd := gMods[s.position].rd; - theId := s.id; // used for later check - d := IITableGet(rd.index.tab, s.id); - if d = invalidKey then InternalError('loadStub: invalid key'); - rs := decodeSymSafePos(rd, d, UnknownLineInfo()); - if rs <> s then InternalError(rs.info, 'loadStub: wrong symbol') - else if rs.id <> theId then InternalError(rs.info, 'loadStub: wrong ID'); - //MessageOut('loaded stub: ' + s.name.s); -end; - -initialization - InitIdTable(gTypeTable); - InitStrTable(rodCompilerProcs); -end. diff --git a/nim/rodwrite.pas b/nim/rodwrite.pas deleted file mode 100755 index c71eda7e3..000000000 --- a/nim/rodwrite.pas +++ /dev/null @@ -1,612 +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 rodwrite; - -// This module is responsible for writing of rod files. Note that writing of -// rod files is a pass, reading of rod files is not! This is why reading and -// writing of rod files is split into two different modules. - -interface - -{$include 'config.inc'} - -uses - sysutils, nsystem, nos, options, strutils, nversion, ast, astalgo, msgs, - platform, condsyms, ropes, idents, crc, rodread, passes, importer; - -function rodwritePass(): TPass; - -implementation - -type - TRodWriter = object(TPassContext) - module: PSym; - crc: TCrc32; - options: TOptions; - defines: PRope; - inclDeps: PRope; - modDeps: PRope; - interf: PRope; - compilerProcs: PRope; - index, imports: TIndex; - converters: PRope; - init: PRope; - data: PRope; - filename: string; - sstack: TSymSeq; // a stack of symbols to process - tstack: TTypeSeq; // a stack of types to process - files: TStringSeq; - end; - PRodWriter = ^TRodWriter; - -function newRodWriter(const modfilename: string; crc: TCrc32; - module: PSym): PRodWriter; forward; -procedure addModDep(w: PRodWriter; const dep: string); forward; -procedure addInclDep(w: PRodWriter; const dep: string); forward; -procedure addInterfaceSym(w: PRodWriter; s: PSym); forward; -procedure addStmt(w: PRodWriter; n: PNode); forward; -procedure writeRod(w: PRodWriter); forward; - -function encodeStr(w: PRodWriter; const s: string): PRope; -begin - result := encode(s) -end; - -procedure processStacks(w: PRodWriter); forward; - -function getDefines: PRope; -var - it: TTabIter; - s: PSym; -begin - s := InitTabIter(it, gSymbols); - result := nil; - while s <> nil do begin - if s.position = 1 then begin - if result <> nil then app(result, ' '+''); - app(result, s.name.s); - end; - s := nextIter(it, gSymbols); - end -end; - -function fileIdx(w: PRodWriter; const filename: string): int; -var - i: int; -begin - for i := 0 to high(w.files) do begin - if w.files[i] = filename then begin result := i; exit end; - end; - result := length(w.files); - setLength(w.files, result+1); - w.files[result] := filename; -end; - -function newRodWriter(const modfilename: string; crc: TCrc32; - module: PSym): PRodWriter; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit - result.sstack := @[];} -{@emit - result.tstack := @[];} - InitIITable(result.index.tab); - InitIITable(result.imports.tab); - result.filename := modfilename; - result.crc := crc; - result.module := module; - result.defines := getDefines(); - result.options := options.gOptions; - {@emit result.files := @[];} -end; - -procedure addModDep(w: PRodWriter; const dep: string); -begin - if w.modDeps <> nil then app(w.modDeps, ' '+''); - app(w.modDeps, encodeInt(fileIdx(w, dep))); -end; - -const - rodNL = #10+''; - -procedure addInclDep(w: PRodWriter; const dep: string); -begin - app(w.inclDeps, encodeInt(fileIdx(w, dep))); - app(w.inclDeps, ' '+''); - app(w.inclDeps, encodeInt(crcFromFile(dep))); - app(w.inclDeps, rodNL); -end; - -procedure pushType(w: PRodWriter; t: PType); -var - L: int; -begin - // check so that the stack does not grow too large: - if IiTableGet(w.index.tab, t.id) = invalidKey then begin - L := length(w.tstack); - setLength(w.tstack, L+1); - w.tstack[L] := t; - end -end; - -procedure pushSym(w: PRodWriter; s: PSym); -var - L: int; -begin - // check so that the stack does not grow too large: - if IiTableGet(w.index.tab, s.id) = invalidKey then begin - L := length(w.sstack); - setLength(w.sstack, L+1); - w.sstack[L] := s; - end -end; - -function encodeNode(w: PRodWriter; const fInfo: TLineInfo; n: PNode): PRope; -var - i: int; - f: TNodeFlags; -begin - if n = nil then begin - // nil nodes have to be stored too: - result := toRope('()'); exit - end; - result := toRope('('+''); - app(result, encodeInt(ord(n.kind))); - // we do not write comments for now - // Line information takes easily 20% or more of the filesize! Therefore we - // omit line information if it is the same as the father's line information: - if (finfo.fileIndex <> n.info.fileIndex) then - appf(result, '?$1,$2,$3', [encodeInt(n.info.col), encodeInt(n.info.line), - encodeInt(fileIdx(w, toFilename(n.info)))]) - else if (finfo.line <> n.info.line) then - appf(result, '?$1,$2', [encodeInt(n.info.col), encodeInt(n.info.line)]) - else if (finfo.col <> n.info.col) then - appf(result, '?$1', [encodeInt(n.info.col)]); - // No need to output the file index, as this is the serialization of one - // file. - f := n.flags * PersistentNodeFlags; - if f <> {@set}[] then - appf(result, '$$$1', [encodeInt({@cast}int32(f))]); - if n.typ <> nil then begin - appf(result, '^$1', [encodeInt(n.typ.id)]); - pushType(w, n.typ); - end; - case n.kind of - nkCharLit..nkInt64Lit: begin - if n.intVal <> 0 then - appf(result, '!$1', [encodeInt(n.intVal)]); - end; - nkFloatLit..nkFloat64Lit: begin - if n.floatVal <> 0.0 then - appf(result, '!$1', [encodeStr(w, toStringF(n.floatVal))]); - end; - nkStrLit..nkTripleStrLit: begin - if n.strVal <> '' then - appf(result, '!$1', [encodeStr(w, n.strVal)]); - end; - nkIdent: - appf(result, '!$1', [encodeStr(w, n.ident.s)]); - nkSym: begin - appf(result, '!$1', [encodeInt(n.sym.id)]); - pushSym(w, n.sym); - end; - else begin - for i := 0 to sonsLen(n)-1 do - app(result, encodeNode(w, n.info, n.sons[i])); - end - end; - app(result, ')'+''); -end; - -function encodeLoc(w: PRodWriter; const loc: TLoc): PRope; -begin - result := nil; - if loc.k <> low(loc.k) then - app(result, encodeInt(ord(loc.k))); - if loc.s <> low(loc.s) then - appf(result, '*$1', [encodeInt(ord(loc.s))]); - if loc.flags <> {@set}[] then - appf(result, '$$$1', [encodeInt({@cast}int32(loc.flags))]); - if loc.t <> nil then begin - appf(result, '^$1', [encodeInt(loc.t.id)]); - pushType(w, loc.t); - end; - if loc.r <> nil then - appf(result, '!$1', [encodeStr(w, ropeToStr(loc.r))]); - if loc.a <> 0 then - appf(result, '?$1', [encodeInt(loc.a)]); - if result <> nil then - result := ropef('<$1>', [result]); -end; - -function encodeType(w: PRodWriter; t: PType): PRope; -var - i: int; -begin - if t = nil then begin - // nil nodes have to be stored too: - result := toRope('[]'); exit - end; - result := nil; - if t.kind = tyForward then InternalError('encodeType: tyForward'); - app(result, encodeInt(ord(t.kind))); - appf(result, '+$1', [encodeInt(t.id)]); - if t.n <> nil then - app(result, encodeNode(w, UnknownLineInfo(), t.n)); - if t.flags <> {@set}[] then - appf(result, '$$$1', [encodeInt({@cast}int32(t.flags))]); - if t.callConv <> low(t.callConv) then - appf(result, '?$1', [encodeInt(ord(t.callConv))]); - if t.owner <> nil then begin - appf(result, '*$1', [encodeInt(t.owner.id)]); - pushSym(w, t.owner); - end; - if t.sym <> nil then begin - appf(result, '&$1', [encodeInt(t.sym.id)]); - pushSym(w, t.sym); - end; - if t.size <> -1 then appf(result, '/$1', [encodeInt(t.size)]); - if t.align <> 2 then appf(result, '=$1', [encodeInt(t.align)]); - if t.containerID <> 0 then - appf(result, '@$1', [encodeInt(t.containerID)]); - app(result, encodeLoc(w, t.loc)); - for i := 0 to sonsLen(t)-1 do begin - if t.sons[i] = nil then - app(result, '^()') - else begin - appf(result, '^$1', [encodeInt(t.sons[i].id)]); - pushType(w, t.sons[i]); - end - end; -end; - -function encodeLib(w: PRodWriter; lib: PLib): PRope; -begin - result := nil; - appf(result, '|$1', [encodeInt(ord(lib.kind))]); - appf(result, '|$1', [encodeStr(w, ropeToStr(lib.name))]); - appf(result, '|$1', [encodeStr(w, lib.path)]); -end; - -function encodeSym(w: PRodWriter; s: PSym): PRope; -var - codeAst: PNode; - col, line: PRope; -begin - codeAst := nil; - if s = nil then begin - // nil nodes have to be stored too: - result := toRope('{}'); exit - end; - result := nil; - app(result, encodeInt(ord(s.kind))); - appf(result, '+$1', [encodeInt(s.id)]); - appf(result, '&$1', [encodeStr(w, s.name.s)]); - if s.typ <> nil then begin - appf(result, '^$1', [encodeInt(s.typ.id)]); - pushType(w, s.typ); - end; - if s.info.col = int16(-1) then col := nil - else col := encodeInt(s.info.col); - if s.info.line = int16(-1) then line := nil - else line := encodeInt(s.info.line); - appf(result, '?$1,$2,$3', [col, line, - encodeInt(fileIdx(w, toFilename(s.info)))]); - if s.owner <> nil then begin - appf(result, '*$1', [encodeInt(s.owner.id)]); - pushSym(w, s.owner); - end; - if s.flags <> {@set}[] then - appf(result, '$$$1', [encodeInt({@cast}int32(s.flags))]); - if s.magic <> mNone then - appf(result, '@$1', [encodeInt(ord(s.magic))]); - if (s.ast <> nil) then begin - if not astNeeded(s) then begin - codeAst := s.ast.sons[codePos]; - s.ast.sons[codePos] := nil; - end; - app(result, encodeNode(w, s.info, s.ast)); - if codeAst <> nil then // restore code ast - s.ast.sons[codePos] := codeAst; - end; - if s.options <> w.options then - appf(result, '!$1', [encodeInt({@cast}int32(s.options))]); - if s.position <> 0 then - appf(result, '%$1', [encodeInt(s.position)]); - if s.offset <> -1 then - appf(result, '`$1', [encodeInt(s.offset)]); - app(result, encodeLoc(w, s.loc)); - if s.annex <> nil then - app(result, encodeLib(w, s.annex)); -end; - -procedure addToIndex(var w: TIndex; key, val: int); -begin - if key - w.lastIdxKey = 1 then begin - // we do not store a key-diff of 1 to safe space - app(w.r, encodeInt(val - w.lastIdxVal)); - app(w.r, rodNL); - end - else - appf(w.r, '$1 $2'+rodNL, [encodeInt(key - w.lastIdxKey), - encodeInt(val - w.lastIdxVal)]); - w.lastIdxKey := key; - w.lastIdxVal := val; - IiTablePut(w.tab, key, val); -end; - -var - debugWritten: TIntSet; - -procedure symStack(w: PRodWriter); -var - i, L: int; - s, m: PSym; -begin - i := 0; - while i < length(w.sstack) do begin - s := w.sstack[i]; - if IiTableGet(w.index.tab, s.id) = invalidKey then begin - m := getModule(s); - if m = nil then InternalError('symStack: module nil: ' + s.name.s); - if (m.id = w.module.id) or (sfFromGeneric in s.flags) then begin - // put definition in here - L := ropeLen(w.data); - addToIndex(w.index, s.id, L); - //intSetIncl(debugWritten, s.id); - app(w.data, encodeSym(w, s)); - app(w.data, rodNL); - if sfInInterface in s.flags then - appf(w.interf, '$1 $2'+rodNL, [encode(s.name.s), encodeInt(s.id)]); - if sfCompilerProc in s.flags then - appf(w.compilerProcs, '$1 $2'+rodNL, [encode(s.name.s), encodeInt(s.id)]); - if s.kind = skConverter then begin - if w.converters <> nil then app(w.converters, ' '+''); - app(w.converters, encodeInt(s.id)) - end - end - else if IiTableGet(w.imports.tab, s.id) = invalidKey then begin - addToIndex(w.imports, s.id, m.id); - //if not IntSetContains(debugWritten, s.id) then begin - // MessageOut(w.filename); - // debug(s.owner); - // debug(s); - // InternalError('BUG!!!!'); - //end - end - end; - inc(i); - end; - setLength(w.sstack, 0); -end; - -procedure typeStack(w: PRodWriter); -var - i, L: int; -begin - i := 0; - while i < length(w.tstack) do begin - if IiTableGet(w.index.tab, w.tstack[i].id) = invalidKey then begin - L := ropeLen(w.data); - addToIndex(w.index, w.tstack[i].id, L); - app(w.data, encodeType(w, w.tstack[i])); - app(w.data, rodNL); - end; - inc(i); - end; - setLength(w.tstack, 0); -end; - -procedure processStacks(w: PRodWriter); -begin - while (length(w.tstack) > 0) or (length(w.sstack) > 0) do begin - symStack(w); - typeStack(w); - end -end; - -procedure rawAddInterfaceSym(w: PRodWriter; s: PSym); -begin - pushSym(w, s); - processStacks(w); -end; - -procedure addInterfaceSym(w: PRodWriter; s: PSym); -begin - if w = nil then exit; - if [sfInInterface, sfCompilerProc] * s.flags <> [] then begin - rawAddInterfaceSym(w, s); - end -end; - -procedure addStmt(w: PRodWriter; n: PNode); -begin - app(w.init, encodeInt(ropeLen(w.data))); - app(w.init, rodNL); - app(w.data, encodeNode(w, UnknownLineInfo(), n)); - app(w.data, rodNL); - processStacks(w); -end; - -procedure writeRod(w: PRodWriter); -var - content: PRope; - i: int; -begin - processStacks(w); - // write header: - content := toRope('NIM:'); - app(content, toRope(FileVersion)); - app(content, rodNL); - app(content, toRope('ID:')); - app(content, encodeInt(w.module.id)); - app(content, rodNL); - app(content, toRope('CRC:')); - app(content, encodeInt(w.crc)); - app(content, rodNL); - app(content, toRope('OPTIONS:')); - app(content, encodeInt({@cast}int32(w.options))); - app(content, rodNL); - app(content, toRope('DEFINES:')); - app(content, w.defines); - app(content, rodNL); - app(content, toRope('FILES('+rodNL)); - for i := 0 to high(w.files) do begin - app(content, encode(w.files[i])); - app(content, rodNL); - end; - app(content, toRope(')'+rodNL)); - app(content, toRope('INCLUDES('+rodNL)); - app(content, w.inclDeps); - app(content, toRope(')'+rodNL)); - app(content, toRope('DEPS:')); - app(content, w.modDeps); - app(content, rodNL); - app(content, toRope('INTERF('+rodNL)); - app(content, w.interf); - app(content, toRope(')'+rodNL)); - app(content, toRope('COMPILERPROCS('+rodNL)); - app(content, w.compilerProcs); - app(content, toRope(')'+rodNL)); - app(content, toRope('INDEX('+rodNL)); - app(content, w.index.r); - app(content, toRope(')'+rodNL)); - app(content, toRope('IMPORTS('+rodNL)); - app(content, w.imports.r); - app(content, toRope(')'+rodNL)); - app(content, toRope('CONVERTERS:')); - app(content, w.converters); - app(content, toRope(rodNL)); - app(content, toRope('INIT('+rodNL)); - app(content, w.init); - app(content, toRope(')'+rodNL)); - app(content, toRope('DATA('+rodNL)); - app(content, w.data); - app(content, toRope(')'+rodNL)); - - //MessageOut('interf ' + ToString(ropeLen(w.interf))); - //MessageOut('index ' + ToString(ropeLen(w.indexRope))); - //MessageOut('init ' + ToString(ropeLen(w.init))); - //MessageOut('data ' + ToString(ropeLen(w.data))); - - writeRope(content, - completeGeneratedFilePath(changeFileExt(w.filename, 'rod'))); -end; - -function process(c: PPassContext; n: PNode): PNode; -var - i: int; - w: PRodWriter; - a: PNode; - s: PSym; -begin - result := n; - if c = nil then exit; - w := PRodWriter(c); - case n.kind of - nkStmtList: begin - for i := 0 to sonsLen(n)-1 do {@discard} process(c, n.sons[i]); - end; - nkTemplateDef, nkMacroDef: begin - s := n.sons[namePos].sym; - addInterfaceSym(w, s); - end; - nkProcDef, nkMethodDef, nkIteratorDef, nkConverterDef: begin - s := n.sons[namePos].sym; - if s = nil then InternalError(n.info, 'rodwrite.process'); - if (n.sons[codePos] <> nil) or (s.magic <> mNone) - or not (sfForward in s.flags) then begin - addInterfaceSym(w, s); - end - end; - nkVarSection: begin - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if a.kind <> nkIdentDefs then InternalError(a.info, 'rodwrite.process'); - addInterfaceSym(w, a.sons[0].sym); - end - end; - nkConstSection: begin - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if a.kind <> nkConstDef then InternalError(a.info, 'rodwrite.process'); - addInterfaceSym(w, a.sons[0].sym); - end - end; - nkTypeSection: 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, 'rodwrite.process'); - s := a.sons[0].sym; - addInterfaceSym(w, s); // this takes care of enum fields too - // Note: The check for ``s.typ.kind = tyEnum`` is wrong for enum - // type aliasing! Otherwise the same enum symbol would be included - // several times! - (* - if (a.sons[2] <> nil) and (a.sons[2].kind = nkEnumTy) then begin - a := s.typ.n; - for j := 0 to sonsLen(a)-1 do - addInterfaceSym(w, a.sons[j].sym); - end *) - end - end; - nkImportStmt: begin - for i := 0 to sonsLen(n)-1 do addModDep(w, getModuleFile(n.sons[i])); - addStmt(w, n); - end; - nkFromStmt: begin - addModDep(w, getModuleFile(n.sons[0])); - addStmt(w, n); - end; - nkIncludeStmt: begin - for i := 0 to sonsLen(n)-1 do addInclDep(w, getModuleFile(n.sons[i])); - end; - nkPragma: addStmt(w, n); - else begin end - end; -end; - -function myOpen(module: PSym; const filename: string): PPassContext; -var - w: PRodWriter; -begin - if module.id < 0 then InternalError('rodwrite: module ID not set'); - w := newRodWriter(filename, rodread.GetCRC(filename), module); - rawAddInterfaceSym(w, module); - result := w; -end; - -function myClose(c: PPassContext; n: PNode): PNode; -var - w: PRodWriter; -begin - w := PRodWriter(c); - writeRod(w); - result := n; -end; - -function rodwritePass(): TPass; -begin - initPass(result); - if optSymbolFiles in gGlobalOptions then begin - result.open := myOpen; - result.close := myClose; - result.process := process; - end -end; - -initialization - IntSetInit(debugWritten); -end. diff --git a/nim/ropes.pas b/nim/ropes.pas deleted file mode 100755 index 286f1b9e6..000000000 --- a/nim/ropes.pas +++ /dev/null @@ -1,635 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit ropes; - -{ Ropes for the C code generator - - Ropes are a data structure that represents a very long string - 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 - nil pointer. - A little picture makes everything clear: - - "this string" & " is internally " & "represented as" - - con -- inner nodes do not contain raw data - / \ - / \ - / \ - con "represented as" - / \ - / \ - / \ - / \ - / \ -"this string" " is internally " - - Note that this is the same as: - "this string" & (" is internally " & "represented as") - - con - / \ - / \ - / \ - "this string" con - / \ - / \ - / \ - / \ - / \ -" is internally " "represented as" - - The 'con' operator is associative! This does not matter however for - the algorithms we use for ropes. - - Note that the left and right pointers are not needed for leafs. - Leafs have relatively high memory overhead (~30 bytes on a 32 - bit machines) and we produce many of them. This is why we cache and - share leafs accross different rope trees. - 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. -} - -interface - -{$include 'config.inc'} - -uses - nsystem, msgs, strutils, platform, nhashes, crc; - -const - CacheLeafs = true; - countCacheMisses = False; // see what our little optimization gives - -type - TFormatStr = string; - // later we may change it to CString for better - // performance of the code generator (assignments copy the format strings - // though it is not necessary) - - PRope = ^TRope; - TRope = object(NObject) - left, right: PRope; - len: int; - data: string; // != nil if a leaf - end {@acyclic}; - // the empty rope is represented by nil to safe space - - TRopeSeq = array of PRope; - -function con(a, b: PRope): PRope; overload; -function con(a: PRope; const b: string): PRope; overload; -function con(const a: string; b: PRope): PRope; overload; -function con(a: array of PRope): PRope; overload; - -procedure app(var a: PRope; b: PRope); overload; -procedure app(var a: PRope; const b: string); overload; - -procedure prepend(var a: PRope; b: PRope); - -function toRope(const s: string): PRope; overload; -function toRopeF(const r: BiggestFloat): PRope; -function toRope(i: BiggestInt): PRope; overload; - -function ropeLen(a: PRope): int; - -procedure WriteRope(head: PRope; const filename: string); -function writeRopeIfNotEqual(r: PRope; const filename: string): boolean; - -function ropeToStr(p: PRope): string; - -function ropef(const frmt: TFormatStr; const args: array of PRope): PRope; - -procedure appf(var c: PRope; const frmt: TFormatStr; - const args: array of PRope); - -function getCacheStats: string; - -function RopeEqualsFile(r: PRope; const f: string): Boolean; -// returns true if the rope r is the same as the contents of file f - -function RopeInvariant(r: PRope): Boolean; -// exported for debugging - -implementation - -function ropeLen(a: PRope): int; -begin - if a = nil then result := 0 - else result := a.len -end; - -function newRope(const data: string = snil): PRope; -begin - new(result); - {@ignore} - fillChar(result^, sizeof(TRope), 0); - {@emit} - if data <> snil then begin - result.len := length(data); - result.data := data; - end -end; - -// -------------- leaf cache: --------------------------------------- -var - cache: PRope; // the root of the cache tree - misses, hits: int; - N: PRope; // dummy rope needed for splay algorithm - -function getCacheStats: string; -begin - if hits+misses <> 0 then - result := 'Misses: ' +{&} ToString(misses) +{&} - ' total: ' +{&} toString(hits+misses) +{&} - ' quot: ' +{&} toStringF(toFloat(misses) / toFloat(hits+misses)) - else - result := '' -end; - -function splay(const s: string; tree: PRope; out cmpres: int): PRope; -var - le, r, y, t: PRope; - c: int; -begin - t := tree; - N.left := nil; N.right := nil; // reset to nil - le := N; - r := N; - repeat - c := cmp(s, t.data); - if c < 0 then begin - if (t.left <> nil) and (s < t.left.data) then begin - y := t.left; t.left := y.right; y.right := t; t := y - end; - if t.left = nil then break; - r.left := t; r := t; t := t.left - end - else if c > 0 then begin - if (t.right <> nil) and (s > t.right.data) then begin - y := t.right; t.right := y.left; y.left := t; t := y - end; - if t.right = nil then break; - le.right := t; le := t; t := t.right - end - else break - until false; - cmpres := c; - le.right := t.left; r.left := t.right; t.left := N.right; t.right := N.left; - result := t -end; - -function insertInCache(const s: string; tree: PRope): PRope; -// Insert i into the tree t, unless it's already there. -// Return a pointer to the resulting tree. -var - t: PRope; - cmp: int; -begin - t := tree; - if t = nil then begin - result := newRope(s); - if countCacheMisses then inc(misses); - exit - end; - t := splay(s, t, cmp); - if cmp = 0 then begin - // We get here if it's already in the Tree - // Don't add it again - result := t; - if countCacheMisses then inc(hits); - end - else begin - if countCacheMisses then inc(misses); - result := newRope(s); - if cmp < 0 then begin - result.left := t.left; result.right := t; t.left := nil - end - else begin // i > t.item: - result.right := t.right; result.left := t; t.right := nil - end - end -end; - -function RopeInvariant(r: PRope): Boolean; -begin - if r = nil then - result := true - else begin - result := true - (* - if r.data <> snil then - result := true - else begin - result := (r.left <> nil) and (r.right <> nil); - if result then result := ropeInvariant(r.left); - if result then result := ropeInvariant(r.right); - end *) - end -end; - -function toRope(const s: string): PRope; -begin - if s = '' then - result := nil - else if cacheLeafs then begin - result := insertInCache(s, cache); - cache := result; - end - else - result := newRope(s); - assert(RopeInvariant(result)); -end; - -// ------------------------------------------------------------------ - -procedure RopeSeqInsert(var rs: TRopeSeq; r: PRope; at: Natural); -var - len, i: int; -begin - len := length(rs); - if at > len then - SetLength(rs, at+1) - else - SetLength(rs, len+1); - - // move old rope elements: - for i := len downto at+1 do - rs[i] := rs[i-1]; // this is correct, I used pen and paper to validate it - rs[at] := r -end; - -function con(a, b: PRope): PRope; overload; -begin - assert(RopeInvariant(a)); - assert(RopeInvariant(b)); - if a = nil then // len is valid for every cord not only for leafs - result := b - else if b = nil then - result := a - else begin - result := newRope(); - result.len := a.len + b.len; - result.left := a; - result.right := b - end; - assert(RopeInvariant(result)); -end; - -function con(a: PRope; const b: string): PRope; overload; -var - r: PRope; -begin - assert(RopeInvariant(a)); - if b = '' then - result := a - else begin - r := toRope(b); - if a = nil then begin - result := r - end - else begin - result := newRope(); - result.len := a.len + r.len; - result.left := a; - result.right := r; - end - end; - assert(RopeInvariant(result)); -end; - -function con(const a: string; b: PRope): PRope; overload; -var - r: PRope; -begin - assert(RopeInvariant(b)); - if a = '' then - result := b - else begin - r := toRope(a); - - if b = nil then - result := r - else begin - result := newRope(); - result.len := b.len + r.len; - result.left := r; - result.right := b; - end - end; - assert(RopeInvariant(result)); -end; - -function con(a: array of PRope): PRope; overload; -var - i: int; -begin - result := nil; - for i := 0 to high(a) do result := con(result, a[i]); - assert(RopeInvariant(result)); -end; - -function toRope(i: BiggestInt): PRope; -begin - result := toRope(ToString(i)) -end; - -function toRopeF(const r: BiggestFloat): PRope; -begin - result := toRope(toStringF(r)) -end; - -procedure app(var a: PRope; b: PRope); overload; -begin - a := con(a, b); - assert(RopeInvariant(a)); -end; - -procedure app(var a: PRope; const b: string); overload; -begin - a := con(a, b); - assert(RopeInvariant(a)); -end; - -procedure prepend(var a: PRope; b: PRope); -begin - a := con(b, a); - assert(RopeInvariant(a)); -end; - -procedure InitStack(var stack: TRopeSeq); -begin - {@ignore} - setLength(stack, 0); - {@emit stack := @[];} -end; - -procedure push(var stack: TRopeSeq; r: PRope); -var - len: int; -begin - len := length(stack); - setLength(stack, len+1); - stack[len] := r; -end; - -function pop(var stack: TRopeSeq): PRope; -var - len: int; -begin - len := length(stack); - result := stack[len-1]; - setLength(stack, len-1); -end; - -procedure WriteRopeRec(var f: TTextFile; c: PRope); -begin - assert(RopeInvariant(c)); - - if c = nil then exit; - if (c.data <> snil) then begin - nimWrite(f, c.data) - end - else begin - writeRopeRec(f, c.left); - writeRopeRec(f, c.right) - end -end; - -procedure newWriteRopeRec(var f: TTextFile; c: PRope); -var - stack: TRopeSeq; - it: PRope; -begin - assert(RopeInvariant(c)); - initStack(stack); - push(stack, c); - while length(stack) > 0 do begin - it := pop(stack); - while it.data = snil do begin - push(stack, it.right); - it := it.left; - assert(it <> nil); - end; - assert(it.data <> snil); - nimWrite(f, it.data); - end -end; - -procedure WriteRope(head: PRope; const filename: string); -var - f: TTextFile; // we use a textfile for automatic buffer handling -begin - if OpenFile(f, filename, fmWrite) then 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); -begin - if p = nil then exit; // do not add to result - if (p.data = snil) then begin - recRopeToStr(result, resultLen, p.left); - recRopeToStr(result, resultLen, p.right); - end - else begin - CopyMem(@result[resultLen+StrStart], @p.data[strStart], p.len); - Inc(resultLen, p.len); - assert(resultLen <= length(result)); - end -end; - -procedure newRecRopeToStr(var result: string; var resultLen: int; - r: PRope); -var - stack: TRopeSeq; - it: PRope; -begin - initStack(stack); - push(stack, r); - while length(stack) > 0 do begin - it := pop(stack); - while it.data = snil do begin - push(stack, it.right); - it := it.left; - end; - assert(it.data <> snil); - CopyMem(@result[resultLen+StrStart], @it.data[strStart], it.len); - Inc(resultLen, it.len); - assert(resultLen <= length(result)); - end -end; - -function ropeToStr(p: PRope): string; -var - resultLen: int; -begin - assert(RopeInvariant(p)); - if p = nil then - result := '' - else begin - result := newString(p.len); - resultLen := 0; - newRecRopeToStr(result, resultLen, p); - end -end; - -function ropef(const frmt: TFormatStr; const args: array of PRope): PRope; -var - i, j, len, start, num: int; -begin - i := strStart; - len := length(frmt); - result := nil; - num := 0; - while i <= len + StrStart - 1 do begin - if frmt[i] = '$' then begin - inc(i); // skip '$' - case frmt[i] of - '$': begin app(result, '$'+''); inc(i); end; - '#': begin inc(i); app(result, args[num]); inc(num); end; - '0'..'9': begin - j := 0; - repeat - j := (j*10) + Ord(frmt[i]) - ord('0'); - inc(i); - until (i > len + StrStart - 1) or not (frmt[i] in ['0'..'9']); - num := j; - if j > high(args)+1 then - internalError('ropes: invalid format string $' + toString(j)); - app(result, args[j-1]); - end; - 'N', 'n': begin app(result, tnl); inc(i); end; - else InternalError('ropes: invalid format string $' + frmt[i]); - end - end; - start := i; - while (i <= len + StrStart - 1) do - if (frmt[i] <> '$') then inc(i) else break; - if i-1 >= start then begin - app(result, ncopy(frmt, start, i-1)); - end - end; - assert(RopeInvariant(result)); -end; - -procedure appf(var c: PRope; const frmt: TFormatStr; const args: array of PRope); -begin - app(c, ropef(frmt, args)) -end; - -const - bufSize = 1024; // 1 KB is reasonable - -function auxRopeEqualsFile(r: PRope; var bin: TBinaryFile; - buf: Pointer): Boolean; -var - readBytes: int; -begin - if (r.data <> snil) then begin - if r.len > bufSize then - // A token bigger than 1 KB? - This cannot happen in reality. - internalError('ropes: token too long'); - readBytes := readBuffer(bin, buf, r.len); - result := (readBytes = r.len) // BUGFIX - and equalMem(buf, addr(r.data[strStart]), r.len); - end - else begin - result := auxRopeEqualsFile(r.left, bin, buf); - if result then - result := auxRopeEqualsFile(r.right, bin, buf); - end -end; - -function RopeEqualsFile(r: PRope; const f: string): Boolean; -var - bin: TBinaryFile; - buf: Pointer; -begin - result := openFile(bin, f); - if not result then exit; // not equal if file does not exist - buf := alloc(BufSize); - result := auxRopeEqualsFile(r, bin, buf); - if result then - result := readBuffer(bin, buf, bufSize) = 0; // really at the end of file? - dealloc(buf); - CloseFile(bin); -end; - -function crcFromRopeAux(r: PRope; startVal: TCrc32): TCrc32; -var - i: int; -begin - if r.data <> snil then begin - result := startVal; - for i := strStart to length(r.data)+strStart-1 do - result := updateCrc32(r.data[i], result); - end - else begin - result := crcFromRopeAux(r.left, startVal); - result := crcFromRopeAux(r.right, result); - end -end; - -function newCrcFromRopeAux(r: PRope; startVal: TCrc32): TCrc32; -var - stack: TRopeSeq; - it: PRope; - L, i: int; -begin - initStack(stack); - push(stack, r); - result := startVal; - while length(stack) > 0 do begin - it := pop(stack); - while it.data = snil do begin - push(stack, it.right); - it := it.left; - end; - assert(it.data <> snil); - i := strStart; - L := length(it.data)+strStart; - while i < L do begin - result := updateCrc32(it.data[i], result); - inc(i); - end - end -end; - -function crcFromRope(r: PRope): TCrc32; -begin - result := newCrcFromRopeAux(r, initCrc32) -end; - -function writeRopeIfNotEqual(r: PRope; const filename: string): boolean; -// returns true if overwritten -var - c: TCrc32; -begin - c := crcFromFile(filename); - if c <> crcFromRope(r) then begin - writeRope(r, filename); - result := true - end - else - result := false -end; - -initialization - new(N); // init dummy node for splay algorithm -{@ignore} - fillChar(N^, sizeof(N^), 0); -{@emit} -end. diff --git a/nim/rst.pas b/nim/rst.pas deleted file mode 100755 index 89ef2c501..000000000 --- a/nim/rst.pas +++ /dev/null @@ -1,2184 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit rst; - -// This module implements a *reStructuredText* parser. A larget -// subset is provided. - -interface - -{$include 'config.inc'} - -uses - nsystem, nos, msgs, strutils, platform, nhashes, ropes, charsets, options; - -type - TRstNodeKind = ( - rnInner, // an inner node or a root - rnHeadline, // a headline - rnOverline, // an over- and underlined headline - rnTransition, // a transition (the ------------- <hr> thingie) - rnParagraph, // a paragraph - - rnBulletList, // a bullet list - rnBulletItem, // a bullet item - rnEnumList, // an enumerated list - rnEnumItem, // an enumerated item - - rnDefList, // a definition list - rnDefItem, // an item of a definition list consisting of ... - rnDefName, // ... a name part ... - rnDefBody, // ... and a body part ... - - rnFieldList, // a field list - rnField, // a field item - rnFieldName, // consisting of a field name ... - rnFieldBody, // ... and a field body - - rnOptionList, - rnOptionListItem, - rnOptionGroup, - rnOption, - rnOptionString, - rnOptionArgument, - rnDescription, - - rnLiteralBlock, - rnQuotedLiteralBlock, - - rnLineBlock, // the | thingie - rnLineBlockItem, // sons of the | thing - - rnBlockQuote, // text just indented - - rnTable, - rnGridTable, - rnTableRow, - rnTableHeaderCell, - rnTableDataCell, - - rnLabel, // used for footnotes and other things - rnFootnote, // a footnote - - rnCitation, // similar to footnote - - rnStandaloneHyperlink, - rnHyperlink, - rnRef, - rnDirective, // a directive - rnDirArg, - rnRaw, - rnTitle, - rnContents, - rnImage, - rnFigure, - rnCodeBlock, - rnContainer, // ``container`` directive - rnIndex, // index directve: - // .. index:: - // key - // * `file#id <file#id>`_ - // * `file#id <file#id>'_ - - rnSubstitutionDef, // a definition of a substitution - - rnGeneralRole, - // Inline markup: - rnSub, - rnSup, - rnIdx, - rnEmphasis, // "*" - rnStrongEmphasis, // "**" - rnInterpretedText, // "`" - rnInlineLiteral, // "``" - rnSubstitutionReferences, // "|" - - rnLeaf // a leaf; the node's text field contains the leaf val - ); -const - rstnodekindToStr: array [TRstNodeKind] of string = ( - 'Inner', 'Headline', 'Overline', 'Transition', 'Paragraph', - 'BulletList', 'BulletItem', 'EnumList', 'EnumItem', 'DefList', 'DefItem', - 'DefName', 'DefBody', 'FieldList', 'Field', 'FieldName', 'FieldBody', - 'OptionList', 'OptionListItem', 'OptionGroup', 'Option', 'OptionString', - 'OptionArgument', 'Description', 'LiteralBlock', 'QuotedLiteralBlock', - 'LineBlock', 'LineBlockItem', 'BlockQuote', 'Table', 'GridTable', - 'TableRow', 'TableHeaderCell', 'TableDataCell', 'Label', 'Footnote', - 'Citation', 'StandaloneHyperlink', 'Hyperlink', 'Ref', 'Directive', - 'DirArg', 'Raw', 'Title', 'Contents', 'Image', 'Figure', 'CodeBlock', - 'Container', 'Index', 'SubstitutionDef', 'GeneralRole', - 'Sub', 'Sup', 'Idx', 'Emphasis', 'StrongEmphasis', 'InterpretedText', - 'InlineLiteral', 'SubstitutionReferences', 'Leaf' - ); - -type - // the syntax tree of RST: - PRSTNode = ^TRstNode; - TRstNodeSeq = array of PRstNode; - TRSTNode = record - kind: TRstNodeKind; - text: string; // valid for leafs in the AST; and the title of - // the document or the section - level: int; // valid for some node kinds - sons: TRstNodeSeq; // the node's sons - end {@acyclic}; - - -function rstParse(const text: string; // the text to be parsed - skipPounds: bool; - const filename: string; // for error messages - line, column: int; - var hasToc: bool): PRstNode; -function rsonsLen(n: PRstNode): int; -function newRstNode(kind: TRstNodeKind): PRstNode; overload; -function newRstNode(kind: TRstNodeKind; const s: string): PRstNode; overload; -procedure addSon(father, son: PRstNode); - -function rstnodeToRefname(n: PRstNode): string; - -function addNodes(n: PRstNode): string; - -function getFieldValue(n: PRstNode; const fieldname: string): string; -function getArgument(n: PRstNode): string; - -// index handling: -procedure setIndexPair(index, key, val: PRstNode); -procedure sortIndex(a: PRstNode); -procedure clearIndex(index: PRstNode; const filename: string); - - -implementation - -// ----------------------------- scanner part -------------------------------- - -const - SymChars: TCharSet = ['a'..'z', 'A'..'Z', '0'..'9', #128..#255]; - -type - TTokType = (tkEof, tkIndent, tkWhite, tkWord, tkAdornment, tkPunct, tkOther); - TToken = record // a RST token - kind: TTokType; // the type of the token - ival: int; // the indentation or parsed integer value - symbol: string; // the parsed symbol as string - line, col: int; // line and column of the token - end; - TTokenSeq = array of TToken; - TLexer = object(NObject) - buf: PChar; - bufpos: int; - line, col, baseIndent: int; - skipPounds: bool; - end; - -procedure getThing(var L: TLexer; var tok: TToken; const s: TCharSet); -var - pos: int; -begin - tok.kind := tkWord; - tok.line := L.line; - tok.col := L.col; - pos := L.bufpos; - while True do begin - addChar(tok.symbol, L.buf[pos]); - inc(pos); - if not (L.buf[pos] in s) then break - end; - inc(L.col, pos - L.bufpos); - L.bufpos := pos; -end; - -procedure getAdornment(var L: TLexer; var tok: TToken); -var - pos: int; - c: char; -begin - tok.kind := tkAdornment; - tok.line := L.line; - tok.col := L.col; - pos := L.bufpos; - c := L.buf[pos]; - while True do begin - addChar(tok.symbol, L.buf[pos]); - inc(pos); - if L.buf[pos] <> c then break - end; - inc(L.col, pos - L.bufpos); - L.bufpos := pos -end; - -function getIndentAux(var L: TLexer; start: int): int; -var - buf: PChar; - pos: int; -begin - pos := start; - buf := L.buf; - // skip the newline (but include it in the token!) - if buf[pos] = #13 then begin - if buf[pos+1] = #10 then inc(pos, 2) else inc(pos); - end - else if buf[pos] = #10 then inc(pos); - if L.skipPounds then begin - if buf[pos] = '#' then inc(pos); - if buf[pos] = '#' then inc(pos); - end; - result := 0; - while True do begin - case buf[pos] of - ' ', #11, #12: begin - inc(pos); - inc(result); - end; - #9: begin - inc(pos); - result := result - (result mod 8) + 8; - end; - else break; // EndOfFile also leaves the loop - end; - end; - if buf[pos] = #0 then result := 0 - else if (buf[pos] = #10) or (buf[pos] = #13) then begin - // look at the next line for proper indentation: - result := getIndentAux(L, pos); - end; - L.bufpos := pos; // no need to set back buf -end; - -procedure getIndent(var L: TLexer; var tok: TToken); -begin - inc(L.line); - tok.line := L.line; - tok.col := 0; - tok.kind := tkIndent; - // skip the newline (but include it in the token!) - tok.ival := getIndentAux(L, L.bufpos); - L.col := tok.ival; - tok.ival := max(tok.ival - L.baseIndent, 0); - tok.symbol := nl +{&} repeatChar(tok.ival); -end; - -procedure rawGetTok(var L: TLexer; var tok: TToken); -var - c: Char; -begin - tok.symbol := ''; - tok.ival := 0; - c := L.buf[L.bufpos]; - case c of - 'a'..'z', 'A'..'Z', #128..#255, '0'..'9': getThing(L, tok, SymChars); - ' ', #9, #11, #12: begin - getThing(L, tok, {@set}[' ', #9]); - tok.kind := tkWhite; - if L.buf[L.bufpos] in [#13, #10] then - rawGetTok(L, tok); // ignore spaces before \n - end; - #13, #10: getIndent(L, tok); - '!', '"', '#', '$', '%', '&', '''', - '(', ')', '*', '+', ',', '-', '.', '/', - ':', ';', '<', '=', '>', '?', '@', '[', '\', ']', - '^', '_', '`', '{', '|', '}', '~': begin - getAdornment(L, tok); - if length(tok.symbol) <= 3 then tok.kind := tkPunct; - end; - else begin - tok.line := L.line; - tok.col := L.col; - if c = #0 then - tok.kind := tkEof - else begin - tok.kind := tkOther; - addChar(tok.symbol, c); - inc(L.bufpos); - inc(L.col); - end - end - end; - tok.col := max(tok.col - L.baseIndent, 0); -end; - -procedure getTokens(const buffer: string; skipPounds: bool; - var tokens: TTokenSeq); -var - L: TLexer; - len: int; -begin -{@ignore} - fillChar(L, sizeof(L), 0); -{@emit} - len := length(tokens); - L.buf := PChar(buffer); - L.line := 1; - // skip UTF-8 BOM - if (L.buf[0] = #239) and (L.buf[1] = #187) and (L.buf[2] = #191) then - inc(L.bufpos, 3); - L.skipPounds := skipPounds; - if skipPounds then begin - if L.buf[L.bufpos] = '#' then inc(L.bufpos); - if L.buf[L.bufpos] = '#' then inc(L.bufpos); - L.baseIndent := 0; - while L.buf[L.bufpos] = ' ' do begin - inc(L.bufpos); - inc(L.baseIndent); - end - end; - while true do begin - inc(len); - setLength(tokens, len); - rawGetTok(L, tokens[len-1]); - if tokens[len-1].kind = tkEof then break; - end; - if tokens[0].kind = tkWhite then begin // BUGFIX - tokens[0].ival := length(tokens[0].symbol); - tokens[0].kind := tkIndent - end -end; - -// -------------------------------------------------------------------------- - -procedure addSon(father, son: PRstNode); -var - L: int; -begin - L := length(father.sons); - setLength(father.sons, L+1); - father.sons[L] := son; -end; - -procedure addSonIfNotNil(father, son: PRstNode); -begin - if son <> nil then addSon(father, son); -end; - -function rsonsLen(n: PRstNode): int; -begin - result := length(n.sons) -end; - -function newRstNode(kind: TRstNodeKind): PRstNode; overload; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit - result.sons := @[]; -} - result.kind := kind; -end; - -function newRstNode(kind: TRstNodeKind; const s: string): PRstNode; overload; -begin - result := newRstNode(kind); - result.text := s; -end; - -// --------------------------------------------------------------------------- -type - TLevelMap = array [Char] of int; - TSubstitution = record - key: string; - value: PRstNode; - end; - TSharedState = record - uLevel, oLevel: int; // counters for the section levels - subs: array of TSubstitution; // substitutions - refs: array of TSubstitution; // references - underlineToLevel: TLevelMap; - // Saves for each possible title adornment character its level in the - // current document. This is for single underline adornments. - overlineToLevel: TLevelMap; - // Saves for each possible title adornment character its level in the - // current document. This is for over-underline adornments. - end; - PSharedState = ^TSharedState; - TRstParser = object(NObject) - idx: int; - tok: TTokenSeq; - s: PSharedState; - indentStack: array of int; - filename: string; - line, col: int; - hasToc: bool; - end; - -function newSharedState(): PSharedState; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - {@emit - result.subs := @[];} - {@emit - result.refs := @[];} -end; - -function tokInfo(const p: TRstParser; const tok: TToken): TLineInfo; -begin - result := newLineInfo(p.filename, p.line+tok.line, p.col+tok.col); -end; - -procedure rstMessage(const p: TRstParser; msgKind: TMsgKind; - const arg: string); overload; -begin - liMessage(tokInfo(p, p.tok[p.idx]), msgKind, arg); -end; - -procedure rstMessage(const p: TRstParser; msgKind: TMsgKind); overload; -begin - liMessage(tokInfo(p, p.tok[p.idx]), msgKind, p.tok[p.idx].symbol); -end; - -function currInd(const p: TRstParser): int; -begin - result := p.indentStack[high(p.indentStack)]; -end; - -procedure pushInd(var p: TRstParser; ind: int); -var - len: int; -begin - len := length(p.indentStack); - setLength(p.indentStack, len+1); - p.indentStack[len] := ind; -end; - -procedure popInd(var p: TRstParser); -begin - if length(p.indentStack) > 1 then - setLength(p.indentStack, length(p.indentStack)-1); -end; - -procedure initParser(var p: TRstParser; sharedState: PSharedState); -begin - {@ignore} - fillChar(p, sizeof(p), 0); - p.tok := nil; - p.indentStack := nil; - pushInd(p, 0); - {@emit - p.indentStack := @[0];} - {@emit - p.tok := @[];} - p.idx := 0; - p.filename := ''; - p.hasToc := false; - p.col := 0; - p.line := 1; - p.s := sharedState; -end; - -// --------------------------------------------------------------- - -procedure addNodesAux(n: PRstNode; var result: string); -var - i: int; -begin - if n.kind = rnLeaf then - add(result, n.text) - else begin - for i := 0 to rsonsLen(n)-1 do - addNodesAux(n.sons[i], result) - end -end; - -function addNodes(n: PRstNode): string; -begin - result := ''; - addNodesAux(n, result); -end; - -procedure rstnodeToRefnameAux(n: PRstNode; var r: string; var b: bool); -var - i: int; -begin - if n.kind = rnLeaf then begin - for i := strStart to length(n.text)+strStart-1 do begin - case n.text[i] of - '0'..'9': begin - if b then begin addChar(r, '-'); b := false; end; - // BUGFIX: HTML id's cannot start with a digit - if length(r) = 0 then addChar(r, 'Z'); - addChar(r, n.text[i]) - end; - 'a'..'z': begin - if b then begin addChar(r, '-'); b := false; end; - addChar(r, n.text[i]) - end; - 'A'..'Z': begin - if b then begin addChar(r, '-'); b := false; end; - addChar(r, chr(ord(n.text[i]) - ord('A') + ord('a'))); - end; - else if (length(r) > 0) then b := true; - end - end - end - else begin - for i := 0 to rsonsLen(n)-1 do rstnodeToRefnameAux(n.sons[i], r, b) - end -end; - -function rstnodeToRefname(n: PRstNode): string; -var - b: bool; -begin - result := ''; - b := false; - rstnodeToRefnameAux(n, result, b); -end; - -function findSub(var p: TRstParser; n: PRstNode): int; -var - key: string; - i: int; -begin - key := addNodes(n); - // the spec says: if no exact match, try one without case distinction: - for i := 0 to high(p.s.subs) do - if key = p.s.subs[i].key then begin - result := i; exit - end; - for i := 0 to high(p.s.subs) do - if cmpIgnoreStyle(key, p.s.subs[i].key) = 0 then begin - result := i; exit - end; - result := -1 -end; - -procedure setSub(var p: TRstParser; const key: string; value: PRstNode); -var - i, len: int; -begin - len := length(p.s.subs); - for i := 0 to len-1 do - if key = p.s.subs[i].key then begin - p.s.subs[i].value := value; exit - end; - setLength(p.s.subs, len+1); - p.s.subs[len].key := key; - p.s.subs[len].value := value; -end; - -procedure setRef(var p: TRstParser; const key: string; value: PRstNode); -var - i, len: int; -begin - len := length(p.s.refs); - for i := 0 to len-1 do - if key = p.s.refs[i].key then begin - p.s.refs[i].value := value; - rstMessage(p, warnRedefinitionOfLabel, key); - exit - end; - setLength(p.s.refs, len+1); - p.s.refs[len].key := key; - p.s.refs[len].value := value; -end; - -function findRef(var p: TRstParser; const key: string): PRstNode; -var - i: int; -begin - for i := 0 to high(p.s.refs) do - if key = p.s.refs[i].key then begin - result := p.s.refs[i].value; exit - end; - result := nil -end; - -function cmpNodes(a, b: PRstNode): int; -var - x, y: PRstNode; -begin - assert(a.kind = rnDefItem); - assert(b.kind = rnDefItem); - x := a.sons[0]; - y := b.sons[0]; - result := cmpIgnoreStyle(addNodes(x), addNodes(y)) -end; - -procedure sortIndex(a: PRstNode); -// we use shellsort here; fast and simple -var - N, i, j, h: int; - v: PRstNode; -begin - assert(a.kind = rnDefList); - N := rsonsLen(a); - h := 1; repeat h := 3*h+1; until h > N; - repeat - h := h div 3; - for i := h to N-1 do begin - v := a.sons[i]; j := i; - while cmpNodes(a.sons[j-h], v) >= 0 do begin - a.sons[j] := a.sons[j-h]; j := j - h; - if j < h then break - end; - a.sons[j] := v; - end; - until h = 1 -end; - -function eqRstNodes(a, b: PRstNode): bool; -var - i: int; -begin - result := false; - if a.kind <> b.kind then exit; - if a.kind = rnLeaf then - result := a.text = b.text - else begin - if rsonsLen(a) <> rsonsLen(b) then exit; - for i := 0 to rsonsLen(a)-1 do - if not eqRstNodes(a.sons[i], b.sons[i]) then exit; - result := true - end -end; - -function matchesHyperlink(h: PRstNode; const filename: string): bool; -var - s: string; -begin - if h.kind = rnInner then begin - assert(rsonsLen(h) = 1); - result := matchesHyperlink(h.sons[0], filename) - end - else if h.kind = rnHyperlink then begin - s := addNodes(h.sons[1]); - if startsWith(s, filename) and (s[length(filename)+strStart] = '#') then - result := true - else - result := false - end - else // this may happen in broken indexes! - result := false -end; - -procedure clearIndex(index: PRstNode; const filename: string); -var - i, j, k, items, lastItem: int; - val: PRstNode; -begin - assert(index.kind = rnDefList); - for i := 0 to rsonsLen(index)-1 do begin - assert(index.sons[i].sons[1].kind = rnDefBody); - val := index.sons[i].sons[1].sons[0]; - if val.kind = rnInner then val := val.sons[0]; - if val.kind = rnBulletList then begin - items := rsonsLen(val); - lastItem := -1; // save the last valid item index - for j := 0 to rsonsLen(val)-1 do begin - if val.sons[j] = nil then - dec(items) - else if matchesHyperlink(val.sons[j].sons[0], filename) then begin - val.sons[j] := nil; - dec(items) - end - else lastItem := j - end; - if items = 1 then // remove bullet list: - index.sons[i].sons[1].sons[0] := val.sons[lastItem].sons[0] - else if items = 0 then - index.sons[i] := nil - end - else if matchesHyperlink(val, filename) then - index.sons[i] := nil - end; - // remove nil nodes: - k := 0; - for i := 0 to rsonsLen(index)-1 do begin - if index.sons[i] <> nil then begin - if k <> i then index.sons[k] := index.sons[i]; - inc(k) - end - end; - setLength(index.sons, k); -end; - -procedure setIndexPair(index, key, val: PRstNode); -var - i: int; - e, a, b: PRstNode; -begin - // writeln(rstnodekindToStr[key.kind], ': ', rstnodekindToStr[val.kind]); - assert(index.kind = rnDefList); - assert(key.kind <> rnDefName); - a := newRstNode(rnDefName); - addSon(a, key); - - for i := 0 to rsonsLen(index)-1 do begin - if eqRstNodes(index.sons[i].sons[0], a) then begin - assert(index.sons[i].sons[1].kind = rnDefBody); - e := index.sons[i].sons[1].sons[0]; - if e.kind <> rnBulletList then begin - e := newRstNode(rnBulletList); - b := newRstNode(rnBulletItem); - addSon(b, index.sons[i].sons[1].sons[0]); - addSon(e, b); - index.sons[i].sons[1].sons[0] := e; - end; - b := newRstNode(rnBulletItem); - addSon(b, val); - addSon(e, b); - - exit // key already exists - end - end; - e := newRstNode(rnDefItem); - assert(val.kind <> rnDefBody); - b := newRstNode(rnDefBody); - addSon(b, val); - addSon(e, a); - addSon(e, b); - addSon(index, e); -end; - -// --------------------------------------------------------------------------- - -function newLeaf(var p: TRstParser): PRstNode; -begin - result := newRstNode(rnLeaf, p.tok[p.idx].symbol) -end; - -function getReferenceName(var p: TRstParser; const endStr: string): PRstNode; -var - res: PRstNode; -begin - res := newRstNode(rnInner); - while true do begin - case p.tok[p.idx].kind of - tkWord, tkOther, tkWhite: addSon(res, newLeaf(p)); - tkPunct: - if p.tok[p.idx].symbol = endStr then begin inc(p.idx); break end - else addSon(res, newLeaf(p)); - else begin - rstMessage(p, errXexpected, endStr); - break - end - end; - inc(p.idx); - end; - result := res; -end; - -function untilEol(var p: TRstParser): PRstNode; -begin - result := newRstNode(rnInner); - while not (p.tok[p.idx].kind in [tkIndent, tkEof]) do begin - addSon(result, newLeaf(p)); inc(p.idx); - end -end; - -procedure expect(var p: TRstParser; const tok: string); -begin - if p.tok[p.idx].symbol = tok then inc(p.idx) - else rstMessage(p, errXexpected, tok) -end; - -(* - From the specification: - - The inline markup start-string and end-string recognition rules are as - follows. If any of the conditions are not met, the start-string or end-string - will not be recognized or processed. - - 1. Inline markup start-strings must start a text block or be immediately - preceded by whitespace or one of: ' " ( [ { < - / : - 2. Inline markup start-strings must be immediately followed by - non-whitespace. - 3. Inline markup end-strings must be immediately preceded by non-whitespace. - 4. Inline markup end-strings must end a text block or be immediately - followed by whitespace or one of: ' " ) ] } > - / : . , ; ! ? \ - 5. If an inline markup start-string is immediately preceded by a single or - double quote, "(", "[", "{", or "<", it must not be immediately followed - by the corresponding single or double quote, ")", "]", "}", or ">". - 6. An inline markup end-string must be separated by at least one character - from the start-string. - 7. An unescaped backslash preceding a start-string or end-string will - disable markup recognition, except for the end-string of inline literals. - See Escaping Mechanism above for details. -*) -function isInlineMarkupEnd(const p: TRstParser; const markup: string): bool; -begin - result := p.tok[p.idx].symbol = markup; - if not result then exit; - // Rule 3: - result := not (p.tok[p.idx-1].kind in [tkIndent, tkWhite]); - if not result then exit; - // Rule 4: - result := (p.tok[p.idx+1].kind in [tkIndent, tkWhite, tkEof]) - or (p.tok[p.idx+1].symbol[strStart] in ['''', '"', ')', ']', '}', '>', - '-', '/', '\', ':', '.', ',', - ';', '!', '?', '_']); - if not result then exit; - // Rule 7: - if p.idx > 0 then begin - if (markup <> '``') and (p.tok[p.idx-1].symbol = '\'+'') then begin - result := false - end - end -end; - -function isInlineMarkupStart(const p: TRstParser; const markup: string): bool; -var - c, d: Char; -begin - result := p.tok[p.idx].symbol = markup; - if not result then exit; - // Rule 1: - result := (p.idx = 0) or (p.tok[p.idx-1].kind in [tkIndent, tkWhite]) - or (p.tok[p.idx-1].symbol[strStart] in ['''', '"', '(', '[', '{', '<', - '-', '/', ':', '_']); - if not result then exit; - // Rule 2: - result := not (p.tok[p.idx+1].kind in [tkIndent, tkWhite, tkEof]); - if not result then exit; - // Rule 5 & 7: - if p.idx > 0 then begin - if p.tok[p.idx-1].symbol = '\'+'' then - result := false - else begin - c := p.tok[p.idx-1].symbol[strStart]; - case c of - '''', '"': d := c; - '(': d := ')'; - '[': d := ']'; - '{': d := '}'; - '<': d := '>'; - else d := #0; - end; - if d <> #0 then - result := p.tok[p.idx+1].symbol[strStart] <> d; - end - end -end; - -procedure parseBackslash(var p: TRstParser; father: PRstNode); -begin - assert(p.tok[p.idx].kind = tkPunct); - if p.tok[p.idx].symbol = '\\' then begin - addSon(father, newRstNode(rnLeaf, '\'+'')); - inc(p.idx); - end - else if p.tok[p.idx].symbol = '\'+'' then begin - // XXX: Unicode? - inc(p.idx); - if p.tok[p.idx].kind <> tkWhite then addSon(father, newLeaf(p)); - inc(p.idx); - end - else begin - addSon(father, newLeaf(p)); - inc(p.idx) - end -end; - -function match(const p: TRstParser; start: int; const expr: string): bool; -// regular expressions are: -// special char exact match -// 'w' tkWord -// ' ' tkWhite -// 'a' tkAdornment -// 'i' tkIndent -// 'p' tkPunct -// 'T' always true -// 'E' whitespace, indent or eof -// 'e' tkWord or '#' (for enumeration lists) -var - i, j, last, len: int; - c: char; -begin - i := strStart; - j := start; - last := length(expr)+strStart-1; - while i <= last do begin - case expr[i] of - 'w': result := p.tok[j].kind = tkWord; - ' ': result := p.tok[j].kind = tkWhite; - 'i': result := p.tok[j].kind = tkIndent; - 'p': result := p.tok[j].kind = tkPunct; - 'a': result := p.tok[j].kind = tkAdornment; - 'o': result := p.tok[j].kind = tkOther; - 'T': result := true; - 'E': result := p.tok[j].kind in [tkEof, tkWhite, tkIndent]; - 'e': begin - result := (p.tok[j].kind = tkWord) or (p.tok[j].symbol = '#'+''); - if result then - case p.tok[j].symbol[strStart] of - 'a'..'z', 'A'..'Z': result := length(p.tok[j].symbol) = 1; - '0'..'9': result := allCharsInSet(p.tok[j].symbol, ['0'..'9']); - else begin end - end - end - else begin - c := expr[i]; - len := 0; - while (i <= last) and (expr[i] = c) do begin inc(i); inc(len) end; - dec(i); - result := (p.tok[j].kind in [tkPunct, tkAdornment]) - and (length(p.tok[j].symbol) = len) - and (p.tok[j].symbol[strStart] = c); - end - end; - if not result then exit; - inc(j); - inc(i) - end; - result := true -end; - -procedure fixupEmbeddedRef(n, a, b: PRstNode); -var - i, sep, incr: int; -begin - sep := -1; - for i := rsonsLen(n)-2 downto 0 do - if n.sons[i].text = '<'+'' then begin sep := i; break end; - if (sep > 0) and (n.sons[sep-1].text[strStart] = ' ') then incr := 2 - else incr := 1; - for i := 0 to sep-incr do addSon(a, n.sons[i]); - for i := sep+1 to rsonsLen(n)-2 do addSon(b, n.sons[i]); -end; - -function parsePostfix(var p: TRstParser; n: PRstNode): PRstNode; -var - a, b: PRstNode; -begin - result := n; - if isInlineMarkupEnd(p, '_'+'') then begin - inc(p.idx); - if (p.tok[p.idx-2].symbol ='`'+'') - and (p.tok[p.idx-3].symbol = '>'+'') then begin - a := newRstNode(rnInner); - b := newRstNode(rnInner); - fixupEmbeddedRef(n, a, b); - if rsonsLen(a) = 0 then begin - result := newRstNode(rnStandaloneHyperlink); - addSon(result, b); - end - else begin - result := newRstNode(rnHyperlink); - addSon(result, a); - addSon(result, b); - setRef(p, rstnodeToRefname(a), b); - end - end - else if n.kind = rnInterpretedText then - n.kind := rnRef - else begin - result := newRstNode(rnRef); - addSon(result, n); - end; - end - else if match(p, p.idx, ':w:') then begin - // a role: - if p.tok[p.idx+1].symbol = 'idx' then - n.kind := rnIdx - else if p.tok[p.idx+1].symbol = 'literal' then - n.kind := rnInlineLiteral - else if p.tok[p.idx+1].symbol = 'strong' then - n.kind := rnStrongEmphasis - else if p.tok[p.idx+1].symbol = 'emphasis' then - n.kind := rnEmphasis - else if (p.tok[p.idx+1].symbol = 'sub') - or (p.tok[p.idx+1].symbol = 'subscript') then - n.kind := rnSub - else if (p.tok[p.idx+1].symbol = 'sup') - or (p.tok[p.idx+1].symbol = 'supscript') then - n.kind := rnSup - else begin - result := newRstNode(rnGeneralRole); - n.kind := rnInner; - addSon(result, n); - addSon(result, newRstNode(rnLeaf, p.tok[p.idx+1].symbol)); - end; - inc(p.idx, 3) - end -end; - -function isURL(const p: TRstParser; i: int): bool; -begin - result := (p.tok[i+1].symbol = ':'+'') and (p.tok[i+2].symbol = '//') - and (p.tok[i+3].kind = tkWord) and (p.tok[i+4].symbol = '.'+'') -end; - -procedure parseURL(var p: TRstParser; father: PRstNode); -var - n: PRstNode; -begin - //if p.tok[p.idx].symbol[strStart] = '<' then begin - if isURL(p, p.idx) then begin - n := newRstNode(rnStandaloneHyperlink); - while true do begin - case p.tok[p.idx].kind of - tkWord, tkAdornment, tkOther: begin end; - tkPunct: begin - if not (p.tok[p.idx+1].kind in [tkWord, tkAdornment, tkOther, tkPunct]) - then break - end - else break - end; - addSon(n, newLeaf(p)); - inc(p.idx); - end; - addSon(father, n); - end - else begin - n := newLeaf(p); - inc(p.idx); - if p.tok[p.idx].symbol = '_'+'' then n := parsePostfix(p, n); - addSon(father, n); - end -end; - -procedure parseUntil(var p: TRstParser; father: PRstNode; - const postfix: string; interpretBackslash: bool); -begin - while true do begin - case p.tok[p.idx].kind of - tkPunct: begin - if isInlineMarkupEnd(p, postfix) then begin - inc(p.idx); - break; - end - else if interpretBackslash then - parseBackslash(p, father) - else begin - addSon(father, newLeaf(p)); - inc(p.idx); - end - end; - tkAdornment, tkWord, tkOther: begin - addSon(father, newLeaf(p)); - inc(p.idx); - end; - tkIndent: begin - addSon(father, newRstNode(rnLeaf, ' '+'')); - inc(p.idx); - if p.tok[p.idx].kind = tkIndent then begin - rstMessage(p, errXExpected, postfix); - break - end - end; - tkWhite: begin - addSon(father, newRstNode(rnLeaf, ' '+'')); - inc(p.idx); - end - else - rstMessage(p, errXExpected, postfix); - end - end -end; - -procedure parseInline(var p: TRstParser; father: PRstNode); -var - n: PRstNode; -begin - case p.tok[p.idx].kind of - tkPunct: begin - if isInlineMarkupStart(p, '**') then begin - inc(p.idx); - n := newRstNode(rnStrongEmphasis); - parseUntil(p, n, '**', true); - addSon(father, n); - end - else if isInlineMarkupStart(p, '*'+'') then begin - inc(p.idx); - n := newRstNode(rnEmphasis); - parseUntil(p, n, '*'+'', true); - addSon(father, n); - end - else if isInlineMarkupStart(p, '``') then begin - inc(p.idx); - n := newRstNode(rnInlineLiteral); - parseUntil(p, n, '``', false); - addSon(father, n); - end - else if isInlineMarkupStart(p, '`'+'') then begin - inc(p.idx); - n := newRstNode(rnInterpretedText); - parseUntil(p, n, '`'+'', true); - n := parsePostfix(p, n); - addSon(father, n); - end - else if isInlineMarkupStart(p, '|'+'') then begin - inc(p.idx); - n := newRstNode(rnSubstitutionReferences); - parseUntil(p, n, '|'+'', false); - addSon(father, n); - end - else begin - parseBackslash(p, father); - end; - end; - tkWord: parseURL(p, father); - tkAdornment, tkOther, tkWhite: begin - addSon(father, newLeaf(p)); - inc(p.idx); - end - else assert(false); - end -end; - -function getDirective(var p: TRstParser): string; -var - j: int; -begin - if (p.tok[p.idx].kind = tkWhite) and (p.tok[p.idx+1].kind = tkWord) then begin - j := p.idx; - inc(p.idx); - result := p.tok[p.idx].symbol; - inc(p.idx); - while p.tok[p.idx].kind in [tkWord, tkPunct, tkAdornment, tkOther] do begin - if p.tok[p.idx].symbol = '::' then break; - add(result, p.tok[p.idx].symbol); - inc(p.idx); - end; - if (p.tok[p.idx].kind = tkWhite) then inc(p.idx); - if p.tok[p.idx].symbol = '::' then begin - inc(p.idx); - if (p.tok[p.idx].kind = tkWhite) then inc(p.idx); - end - else begin - p.idx := j; // set back - result := '' // error - end - end - else - result := ''; -end; - -function parseComment(var p: TRstParser): PRstNode; -var - indent: int; -begin - case p.tok[p.idx].kind of - tkIndent, tkEof: begin - if p.tok[p.idx+1].kind = tkIndent then begin - inc(p.idx); - // empty comment - end - else begin - indent := p.tok[p.idx].ival; - while True do begin - case p.tok[p.idx].kind of - tkEof: break; - tkIndent: begin - if (p.tok[p.idx].ival < indent) then break; - end - else begin end - end; - inc(p.idx) - end - end - end - else - while not (p.tok[p.idx].kind in [tkIndent, tkEof]) do inc(p.idx); - end; - result := nil; -end; - -type - TDirKind = ( // must be ordered alphabetically! - dkNone, dkAuthor, dkAuthors, dkCodeBlock, dkContainer, - dkContents, dkFigure, dkImage, dkInclude, dkIndex, dkRaw, dkTitle - ); -const - DirIds: array [0..11] of string = ( - '', 'author', 'authors', 'code-block', 'container', - 'contents', 'figure', 'image', 'include', 'index', 'raw', 'title' - ); - -function getDirKind(const s: string): TDirKind; -var - i: int; -begin - i := binaryStrSearch(DirIds, s); - if i >= 0 then result := TDirKind(i) - else result := dkNone -end; - -procedure parseLine(var p: TRstParser; father: PRstNode); -begin - while True do begin - case p.tok[p.idx].kind of - tkWhite, tkWord, tkOther, tkPunct: parseInline(p, father); - else break; - end - end -end; - -procedure parseSection(var p: TRstParser; result: PRstNode); forward; - -function parseField(var p: TRstParser): PRstNode; -var - col, indent: int; - fieldname, fieldbody: PRstNode; -begin - result := newRstNode(rnField); - col := p.tok[p.idx].col; - inc(p.idx); // skip : - fieldname := newRstNode(rnFieldname); - parseUntil(p, fieldname, ':'+'', false); - fieldbody := newRstNode(rnFieldbody); - - if p.tok[p.idx].kind <> tkIndent then - parseLine(p, fieldbody); - if p.tok[p.idx].kind = tkIndent then begin - indent := p.tok[p.idx].ival; - if indent > col then begin - pushInd(p, indent); - parseSection(p, fieldbody); - popInd(p); - end - end; - addSon(result, fieldname); - addSon(result, fieldbody); -end; - -function parseFields(var p: TRstParser): PRstNode; -var - col: int; -begin - result := nil; - if (p.tok[p.idx].kind = tkIndent) - and (p.tok[p.idx+1].symbol = ':'+'') then begin - col := p.tok[p.idx].ival; // BUGFIX! - result := newRstNode(rnFieldList); - inc(p.idx); - while true do begin - addSon(result, parseField(p)); - if (p.tok[p.idx].kind = tkIndent) and (p.tok[p.idx].ival = col) - and (p.tok[p.idx+1].symbol = ':'+'') then inc(p.idx) - else break - end - end -end; - -function getFieldValue(n: PRstNode; const fieldname: string): string; -var - i: int; - f: PRstNode; -begin - result := ''; - if n.sons[1] = nil then exit; - if (n.sons[1].kind <> rnFieldList) then - InternalError('getFieldValue (2): ' + rstnodeKindToStr[n.sons[1].kind]); - for i := 0 to rsonsLen(n.sons[1])-1 do begin - f := n.sons[1].sons[i]; - if cmpIgnoreStyle(addNodes(f.sons[0]), fieldname) = 0 then begin - result := addNodes(f.sons[1]); - if result = '' then result := #1#1; // indicates that the field exists - exit - end - end -end; - -function getArgument(n: PRstNode): string; -begin - if n.sons[0] = nil then result := '' - else result := addNodes(n.sons[0]); -end; - -function parseDotDot(var p: TRstParser): PRstNode; forward; - -function parseLiteralBlock(var p: TRstParser): PRstNode; -var - indent: int; - n: PRstNode; -begin - result := newRstNode(rnLiteralBlock); - n := newRstNode(rnLeaf, ''); - if p.tok[p.idx].kind = tkIndent then begin - indent := p.tok[p.idx].ival; - inc(p.idx); - while True do begin - case p.tok[p.idx].kind of - tkEof: break; - tkIndent: begin - if (p.tok[p.idx].ival < indent) then begin - break; - end - else begin - add(n.text, nl); - add(n.text, repeatChar(p.tok[p.idx].ival - indent)); - inc(p.idx) - end - end - else begin - add(n.text, p.tok[p.idx].symbol); - inc(p.idx) - end - end - end - end - else begin - while not (p.tok[p.idx].kind in [tkIndent, tkEof]) do begin - add(n.text, p.tok[p.idx].symbol); - inc(p.idx) - end - end; - addSon(result, n); -end; - -function getLevel(var map: TLevelMap; var lvl: int; c: Char): int; -begin - if map[c] = 0 then begin - inc(lvl); - map[c] := lvl; - end; - result := map[c] -end; - -function tokenAfterNewline(const p: TRstParser): int; -begin - result := p.idx; - while true do - case p.tok[result].kind of - tkEof: break; - tkIndent: begin inc(result); break end; - else inc(result) - end -end; - -// --------------------------------------------------------------------------- - -function isLineBlock(const p: TRstParser): bool; -var - j: int; -begin - j := tokenAfterNewline(p); - result := (p.tok[p.idx].col = p.tok[j].col) and (p.tok[j].symbol = '|'+'') - or (p.tok[j].col > p.tok[p.idx].col) -end; - -function predNL(const p: TRstParser): bool; -begin - result := true; - if (p.idx > 0) then - result := (p.tok[p.idx-1].kind = tkIndent) - and (p.tok[p.idx-1].ival = currInd(p)) -end; - -function isDefList(const p: TRstParser): bool; -var - j: int; -begin - j := tokenAfterNewline(p); - result := (p.tok[p.idx].col < p.tok[j].col) - and (p.tok[j].kind in [tkWord, tkOther, tkPunct]) - and (p.tok[j-2].symbol <> '::'); -end; - -function whichSection(const p: TRstParser): TRstNodeKind; -begin - case p.tok[p.idx].kind of - tkAdornment: begin - if match(p, p.idx+1, 'ii') then result := rnTransition - else if match(p, p.idx+1, ' a') then result := rnTable - else if match(p, p.idx+1, 'i'+'') then result := rnOverline - else result := rnLeaf - end; - tkPunct: begin - if match(p, tokenAfterNewLine(p), 'ai') then - result := rnHeadline - else if p.tok[p.idx].symbol = '::' then - result := rnLiteralBlock - else if predNL(p) - and ((p.tok[p.idx].symbol = '+'+'') or - (p.tok[p.idx].symbol = '*'+'') or - (p.tok[p.idx].symbol = '-'+'')) - and (p.tok[p.idx+1].kind = tkWhite) then - result := rnBulletList - else if (p.tok[p.idx].symbol = '|'+'') and isLineBlock(p) then - result := rnLineBlock - else if (p.tok[p.idx].symbol = '..') and predNL(p) then - result := rnDirective - else if (p.tok[p.idx].symbol = ':'+'') and predNL(p) then - result := rnFieldList - else if match(p, p.idx, '(e) ') then - result := rnEnumList - else if match(p, p.idx, '+a+') then begin - result := rnGridTable; - rstMessage(p, errGridTableNotImplemented); - end - else if isDefList(p) then - result := rnDefList - else if match(p, p.idx, '-w') or match(p, p.idx, '--w') - or match(p, p.idx, '/w') then - result := rnOptionList - else - result := rnParagraph - end; - tkWord, tkOther, tkWhite: begin - if match(p, tokenAfterNewLine(p), 'ai') then - result := rnHeadline - else if isDefList(p) then - result := rnDefList - else if match(p, p.idx, 'e) ') or match(p, p.idx, 'e. ') then - result := rnEnumList - else - result := rnParagraph; - end; - else result := rnLeaf; - end -end; - -function parseLineBlock(var p: TRstParser): PRstNode; -var - col: int; - item: PRstNode; -begin - result := nil; - if p.tok[p.idx+1].kind = tkWhite then begin - col := p.tok[p.idx].col; - result := newRstNode(rnLineBlock); - pushInd(p, p.tok[p.idx+2].col); - inc(p.idx, 2); - while true do begin - item := newRstNode(rnLineBlockItem); - parseSection(p, item); - addSon(result, item); - if (p.tok[p.idx].kind = tkIndent) and (p.tok[p.idx].ival = col) - and (p.tok[p.idx+1].symbol = '|'+'') - and (p.tok[p.idx+2].kind = tkWhite) then inc(p.idx, 3) - else break; - end; - popInd(p); - end; -end; - -procedure parseParagraph(var p: TRstParser; result: PRstNode); -begin - while True do begin - case p.tok[p.idx].kind of - tkIndent: begin - if p.tok[p.idx+1].kind = tkIndent then begin - inc(p.idx); - break - end - else if (p.tok[p.idx].ival = currInd(p)) then begin - inc(p.idx); - case whichSection(p) of - rnParagraph, rnLeaf, rnHeadline, rnOverline, rnDirective: - addSon(result, newRstNode(rnLeaf, ' '+'')); - rnLineBlock: addSonIfNotNil(result, parseLineBlock(p)); - else break; - end; - end - else break - end; - tkPunct: begin - if (p.tok[p.idx].symbol = '::') and (p.tok[p.idx+1].kind = tkIndent) - and (currInd(p) < p.tok[p.idx+1].ival) then begin - addSon(result, newRstNode(rnLeaf, ':'+'')); - inc(p.idx); // skip '::' - addSon(result, parseLiteralBlock(p)); - break - end - else - parseInline(p, result) - end; - tkWhite, tkWord, tkAdornment, tkOther: - parseInline(p, result); - else break; - end - end -end; - -function parseParagraphWrapper(var p: TRstParser): PRstNode; -begin - result := newRstNode(rnParagraph); - parseParagraph(p, result); -end; - -function parseHeadline(var p: TRstParser): PRstNode; -var - c: Char; -begin - result := newRstNode(rnHeadline); - parseLine(p, result); - assert(p.tok[p.idx].kind = tkIndent); - assert(p.tok[p.idx+1].kind = tkAdornment); - c := p.tok[p.idx+1].symbol[strStart]; - inc(p.idx, 2); - result.level := getLevel(p.s.underlineToLevel, p.s.uLevel, c); -end; - -type - TIntSeq = array of int; - -function tokEnd(const p: TRstParser): int; -begin - result := p.tok[p.idx].col + length(p.tok[p.idx].symbol) - 1; -end; - -procedure getColumns(var p: TRstParser; var cols: TIntSeq); -var - L: int; -begin - L := 0; - while true do begin - inc(L); - setLength(cols, L); - cols[L-1] := tokEnd(p); - assert(p.tok[p.idx].kind = tkAdornment); - inc(p.idx); - if p.tok[p.idx].kind <> tkWhite then break; - inc(p.idx); - if p.tok[p.idx].kind <> tkAdornment then break - end; - if p.tok[p.idx].kind = tkIndent then inc(p.idx); - // last column has no limit: - cols[L-1] := 32000; -end; - -function parseDoc(var p: TRstParser): PRstNode; forward; - -function parseSimpleTable(var p: TRstParser): PRstNode; -var - cols: TIntSeq; - row: array of string; - j, i, last, line: int; - c: Char; - q: TRstParser; - a, b: PRstNode; -begin - result := newRstNode(rnTable); -{@ignore} - cols := nil; - row := nil; -{@emit - cols := @[];} -{@emit - row := @[];} - a := nil; - c := p.tok[p.idx].symbol[strStart]; - while true do begin - if p.tok[p.idx].kind = tkAdornment then begin - last := tokenAfterNewline(p); - if p.tok[last].kind in [tkEof, tkIndent] then begin - // skip last adornment line: - p.idx := last; break - end; - getColumns(p, cols); - setLength(row, length(cols)); - if a <> nil then - for j := 0 to rsonsLen(a)-1 do a.sons[j].kind := rnTableHeaderCell; - end; - if p.tok[p.idx].kind = tkEof then break; - for j := 0 to high(row) do row[j] := ''; - // the following while loop iterates over the lines a single cell may span: - line := p.tok[p.idx].line; - while true do begin - i := 0; - while not (p.tok[p.idx].kind in [tkIndent, tkEof]) do begin - if (tokEnd(p) <= cols[i]) then begin - add(row[i], p.tok[p.idx].symbol); - inc(p.idx); - end - else begin - if p.tok[p.idx].kind = tkWhite then inc(p.idx); - inc(i) - end - end; - if p.tok[p.idx].kind = tkIndent then inc(p.idx); - if tokEnd(p) <= cols[0] then break; - if p.tok[p.idx].kind in [tkEof, tkAdornment] then break; - for j := 1 to high(row) do addChar(row[j], #10); - end; - // process all the cells: - a := newRstNode(rnTableRow); - for j := 0 to high(row) do begin - initParser(q, p.s); - q.col := cols[j]; - q.line := line-1; - q.filename := p.filename; - getTokens(row[j], false, q.tok); - b := newRstNode(rnTableDataCell); - addSon(b, parseDoc(q)); - addSon(a, b); - end; - addSon(result, a); - end; -end; - -function parseTransition(var p: TRstParser): PRstNode; -begin - result := newRstNode(rnTransition); - inc(p.idx); - if p.tok[p.idx].kind = tkIndent then inc(p.idx); - if p.tok[p.idx].kind = tkIndent then inc(p.idx); -end; - -function parseOverline(var p: TRstParser): PRstNode; -var - c: char; -begin - c := p.tok[p.idx].symbol[strStart]; - inc(p.idx, 2); - result := newRstNode(rnOverline); - while true do begin - parseLine(p, result); - if p.tok[p.idx].kind = tkIndent then begin - inc(p.idx); - if p.tok[p.idx-1].ival > currInd(p) then - addSon(result, newRstNode(rnLeaf, ' '+'')) - else - break - end - else break - end; - result.level := getLevel(p.s.overlineToLevel, p.s.oLevel, c); - if p.tok[p.idx].kind = tkAdornment then begin - inc(p.idx); // XXX: check? - if p.tok[p.idx].kind = tkIndent then inc(p.idx); - end -end; - -function parseBulletList(var p: TRstParser): PRstNode; -var - bullet: string; - col: int; - item: PRstNode; -begin - result := nil; - if p.tok[p.idx+1].kind = tkWhite then begin - bullet := p.tok[p.idx].symbol; - col := p.tok[p.idx].col; - result := newRstNode(rnBulletList); - pushInd(p, p.tok[p.idx+2].col); - inc(p.idx, 2); - while true do begin - item := newRstNode(rnBulletItem); - parseSection(p, item); - addSon(result, item); - if (p.tok[p.idx].kind = tkIndent) and (p.tok[p.idx].ival = col) - and (p.tok[p.idx+1].symbol = bullet) - and (p.tok[p.idx+2].kind = tkWhite) then inc(p.idx, 3) - else break; - end; - popInd(p); - end; -end; - -function parseOptionList(var p: TRstParser): PRstNode; -var - a, b, c: PRstNode; - j: int; -begin - result := newRstNode(rnOptionList); - while true do begin - if match(p, p.idx, '-w') - or match(p, p.idx, '--w') - or match(p, p.idx, '/w') then begin - a := newRstNode(rnOptionGroup); - b := newRstNode(rnDescription); - c := newRstNode(rnOptionListItem); - while not (p.tok[p.idx].kind in [tkIndent, tkEof]) do begin - if (p.tok[p.idx].kind = tkWhite) - and (length(p.tok[p.idx].symbol) > 1) then begin - inc(p.idx); break - end; - addSon(a, newLeaf(p)); - inc(p.idx); - end; - j := tokenAfterNewline(p); - if (j > 0) and (p.tok[j-1].kind = tkIndent) - and (p.tok[j-1].ival > currInd(p)) then begin - pushInd(p, p.tok[j-1].ival); - parseSection(p, b); - popInd(p); - end - else begin - parseLine(p, b); - end; - if (p.tok[p.idx].kind = tkIndent) then inc(p.idx); - addSon(c, a); - addSon(c, b); - addSon(result, c); - end - else break; - end -end; - -function parseDefinitionList(var p: TRstParser): PRstNode; -var - j, col: int; - a, b, c: PRstNode; -begin - result := nil; - j := tokenAfterNewLine(p)-1; - if (j >= 1) and (p.tok[j].kind = tkIndent) - and (p.tok[j].ival > currInd(p)) and (p.tok[j-1].symbol <> '::') then begin - col := p.tok[p.idx].col; - result := newRstNode(rnDefList); - while true do begin - j := p.idx; - a := newRstNode(rnDefName); - parseLine(p, a); - //writeln('after def line: ', p.tok[p.idx].ival :1, ' ', col : 1); - if (p.tok[p.idx].kind = tkIndent) - and (p.tok[p.idx].ival > currInd(p)) - and (p.tok[p.idx+1].symbol <> '::') - and not (p.tok[p.idx+1].kind in [tkIndent, tkEof]) then begin - pushInd(p, p.tok[p.idx].ival); - b := newRstNode(rnDefBody); - parseSection(p, b); - c := newRstNode(rnDefItem); - addSon(c, a); - addSon(c, b); - addSon(result, c); - popInd(p); - end - else begin - p.idx := j; - break - end; - if (p.tok[p.idx].kind = tkIndent) and (p.tok[p.idx].ival = col) then begin - inc(p.idx); - j := tokenAfterNewLine(p)-1; - if (j >= 1) and (p.tok[j].kind = tkIndent) - and (p.tok[j].ival > col) - and (p.tok[j-1].symbol <> '::') - and (p.tok[j+1].kind <> tkIndent) then begin end - else break - end - end; - if rsonsLen(result) = 0 then result := nil - end -end; - -function parseEnumList(var p: TRstParser): PRstNode; -const - wildcards: array [0..2] of string = ('(e) ', 'e) ', 'e. '); - wildpos: array [0..2] of int = (1, 0, 0); -var - w, col, j: int; - item: PRstNode; -begin - result := nil; - w := 0; - while w <= 2 do begin - if match(p, p.idx, wildcards[w]) then break; - inc(w); - end; - if w <= 2 then begin - col := p.tok[p.idx].col; - result := newRstNode(rnEnumList); - inc(p.idx, wildpos[w]+3); - j := tokenAfterNewLine(p); - if (p.tok[j].col = p.tok[p.idx].col) or match(p, j, wildcards[w]) then begin - pushInd(p, p.tok[p.idx].col); - while true do begin - item := newRstNode(rnEnumItem); - parseSection(p, item); - addSon(result, item); - if (p.tok[p.idx].kind = tkIndent) - and (p.tok[p.idx].ival = col) - and match(p, p.idx+1, wildcards[w]) then - inc(p.idx, wildpos[w]+4) - else - break - end; - popInd(p); - end - else begin - dec(p.idx, wildpos[w]+3); - result := nil - end - end -end; - -function sonKind(father: PRstNode; i: int): TRstNodeKind; -begin - result := rnLeaf; - if i < rsonsLen(father) then result := father.sons[i].kind; -end; - -procedure parseSection(var p: TRstParser; result: PRstNode); -var - a: PRstNode; - k: TRstNodeKind; - leave: bool; -begin - while true do begin - leave := false; - assert(p.idx >= 0); - while p.tok[p.idx].kind = tkIndent do begin - if currInd(p) = p.tok[p.idx].ival then begin - inc(p.idx); - end - else if p.tok[p.idx].ival > currInd(p) then begin - pushInd(p, p.tok[p.idx].ival); - a := newRstNode(rnBlockQuote); - parseSection(p, a); - addSon(result, a); - popInd(p); - end - else begin - leave := true; - break; - end - end; - if leave then break; - if p.tok[p.idx].kind = tkEof then break; - a := nil; - k := whichSection(p); - case k of - rnLiteralBlock: begin - inc(p.idx); // skip '::' - a := parseLiteralBlock(p); - end; - rnBulletList: a := parseBulletList(p); - rnLineblock: a := parseLineBlock(p); - rnDirective: a := parseDotDot(p); - rnEnumList: a := parseEnumList(p); - rnLeaf: begin - rstMessage(p, errNewSectionExpected); - end; - rnParagraph: begin end; - rnDefList: a := parseDefinitionList(p); - rnFieldList: begin - dec(p.idx); - a := parseFields(p); - end; - rnTransition: a := parseTransition(p); - rnHeadline: a := parseHeadline(p); - rnOverline: a := parseOverline(p); - rnTable: a := parseSimpleTable(p); - rnOptionList: a := parseOptionList(p); - else InternalError('rst.parseSection()'); - end; - if (a = nil) and (k <> rnDirective) then begin - a := newRstNode(rnParagraph); - parseParagraph(p, a); - end; - addSonIfNotNil(result, a); - end; - if (sonKind(result, 0) = rnParagraph) - and (sonKind(result, 1) <> rnParagraph) then - result.sons[0].kind := rnInner; -end; - -function parseSectionWrapper(var p: TRstParser): PRstNode; -begin - result := newRstNode(rnInner); - parseSection(p, result); - while (result.kind = rnInner) and (rsonsLen(result) = 1) do - result := result.sons[0] -end; - -function parseDoc(var p: TRstParser): PRstNode; -begin - result := parseSectionWrapper(p); - if p.tok[p.idx].kind <> tkEof then - rstMessage(p, errGeneralParseError); -end; - -type - TDirFlag = (hasArg, hasOptions, argIsFile); - TDirFlags = set of TDirFlag; - TSectionParser = function (var p: TRstParser): PRstNode; - -function parseDirective(var p: TRstParser; flags: TDirFlags; - contentParser: TSectionParser): PRstNode; -var - args, options, content: PRstNode; -begin - result := newRstNode(rnDirective); - args := nil; - options := nil; - if hasArg in flags then begin - args := newRstNode(rnDirArg); - if argIsFile in flags then begin - while True do begin - case p.tok[p.idx].kind of - tkWord, tkOther, tkPunct, tkAdornment: begin - addSon(args, newLeaf(p)); - inc(p.idx); - end; - else break; - end - end - end - else begin - parseLine(p, args); - end - end; - addSon(result, args); - if hasOptions in flags then begin - if (p.tok[p.idx].kind = tkIndent) and (p.tok[p.idx].ival >= 3) - and (p.tok[p.idx+1].symbol = ':'+'') then - options := parseFields(p); - end; - addSon(result, options); - if (assigned(contentParser)) and (p.tok[p.idx].kind = tkIndent) - and (p.tok[p.idx].ival > currInd(p)) then begin - pushInd(p, p.tok[p.idx].ival); - content := contentParser(p); - popInd(p); - addSon(result, content) - end - else - addSon(result, nil); -end; - -function dirInclude(var p: TRstParser): PRstNode; -(* -The following options are recognized: - -start-after : text to find in the external data file - Only the content after the first occurrence of the specified text will - be included. -end-before : text to find in the external data file - Only the content before the first occurrence of the specified text - (but after any after text) will be included. -literal : flag (empty) - The entire included text is inserted into the document as a single - literal block (useful for program listings). -encoding : name of text encoding - The text encoding of the external data file. Defaults to the document's - encoding (if specified). -*) -var - n: PRstNode; - filename, path: string; - q: TRstParser; -begin - result := nil; - n := parseDirective(p, {@set}[hasArg, argIsFile, hasOptions], nil); - filename := strip(addNodes(n.sons[0])); - path := findFile(filename); - if path = '' then - rstMessage(p, errCannotOpenFile, filename) - else begin - // XXX: error handling; recursive file inclusion! - if getFieldValue(n, 'literal') <> '' then begin - result := newRstNode(rnLiteralBlock); - addSon(result, newRstNode(rnLeaf, readFile(path))); - end - else begin - initParser(q, p.s); - q.filename := filename; - getTokens(readFile(path), false, q.tok); - // workaround a GCC bug: - if find(q.tok[high(q.tok)].symbol, #0#1#2) > 0 then begin - InternalError('Too many binary zeros in include file'); - end; - result := parseDoc(q); - end - end -end; - -function dirCodeBlock(var p: TRstParser): PRstNode; -var - n: PRstNode; - filename, path: string; -begin - result := parseDirective(p, {@set}[hasArg, hasOptions], parseLiteralBlock); - filename := strip(getFieldValue(result, 'file')); - if filename <> '' then begin - path := findFile(filename); - if path = '' then rstMessage(p, errCannotOpenFile, filename); - n := newRstNode(rnLiteralBlock); - addSon(n, newRstNode(rnLeaf, readFile(path))); - result.sons[2] := n; - end; - result.kind := rnCodeBlock; -end; - -function dirContainer(var p: TRstParser): PRstNode; -begin - result := parseDirective(p, {@set}[hasArg], parseSectionWrapper); - assert(result.kind = rnDirective); - assert(rsonsLen(result) = 3); - result.kind := rnContainer; -end; - -function dirImage(var p: TRstParser): PRstNode; -begin - result := parseDirective(p, {@set}[hasOptions, hasArg, argIsFile], nil); - result.kind := rnImage -end; - -function dirFigure(var p: TRstParser): PRstNode; -begin - result := parseDirective(p, {@set}[hasOptions, hasArg, argIsFile], - parseSectionWrapper); - result.kind := rnFigure -end; - -function dirTitle(var p: TRstParser): PRstNode; -begin - result := parseDirective(p, {@set}[hasArg], nil); - result.kind := rnTitle -end; - -function dirContents(var p: TRstParser): PRstNode; -begin - result := parseDirective(p, {@set}[hasArg], nil); - result.kind := rnContents -end; - -function dirIndex(var p: TRstParser): PRstNode; -begin - result := parseDirective(p, {@set}[], parseSectionWrapper); - result.kind := rnIndex -end; - -function dirRaw(var p: TRstParser): PRstNode; -(* -The following options are recognized: - -file : string (newlines removed) - The local filesystem path of a raw data file to be included. -url : string (whitespace removed) - An Internet URL reference to a raw data file to be included. -encoding : name of text encoding - The text encoding of the external raw data (file or URL). - Defaults to the document's encoding (if specified). -*) -var - filename, path, f: string; -begin - result := parseDirective(p, {@set}[hasOptions], parseSectionWrapper); - result.kind := rnRaw; - filename := getFieldValue(result, 'file'); - if filename <> '' then begin - path := findFile(filename); - if path = '' then - rstMessage(p, errCannotOpenFile, filename) - else begin - f := readFile(path); - result := newRstNode(rnRaw); - addSon(result, newRstNode(rnLeaf, f)); - end - end -end; - -function parseDotDot(var p: TRstParser): PRstNode; -var - d: string; - col: int; - a, b: PRstNode; -begin - result := nil; - col := p.tok[p.idx].col; - inc(p.idx); - d := getDirective(p); - if d <> '' then begin - pushInd(p, col); - case getDirKind(d) of - dkInclude: result := dirInclude(p); - dkImage: result := dirImage(p); - dkFigure: result := dirFigure(p); - dkTitle: result := dirTitle(p); - dkContainer: result := dirContainer(p); - dkContents: result := dirContents(p); - dkRaw: result := dirRaw(p); - dkCodeblock: result := dirCodeBlock(p); - dkIndex: result := dirIndex(p); - else rstMessage(p, errInvalidDirectiveX, d); - end; - popInd(p); - end - else if match(p, p.idx, ' _') then begin - // hyperlink target: - inc(p.idx, 2); - a := getReferenceName(p, ':'+''); - if p.tok[p.idx].kind = tkWhite then inc(p.idx); - b := untilEol(p); - setRef(p, rstnodeToRefname(a), b); - end - else if match(p, p.idx, ' |') then begin - // substitution definitions: - inc(p.idx, 2); - a := getReferenceName(p, '|'+''); - if p.tok[p.idx].kind = tkWhite then inc(p.idx); - if cmpIgnoreStyle(p.tok[p.idx].symbol, 'replace') = 0 then begin - inc(p.idx); - expect(p, '::'); - b := untilEol(p); - end - else if cmpIgnoreStyle(p.tok[p.idx].symbol, 'image') = 0 then begin - inc(p.idx); - b := dirImage(p); - end - else - rstMessage(p, errInvalidDirectiveX, p.tok[p.idx].symbol); - setSub(p, addNodes(a), b); - end - else if match(p, p.idx, ' [') then begin - // footnotes, citations - inc(p.idx, 2); - a := getReferenceName(p, ']'+''); - if p.tok[p.idx].kind = tkWhite then inc(p.idx); - b := untilEol(p); - setRef(p, rstnodeToRefname(a), b); - end - else - result := parseComment(p); -end; - -function resolveSubs(var p: TRstParser; n: PRstNode): PRstNode; -var - i, x: int; - y: PRstNode; - e, key: string; -begin - result := n; - if n = nil then exit; - case n.kind of - rnSubstitutionReferences: begin - x := findSub(p, n); - if x >= 0 then result := p.s.subs[x].value - else begin - key := addNodes(n); - e := getEnv(key); - if e <> '' then result := newRstNode(rnLeaf, e) - else rstMessage(p, warnUnknownSubstitutionX, key); - end - end; - rnRef: begin - y := findRef(p, rstnodeToRefname(n)); - if y <> nil then begin - result := newRstNode(rnHyperlink); - n.kind := rnInner; - addSon(result, n); - addSon(result, y); - end - end; - rnLeaf: begin end; - rnContents: p.hasToc := true; - else begin - for i := 0 to rsonsLen(n)-1 do - n.sons[i] := resolveSubs(p, n.sons[i]); - end - end -end; - -function rstParse(const text: string; // the text to be parsed - skipPounds: bool; - const filename: string; // for error messages - line, column: int; - var hasToc: bool): PRstNode; -var - p: TRstParser; -begin - if isNil(text) then - rawMessage(errCannotOpenFile, filename); - initParser(p, newSharedState()); - p.filename := filename; - p.line := line; - p.col := column; - getTokens(text, skipPounds, p.tok); - result := resolveSubs(p, parseDoc(p)); - hasToc := p.hasToc; -end; - -end. diff --git a/nim/scanner.pas b/nim/scanner.pas deleted file mode 100755 index c03ae9224..000000000 --- a/nim/scanner.pas +++ /dev/null @@ -1,1036 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit scanner; - -// This scanner is handwritten for efficiency. I used an elegant buffering -// scheme which I have not seen anywhere else: -// We guarantee that a whole line is in the buffer. Thus only when scanning -// the \n or \r character we have to check wether we need to read in the next -// chunk. (\n or \r already need special handling for incrementing the line -// counter; choosing both \n and \r allows the scanner to properly read Unix, -// DOS or Macintosh text files, even when it is not the native format. - -interface - -{$include 'config.inc'} - -uses - charsets, nsystem, sysutils, nhashes, options, msgs, strutils, platform, - idents, lexbase, llstream, wordrecg; - -const - MaxLineLength = 80; // lines longer than this lead to a warning - - numChars: TCharSet = ['0'..'9','a'..'z','A'..'Z']; - SymChars: TCharSet = ['a'..'z', 'A'..'Z', '0'..'9', #128..#255]; - SymStartChars: TCharSet = ['a'..'z', 'A'..'Z', #128..#255]; - OpChars: TCharSet = ['+', '-', '*', '/', '\', '<', '>', '!', '?', '^', '.', - '|', '=', '%', '&', '$', '@', '~', #128..#255]; - -type - TTokType = (tkInvalid, tkEof, // order is important here! - tkSymbol, - // keywords: - //[[[cog - //from string import split, capitalize - //keywords = split(open("data/keywords.txt").read()) - //idents = "" - //strings = "" - //i = 1 - //for k in keywords: - // 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, - tkBind, tkBlock, tkBreak, tkCase, - tkCast, tkConst, tkContinue, tkConverter, - tkDiscard, tkDistinct, tkDiv, tkElif, - tkElse, tkEnd, tkEnum, tkExcept, - tkFinally, tkFor, tkFrom, tkGeneric, - tkIf, tkImplies, tkImport, tkIn, - tkInclude, tkIs, tkIsnot, tkIterator, - tkLambda, tkMacro, tkMethod, tkMod, - tkNil, tkNot, tkNotin, tkObject, - tkOf, tkOr, tkOut, tkProc, - tkPtr, tkRaise, tkRef, tkReturn, - tkShl, tkShr, tkTemplate, tkTry, - tkTuple, tkType, tkVar, tkWhen, - tkWhile, tkWith, tkWithout, tkXor, - tkYield, - //[[[end]]] - tkIntLit, tkInt8Lit, tkInt16Lit, tkInt32Lit, tkInt64Lit, - tkFloatLit, tkFloat32Lit, tkFloat64Lit, - tkStrLit, tkRStrLit, tkTripleStrLit, tkCallRStrLit, tkCallTripleStrLit, - tkCharLit, tkParLe, tkParRi, tkBracketLe, tkBracketRi, tkCurlyLe, tkCurlyRi, - tkBracketDotLe, tkBracketDotRi, // [. and .] - tkCurlyDotLe, tkCurlyDotRi, // {. and .} - tkParDotLe, tkParDotRi, // (. and .) - tkComma, tkSemiColon, tkColon, - tkEquals, tkDot, tkDotDot, tkHat, tkOpr, - tkComment, tkAccent, tkInd, tkSad, tkDed, - // pseudo token types used by the source renderers: - tkSpaces, tkInfixOpr, tkPrefixOpr, tkPostfixOpr - ); - TTokTypes = set of TTokType; -const - tokKeywordLow = succ(tkSymbol); - tokKeywordHigh = pred(tkIntLit); - tokOperators: TTokTypes = {@set}[tkOpr, tkSymbol, tkBracketLe, tkBracketRi, - tkIn, tkIs, tkIsNot, tkEquals, tkDot, tkHat, tkNot, tkAnd, tkOr, tkXor, - tkShl, tkShr, tkDiv, tkMod, tkNotIn]; - - TokTypeToStr: array [TTokType] of string = ( - 'tkInvalid', '[EOF]', - 'tkSymbol', - //[[[cog - //cog.out(strings) - //]]] - 'addr', 'and', 'as', 'asm', - 'bind', 'block', 'break', 'case', - 'cast', 'const', 'continue', 'converter', - 'discard', 'distinct', 'div', 'elif', - 'else', 'end', 'enum', 'except', - 'finally', 'for', 'from', 'generic', - 'if', 'implies', 'import', 'in', - 'include', 'is', 'isnot', 'iterator', - 'lambda', 'macro', 'method', 'mod', - 'nil', 'not', 'notin', 'object', - 'of', 'or', 'out', 'proc', - 'ptr', 'raise', 'ref', 'return', - 'shl', 'shr', 'template', 'try', - 'tuple', 'type', 'var', 'when', - 'while', 'with', 'without', 'xor', - 'yield', - //[[[end]]] - 'tkIntLit', 'tkInt8Lit', 'tkInt16Lit', 'tkInt32Lit', 'tkInt64Lit', - 'tkFloatLit', 'tkFloat32Lit', 'tkFloat64Lit', - 'tkStrLit', 'tkRStrLit', 'tkTripleStrLit', - 'tkCallRStrLit', 'tkCallTripleStrLit', - 'tkCharLit', - '('+'', ')'+'', '['+'', ']'+'', '{'+'', '}'+'', - '[.', '.]', '{.', '.}', '(.', '.)', ','+'', ';'+'', ':'+'', - '='+'', '.'+'', '..', '^'+'', 'tkOpr', - 'tkComment', '`'+'', '[new indentation]', '[same indentation]', - '[dedentation]', - 'tkSpaces', 'tkInfixOpr', 'tkPrefixOpr', 'tkPostfixOpr' - ); - -type - TNumericalBase = (base10, // base10 is listed as the first element, - // so that it is the correct default value - base2, - base8, - base16); - PToken = ^TToken; - TToken = object // a Nimrod token - tokType: TTokType; // the type of the token - indent: int; // the indentation; only valid if tokType = tkIndent - ident: PIdent; // the parsed identifier - iNumber: BiggestInt; // the parsed integer literal - fNumber: BiggestFloat; // the parsed floating point literal - base: TNumericalBase; // the numerical base; only valid for int - // or float literals - literal: string; // the parsed (string) literal; and - // documentation comments are here too - next: PToken; // next token; can be used for arbitrary look-ahead - end; - - PLexer = ^TLexer; - TLexer = object(TBaseLexer) - filename: string; - indentStack: array of int; // the indentation stack - dedent: int; // counter for DED token generation - indentAhead: int; // if > 0 an indendation has already been read - // this is needed because scanning comments - // needs so much look-ahead - end; - -var - gLinesCompiled: int; // all lines that have been compiled - -procedure pushInd(var L: TLexer; indent: int); -procedure popInd(var L: TLexer); - -function isKeyword(kind: TTokType): boolean; - -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 - -function getColumn(const L: TLexer): int; - -function getLineInfo(const L: TLexer): TLineInfo; - -procedure closeLexer(var lex: TLexer); - -procedure PrintTok(tok: PToken); -function tokToStr(tok: PToken): string; - -// auxiliary functions: -procedure lexMessage(const L: TLexer; const msg: TMsgKind; - const arg: string = ''); - -// the Pascal scanner uses this too: -procedure fillToken(var L: TToken); - -implementation - -function isKeyword(kind: TTokType): boolean; -begin - result := (kind >= tokKeywordLow) and (kind <= tokKeywordHigh) -end; - -procedure pushInd(var L: TLexer; indent: int); -var - len: int; -begin - len := length(L.indentStack); - setLength(L.indentStack, len+1); - if (indent > L.indentStack[len-1]) then - L.indentstack[len] := indent - else - InternalError('pushInd'); - //writeln('push indent ', indent); -end; - -procedure popInd(var L: TLexer); -var - len: int; -begin - len := length(L.indentStack); - setLength(L.indentStack, len-1); -end; - -function findIdent(const L: TLexer; indent: int): boolean; -var - i: int; -begin - for i := length(L.indentStack)-1 downto 0 do - if L.indentStack[i] = indent then begin result := true; exit end; - result := false -end; - -function tokToStr(tok: PToken): string; -begin - case tok.tokType of - tkIntLit..tkInt64Lit: - result := toString(tok.iNumber); - tkFloatLit..tkFloat64Lit: - result := toStringF(tok.fNumber); - tkInvalid, tkStrLit..tkCharLit, tkComment: - result := tok.literal; - tkParLe..tkColon, tkEof, tkInd, tkSad, tkDed, tkAccent: - result := tokTypeToStr[tok.tokType]; - else if (tok.ident <> nil) then - result := tok.ident.s - else begin - InternalError('tokToStr'); - result := '' - end - end -end; - -procedure PrintTok(tok: PToken); -begin - write(output, TokTypeToStr[tok.tokType]); - write(output, ' '+''); - writeln(output, tokToStr(tok)) -end; - -// ---------------------------------------------------------------------------- - -var - dummyIdent: PIdent; - -procedure fillToken(var L: TToken); -begin - L.TokType := tkInvalid; - L.iNumber := 0; - L.Indent := 0; - L.literal := ''; - L.fNumber := 0.0; - L.base := base10; - L.ident := dummyIdent; // this prevents many bugs! -end; - -procedure openLexer(out lex: TLexer; const filename: string; - inputstream: PLLStream); -begin -{@ignore} - FillChar(lex, sizeof(lex), 0); -{@emit} - openBaseLexer(lex, inputstream); -{@ignore} - setLength(lex.indentStack, 1); - lex.indentStack[0] := 0; -{@emit lex.indentStack := @[0]; } - lex.filename := filename; - lex.indentAhead := -1; -end; - -procedure closeLexer(var lex: TLexer); -begin - inc(gLinesCompiled, lex.LineNumber); - closeBaseLexer(lex); -end; - -function getColumn(const L: TLexer): int; -begin - result := getColNumber(L, L.bufPos) -end; - -function getLineInfo(const L: TLexer): TLineInfo; -begin - result := newLineInfo(L.filename, L.linenumber, getColNumber(L, L.bufpos)) -end; - -procedure lexMessage(const L: TLexer; const msg: TMsgKind; - const arg: string = ''); -begin - msgs.liMessage(getLineInfo(L), msg, arg) -end; - -procedure lexMessagePos(var L: TLexer; const msg: TMsgKind; pos: int; - const arg: string = ''); -var - info: TLineInfo; -begin - info := newLineInfo(L.filename, L.linenumber, pos - L.lineStart); - msgs.liMessage(info, msg, arg); -end; - -// ---------------------------------------------------------------------------- - -procedure matchUnderscoreChars(var L: TLexer; var tok: TToken; - const chars: TCharSet); -// matches ([chars]_)* -var - pos: int; - buf: PChar; -begin - pos := L.bufpos; // use registers for pos, buf - buf := L.buf; - repeat - if buf[pos] in chars then begin - addChar(tok.literal, buf[pos]); - Inc(pos) - end - else break; - if buf[pos] = '_' then begin - addChar(tok.literal, '_'); - Inc(pos); - end; - until false; - L.bufPos := pos; -end; - -function matchTwoChars(const L: TLexer; first: Char; - const second: TCharSet): Boolean; -begin - result := (L.buf[L.bufpos] = first) and (L.buf[L.bufpos+1] in Second); -end; - -function isFloatLiteral(const s: string): boolean; -var - i: int; -begin - for i := strStart to length(s)+strStart-1 do - if s[i] in ['.','e','E'] then begin - result := true; exit - end; - result := false -end; - -function GetNumber(var L: TLexer): TToken; -var - pos, endpos: int; - xi: biggestInt; -begin - // get the base: - result.tokType := tkIntLit; // int literal until we know better - result.literal := ''; - result.base := base10; // BUGFIX - pos := L.bufpos; - // make sure the literal is correct for error messages: - matchUnderscoreChars(L, result, ['A'..'Z', 'a'..'z', '0'..'9']); - if (L.buf[L.bufpos] = '.') and (L.buf[L.bufpos+1] in ['0'..'9']) then begin - addChar(result.literal, '.'); - inc(L.bufpos); - //matchUnderscoreChars(L, result, ['A'..'Z', 'a'..'z', '0'..'9']) - matchUnderscoreChars(L, result, ['0'..'9']); - if L.buf[L.bufpos] in ['e', 'E'] then begin - addChar(result.literal, 'e'); - inc(L.bufpos); - if L.buf[L.bufpos] in ['+', '-'] then begin - addChar(result.literal, L.buf[L.bufpos]); - inc(L.bufpos); - end; - matchUnderscoreChars(L, result, ['0'..'9']); - end - end; - endpos := L.bufpos; - if L.buf[endpos] = '''' then begin - //matchUnderscoreChars(L, result, ['''', 'f', 'F', 'i', 'I', '0'..'9']); - inc(endpos); - L.bufpos := pos; // restore position - case L.buf[endpos] of - 'f', 'F': begin - inc(endpos); - if (L.buf[endpos] = '6') and (L.buf[endpos+1] = '4') then begin - result.tokType := tkFloat64Lit; - inc(endpos, 2); - end - else if (L.buf[endpos] = '3') and (L.buf[endpos+1] = '2') then begin - result.tokType := tkFloat32Lit; - inc(endpos, 2); - end - else lexMessage(L, errInvalidNumber, result.literal); - end; - 'i', 'I': begin - inc(endpos); - if (L.buf[endpos] = '6') and (L.buf[endpos+1] = '4') then begin - result.tokType := tkInt64Lit; - inc(endpos, 2); - end - else if (L.buf[endpos] = '3') and (L.buf[endpos+1] = '2') then begin - result.tokType := tkInt32Lit; - inc(endpos, 2); - end - else if (L.buf[endpos] = '1') and (L.buf[endpos+1] = '6') then begin - result.tokType := tkInt16Lit; - inc(endpos, 2); - end - else if (L.buf[endpos] = '8') then begin - result.tokType := tkInt8Lit; - inc(endpos); - end - else lexMessage(L, errInvalidNumber, result.literal); - end; - else lexMessage(L, errInvalidNumber, result.literal); - end - end - else - L.bufpos := pos; // restore position - - try - if (L.buf[pos] = '0') and (L.buf[pos+1] in ['x','X','b','B','o','O','c','C']) - then begin - inc(pos, 2); - xi := 0; - // it may be a base prefix - case L.buf[pos-1] of - 'b', 'B': begin - result.base := base2; - while true do begin - case L.buf[pos] of - 'A'..'Z', 'a'..'z', '2'..'9', '.': begin - lexMessage(L, errInvalidNumber, result.literal); - inc(pos) - end; - '_': inc(pos); - '0', '1': begin - xi := shlu(xi, 1) or (ord(L.buf[pos]) - ord('0')); - inc(pos); - end; - else break; - end - end - end; - 'o', 'c', 'C': begin - result.base := base8; - while true do begin - case L.buf[pos] of - 'A'..'Z', 'a'..'z', '8'..'9', '.': begin - lexMessage(L, errInvalidNumber, result.literal); - inc(pos) - end; - '_': inc(pos); - '0'..'7': begin - xi := shlu(xi, 3) or (ord(L.buf[pos]) - ord('0')); - inc(pos); - end; - else break; - end - end - end; - 'O': lexMessage(L, errInvalidNumber, result.literal); - 'x', 'X': begin - result.base := base16; - while true do begin - case L.buf[pos] of - 'G'..'Z', 'g'..'z', '.': begin - lexMessage(L, errInvalidNumber, result.literal); - inc(pos); - end; - '_': inc(pos); - '0'..'9': begin - xi := shlu(xi, 4) or (ord(L.buf[pos]) - ord('0')); - inc(pos); - end; - 'a'..'f': begin - xi := shlu(xi, 4) or (ord(L.buf[pos]) - ord('a') + 10); - inc(pos); - end; - 'A'..'F': begin - xi := shlu(xi, 4) or (ord(L.buf[pos]) - ord('A') + 10); - inc(pos); - end; - else break; - end - end - end; - else InternalError(getLineInfo(L), 'getNumber'); - end; - // now look at the optional type suffix: - case result.tokType of - tkIntLit, tkInt64Lit: - result.iNumber := xi; - tkInt8Lit: - result.iNumber := biggestInt(int8(toU8(int(xi)))); - tkInt16Lit: - result.iNumber := biggestInt(toU16(int(xi))); - tkInt32Lit: - result.iNumber := biggestInt(toU32(xi)); - tkFloat32Lit: - result.fNumber := ({@cast}PFloat32(addr(xi)))^; - // note: this code is endian neutral! - // XXX: Test this on big endian machine! - tkFloat64Lit: - result.fNumber := ({@cast}PFloat64(addr(xi)))^; - else InternalError(getLineInfo(L), 'getNumber'); - end - end - else if isFloatLiteral(result.literal) - or (result.tokType = tkFloat32Lit) - or (result.tokType = tkFloat64Lit) then begin - result.fnumber := parseFloat(result.literal); - if result.tokType = tkIntLit then result.tokType := tkFloatLit; - end - else begin - result.iNumber := ParseBiggestInt(result.literal); - if (result.iNumber < low(int32)) or (result.iNumber > high(int32)) then - begin - if result.tokType = tkIntLit then result.tokType := tkInt64Lit - else if result.tokType <> tkInt64Lit then - lexMessage(L, errInvalidNumber, result.literal); - end - end; - except - on EInvalidValue do - lexMessage(L, errInvalidNumber, result.literal); - {@ignore} - on sysutils.EIntOverflow do - lexMessage(L, errNumberOutOfRange, result.literal); - {@emit} - on EOverflow do - lexMessage(L, errNumberOutOfRange, result.literal); - on EOutOfRange do - lexMessage(L, errNumberOutOfRange, result.literal); - end; - L.bufpos := endpos; -end; - -procedure handleHexChar(var L: TLexer; var xi: int); -begin - case L.buf[L.bufpos] of - '0'..'9': begin - xi := (xi shl 4) or (ord(L.buf[L.bufpos]) - ord('0')); - inc(L.bufpos); - end; - 'a'..'f': begin - xi := (xi shl 4) or (ord(L.buf[L.bufpos]) - ord('a') + 10); - inc(L.bufpos); - end; - 'A'..'F': begin - xi := (xi shl 4) or (ord(L.buf[L.bufpos]) - ord('A') + 10); - inc(L.bufpos); - end; - else begin end // do nothing - end -end; - -procedure handleDecChars(var L: TLexer; var xi: int); -begin - while L.buf[L.bufpos] in ['0'..'9'] do begin - xi := (xi * 10) + (ord(L.buf[L.bufpos]) - ord('0')); - inc(L.bufpos); - end; -end; - -procedure getEscapedChar(var L: TLexer; var tok: TToken); -var - xi: int; -begin - inc(L.bufpos); // skip '\' - case L.buf[L.bufpos] of - 'n', 'N': begin - if tok.toktype = tkCharLit then - lexMessage(L, errNnotAllowedInCharacter); - tok.literal := tok.literal +{&} tnl; - Inc(L.bufpos); - end; - 'r', 'R', 'c', 'C': begin addChar(tok.literal, CR); Inc(L.bufpos); end; - 'l', 'L': begin addChar(tok.literal, LF); Inc(L.bufpos); end; - 'f', 'F': begin addChar(tok.literal, FF); inc(L.bufpos); end; - 'e', 'E': begin addChar(tok.literal, ESC); Inc(L.bufpos); end; - 'a', 'A': begin addChar(tok.literal, BEL); Inc(L.bufpos); end; - 'b', 'B': begin addChar(tok.literal, BACKSPACE); Inc(L.bufpos); end; - 'v', 'V': begin addChar(tok.literal, VT); Inc(L.bufpos); end; - 't', 'T': begin addChar(tok.literal, Tabulator); Inc(L.bufpos); end; - '''', '"': begin addChar(tok.literal, L.buf[L.bufpos]); Inc(L.bufpos); end; - '\': begin addChar(tok.literal, '\'); Inc(L.bufpos) end; - 'x', 'X': begin - inc(L.bufpos); - xi := 0; - handleHexChar(L, xi); - handleHexChar(L, xi); - addChar(tok.literal, Chr(xi)); - end; - '0'..'9': begin - if matchTwoChars(L, '0', ['0'..'9']) then - // this warning will make it easier for newcomers: - lexMessage(L, warnOctalEscape); - xi := 0; - handleDecChars(L, xi); - if (xi <= 255) then - addChar(tok.literal, Chr(xi)) - else - lexMessage(L, errInvalidCharacterConstant) - end - else lexMessage(L, errInvalidCharacterConstant) - end -end; - -function HandleCRLF(var L: TLexer; pos: int): int; -begin - case L.buf[pos] of - CR: begin - if getColNumber(L, pos) > MaxLineLength then - lexMessagePos(L, hintLineTooLong, pos); - result := lexbase.HandleCR(L, pos) - end; - LF: begin - if getColNumber(L, pos) > MaxLineLength then - lexMessagePos(L, hintLineTooLong, pos); - result := lexbase.HandleLF(L, pos) - end; - else result := pos - end -end; - -procedure getString(var L: TLexer; var tok: TToken; rawMode: Boolean); -var - line, line2, pos: int; - c: Char; - buf: PChar; -begin - pos := L.bufPos + 1; // skip " - buf := L.buf; // put `buf` in a register - line := L.linenumber; // save linenumber for better error message - if (buf[pos] = '"') and (buf[pos+1] = '"') then begin - tok.tokType := tkTripleStrLit; - // long string literal: - inc(pos, 2); // skip "" - // skip leading newline: - pos := HandleCRLF(L, pos); - buf := L.buf; - repeat - case buf[pos] of - '"': begin - if (buf[pos+1] = '"') and (buf[pos+2] = '"') then - break; - addChar(tok.literal, '"'); - Inc(pos) - end; - CR, LF: begin - pos := HandleCRLF(L, pos); - buf := L.buf; - tok.literal := tok.literal +{&} tnl; - end; - lexbase.EndOfFile: begin - line2 := L.linenumber; - L.LineNumber := line; - lexMessagePos(L, errClosingTripleQuoteExpected, L.lineStart); - L.LineNumber := line2; - break - end - else begin - addChar(tok.literal, buf[pos]); - Inc(pos) - end - end - until false; - L.bufpos := pos + 3 // skip the three """ - end - else begin // ordinary string literal - if rawMode then tok.tokType := tkRStrLit - else tok.tokType := tkStrLit; - repeat - c := buf[pos]; - if c = '"' then begin - inc(pos); // skip '"' - break - end; - if c in [CR, LF, lexbase.EndOfFile] then begin - lexMessage(L, errClosingQuoteExpected); - break - end; - if (c = '\') and not rawMode then begin - L.bufPos := pos; - getEscapedChar(L, tok); - pos := L.bufPos; - end - else begin - addChar(tok.literal, c); - Inc(pos) - end - until false; - L.bufpos := pos; - end -end; - -procedure getCharacter(var L: TLexer; var tok: TToken); -var - c: Char; -begin - Inc(L.bufpos); // skip ' - c := L.buf[L.bufpos]; - case c of - #0..Pred(' '), '''': lexMessage(L, errInvalidCharacterConstant); - '\': getEscapedChar(L, tok); - else begin - tok.literal := c + ''; - Inc(L.bufpos); - end - end; - if L.buf[L.bufpos] <> '''' then lexMessage(L, errMissingFinalQuote); - inc(L.bufpos); // skip ' -end; - -{@ignore} -{$ifopt Q+} {$define Q_on} {$Q-} {$endif} -{$ifopt R+} {$define R_on} {$R-} {$endif} -{@emit} -procedure getSymbol(var L: TLexer; var tok: TToken); -var - pos: int; - c: Char; - buf: pchar; - h: THash; // hashing algorithm inlined -begin - h := 0; - pos := L.bufpos; - buf := L.buf; - while true do begin - c := buf[pos]; - case c of - 'a'..'z', '0'..'9', #128..#255: begin - h := h +{%} Ord(c); - h := h +{%} h shl 10; - h := h xor (h shr 6) - end; - 'A'..'Z': begin - c := chr(ord(c) + (ord('a')-ord('A'))); // toLower() - h := h +{%} Ord(c); - h := h +{%} h shl 10; - h := h xor (h shr 6) - end; - '_': begin end; - else break - end; - Inc(pos) - end; - h := h +{%} h shl 3; - h := h xor (h shr 11); - h := h +{%} h shl 15; - tok.ident := getIdent(addr(L.buf[L.bufpos]), pos-L.bufpos, h); - L.bufpos := pos; - if (tok.ident.id < ord(tokKeywordLow)-ord(tkSymbol)) or - (tok.ident.id > ord(tokKeywordHigh)-ord(tkSymbol)) then - tok.tokType := tkSymbol - else - tok.tokType := TTokType(tok.ident.id+ord(tkSymbol)); - if buf[pos] = '"' then begin - getString(L, tok, true); - if tok.tokType = tkRStrLit then tok.tokType := tkCallRStrLit - else tok.tokType := tkCallTripleStrLit - end -end; - -procedure getOperator(var L: TLexer; var tok: TToken); -var - pos: int; - c: Char; - buf: pchar; - h: THash; // hashing algorithm inlined -begin - pos := L.bufpos; - buf := L.buf; - h := 0; - while true do begin - c := buf[pos]; - if c in OpChars then begin - h := h +{%} Ord(c); - h := h +{%} h shl 10; - h := h xor (h shr 6) - end - else break; - Inc(pos) - end; - h := h +{%} h shl 3; - h := h xor (h shr 11); - h := h +{%} h shl 15; - tok.ident := getIdent(addr(L.buf[L.bufpos]), pos-L.bufpos, h); - if (tok.ident.id < oprLow) or (tok.ident.id > oprHigh) then - tok.tokType := tkOpr - else - tok.tokType := TTokType(tok.ident.id - oprLow + ord(tkColon)); - L.bufpos := pos -end; -{@ignore} -{$ifdef Q_on} {$undef Q_on} {$Q+} {$endif} -{$ifdef R_on} {$undef R_on} {$R+} {$endif} -{@emit} - -procedure handleIndentation(var L: TLexer; var tok: TToken; indent: int); -var - i: int; -begin - tok.indent := indent; - i := high(L.indentStack); - if indent > L.indentStack[i] then - tok.tokType := tkInd - else if indent = L.indentStack[i] then - tok.tokType := tkSad - else begin - // check we have the indentation somewhere in the stack: - while (i >= 0) and (indent <> L.indentStack[i]) do begin - dec(i); - inc(L.dedent); - end; - dec(L.dedent); - tok.tokType := tkDed; - if i < 0 then begin - tok.tokType := tkSad; // for the parser it is better as SAD - lexMessage(L, errInvalidIndentation); - end - end -end; - -procedure scanComment(var L: TLexer; var tok: TToken); -var - buf: PChar; - pos, col: int; - indent: int; -begin - pos := L.bufpos; - buf := L.buf; - // a comment ends if the next line does not start with the # on the same - // column after only whitespace - tok.tokType := tkComment; - col := getColNumber(L, pos); - while true do begin - while not (buf[pos] in [CR, LF, lexbase.EndOfFile]) do begin - addChar(tok.literal, buf[pos]); inc(pos); - end; - pos := handleCRLF(L, pos); - buf := L.buf; - indent := 0; - while buf[pos] = ' ' do begin inc(pos); inc(indent) end; - if (buf[pos] = '#') and (col = indent) then begin - tok.literal := tok.literal +{&} nl; - end - else begin - if buf[pos] > ' ' then begin - L.indentAhead := indent; - inc(L.dedent) - end; - break - end - end; - L.bufpos := pos; -end; - -procedure skip(var L: TLexer; var tok: TToken); -var - buf: PChar; - indent, pos: int; -begin - pos := L.bufpos; - buf := L.buf; - repeat - case buf[pos] of - ' ': Inc(pos); - Tabulator: begin - lexMessagePos(L, errTabulatorsAreNotAllowed, pos); - inc(pos); // BUGFIX - end; - // newline is special: - CR, LF: begin - pos := HandleCRLF(L, pos); - buf := L.buf; - indent := 0; - while buf[pos] = ' ' do begin - Inc(pos); Inc(indent) - end; - if (buf[pos] > ' ') then begin - handleIndentation(L, tok, indent); - break; - end - end; - else break // EndOfFile also leaves the loop - end - until false; - L.bufpos := pos; -end; - -procedure rawGetTok(var L: TLexer; var tok: TToken); -var - c: Char; -begin - fillToken(tok); - if L.dedent > 0 then begin - dec(L.dedent); - if L.indentAhead >= 0 then begin - handleIndentation(L, tok, L.indentAhead); - L.indentAhead := -1; - end - else - tok.tokType := tkDed; - exit; - end; - // Skip whitespace, comments: - skip(L, tok); // skip - // got an documentation comment or tkIndent, return that: - if tok.toktype <> tkInvalid then exit; - - c := L.buf[L.bufpos]; - if c in SymStartChars - ['r', 'R', 'l'] then // common case first - getSymbol(L, tok) - else if c in ['0'..'9'] then - tok := getNumber(L) - else begin - case c of - '#': scanComment(L, tok); - ':': begin - tok.tokType := tkColon; - inc(L.bufpos); - end; - ',': begin - tok.toktype := tkComma; - Inc(L.bufpos) - end; - 'l': begin - // if we parsed exactly one character and its a small L (l), this - // is treated as a warning because it may be confused with the number 1 - if not (L.buf[L.bufpos+1] in (SymChars+['_'])) then - lexMessage(L, warnSmallLshouldNotBeUsed); - getSymbol(L, tok); - end; - 'r', 'R': begin - if L.buf[L.bufPos+1] = '"' then begin - Inc(L.bufPos); - getString(L, tok, true); - end - else getSymbol(L, tok); - end; - '(': begin - Inc(L.bufpos); - if (L.buf[L.bufPos] = '.') - and (L.buf[L.bufPos+1] <> '.') then begin - tok.toktype := tkParDotLe; - Inc(L.bufpos); - end - else - tok.toktype := tkParLe; - end; - ')': begin - tok.toktype := tkParRi; - Inc(L.bufpos) - end; - '[': begin - Inc(L.bufpos); - if (L.buf[L.bufPos] = '.') - and (L.buf[L.bufPos+1] <> '.') then begin - tok.toktype := tkBracketDotLe; - Inc(L.bufpos); - end - else - tok.toktype := tkBracketLe; - end; - ']': begin - tok.toktype := tkBracketRi; - Inc(L.bufpos) - end; - '.': begin - if L.buf[L.bufPos+1] = ']' then begin - tok.tokType := tkBracketDotRi; - Inc(L.bufpos, 2); - end - else if L.buf[L.bufPos+1] = '}' then begin - tok.tokType := tkCurlyDotRi; - Inc(L.bufpos, 2); - end - else if L.buf[L.bufPos+1] = ')' then begin - tok.tokType := tkParDotRi; - Inc(L.bufpos, 2); - end - else - getOperator(L, tok) - end; - '{': begin - Inc(L.bufpos); - if (L.buf[L.bufPos] = '.') - and (L.buf[L.bufPos+1] <> '.') then begin - tok.toktype := tkCurlyDotLe; - Inc(L.bufpos); - end - else - tok.toktype := tkCurlyLe; - end; - '}': begin - tok.toktype := tkCurlyRi; - Inc(L.bufpos) - end; - ';': begin - tok.toktype := tkSemiColon; - Inc(L.bufpos) - end; - '`': begin - tok.tokType := tkAccent; - Inc(L.bufpos); - end; - '"': getString(L, tok, false); - '''': begin - getCharacter(L, tok); - tok.tokType := tkCharLit; - end; - lexbase.EndOfFile: tok.toktype := tkEof; - else if c in OpChars then - getOperator(L, tok) - else begin - tok.literal := c + ''; - tok.tokType := tkInvalid; - lexMessage(L, errInvalidToken, c +{&} ' (\' +{&} toString(ord(c)) + ')'); - Inc(L.bufpos); - end - end - end -end; - -initialization - dummyIdent := getIdent(''); -end. diff --git a/nim/sem.pas b/nim/sem.pas deleted file mode 100755 index a5d28d734..000000000 --- a/nim/sem.pas +++ /dev/null @@ -1,280 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit sem; - -// This module implements the semantic checking pass. - -interface - -{$include 'config.inc'} - -uses - sysutils, nsystem, charsets, strutils, nhashes, - lists, options, scanner, ast, astalgo, trees, treetab, wordrecg, - 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; - -function semPass(): TPass; - -implementation - -function considerAcc(n: PNode): PIdent; -var - x: PNode; -begin - x := n; - if x.kind = nkAccQuoted then x := x.sons[0]; - case x.kind of - nkIdent: result := x.ident; - nkSym: result := x.sym.name; - else begin - liMessage(n.info, errIdentifierExpected, renderTree(n)); - result := nil - end - end -end; - -function isTopLevel(c: PContext): bool; -begin - result := c.tab.tos <= 2 -end; - -function newSymS(const kind: TSymKind; n: PNode; c: PContext): PSym; -begin - result := newSym(kind, considerAcc(n), getCurrOwner()); - result.info := n.info; -end; - -procedure markUsed(n: PNode; s: PSym); -begin - include(s.flags, sfUsed); - if sfDeprecated in s.flags then liMessage(n.info, warnDeprecated, s.name.s); -end; - -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 semStmtScope(c: PContext; n: PNode): PNode; forward; - -type - TExprFlag = (efAllowType, efLValue, efWantIterator); - TExprFlags = set of TExprFlag; - -function semExpr(c: PContext; n: PNode; - flags: TExprFlags = {@set}[]): PNode; forward; -function semExprWithType(c: PContext; n: PNode; - flags: TExprFlags = {@set}[]): PNode; forward; -function fitNode(c: PContext; formal: PType; arg: PNode): 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; -procedure semParamList(c: PContext; n, genericParams: 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 instGenericContainer(c: PContext; n: PNode; header: PType): PType; forward; - -function semConstExpr(c: PContext; n: PNode): PNode; -begin - result := semExprWithType(c, n); - if result = nil then begin - liMessage(n.info, errConstExprExpected); - exit - end; - result := getConstExpr(c.module, result); - if result = nil then - liMessage(n.info, errConstExprExpected); -end; - -function semAndEvalConstExpr(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)); - result := evalConstExpr(c.module, e); - if (result = nil) or (result.kind = nkEmpty) then - liMessage(n.info, errConstExprExpected); - end -end; - -function semAfterMacroCall(c: PContext; n: PNode; s: PSym): PNode; -begin - result := n; - case s.typ.sons[0].kind of - tyExpr: result := semExprWithType(c, result); - tyStmt: result := semStmt(c, result); - tyTypeDesc: result.typ := semTypeNode(c, result, nil); - else liMessage(s.info, errInvalidParamKindX, typeToString(s.typ.sons[0])) - end -end; - -{$include 'semtempl.pas'} - -function semMacroExpr(c: PContext; n: PNode; sym: PSym; - semCheck: bool = true): PNode; -var - p: PEvalContext; - s: PStackFrame; -begin - inc(evalTemplateCounter); - if evalTemplateCounter > 100 then - liMessage(n.info, errTemplateInstantiationTooNested); - markUsed(n, sym); - p := newEvalContext(c.module, '', false); - 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); - if semCheck then - result := semAfterMacroCall(c, result, sym); - dec(evalTemplateCounter); -end; - -{$include 'seminst.pas'} -{$include 'sigmatch.pas'} - -procedure CheckBool(t: PNode); -begin - if (t.Typ = nil) or (skipTypes(t.Typ, {@set}[tyGenericInst, - tyVar, tyOrdinal]).kind <> tyBool) then - liMessage(t.Info, errExprMustBeBool); -end; - -procedure typeMismatch(n: PNode; formal, actual: PType); -begin - liMessage(n.Info, errGenerated, - msgKindToString(errTypeMismatch) +{&} typeToString(actual) +{&} ') ' - +{&} format(msgKindToString(errButExpectedX), [typeToString(formal)])); -end; - -{$include 'semtypes.pas'} -{$include 'semexprs.pas'} -{$include 'semgnrc.pas'} -{$include 'semstmts.pas'} - -procedure addCodeForGenerics(c: PContext; n: PNode); -var - i: int; - prc: PSym; - it: PNode; -begin - for i := c.lastGenericIdx to sonsLen(c.generics)-1 do begin - it := c.generics.sons[i].sons[1]; - if it.kind <> nkSym then InternalError('addCodeForGenerics'); - prc := it.sym; - if (prc.kind in [skProc, skMethod, skConverter]) - and (prc.magic = mNone) then begin - if (prc.ast = nil) or (prc.ast.sons[codePos] = nil) then - InternalError(prc.info, 'no code for ' + prc.name.s); - addSon(n, prc.ast); - end - end; - c.lastGenericIdx := sonsLen(c.generics); -end; - -function myOpen(module: PSym; const filename: string): PPassContext; -var - c: PContext; -begin - c := newContext(module, filename); - if (c.p <> nil) then InternalError(module.info, 'sem.myOpen'); - c.semConstExpr := semConstExpr; - c.p := newProcCon(module); - 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; - 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; - a: PNode; -begin - result := nil; - c := PContext(context); - result := semStmt(c, n); - // BUGFIX: process newly generated generics here, not at the end! - if sonsLen(c.generics) > 0 then begin - a := newNodeI(nkStmtList, n.info); - addCodeForGenerics(c, a); - if sonsLen(a) > 0 then begin - // a generic has been added to `a`: - addSonIfNotNil(a, result); - result := a - end - end -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 InternalError(n.info, 'n is not nil'); - //result := n; - addCodeForGenerics(c, result); - popOwner(); - c.p := nil; -end; - -function semPass(): TPass; -begin - initPass(result); - result.open := myOpen; - result.openCached := myOpenCached; - result.close := myClose; - result.process := myProcess; -end; - -end. diff --git a/nim/semdata.pas b/nim/semdata.pas deleted file mode 100755 index 37934f3d6..000000000 --- a/nim/semdata.pas +++ /dev/null @@ -1,266 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit semdata; - -// This module contains the data structures for the semantic checking phase. - -interface - -{$include 'config.inc'} - -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, passes, - rodread; - -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; - - PContext = ^TContext; - TContext = object(TPassContext) // a context represents a module - module: PSym; // the module sym belonging to the context - p: PProcCon; // procedure context - InstCounter: int; // to prevent endless instantiations - generics: PNode; // a list of the things to compile; list of - // nkExprEqExpr nodes which contain the - // generic symbol and the instantiated symbol - lastGenericIdx: int; // used for the generics stack - tab: TSymTab; // each module has its own symbol table - AmbiguousSymbols: TIntSet; // ids of all ambiguous symbols (cannot - // store this info in the syms themselves!) - converters: TSymSeq; // sequence of converters - optionStack: TLinkedList; - libs: TLinkedList; // all libs used by this module - fromCache: bool; // is the module read from a cache? - semConstExpr: function (c: PContext; n: PNode): PNode; - // for the pragmas module - includedFiles: TIntSet; // used to detect recursive include files - filename: string; // the module's filename - end; - -var - gInstTypes: TIdTable; // map PType to PType - -function newContext(module: PSym; const nimfile: string): PContext; -function newProcCon(owner: PSym): PProcCon; - -function lastOptionEntry(c: PContext): POptionEntry; -function newOptionEntry(): POptionEntry; - -procedure addConverter(c: PContext; conv: PSym); - -function newLib(kind: TLibKind): PLib; -procedure addToLib(lib: PLib; sym: PSym); - -function makePtrType(c: PContext; baseType: PType): PType; -function makeVarType(c: PContext; baseType: PType): PType; - -function newTypeS(const kind: TTypeKind; c: PContext): PType; -procedure fillTypeS(dest: PType; const kind: TTypeKind; c: PContext); -function makeRangeType(c: PContext; first, last: biggestInt; - const info: TLineInfo): PType; - -procedure illFormedAst(n: PNode); -function getSon(n: PNode; indx: int): PNode; -procedure checkSonsLen(n: PNode; len: int); -procedure checkMinSonsLen(n: PNode; len: int); - -// 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; - -function lastOptionEntry(c: PContext): POptionEntry; -begin - result := POptionEntry(c.optionStack.tail); -end; - -function newProcCon(owner: PSym): PProcCon; -begin - if owner = nil then InternalError('owner is nil'); - 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(module: PSym; const nimfile: string): PContext; -begin - new(result); -{@ignore} - fillChar(result^, sizeof(result^), 0); -{@emit} - InitSymTab(result.tab); - IntSetInit(result.AmbiguousSymbols); - initLinkedList(result.optionStack); - initLinkedList(result.libs); - append(result.optionStack, newOptionEntry()); - result.module := module; - result.generics := newNode(nkStmtList); -{@emit result.converters := @[];} - result.filename := nimfile; - IntSetInit(result.includedFiles); -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; - - -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); - if sym.annex <> nil then liMessage(sym.info, errInvalidPragma); - sym.annex := lib -end; - -function makePtrType(c: PContext; baseType: PType): PType; -begin - if (baseType = nil) then InternalError('makePtrType'); - result := newTypeS(tyPtr, c); - addSon(result, baseType); -end; - -function makeVarType(c: PContext; baseType: PType): PType; -begin - if (baseType = nil) then InternalError('makeVarType'); - result := newTypeS(tyVar, c); - addSon(result, baseType); -end; - -function newTypeS(const kind: TTypeKind; c: PContext): PType; -begin - result := newType(kind, getCurrOwner()) -end; - -procedure fillTypeS(dest: PType; const kind: TTypeKind; c: PContext); -begin - dest.kind := kind; - dest.owner := getCurrOwner(); - dest.size := -1; -end; - -function makeRangeType(c: PContext; first, last: biggestInt; - const info: TLineInfo): PType; -var - n: PNode; -begin - n := newNodeI(nkRange, info); - 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; - -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; - -initialization - initIdTable(gInstTypes); -end. diff --git a/nim/semexprs.pas b/nim/semexprs.pas deleted file mode 100755 index 2d1d0a957..000000000 --- a/nim/semexprs.pas +++ /dev/null @@ -1,1426 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - - -// this module does the semantic checking for expressions - -function semTemplateExpr(c: PContext; n: PNode; s: PSym; - semCheck: bool = true): PNode; -begin - markUsed(n, s); - pushInfoContext(n.info); - result := evalTemplate(c, n, s); - if semCheck then - result := semAfterMacroCall(c, result, s); - popInfoContext(); -end; - -function semDotExpr(c: PContext; n: PNode; - flags: TExprFlags = {@set}[]): PNode; forward; - -function semExprWithType(c: PContext; n: PNode; - flags: TExprFlags = {@set}[]): PNode; -var - d: PNode; -begin - result := semExpr(c, n, flags); - 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 - d := newNodeIT(nkHiddenDeref, result.info, result.typ.sons[0]); - addSon(d, result); - result := d - end -end; - -procedure checkConversionBetweenObjects(const info: TLineInfo; - castDest, src: PType); -var - diff: int; -begin - diff := inheritanceDiff(castDest, src); - if diff = high(int) then - liMessage(info, errGenerated, - format(MsgKindToString(errIllegalConvFromXtoY), - [typeToString(src), typeToString(castDest)])); -end; - -procedure checkConvertible(const info: TLineInfo; castDest, src: PType); -const - IntegralTypes = [tyBool, tyEnum, tyChar, tyInt..tyFloat128]; -var - d, s: PType; -begin - if sameType(castDest, src) then begin - // don't annoy conversions that may be needed on another processor: - if not (castDest.kind in [tyInt..tyFloat128, tyNil]) then - liMessage(info, hintConvFromXtoItselfNotNeeded, typeToString(castDest)); - exit - end; - - // common case first (converting of objects) - d := skipTypes(castDest, abstractVar); - s := skipTypes(src, abstractVar); - while (d <> nil) and (d.Kind in [tyPtr, tyRef]) - and (d.Kind = s.Kind) do begin - d := base(d); - s := base(s); - end; - if d = nil then - liMessage(info, errGenerated, - format(msgKindToString(errIllegalConvFromXtoY), - [typeToString(src), typeToString(castDest)])); - if (d.Kind = tyObject) and (s.Kind = tyObject) then - checkConversionBetweenObjects(info, d, s) - else if (skipTypes(castDest, abstractVarRange).Kind in IntegralTypes) - and (skipTypes(src, abstractVarRange).Kind in IntegralTypes) then begin - // accept conversion between intregral types - end - else begin - // we use d, s here to speed up that operation a bit: - case cmpTypes(d, s) of - isNone, isGeneric: begin - if not equalOrDistinctOf(castDest, src) and - not equalOrDistinctOf(src, castDest) then - liMessage(info, errGenerated, - format(MsgKindToString(errIllegalConvFromXtoY), - [typeToString(src), typeToString(castDest)])); - end - else begin end - end - end -end; - -function isCastable(dst, src: PType): Boolean; -//const -// castableTypeKinds = {@set}[tyInt, tyPtr, tyRef, tyCstring, tyString, -// tySequence, tyPointer, tyNil, tyOpenArray, -// tyProc, tySet, tyEnum, tyBool, tyChar]; -var - ds, ss: biggestInt; -begin - // this is very unrestrictive; cast is allowed if castDest.size >= src.size - ds := computeSize(dst); - ss := computeSize(src); - if ds < 0 then result := false - else if ss < 0 then result := false - else - result := (ds >= ss) or - (skipTypes(dst, abstractInst).kind in [tyInt..tyFloat128]) or - (skipTypes(src, abstractInst).kind in [tyInt..tyFloat128]) -end; - -function semConv(c: PContext; n: PNode; s: PSym): PNode; -var - op: PNode; - i: int; -begin - if sonsLen(n) <> 2 then liMessage(n.info, errConvNeedsOneArg); - result := newNodeI(nkConv, n.info); - result.typ := semTypeNode(c, n.sons[0], nil); - addSon(result, copyTree(n.sons[0])); - addSon(result, semExprWithType(c, n.sons[1])); - op := result.sons[1]; - if op.kind <> nkSymChoice then - checkConvertible(result.info, result.typ, op.typ) - else begin - for i := 0 to sonsLen(op)-1 do begin - if sameType(result.typ, op.sons[i].typ) then begin - markUsed(n, op.sons[i].sym); - result := op.sons[i]; exit - end - end; - liMessage(n.info, errUseQualifier, op.sons[0].sym.name.s); - end -end; - -function semCast(c: PContext; n: PNode): PNode; -begin - if optSafeCode in gGlobalOptions then liMessage(n.info, errCastNotInSafeMode); - include(c.p.owner.flags, sfSideEffect); - checkSonsLen(n, 2); - result := newNodeI(nkCast, n.info); - result.typ := semTypeNode(c, n.sons[0], nil); - addSon(result, copyTree(n.sons[0])); - addSon(result, semExprWithType(c, n.sons[1])); - if not isCastable(result.typ, result.sons[1].Typ) then - liMessage(result.info, errExprCannotBeCastedToX, typeToString(result.Typ)); -end; - -function semLowHigh(c: PContext; n: PNode; m: TMagic): PNode; -const - opToStr: array [mLow..mHigh] of string = ('low', 'high'); -var - typ: PType; -begin - if sonsLen(n) <> 2 then - liMessage(n.info, errXExpectsTypeOrValue, opToStr[m]) - else begin - n.sons[1] := semExprWithType(c, n.sons[1], {@set}[efAllowType]); - typ := skipTypes(n.sons[1].typ, abstractVarRange); - case typ.Kind of - tySequence, tyString, tyOpenArray: begin - n.typ := getSysType(tyInt); - end; - tyArrayConstr, tyArray: begin - n.typ := n.sons[1].typ.sons[0]; // indextype - end; - tyInt..tyInt64, tyChar, tyBool, tyEnum: begin - n.typ := n.sons[1].typ; - end - else - liMessage(n.info, errInvalidArgForX, opToStr[m]) - end - end; - result := n; -end; - -function semSizeof(c: PContext; n: PNode): PNode; -begin - if sonsLen(n) <> 2 then - liMessage(n.info, errXExpectsTypeOrValue, 'sizeof') - else - n.sons[1] := semExprWithType(c, n.sons[1], {@set}[efAllowType]); - n.typ := getSysType(tyInt); - result := n -end; - -function semIs(c: PContext; n: PNode): PNode; -var - a, b: PType; -begin - if sonsLen(n) = 3 then begin - n.sons[1] := semExprWithType(c, n.sons[1], {@set}[efAllowType]); - n.sons[2] := semExprWithType(c, n.sons[2], {@set}[efAllowType]); - a := n.sons[1].typ; - b := n.sons[2].typ; - if (b.kind <> tyObject) or (a.kind <> tyObject) then - liMessage(n.info, errIsExpectsObjectTypes); - 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); - result := n; -end; - -procedure semOpAux(c: PContext; n: PNode); -var - i: int; - a: PNode; - info: TLineInfo; -begin - for i := 1 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkExprEqExpr then begin - checkSonsLen(a, 2); - info := a.sons[0].info; - a.sons[0] := newIdentNode(considerAcc(a.sons[0]), info); - a.sons[1] := semExprWithType(c, a.sons[1]); - a.typ := a.sons[1].typ; - end - else - n.sons[i] := semExprWithType(c, a); - end -end; - -function overloadedCallOpr(c: PContext; n: PNode): PNode; -var - par: PIdent; - i: int; -begin - // quick check if there is *any* () operator overloaded: - par := getIdent('()'); - if SymtabGet(c.Tab, par) = nil then begin - result := nil - end - else begin - result := newNodeI(nkCall, n.info); - addSon(result, newIdentNode(par, n.info)); - for i := 0 to sonsLen(n)-1 do addSon(result, n.sons[i]); - result := semExpr(c, result) - end -end; - -procedure changeType(n: PNode; newType: PType); -var - i: int; - f: PSym; - a, m: PNode; -begin - case n.kind of - nkCurly, nkBracket: begin - for i := 0 to sonsLen(n)-1 do changeType(n.sons[i], elemType(newType)); - end; - nkPar: begin - if newType.kind <> tyTuple then - InternalError(n.info, 'changeType: no tuple type for constructor'); - if newType.n = nil then - InternalError(n.info, 'changeType: no tuple fields'); - if (sonsLen(n) > 0) and (n.sons[0].kind = nkExprColonExpr) then begin - for i := 0 to sonsLen(n)-1 do begin - m := n.sons[i].sons[0]; - if m.kind <> nkSym then - internalError(m.info, 'changeType(): invalid tuple constr'); - f := getSymFromList(newType.n, m.sym.name); - if f = nil then - internalError(m.info, 'changeType(): invalid identifier'); - changeType(n.sons[i].sons[1], f.typ); - end - end - else begin - for i := 0 to sonsLen(n)-1 do begin - m := n.sons[i]; - a := newNodeIT(nkExprColonExpr, m.info, newType.sons[i]); - addSon(a, newSymNode(newType.n.sons[i].sym)); - addSon(a, m); - changeType(m, newType.sons[i]); - n.sons[i] := a; - end; - end - end; - else begin end - end; - n.typ := newType; -end; - -function semArrayConstr(c: PContext; n: PNode): PNode; -var - typ: PType; - i: int; -begin - result := newNodeI(nkBracket, n.info); - result.typ := newTypeS(tyArrayConstr, c); - addSon(result.typ, nil); // index type - if sonsLen(n) = 0 then - addSon(result.typ, newTypeS(tyEmpty, c)) // needs an empty basetype! - else begin - addSon(result, semExprWithType(c, n.sons[0])); - typ := skipTypes(result.sons[0].typ, - {@set}[tyGenericInst, tyVar, tyOrdinal]); - for i := 1 to sonsLen(n)-1 do begin - n.sons[i] := semExprWithType(c, n.sons[i]); - addSon(result, fitNode(c, typ, n.sons[i])); - end; - addSon(result.typ, typ) - end; - result.typ.sons[0] := makeRangeType(c, 0, sonsLen(result)-1, n.info); -end; - -const - ConstAbstractTypes = {@set}[tyNil, tyChar, tyInt..tyInt64, - tyFloat..tyFloat128, - tyArrayConstr, tyTuple, tySet]; - -procedure fixAbstractType(c: PContext; n: PNode); -var - i: int; - s: PType; - it: PNode; -begin - for i := 1 to sonsLen(n)-1 do begin - it := n.sons[i]; - case it.kind of - nkHiddenStdConv, nkHiddenSubConv: begin - if it.sons[1].kind = nkBracket then - it.sons[1] := semArrayConstr(c, it.sons[1]); - if skipTypes(it.typ, abstractVar).kind = tyOpenArray then begin - s := skipTypes(it.sons[1].typ, abstractVar); - if (s.kind = tyArrayConstr) and (s.sons[1].kind = tyEmpty) then begin - s := copyType(s, getCurrOwner(), false); - skipTypes(s, abstractVar).sons[1] := elemType( - skipTypes(it.typ, abstractVar)); - it.sons[1].typ := s; - end - end - else if skipTypes(it.sons[1].typ, abstractVar).kind in - [tyNil, tyArrayConstr, tyTuple, tySet] then begin - s := skipTypes(it.typ, abstractVar); - changeType(it.sons[1], s); - n.sons[i] := it.sons[1]; - end - end; - nkBracket: begin - // an implicitely constructed array (passed to an open array): - n.sons[i] := semArrayConstr(c, it); - end; - else if (it.typ = nil) then - InternalError(it.info, 'fixAbstractType: ' + renderTree(it)); - end - end -end; - -function skipObjConv(n: PNode): PNode; -begin - case n.kind of - nkHiddenStdConv, nkHiddenSubConv, nkConv: begin - if skipTypes(n.sons[1].typ, abstractPtrs).kind in [tyTuple, tyObject] then - result := n.sons[1] - else - result := n - end; - nkObjUpConv, nkObjDownConv: result := n.sons[0]; - else result := n - end -end; - -type - TAssignableResult = ( - arNone, // no l-value and no discriminant - arLValue, // is an l-value - arDiscriminant // is a discriminant - ); - -function isAssignable(n: PNode): TAssignableResult; -begin - result := arNone; - case n.kind of - nkSym: begin - if (n.sym.kind in [skVar, skTemp]) then - result := arLValue - end; - nkDotExpr: begin - checkMinSonsLen(n, 1); - if skipTypes(n.sons[0].typ, abstractInst).kind in [tyVar, tyPtr, tyRef] then - result := arLValue - else - result := isAssignable(n.sons[0]); - if (result = arLValue) and (sfDiscriminant in n.sons[1].sym.flags) then - result := arDiscriminant - end; - nkBracketExpr: begin - checkMinSonsLen(n, 1); - if skipTypes(n.sons[0].typ, abstractInst).kind in [tyVar, tyPtr, tyRef] then - result := arLValue - else - result := isAssignable(n.sons[0]); - 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 skipTypes(n.typ, abstractPtrs).kind in [tyOpenArray, tyTuple, tyObject] then - result := isAssignable(n.sons[1]) - end; - nkHiddenDeref, nkDerefExpr: result := arLValue; - nkObjUpConv, nkObjDownConv, nkCheckedFieldExpr: - result := isAssignable(n.sons[0]); - else begin end - end; -end; - -function newHiddenAddrTaken(c: PContext; n: PNode): PNode; -begin - if n.kind = nkHiddenDeref then begin - checkSonsLen(n, 1); - result := n.sons[0] - end - else begin - result := newNodeIT(nkHiddenAddr, n.info, makeVarType(c, n.typ)); - addSon(result, n); - if isAssignable(n) <> arLValue then begin - liMessage(n.info, errVarForOutParamNeeded); - end - end -end; - -function analyseIfAddressTaken(c: PContext; n: PNode): PNode; -begin - result := n; - case n.kind of - nkSym: begin - if skipTypes(n.sym.typ, abstractInst).kind <> tyVar then begin - include(n.sym.flags, sfAddrTaken); - result := newHiddenAddrTaken(c, n); - end - end; - nkDotExpr: begin - checkSonsLen(n, 2); - if n.sons[1].kind <> nkSym then - internalError(n.info, 'analyseIfAddressTaken'); - if skipTypes(n.sons[1].sym.typ, abstractInst).kind <> tyVar then begin - include(n.sons[1].sym.flags, sfAddrTaken); - result := newHiddenAddrTaken(c, n); - end - end; - nkBracketExpr: begin - checkMinSonsLen(n, 1); - if skipTypes(n.sons[0].typ, abstractInst).kind <> tyVar then begin - if n.sons[0].kind = nkSym then - include(n.sons[0].sym.flags, sfAddrTaken); - result := newHiddenAddrTaken(c, n); - end - end; - else result := newHiddenAddrTaken(c, n); // BUGFIX! - end -end; - -procedure analyseIfAddressTakenInCall(c: PContext; n: PNode); -const - FakeVarParams = {@set}[mNew, mNewFinalize, mInc, ast.mDec, mIncl, - mExcl, mSetLengthStr, mSetLengthSeq, - mAppendStrCh, mAppendStrStr, mSwap, - mAppendSeqElem, mNewSeq]; -var - i: int; - t: PType; -begin - checkMinSonsLen(n, 1); - t := n.sons[0].typ; - if (n.sons[0].kind = nkSym) - and (n.sons[0].sym.magic in FakeVarParams) then exit; - for i := 1 to sonsLen(n)-1 do - if (i < sonsLen(t)) and (skipTypes(t.sons[i], abstractInst).kind = tyVar) then - n.sons[i] := analyseIfAddressTaken(c, n.sons[i]); -end; - -function semDirectCallAnalyseEffects(c: PContext; n: PNode; - flags: TExprFlags): PNode; -var - callee: PSym; -begin - if not (efWantIterator in flags) then - result := semDirectCall(c, n, {@set}[skProc, skMethod, skConverter]) - else - result := semDirectCall(c, n, {@set}[skIterator]); - if result <> nil then begin - if result.sons[0].kind <> nkSym then - InternalError('semDirectCallAnalyseEffects'); - callee := result.sons[0].sym; - if (callee.kind = skIterator) and (callee.id = c.p.owner.id) then - liMessage(n.info, errRecursiveDependencyX, callee.name.s); - if not (sfNoSideEffect in callee.flags) then - if (sfForward in callee.flags) - or ([sfImportc, sfSideEffect] * callee.flags <> []) then - include(c.p.owner.flags, sfSideEffect); - end -end; - -function semIndirectOp(c: PContext; n: PNode; flags: TExprFlags): PNode; -var - m: TCandidate; - msg: string; - i: int; - prc: PNode; - t: PType; -begin - result := nil; - prc := n.sons[0]; - checkMinSonsLen(n, 1); - if n.sons[0].kind = nkDotExpr then begin - checkSonsLen(n.sons[0], 2); - n.sons[0] := semDotExpr(c, n.sons[0]); - if n.sons[0].kind = nkDotCall then begin // it is a static call! - result := n.sons[0]; - result.kind := nkCall; - for i := 1 to sonsLen(n)-1 do addSon(result, n.sons[i]); - result := semExpr(c, result, flags); - exit - end - end - else - n.sons[0] := semExpr(c, n.sons[0]); - semOpAux(c, n); - if (n.sons[0].typ <> nil) then t := skipTypes(n.sons[0].typ, abstractInst) - else t := nil; - if (t <> nil) and (t.kind = tyProc) then begin - initCandidate(m, t); - matches(c, n, m); - if m.state <> csMatch then begin - msg := msgKindToString(errTypeMismatch); - for i := 1 to sonsLen(n)-1 do begin - if i > 1 then add(msg, ', '); - add(msg, typeToString(n.sons[i].typ)); - end; - add(msg, ')' +{&} nl +{&} msgKindToString(errButExpected) +{&} - nl +{&} typeToString(n.sons[0].typ)); - liMessage(n.Info, errGenerated, msg); - result := nil - end - else - result := m.call; - // we assume that a procedure that calls something indirectly - // has side-effects: - if not (tfNoSideEffect in t.flags) then - include(c.p.owner.flags, sfSideEffect); - end - else begin - result := overloadedCallOpr(c, n); - // Now that nkSym does not imply an iteration over the proc/iterator space, - // the old ``prc`` (which is likely an nkIdent) has to be restored: - if result = nil then begin - n.sons[0] := prc; - result := semDirectCallAnalyseEffects(c, n, flags); - end; - if result = nil then - liMessage(n.info, errExprXCannotBeCalled, - renderTree(n, {@set}[renderNoComments])); - end; - fixAbstractType(c, result); - analyseIfAddressTakenInCall(c, result); -end; - -function semDirectOp(c: PContext; n: PNode; flags: TExprFlags): PNode; -begin - // this seems to be a hotspot in the compiler! - semOpAux(c, n); - result := semDirectCallAnalyseEffects(c, n, flags); - if result = nil then begin - result := overloadedCallOpr(c, n); - if result = nil then - liMessage(n.Info, errGenerated, getNotFoundError(c, n)) - end; - fixAbstractType(c, result); - analyseIfAddressTakenInCall(c, result); -end; - -function semEcho(c: PContext; n: PNode): PNode; -var - i: int; - call, arg: PNode; -begin - // this really is a macro - checkMinSonsLen(n, 1); - for i := 1 to sonsLen(n)-1 do begin - arg := semExprWithType(c, n.sons[i]); - call := newNodeI(nkCall, arg.info); - addSon(call, newIdentNode(getIdent('$'+''), n.info)); - addSon(call, arg); - n.sons[i] := semExpr(c, call); - end; - result := n; -end; - -function LookUpForDefined(c: PContext; n: PNode; onlyCurrentScope: bool): PSym; -var - m: PSym; - ident: PIdent; -begin - case n.kind of - nkIdent: begin - if onlyCurrentScope then - result := SymtabLocalGet(c.tab, n.ident) - else - result := SymtabGet(c.Tab, n.ident); // no need for stub loading - end; - nkDotExpr: begin - result := nil; - if onlyCurrentScope then exit; - checkSonsLen(n, 2); - m := LookupForDefined(c, n.sons[0], onlyCurrentScope); - 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); - end - else - liMessage(n.sons[1].info, errIdentifierExpected, ''); - end - end; - nkAccQuoted: begin - checkSonsLen(n, 1); - result := lookupForDefined(c, n.sons[0], onlyCurrentScope); - end - else begin - liMessage(n.info, errIdentifierExpected, renderTree(n)); - result := nil; - end - end -end; - -function semDefined(c: PContext; n: PNode; onlyCurrentScope: bool): PNode; -begin - checkSonsLen(n, 2); - result := newIntNode(nkIntLit, 0); - // we replace this node by a 'true' or 'false' node - if LookUpForDefined(c, n.sons[1], onlyCurrentScope) <> nil then - result.intVal := 1 - else if not onlyCurrentScope and (n.sons[1].kind = nkIdent) - and condsyms.isDefined(n.sons[1].ident) then - result.intVal := 1; - result.info := n.info; - result.typ := getSysType(tyBool); -end; - -function setMs(n: PNode; s: PSym): PNode; -begin - result := n; - n.sons[0] := newSymNode(s); - n.sons[0].info := n.info; -end; - -function semMagic(c: PContext; n: PNode; s: PSym; flags: TExprFlags): PNode; -// this is a hotspot in the compiler! -begin - result := n; - case s.magic of // magics that need special treatment - mDefined: result := semDefined(c, setMs(n, s), false); - mDefinedInScope: result := semDefined(c, setMs(n, s), true); - mLow: result := semLowHigh(c, setMs(n, s), mLow); - mHigh: result := semLowHigh(c, setMs(n, s), mHigh); - mSizeOf: result := semSizeof(c, setMs(n, s)); - mIs: result := semIs(c, setMs(n, s)); - mEcho: result := semEcho(c, setMs(n, s)); - else result := semDirectOp(c, n, flags); - end; -end; - -function isTypeExpr(n: PNode): bool; -begin - case n.kind of - nkType, nkTypeOfExpr: result := true; - nkSym: result := n.sym.kind = skType; - else result := false - end -end; - -function lookupInRecordAndBuildCheck(c: PContext; n, r: PNode; - 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 - i, j: int; - s, it, inExpr, notExpr: PNode; -begin - result := nil; - case r.kind of - nkRecList: begin - for i := 0 to sonsLen(r)-1 do begin - result := lookupInRecordAndBuildCheck(c, n, r.sons[i], field, check); - if result <> nil then exit - end - end; - nkRecCase: begin - checkMinSonsLen(r, 2); - if (r.sons[0].kind <> nkSym) then IllFormedAst(r); - result := lookupInRecordAndBuildCheck(c, n, r.sons[0], field, check); - if result <> nil then exit; - s := newNodeI(nkCurly, r.info); - for i := 1 to sonsLen(r)-1 do begin - it := r.sons[i]; - case it.kind of - nkOfBranch: begin - result := lookupInRecordAndBuildCheck(c, n, lastSon(it), - field, check); - if result = nil then begin - for j := 0 to sonsLen(it)-2 do addSon(s, copyTree(it.sons[j])); - end - else begin - if check = nil then begin - check := newNodeI(nkCheckedFieldExpr, n.info); - addSon(check, nil); // make space for access node - end; - s := newNodeI(nkCurly, n.info); - for j := 0 to sonsLen(it)-2 do addSon(s, copyTree(it.sons[j])); - inExpr := newNodeI(nkCall, n.info); - addSon(inExpr, newIdentNode(getIdent('in'), n.info)); - addSon(inExpr, copyTree(r.sons[0])); - addSon(inExpr, s); - //writeln(output, renderTree(inExpr)); - addSon(check, semExpr(c, inExpr)); - exit - end - end; - nkElse: begin - result := lookupInRecordAndBuildCheck(c, n, lastSon(it), - field, check); - if result <> nil then begin - if check = nil then begin - check := newNodeI(nkCheckedFieldExpr, n.info); - addSon(check, nil); // make space for access node - end; - inExpr := newNodeI(nkCall, n.info); - addSon(inExpr, newIdentNode(getIdent('in'), n.info)); - addSon(inExpr, copyTree(r.sons[0])); - addSon(inExpr, s); - notExpr := newNodeI(nkCall, n.info); - addSon(notExpr, newIdentNode(getIdent('not'), n.info)); - addSon(notExpr, inExpr); - addSon(check, semExpr(c, notExpr)); - exit - end - end; - else - illFormedAst(it); - end - end - end; - nkSym: begin - if r.sym.name.id = field.id then result := r.sym; - end; - else illFormedAst(n); - end -end; - -function makeDeref(n: PNode): PNode; -var - t: PType; - a: PNode; -begin - t := skipTypes(n.typ, {@set}[tyGenericInst]); - result := n; - if t.kind = tyVar then begin - result := newNodeIT(nkHiddenDeref, n.info, t.sons[0]); - addSon(result, n); - t := skipTypes(t.sons[0], {@set}[tyGenericInst]); - end; - if t.kind in [tyPtr, tyRef] then begin - a := result; - result := newNodeIT(nkDerefExpr, n.info, t.sons[0]); - addSon(result, a); - end -end; - -function semFieldAccess(c: PContext; n: PNode; flags: TExprFlags): PNode; -var - f: PSym; - ty: PType; - i: PIdent; - check: PNode; -begin - // this is difficult, because the '.' is used in many different contexts - // in Nimrod. We first allow types in the semantic checking. - checkSonsLen(n, 2); - n.sons[0] := semExprWithType(c, n.sons[0], [efAllowType]+flags); - i := considerAcc(n.sons[1]); - ty := n.sons[0].Typ; - f := nil; - result := nil; - if ty.kind = tyEnum then begin - // look up if the identifier belongs to the enum: - while (ty <> nil) do begin - f := getSymFromList(ty.n, i); - if f <> nil then break; - ty := ty.sons[0]; // enum inheritance - end; - if f <> nil then begin - result := newSymNode(f); - result.info := n.info; - result.typ := ty; - markUsed(n, f); - end - else - liMessage(n.sons[1].info, errEnumHasNoValueX, i.s); - exit; - end - else if not (efAllowType in flags) and isTypeExpr(n.sons[0]) then begin - liMessage(n.sons[0].info, errATypeHasNoValue); - exit - end; - - ty := skipTypes(ty, {@set}[tyGenericInst, tyVar, tyPtr, tyRef]); - if ty.kind = tyObject then begin - while true do begin - check := nil; - f := lookupInRecordAndBuildCheck(c, n, ty.n, i, check); - //f := lookupInRecord(ty.n, i); - if f <> nil then break; - if ty.sons[0] = nil then break; - ty := skipTypes(ty.sons[0], {@set}[tyGenericInst]); - end; - if f <> nil then begin - if ([sfStar, sfMinus] * f.flags <> []) - or (getModule(f).id = c.module.id) then begin - // is the access to a public field or in the same module? - n.sons[0] := makeDeref(n.sons[0]); - n.sons[1] := newSymNode(f); // we now have the correct field - n.typ := f.typ; - markUsed(n, f); - if check = nil then result := n - else begin - check.sons[0] := n; - check.typ := n.typ; - result := check - end; - exit - end - end - end - else if ty.kind = tyTuple then begin - f := getSymFromList(ty.n, i); - if f <> nil then begin - n.sons[0] := makeDeref(n.sons[0]); - n.sons[1] := newSymNode(f); - n.typ := f.typ; - result := n; - markUsed(n, f); - exit - end - end; - // allow things like "".replace(...) - // --> replace("", ...) - f := SymTabGet(c.tab, i); - //if (f <> nil) and (f.kind = skStub) then loadStub(f); - // ``loadStub`` is not correct here as we don't care for ``f`` really - if (f <> nil) then begin - // BUGFIX: do not check for (f.kind in [skProc, skMethod, skIterator]) here - result := newNodeI(nkDotCall, n.info); - // This special node kind is to merge with the call handler in `semExpr`. - addSon(result, newIdentNode(i, n.info)); - addSon(result, copyTree(n.sons[0])); - end - else begin - liMessage(n.Info, errUndeclaredFieldX, i.s); - end -end; - -function whichSliceOpr(n: PNode): string; -begin - if (n.sons[0] = nil) then - if (n.sons[1] = nil) then result := '[..]' - else result := '[..$]' - else if (n.sons[1] = nil) then result := '[$..]' - else result := '[$..$]' -end; - -function semArrayAccess(c: PContext; n: PNode; flags: TExprFlags): PNode; -var - arr, indexType: PType; - i: int; - arg: PNode; - idx: biggestInt; -begin - // check if array type: - checkMinSonsLen(n, 2); - n.sons[0] := semExprWithType(c, n.sons[0], flags-[efAllowType]); - arr := skipTypes(n.sons[0].typ, {@set}[tyGenericInst, tyVar, tyPtr, tyRef]); - case arr.kind of - tyArray, tyOpenArray, tyArrayConstr, tySequence, tyString, - tyCString: begin - n.sons[0] := makeDeref(n.sons[0]); - for i := 1 to sonsLen(n)-1 do - n.sons[i] := semExprWithType(c, n.sons[i], flags-[efAllowType]); - if arr.kind = tyArray then indexType := arr.sons[0] - else indexType := getSysType(tyInt); - arg := IndexTypesMatch(c, indexType, n.sons[1].typ, n.sons[1]); - if arg <> nil then - n.sons[1] := arg - else - liMessage(n.info, errIndexTypesDoNotMatch); - result := n; - result.typ := elemType(arr); - end; - tyTuple: begin - n.sons[0] := makeDeref(n.sons[0]); - // [] operator for tuples requires constant expression - n.sons[1] := semConstExpr(c, n.sons[1]); - if skipTypes(n.sons[1].typ, {@set}[tyGenericInst, tyRange, tyOrdinal]).kind in - [tyInt..tyInt64] then begin - idx := getOrdValue(n.sons[1]); - if (idx >= 0) and (idx < sonsLen(arr)) then - n.typ := arr.sons[int(idx)] - else - liMessage(n.info, errInvalidIndexValueForTuple); - end - else - liMessage(n.info, errIndexTypesDoNotMatch); - result := n; - end - else begin // overloaded [] operator: - result := newNodeI(nkCall, n.info); - if n.sons[1].kind = nkRange then begin - checkSonsLen(n.sons[1], 2); - addSon(result, newIdentNode(getIdent(whichSliceOpr(n.sons[1])), n.info)); - addSon(result, n.sons[0]); - addSonIfNotNil(result, n.sons[1].sons[0]); - addSonIfNotNil(result, n.sons[1].sons[1]); - end - else begin - addSon(result, newIdentNode(getIdent('[]'), n.info)); - addSon(result, n.sons[0]); - addSon(result, n.sons[1]); - end; - result := semExpr(c, result); - end - end -end; - -function semIfExpr(c: PContext; n: PNode): PNode; -var - typ: PType; - i: int; - it: PNode; -begin - result := n; - checkSonsLen(n, 2); - typ := nil; - for i := 0 to sonsLen(n) - 1 do begin - it := n.sons[i]; - case it.kind of - nkElifExpr: begin - checkSonsLen(it, 2); - it.sons[0] := semExprWithType(c, it.sons[0]); - checkBool(it.sons[0]); - it.sons[1] := semExprWithType(c, it.sons[1]); - if typ = nil then typ := it.sons[1].typ - else it.sons[1] := fitNode(c, typ, it.sons[1]) - end; - nkElseExpr: begin - checkSonsLen(it, 1); - it.sons[0] := semExprWithType(c, it.sons[0]); - if (typ = nil) then InternalError(it.info, 'semIfExpr'); - it.sons[0] := fitNode(c, typ, it.sons[0]); - end; - else illFormedAst(n); - end - end; - result.typ := typ; -end; - -function semSetConstr(c: PContext; n: PNode): PNode; -var - typ: PType; - i: int; - m: PNode; -begin - 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; - for i := 0 to sonsLen(n)-1 do begin - if n.sons[i].kind = nkRange then begin - checkSonsLen(n.sons[i], 2); - n.sons[i].sons[0] := semExprWithType(c, n.sons[i].sons[0]); - n.sons[i].sons[1] := semExprWithType(c, n.sons[i].sons[1]); - if typ = nil then - typ := skipTypes(n.sons[i].sons[0].typ, - {@set}[tyGenericInst, tyVar, tyOrdinal]); - n.sons[i].typ := n.sons[i].sons[1].typ; // range node needs type too - end - else begin - n.sons[i] := semExprWithType(c, n.sons[i]); - if typ = nil then - typ := skipTypes(n.sons[i].typ, {@set}[tyGenericInst, tyVar, tyOrdinal]) - end - end; - if not isOrdinalType(typ) then begin - liMessage(n.info, errOrdinalTypeExpected); - exit - end; - if lengthOrd(typ) > MaxSetElements then - 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 := 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 - else begin - m := fitNode(c, typ, n.sons[i]); - end; - addSon(result, m); - end - end -end; - -type - TParKind = (paNone, paSingle, paTupleFields, paTuplePositions); - -function checkPar(n: PNode): TParKind; -var - i, len: int; -begin - len := sonsLen(n); - if len = 0 then result := paTuplePositions // () - else if len = 1 then result := paSingle // (expr) - else begin - if n.sons[0].kind = nkExprColonExpr then result := paTupleFields - else result := paTuplePositions; - for i := 0 to len-1 do begin - if result = paTupleFields then begin - if (n.sons[i].kind <> nkExprColonExpr) - or not (n.sons[i].sons[0].kind in [nkSym, nkIdent]) then begin - liMessage(n.sons[i].info, errNamedExprExpected); - result := paNone; exit - end - end - else begin - if n.sons[i].kind = nkExprColonExpr then begin - liMessage(n.sons[i].info, errNamedExprNotAllowed); - result := paNone; exit - end - end - end - end -end; - -function semTupleFieldsConstr(c: PContext; n: PNode): PNode; -var - i: int; - typ: PType; - ids: TIntSet; - id: PIdent; - f: PSym; -begin - result := newNodeI(nkPar, n.info); - typ := newTypeS(tyTuple, c); - 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 not (n.sons[i].sons[0].kind in [nkSym, nkIdent]) then - illFormedAst(n.sons[i]); - 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]); - f := newSymS(skField, n.sons[i].sons[0], c); - f.typ := n.sons[i].sons[1].typ; - addSon(typ, f.typ); - addSon(typ.n, newSymNode(f)); - n.sons[i].sons[0] := newSymNode(f); - addSon(result, n.sons[i]); - end; - result.typ := typ; -end; - -function semTuplePositionsConstr(c: PContext; n: PNode): PNode; -var - i: int; - typ: PType; -begin - result := n; // we don't modify n, but compute the type: - typ := newTypeS(tyTuple, c); - // leave typ.n nil! - for i := 0 to sonsLen(n)-1 do begin - n.sons[i] := semExprWithType(c, n.sons[i]); - addSon(typ, n.sons[i].typ); - end; - result.typ := typ; -end; - -function semStmtListExpr(c: PContext; n: PNode): PNode; -var - len, i: int; -begin - result := n; - 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 - n.sons[len-1] := semExprWithType(c, n.sons[len-1]); - n.typ := n.sons[len-1].typ - end -end; - -function semBlockExpr(c: PContext; n: PNode): PNode; -begin - result := n; - Inc(c.p.nestedBlockCounter); - checkSonsLen(n, 2); - openScope(c.tab); // BUGFIX: label is in the scope of block! - if n.sons[0] <> nil then begin - addDecl(c, newSymS(skLabel, n.sons[0], c)) - end; - n.sons[1] := semStmtListExpr(c, n.sons[1]); - n.typ := n.sons[1].typ; - closeScope(c.tab); - Dec(c.p.nestedBlockCounter); -end; - -function isCallExpr(n: PNode): bool; -begin - result := n.kind in [nkCall, nkInfix, nkPrefix, nkPostfix, nkCommand, - nkCallStrLit]; -end; - -function semMacroStmt(c: PContext; n: PNode; semCheck: bool = true): PNode; -var - s: PSym; - a: PNode; - i: int; -begin - checkMinSonsLen(n, 2); - if isCallExpr(n.sons[0]) then - a := n.sons[0].sons[0] - else - a := n.sons[0]; - s := qualifiedLookup(c, a, false); - if (s <> nil) then begin - case s.kind of - skMacro: result := semMacroExpr(c, n, s, semCheck); - skTemplate: begin - // transform - // nkMacroStmt(nkCall(a...), stmt, b...) - // to - // nkCall(a..., stmt, b...) - result := newNodeI(nkCall, n.info); - addSon(result, a); - if isCallExpr(n.sons[0]) then begin - for i := 1 to sonsLen(n.sons[0])-1 do - addSon(result, n.sons[0].sons[i]); - end; - for i := 1 to sonsLen(n)-1 do addSon(result, n.sons[i]); - result := semTemplateExpr(c, result, s, semCheck); - end; - else - liMessage(n.info, errXisNoMacroOrTemplate, s.name.s); - end - end - else - liMessage(n.info, errInvalidExpressionX, - renderTree(a, {@set}[renderNoComments])); -end; - -function semSym(c: PContext; n: PNode; s: PSym; flags: TExprFlags): PNode; -begin - if (s.kind = skType) and not (efAllowType in flags) then - liMessage(n.info, errATypeHasNoValue); - case s.kind of - skProc, skMethod, skIterator, skConverter: begin - if not (sfProcVar in s.flags) - and (s.typ.callConv = ccDefault) - and (getModule(s).id <> c.module.id) then - liMessage(n.info, warnXisPassedToProcVar, s.name.s); - // XXX change this to errXCannotBePassedToProcVar after version 0.8.2 - // TODO VERSION 0.8.4 - //if (s.magic <> mNone) then - // liMessage(n.info, errInvalidContextForBuiltinX, s.name.s); - result := symChoice(c, n, s); - end; - skConst: begin - (* - Consider:: - const x = [] - proc p(a: openarray[int]) - proc q(a: openarray[char]) - p(x) - q(x) - - It is clear that ``[]`` means two totally different things. Thus, we - copy `x`'s AST into each context, so that the type fixup phase can - deal with two different ``[]``. - *) - markUsed(n, s); - if s.typ.kind in ConstAbstractTypes then begin - result := copyTree(s.ast); - result.info := n.info; - result.typ := s.typ; - end - else begin - result := newSymNode(s); - result.info := n.info; - end - end; - skMacro: result := semMacroExpr(c, n, s); - skTemplate: result := semTemplateExpr(c, n, s); - skVar: begin - markUsed(n, s); - // if a proc accesses a global variable, it is not side effect free - if sfGlobal in s.flags then include(c.p.owner.flags, sfSideEffect); - result := newSymNode(s); - result.info := n.info; - end; - skGenericParam: begin - if s.ast = nil then InternalError(n.info, 'no default for'); - result := semExpr(c, s.ast); - end - else begin - markUsed(n, s); - result := newSymNode(s); - result.info := n.info; - end - end; -end; - -function semDotExpr(c: PContext; n: PNode; flags: TExprFlags): PNode; -var - s: PSym; -begin - s := qualifiedLookup(c, n, true); // check for ambiguity - if s <> nil then - result := semSym(c, n, s, flags) - else - // this is a test comment; please don't touch it - result := semFieldAccess(c, n, flags); -end; - -function semExpr(c: PContext; n: PNode; flags: TExprFlags = {@set}[]): PNode; -var - s: PSym; - t: PType; -begin - result := n; - if n = nil then exit; - if nfSem in n.flags then exit; - case n.kind of - // atoms: - nkIdent: begin - 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);*) - // because of the changed symbol binding, this does not mean that we - // don't have to check the symbol for semantics here again! - result := semSym(c, n, n.sym, flags); - end; - nkEmpty, nkNone: begin end; - nkNilLit: result.typ := getSysType(tyNil); - nkType: begin - if not (efAllowType in flags) then liMessage(n.info, errATypeHasNoValue); - n.typ := semTypeNode(c, n, nil); - end; - nkIntLit: if result.typ = nil then result.typ := getSysType(tyInt); - nkInt8Lit: if result.typ = nil then result.typ := getSysType(tyInt8); - nkInt16Lit: if result.typ = nil then result.typ := getSysType(tyInt16); - nkInt32Lit: if result.typ = nil then result.typ := getSysType(tyInt32); - nkInt64Lit: if result.typ = nil then result.typ := getSysType(tyInt64); - nkFloatLit: if result.typ = nil then result.typ := getSysType(tyFloat); - nkFloat32Lit: if result.typ = nil then result.typ := getSysType(tyFloat32); - nkFloat64Lit: if result.typ = nil then result.typ := getSysType(tyFloat64); - nkStrLit..nkTripleStrLit: - if result.typ = nil then result.typ := getSysType(tyString); - nkCharLit: - if result.typ = nil then result.typ := getSysType(tyChar); - nkDotExpr: begin - result := semDotExpr(c, n, flags); - if result.kind = nkDotCall then begin - result.kind := nkCall; - result := semExpr(c, result, flags) - end; - end; - nkBind: result := semExpr(c, n.sons[0], flags); - nkCall, nkInfix, nkPrefix, nkPostfix, nkCommand, nkCallStrLit: begin - // check if it is an expression macro: - checkMinSonsLen(n, 1); - s := qualifiedLookup(c, n.sons[0], false); - if (s <> nil) then begin - case s.kind of - skMacro: result := semMacroExpr(c, n, s); - skTemplate: result := semTemplateExpr(c, n, s); - skType: begin - if n.kind <> nkCall then - liMessage(n.info, errXisNotCallable, s.name.s); - // XXX does this check make any sense? - result := semConv(c, n, s); - end; - skProc, skMethod, skConverter, skIterator: begin - if s.magic = mNone then result := semDirectOp(c, n, flags) - else result := semMagic(c, n, s, flags); - end; - else begin - //liMessage(n.info, warnUser, renderTree(n)); - result := semIndirectOp(c, n, flags) - end - end - end - else if n.sons[0].kind = nkSymChoice then - result := semDirectOp(c, n, flags) - else - result := semIndirectOp(c, n, flags); - end; - nkMacroStmt: begin - result := semMacroStmt(c, n); - end; - nkBracketExpr: begin - checkMinSonsLen(n, 1); - s := qualifiedLookup(c, n.sons[0], false); - if (s <> nil) - and (s.kind in [skProc, skMethod, skConverter, skIterator]) then begin - // type parameters: partial generic specialization - // XXX: too implement! - internalError(n.info, 'explicit generic instantation not implemented'); - result := partialSpecialization(c, n, s); - end - else begin - result := semArrayAccess(c, n, flags); - end - end; - nkPragmaExpr: begin - // which pragmas are allowed for expressions? `likely`, `unlikely` - internalError(n.info, 'semExpr() to implement'); - // XXX: to implement - end; - nkPar: begin - case checkPar(n) of - paNone: result := nil; - paTuplePositions: result := semTuplePositionsConstr(c, n); - paTupleFields: result := semTupleFieldsConstr(c, n); - paSingle: result := semExpr(c, n.sons[0]); - end; - end; - nkCurly: result := semSetConstr(c, n); - nkBracket: result := semArrayConstr(c, n); - nkLambda: result := semLambda(c, n); - nkDerefExpr: begin - checkSonsLen(n, 1); - n.sons[0] := semExprWithType(c, n.sons[0]); - result := n; - t := skipTypes(n.sons[0].typ, {@set}[tyGenericInst, tyVar]); - case t.kind of - tyRef, tyPtr: n.typ := t.sons[0]; - else liMessage(n.sons[0].info, errCircumNeedsPointer); - end; - result := n; - end; - nkAddr: begin - result := n; - checkSonsLen(n, 1); - n.sons[0] := semExprWithType(c, n.sons[0]); - if isAssignable(n.sons[0]) <> arLValue then - liMessage(n.info, errExprHasNoAddress); - n.typ := makePtrType(c, n.sons[0].typ); - end; - nkHiddenAddr, nkHiddenDeref: begin - checkSonsLen(n, 1); - n.sons[0] := semExpr(c, n.sons[0], flags); - end; - nkCast: result := semCast(c, n); - nkAccQuoted: begin - checkSonsLen(n, 1); - result := semExpr(c, n.sons[0]); - end; - nkIfExpr: result := semIfExpr(c, n); - nkStmtListExpr: result := semStmtListExpr(c, n); - nkBlockExpr: result := semBlockExpr(c, n); - nkHiddenStdConv, nkHiddenSubConv, nkConv, nkHiddenCallConv: - checkSonsLen(n, 2); - nkStringToCString, nkCStringToString, nkPassAsOpenArray, nkObjDownConv, - nkObjUpConv: - checkSonsLen(n, 1); - nkChckRangeF, nkChckRange64, nkChckRange: - checkSonsLen(n, 3); - nkCheckedFieldExpr: - checkMinSonsLen(n, 2); - nkSymChoice: begin - liMessage(n.info, errExprXAmbiguous, - renderTree(n, {@set}[renderNoComments])); - result := nil - end - else begin - //InternalError(n.info, nodeKindToStr[n.kind]); - liMessage(n.info, errInvalidExpressionX, - renderTree(n, {@set}[renderNoComments])); - result := nil - end - end; - include(result.flags, nfSem); -end; diff --git a/nim/semfold.pas b/nim/semfold.pas deleted file mode 100755 index 791f39149..000000000 --- a/nim/semfold.pas +++ /dev/null @@ -1,578 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// 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, c: 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 skipTypes(n.typ, abstractVarRange).kind = tyChar then - result := newIntNode(nkCharLit, intVal) - else - result := newIntNode(nkIntLit, intVal); - result.typ := n.typ; - result.info := n.info; -end; - -function newFloatNodeT(const floatVal: BiggestFloat; n: PNode): PNode; -begin - result := newFloatNode(nkFloatLit, floatVal); - result.typ := n.typ; - result.info := n.info; -end; - -function newStrNodeT(const strVal: string; n: PNode): PNode; -begin - result := newStrNode(nkStrLit, strVal); - result.typ := n.typ; - result.info := n.info; -end; - -function getInt(a: PNode): biggestInt; -begin - case a.kind of - nkIntLit..nkInt64Lit: result := a.intVal; - else begin internalError(a.info, 'getInt'); result := 0 end; - end -end; - -function getFloat(a: PNode): biggestFloat; -begin - case a.kind of - nkFloatLit..nkFloat64Lit: result := a.floatVal; - else begin internalError(a.info, 'getFloat'); result := 0.0 end; - end -end; - -function getStr(a: PNode): string; -begin - case a.kind of - nkStrLit..nkTripleStrLit: result := a.strVal; - else begin internalError(a.info, 'getStr'); result := '' end; - end -end; - -function getStrOrChar(a: PNode): string; -begin - case a.kind of - nkStrLit..nkTripleStrLit: result := a.strVal; - nkCharLit: result := chr(int(a.intVal))+''; - else begin internalError(a.info, 'getStrOrChar'); result := '' end; - end -end; - -function enumValToString(a: PNode): string; -var - n: PNode; - field: PSym; - x: biggestInt; - i: int; -begin - x := getInt(a); - n := skipTypes(a.typ, abstractInst).n; - for i := 0 to sonsLen(n)-1 do begin - if n.sons[i].kind <> nkSym then InternalError(a.info, 'enumValToString'); - field := n.sons[i].sym; - if field.position = x then begin - result := field.name.s; exit - end; - end; - InternalError(a.info, 'no symbol for ordinal value: ' + toString(x)); -end; - -function evalOp(m: TMagic; n, a, b, c: PNode): PNode; -// b and c may be nil -begin - result := nil; - case m of - mOrd: result := newIntNodeT(getOrdValue(a), n); - mChr: result := newIntNodeT(getInt(a), n); - mUnaryMinusI, mUnaryMinusI64: result := newIntNodeT(-getInt(a), n); - mUnaryMinusF64: result := newFloatNodeT(-getFloat(a), n); - mNot: result := newIntNodeT(1 - getInt(a), n); - mCard: result := newIntNodeT(nimsets.cardSet(a), n); - mBitnotI, mBitnotI64: result := newIntNodeT(not getInt(a), n); - - mLengthStr: result := newIntNodeT(length(getStr(a)), n); - mLengthArray: result := newIntNodeT(lengthOrd(a.typ), n); - mLengthSeq, mLengthOpenArray: - result := newIntNodeT(sonsLen(a), n); // BUGFIX - - mUnaryPlusI, mUnaryPlusI64, mUnaryPlusF64: result := a; // throw `+` away - mToFloat, mToBiggestFloat: - result := newFloatNodeT(toFloat(int(getInt(a))), n); - mToInt, mToBiggestInt: result := newIntNodeT(nsystem.toInt(getFloat(a)), n); - mAbsF64: result := newFloatNodeT(abs(getFloat(a)), n); - mAbsI, mAbsI64: begin - if getInt(a) >= 0 then result := a - else result := newIntNodeT(-getInt(a), n); - end; - mZe8ToI, mZe8ToI64, mZe16ToI, mZe16ToI64, mZe32ToI64, mZeIToI64: begin - // byte(-128) = 1...1..1000_0000'64 --> 0...0..1000_0000'64 - result := newIntNodeT(getInt(a) and (shlu(1, getSize(a.typ)*8) - 1), n); - end; - mToU8: result := newIntNodeT(getInt(a) and $ff, n); - mToU16: result := newIntNodeT(getInt(a) and $ffff, n); - mToU32: result := newIntNodeT(getInt(a) and $00000000ffffffff, n); - - mSucc: result := newIntNodeT(getOrdValue(a)+getInt(b), n); - mPred: result := newIntNodeT(getOrdValue(a)-getInt(b), n); - - mAddI, mAddI64: result := newIntNodeT(getInt(a)+getInt(b), n); - mSubI, mSubI64: result := newIntNodeT(getInt(a)-getInt(b), n); - mMulI, mMulI64: result := newIntNodeT(getInt(a)*getInt(b), n); - mMinI, mMinI64: begin - if getInt(a) > getInt(b) then result := newIntNodeT(getInt(b), n) - else result := newIntNodeT(getInt(a), n); - end; - mMaxI, mMaxI64: begin - if getInt(a) > getInt(b) then result := newIntNodeT(getInt(a), n) - else result := newIntNodeT(getInt(b), n); - end; - mShlI, mShlI64: begin - case skipTypes(n.typ, abstractRange).kind of - tyInt8: result := newIntNodeT(int8(getInt(a)) shl int8(getInt(b)), n); - tyInt16: result := newIntNodeT(int16(getInt(a)) shl int16(getInt(b)), n); - tyInt32: result := newIntNodeT(int32(getInt(a)) shl int32(getInt(b)), n); - tyInt64, tyInt: - result := newIntNodeT(shlu(getInt(a), getInt(b)), n); - else InternalError(n.info, 'constant folding for shl'); - end - end; - mShrI, mShrI64: begin - case skipTypes(n.typ, abstractRange).kind of - tyInt8: result := newIntNodeT(int8(getInt(a)) shr int8(getInt(b)), n); - tyInt16: result := newIntNodeT(int16(getInt(a)) shr int16(getInt(b)), n); - tyInt32: result := newIntNodeT(int32(getInt(a)) shr int32(getInt(b)), n); - tyInt64, tyInt: - result := newIntNodeT(shru(getInt(a), getInt(b)), n); - else InternalError(n.info, 'constant folding for shl'); - end - end; - mDivI, mDivI64: result := newIntNodeT(getInt(a) div getInt(b), n); - mModI, mModI64: result := newIntNodeT(getInt(a) mod getInt(b), n); - - mAddF64: result := newFloatNodeT(getFloat(a)+getFloat(b), n); - mSubF64: result := newFloatNodeT(getFloat(a)-getFloat(b), n); - mMulF64: result := newFloatNodeT(getFloat(a)*getFloat(b), n); - mDivF64: begin - if getFloat(b) = 0.0 then begin - if getFloat(a) = 0.0 then - result := newFloatNodeT(NaN, n) - else - result := newFloatNodeT(Inf, n); - end - else - result := newFloatNodeT(getFloat(a)/getFloat(b), n); - end; - mMaxF64: begin - if getFloat(a) > getFloat(b) then result := newFloatNodeT(getFloat(a), n) - else result := newFloatNodeT(getFloat(b), n); - end; - mMinF64: begin - if getFloat(a) > getFloat(b) then result := newFloatNodeT(getFloat(b), n) - else result := newFloatNodeT(getFloat(a), n); - end; - mIsNil: result := newIntNodeT(ord(a.kind = nkNilLit), n); - mLtI, mLtI64, mLtB, mLtEnum, mLtCh: - result := newIntNodeT(ord(getOrdValue(a) < getOrdValue(b)), n); - mLeI, mLeI64, mLeB, mLeEnum, mLeCh: - result := newIntNodeT(ord(getOrdValue(a) <= getOrdValue(b)), n); - mEqI, mEqI64, mEqB, mEqEnum, mEqCh: - result := newIntNodeT(ord(getOrdValue(a) = getOrdValue(b)), n); - // operators for floats - mLtF64: result := newIntNodeT(ord(getFloat(a) < getFloat(b)), n); - mLeF64: result := newIntNodeT(ord(getFloat(a) <= getFloat(b)), n); - mEqF64: result := newIntNodeT(ord(getFloat(a) = getFloat(b)), n); - // operators for strings - mLtStr: result := newIntNodeT(ord(getStr(a) < getStr(b)), n); - mLeStr: result := newIntNodeT(ord(getStr(a) <= getStr(b)), n); - mEqStr: result := newIntNodeT(ord(getStr(a) = getStr(b)), n); - - mLtU, mLtU64: - result := newIntNodeT(ord(ltU(getOrdValue(a), getOrdValue(b))), n); - mLeU, mLeU64: - result := newIntNodeT(ord(leU(getOrdValue(a), getOrdValue(b))), n); - mBitandI, mBitandI64, mAnd: - result := newIntNodeT(getInt(a) and getInt(b), n); - mBitorI, mBitorI64, mOr: - result := newIntNodeT(getInt(a) or getInt(b), n); - mBitxorI, mBitxorI64, mXor: - result := newIntNodeT(getInt(a) xor getInt(b), n); - - mAddU, mAddU64: result := newIntNodeT(addU(getInt(a), getInt(b)), n); - mSubU, mSubU64: result := newIntNodeT(subU(getInt(a), getInt(b)), n); - mMulU, mMulU64: result := newIntNodeT(mulU(getInt(a), getInt(b)), n); - mModU, mModU64: result := newIntNodeT(modU(getInt(a), getInt(b)), n); - mDivU, mDivU64: result := newIntNodeT(divU(getInt(a), getInt(b)), n); - - mLeSet: result := newIntNodeT(Ord(containsSets(a, b)), n); - mEqSet: result := newIntNodeT(Ord(equalSets(a, b)), n); - mLtSet: result := newIntNodeT(Ord(containsSets(a, b) - and not equalSets(a, b)), n); - mMulSet: begin - result := nimsets.intersectSets(a, b); - result.info := n.info; - end; - mPlusSet: begin - result := nimsets.unionSets(a, b); - result.info := n.info; - end; - mMinusSet: begin - result := nimsets.diffSets(a, b); - result.info := n.info; - end; - mSymDiffSet: begin - result := nimsets.symdiffSets(a, b); - result.info := n.info; - end; - mConStrStr: result := newStrNodeT(getStrOrChar(a)+{&}getStrOrChar(b), 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: - result := newStrNodeT(toString(getOrdValue(a)), n); - mBoolToStr: begin - if getOrdValue(a) = 0 then - result := newStrNodeT('false', n) - else - result := newStrNodeT('true', n) - end; - mCopyStr: - result := newStrNodeT(ncopy(getStr(a), int(getOrdValue(b))+strStart), n); - mCopyStrLast: - result := newStrNodeT(ncopy(getStr(a), int(getOrdValue(b))+strStart, - int(getOrdValue(c))+strStart), n); - mFloatToStr: result := newStrNodeT(toStringF(getFloat(a)), n); - mCStrToStr, mCharToStr: result := newStrNodeT(getStrOrChar(a), n); - mStrToStr: result := a; - mEnumToStr: result := newStrNodeT(enumValToString(a), n); - mArrToSeq: begin - result := copyTree(a); - result.typ := n.typ; - end; - mNewString, mExit, mInc, ast.mDec, mEcho, mAssert, mSwap, - mAppendStrCh, mAppendStrStr, mAppendSeqElem, - mSetLengthStr, mSetLengthSeq, mNLen..mNError: begin end; - else InternalError(a.info, 'evalOp(' +{&} magicToStr[m] +{&} ')'); - end -end; - -function getConstIfExpr(c: PSym; n: PNode): PNode; -var - i: int; - it, e: PNode; -begin - result := nil; - for i := 0 to sonsLen(n) - 1 do begin - it := n.sons[i]; - case it.kind of - nkElifExpr: begin - e := getConstExpr(c, it.sons[0]); - if e = nil then begin result := nil; exit end; - if getOrdValue(e) <> 0 then - if result = nil then begin - result := getConstExpr(c, it.sons[1]); - if result = nil then exit - end - end; - nkElseExpr: begin - if result = nil then - result := getConstExpr(c, it.sons[0]); - end; - else internalError(it.info, 'getConstIfExpr()'); - end - end -end; - -function partialAndExpr(c: PSym; n: PNode): PNode; -// partial evaluation -var - a, b: PNode; -begin - result := n; - a := getConstExpr(c, n.sons[1]); - b := getConstExpr(c, n.sons[2]); - if a <> nil then begin - 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 - if getInt(b) = 0 then result := b - else result := n.sons[1] - end -end; - -function partialOrExpr(c: PSym; n: PNode): PNode; -// partial evaluation -var - a, b: PNode; -begin - result := n; - a := getConstExpr(c, n.sons[1]); - b := getConstExpr(c, n.sons[2]); - if a <> nil then begin - 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 - if getInt(b) <> 0 then result := b - else result := n.sons[1] - end -end; - -function leValueConv(a, b: PNode): Boolean; -begin - result := false; - case a.kind of - nkCharLit..nkInt64Lit: - case b.kind of - nkCharLit..nkInt64Lit: result := a.intVal <= b.intVal; - nkFloatLit..nkFloat64Lit: result := a.intVal <= round(b.floatVal); - else InternalError(a.info, 'leValueConv'); - end; - nkFloatLit..nkFloat64Lit: - case b.kind of - nkFloatLit..nkFloat64Lit: result := a.floatVal <= b.floatVal; - nkCharLit..nkInt64Lit: result := a.floatVal <= toFloat(int(b.intVal)); - else InternalError(a.info, 'leValueConv'); - end; - else InternalError(a.info, 'leValueConv'); - end -end; - -function getConstExpr(module: PSym; n: PNode): PNode; -var - s: PSym; - a, b, c: PNode; - i: int; -begin - result := nil; - case n.kind of - nkSym: begin - s := n.sym; - if s.kind = skEnumField then - 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); - mNimrodMajor: result := newIntNodeT(VersionMajor, n); - mNimrodMinor: result := newIntNodeT(VersionMinor, n); - mNimrodPatch: result := newIntNodeT(VersionPatch, n); - mCpuEndian: result := newIntNodeT(ord(CPU[targetCPU].endian), n); - mHostOS: - result := newStrNodeT(toLower(platform.OS[targetOS].name), n); - mHostCPU: - result := newStrNodeT(toLower(platform.CPU[targetCPU].name),n); - mNaN: result := newFloatNodeT(NaN, n); - mInf: result := newFloatNodeT(Inf, n); - mNegInf: result := newFloatNodeT(NegInf, n); - else result := copyTree(s.ast); // BUGFIX - end - end - else if s.kind in [skProc, skMethod] then // BUGFIX - result := n - end; - nkCharLit..nkNilLit: result := copyNode(n); - nkIfExpr: result := getConstIfExpr(module, n); - nkCall, nkCommand, nkCallStrLit: begin - if (n.sons[0].kind <> nkSym) then exit; - s := n.sons[0].sym; - if (s.kind <> skProc) then exit; - try - case s.magic of - mNone: begin - exit - // XXX: if it has no sideEffect, it should be evaluated - end; - mSizeOf: begin - a := n.sons[1]; - if computeSize(a.typ) < 0 then - liMessage(a.info, errCannotEvalXBecauseIncompletelyDefined, - 'sizeof'); - if a.typ.kind in [tyArray, tyObject, tyTuple] then - result := nil // XXX: size computation for complex types - // is still wrong - else - result := newIntNodeT(getSize(a.typ), n); - end; - mLow: result := newIntNodeT(firstOrd(n.sons[1].typ), n); - mHigh: begin - if not (skipTypes(n.sons[1].typ, abstractVar).kind in [tyOpenArray, - tySequence, tyString]) then - result := newIntNodeT(lastOrd( - skipTypes(n.sons[1].typ, abstractVar)), n); - end; - else begin - a := getConstExpr(module, n.sons[1]); - if a = nil then exit; - if sonsLen(n) > 2 then begin - b := getConstExpr(module, n.sons[2]); - if b = nil then exit; - if sonsLen(n) > 3 then begin - c := getConstExpr(module, n.sons[3]); - if c = nil then exit; - end - end - else b := nil; - result := evalOp(s.magic, n, a, b, c); - end - end - except - on EIntOverflow do liMessage(n.info, errOverOrUnderflow); - on EDivByZero do liMessage(n.info, errConstantDivisionByZero); - end - end; - nkAddr: begin - a := getConstExpr(module, n.sons[0]); - if a <> nil then begin - result := n; - n.sons[0] := a - end; - end; - nkBracket: begin - result := copyTree(n); - for i := 0 to sonsLen(n)-1 do begin - 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(module, n.sons[0]); - if a = nil then exit; - b := getConstExpr(module, n.sons[1]); - if b = nil then exit; - result := copyNode(n); - addSon(result, a); - addSon(result, b); - end; - nkCurly: begin - result := copyTree(n); - for i := 0 to sonsLen(n)-1 do begin - 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; - nkPar: begin // tuple constructor - 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(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(module, n.sons[i]); - if a = nil then begin result := nil; exit end; - result.sons[i] := a; - end - end; - include(result.flags, nfAllConst); - end; - nkChckRangeF, nkChckRange64, nkChckRange: begin - 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 - result.typ := n.typ - end - else - liMessage(n.info, errGenerated, - format(msgKindToString(errIllegalConvFromXtoY), - [typeToString(n.sons[0].typ), typeToString(n.typ)])); - end; - nkStringToCString, nkCStringToString: begin - 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(module, n.sons[1]); - if a = nil then exit; - case skipTypes(n.typ, abstractRange).kind of - tyInt..tyInt64: begin - case skipTypes(a.typ, abstractRange).kind of - tyFloat..tyFloat64: - result := newIntNodeT(nsystem.toInt(getFloat(a)), n); - tyChar: - result := newIntNodeT(getOrdValue(a), n); - else begin - result := a; - result.typ := n.typ; - end - end - end; - tyFloat..tyFloat64: begin - case skipTypes(a.typ, abstractRange).kind of - tyInt..tyInt64, tyEnum, tyBool, tyChar: - result := newFloatNodeT(toFloat(int(getOrdValue(a))), n); - else begin - result := a; - result.typ := n.typ; - end - end - end; - tyOpenArray, tyProc: begin end; - else begin - //n.sons[1] := a; - //result := n; - result := a; - result.typ := n.typ; - end - end - end - else begin - end - end -end; - -end. diff --git a/nim/semgnrc.pas b/nim/semgnrc.pas deleted file mode 100755 index ee905d444..000000000 --- a/nim/semgnrc.pas +++ /dev/null @@ -1,287 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - - -// This implements the first pass over the generic body; it resolves some -// symbols. Thus for generics there is a two-phase symbol lookup just like -// in C++. -// A problem is that it cannot be detected if the symbol is introduced -// as in ``var x = ...`` or used because macros/templates can hide this! -// So we have to eval templates/macros right here so that symbol -// lookup can be accurate. - -type - TSemGenericFlag = (withinBind, withinTypeDesc); - TSemGenericFlags = set of TSemGenericFlag; - -function semGenericStmt(c: PContext; n: PNode; - flags: TSemGenericFlags = {@set}[]): PNode; forward; - -function semGenericStmtScope(c: PContext; n: PNode; - flags: TSemGenericFlags = {@set}[]): PNode; -begin - openScope(c.tab); - result := semGenericStmt(c, n, flags); - closeScope(c.tab); -end; - -function semGenericStmtSymbol(c: PContext; n: PNode; s: PSym): PNode; -begin - case s.kind of - skUnknown: begin - // Introduced in this pass! Leave it as an identifier. - result := n; - end; - skProc, skMethod, skIterator, skConverter: result := symChoice(c, n, s); - skTemplate: result := semTemplateExpr(c, n, s, false); - skMacro: result := semMacroExpr(c, n, s, false); - skGenericParam: result := newSymNode(s); - skParam: result := n; - skType: begin - if (s.typ <> nil) and (s.typ.kind <> tyGenericParam) then - result := newSymNode(s) - else - result := n - end - else result := newSymNode(s) - end -end; - -function getIdentNode(n: PNode): PNode; -begin - case n.kind of - nkPostfix: result := getIdentNode(n.sons[1]); - nkPragmaExpr, nkAccQuoted: result := getIdentNode(n.sons[0]); - nkIdent: result := n; - else begin - illFormedAst(n); - result := nil - end - end -end; - -function semGenericStmt(c: PContext; n: PNode; - flags: TSemGenericFlags = {@set}[]): PNode; -var - i, j, L: int; - a: PNode; - s: PSym; -begin - result := n; - if n = nil then exit; - case n.kind of - nkIdent, nkAccQuoted: begin - s := lookUp(c, n); - if withinBind in flags then - result := symChoice(c, n, s) - else - result := semGenericStmtSymbol(c, n, s); - end; - nkDotExpr: begin - s := QualifiedLookUp(c, n, true); - if s <> nil then - result := semGenericStmtSymbol(c, n, s); - end; - nkSym..nkNilLit: begin end; - nkBind: result := semGenericStmt(c, n.sons[0], {@set}[withinBind]); - - nkCall, nkHiddenCallConv, nkInfix, nkPrefix, nkCommand, nkCallStrLit: begin - // check if it is an expression macro: - checkMinSonsLen(n, 1); - s := qualifiedLookup(c, n.sons[0], false); - if (s <> nil) then begin - case s.kind of - skMacro: begin result := semMacroExpr(c, n, s, false); exit end; - skTemplate: begin result := semTemplateExpr(c, n, s, false); exit end; - skUnknown, skParam: begin - // Leave it as an identifier. - end; - skProc, skMethod, skIterator, skConverter: begin - n.sons[0] := symChoice(c, n.sons[0], s); - end; - skGenericParam: n.sons[0] := newSymNode(s); - skType: begin - // bad hack for generics: - if (s.typ <> nil) and (s.typ.kind <> tyGenericParam) then begin - n.sons[0] := newSymNode(s); - end - end; - else n.sons[0] := newSymNode(s) - end - end; - for i := 1 to sonsLen(n)-1 do - n.sons[i] := semGenericStmt(c, n.sons[i], flags); - end; - nkMacroStmt: begin - result := semMacroStmt(c, n, false); - end; - nkIfStmt: begin - for i := 0 to sonsLen(n)-1 do - n.sons[i] := semGenericStmtScope(c, n.sons[i]); - end; - nkWhileStmt: begin - openScope(c.tab); - for i := 0 to sonsLen(n)-1 do - n.sons[i] := semGenericStmt(c, n.sons[i]); - closeScope(c.tab); - end; - nkCaseStmt: begin - openScope(c.tab); - n.sons[0] := semGenericStmt(c, n.sons[0]); - for i := 1 to sonsLen(n)-1 do begin - a := n.sons[i]; - checkMinSonsLen(a, 1); - L := sonsLen(a); - for j := 0 to L-2 do - a.sons[j] := semGenericStmt(c, a.sons[j]); - a.sons[L-1] := semGenericStmtScope(c, a.sons[L-1]); - end; - closeScope(c.tab); - end; - nkForStmt: begin - L := sonsLen(n); - openScope(c.tab); - n.sons[L-2] := semGenericStmt(c, n.sons[L-2]); - for i := 0 to L-3 do - addDecl(c, newSymS(skUnknown, n.sons[i], c)); - n.sons[L-1] := semGenericStmt(c, n.sons[L-1]); - closeScope(c.tab); - end; - nkBlockStmt, nkBlockExpr, nkBlockType: begin - checkSonsLen(n, 2); - openScope(c.tab); - if n.sons[0] <> nil then - addDecl(c, newSymS(skUnknown, n.sons[0], c)); - n.sons[1] := semGenericStmt(c, n.sons[1]); - closeScope(c.tab); - end; - nkTryStmt: begin - checkMinSonsLen(n, 2); - n.sons[0] := semGenericStmtScope(c, n.sons[0]); - for i := 1 to sonsLen(n)-1 do begin - a := n.sons[i]; - checkMinSonsLen(a, 1); - L := sonsLen(a); - for j := 0 to L-2 do - a.sons[j] := semGenericStmt(c, a.sons[j], {@set}[withinTypeDesc]); - a.sons[L-1] := semGenericStmtScope(c, a.sons[L-1]); - end; - end; - nkVarSection: begin - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if (a.kind <> nkIdentDefs) and (a.kind <> nkVarTuple) then - IllFormedAst(a); - checkMinSonsLen(a, 3); - L := sonsLen(a); - a.sons[L-2] := semGenericStmt(c, a.sons[L-2], {@set}[withinTypeDesc]); - a.sons[L-1] := semGenericStmt(c, a.sons[L-1]); - for j := 0 to L-3 do - addDecl(c, newSymS(skUnknown, getIdentNode(a.sons[j]), c)); - end - end; - nkGenericParams: begin - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if (a.kind <> nkIdentDefs) then IllFormedAst(a); - checkMinSonsLen(a, 3); - L := sonsLen(a); - a.sons[L-2] := semGenericStmt(c, a.sons[L-2], {@set}[withinTypeDesc]); - // do not perform symbol lookup for default expressions - for j := 0 to L-3 do - addDecl(c, newSymS(skUnknown, getIdentNode(a.sons[j]), c)); - end - end; - nkConstSection: begin - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if (a.kind <> nkConstDef) then IllFormedAst(a); - checkSonsLen(a, 3); - addDecl(c, newSymS(skUnknown, getIdentNode(a.sons[0]), c)); - a.sons[1] := semGenericStmt(c, a.sons[1], {@set}[withinTypeDesc]); - a.sons[2] := semGenericStmt(c, a.sons[2]); - end - end; - nkTypeSection: begin - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if (a.kind <> nkTypeDef) then IllFormedAst(a); - checkSonsLen(a, 3); - addDecl(c, newSymS(skUnknown, getIdentNode(a.sons[0]), c)); - end; - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if (a.kind <> nkTypeDef) then IllFormedAst(a); - checkSonsLen(a, 3); - if a.sons[1] <> nil then begin - openScope(c.tab); - a.sons[1] := semGenericStmt(c, a.sons[1]); - a.sons[2] := semGenericStmt(c, a.sons[2], {@set}[withinTypeDesc]); - closeScope(c.tab); - end - else - a.sons[2] := semGenericStmt(c, a.sons[2], {@set}[withinTypeDesc]); - end - end; - nkEnumTy: begin - checkMinSonsLen(n, 1); - if n.sons[0] <> nil then - n.sons[0] := semGenericStmt(c, n.sons[0], {@set}[withinTypeDesc]); - for i := 1 to sonsLen(n)-1 do begin - case n.sons[i].kind of - nkEnumFieldDef: a := n.sons[i].sons[0]; - nkIdent: a := n.sons[i]; - else illFormedAst(n); - end; - addDeclAt(c, newSymS(skUnknown, getIdentNode(a.sons[i]), c), - c.tab.tos-1); - end - end; - nkObjectTy, nkTupleTy: begin end; - nkFormalParams: begin - checkMinSonsLen(n, 1); - if n.sons[0] <> nil then - n.sons[0] := semGenericStmt(c, n.sons[0], {@set}[withinTypeDesc]); - for i := 1 to sonsLen(n)-1 do begin - a := n.sons[i]; - if (a.kind <> nkIdentDefs) then IllFormedAst(a); - checkMinSonsLen(a, 3); - L := sonsLen(a); - a.sons[L-1] := semGenericStmt(c, a.sons[L-2], {@set}[withinTypeDesc]); - a.sons[L-1] := semGenericStmt(c, a.sons[L-1]); - for j := 0 to L-3 do begin - addDecl(c, newSymS(skUnknown, getIdentNode(a.sons[j]), c)); - end - end - end; - nkProcDef, nkMethodDef, nkConverterDef, nkMacroDef, nkTemplateDef, - nkIteratorDef, nkLambda: begin - checkSonsLen(n, codePos+1); - addDecl(c, newSymS(skUnknown, getIdentNode(n.sons[0]), c)); - openScope(c.tab); - n.sons[genericParamsPos] := semGenericStmt(c, n.sons[genericParamsPos]); - if n.sons[paramsPos] <> nil then begin - if n.sons[paramsPos].sons[0] <> nil then - addDecl(c, newSym(skUnknown, getIdent('result'), nil)); - n.sons[paramsPos] := semGenericStmt(c, n.sons[paramsPos]); - end; - n.sons[pragmasPos] := semGenericStmt(c, n.sons[pragmasPos]); - n.sons[codePos] := semGenericStmtScope(c, n.sons[codePos]); - closeScope(c.tab); - end - else begin - for i := 0 to sonsLen(n)-1 do - result.sons[i] := semGenericStmt(c, n.sons[i], flags); - end - end -end; diff --git a/nim/seminst.pas b/nim/seminst.pas deleted file mode 100755 index ea8889007..000000000 --- a/nim/seminst.pas +++ /dev/null @@ -1,365 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 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 info: TLineInfo): PSym; forward; -// generates an instantiated proc - - -function searchInstTypes(const tab: TIdTable; key: PType): PType; -var - t: PType; - h: THash; - j: int; - match: bool; -begin // returns nil if we need to declare this type - result := PType(IdTableGet(tab, key)); - if (result = nil) and (tab.counter > 0) then begin - // we have to do a slow linear search because types may need - // to be compared by their structure: - for h := 0 to high(tab.data) do begin - t := PType(tab.data[h].key); - if t <> nil then begin - if key.containerId = t.containerID then begin - match := true; - for j := 0 to sonsLen(t) - 1 do begin - // XXX sameType is not really correct for nested generics? - if not sameType(t.sons[j], key.sons[j]) then begin - match := false; break - end - end; - if match then begin result := PType(tab.data[h].val); exit end; - end - end - end - end -end; - -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 instantiateSym(c: PInstantiateClosure; sym: PSym): PSym; -begin - if sym = nil then begin result := nil; exit end; // BUGFIX - result := PSym(idTableGet(c.symMap, sym)); - if (result = nil) then begin - if (sym.owner.id = c.fn.id) then begin // XXX: nested generics? - result := copySym(sym, false); - include(result.flags, sfFromGeneric); - idTablePut(c.symMap, 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; -*) - -procedure instantiateGenericParamList(c: PContext; n: PNode; const pt: TIdTable); -var - i: int; - s, q: PSym; - t: PType; - a: PNode; -begin - if (n.kind <> nkGenericParams) then - InternalError(n.info, 'instantiateGenericParamList; no generic params'); - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind <> nkSym then - InternalError(a.info, 'instantiateGenericParamList; no symbol'); - q := a.sym; - if not (q.typ.kind in [tyTypeDesc, tyGenericParam]) then continue; - s := newSym(skType, q.name, getCurrOwner()); - t := PType(IdTableGet(pt, q.typ)); - if t = nil then liMessage(a.info, errCannotInstantiateX, s.name.s); - if (t.kind = tyGenericParam) then begin - InternalError(a.info, 'instantiateGenericParamList: ' + q.name.s); - end; - 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 - //if gVerbosity > 0 then - // MessageOut('found in cache: ' + getProcHeader(instSym)); - 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; - -function generateInstance(c: PContext; fn: PSym; const pt: TIdTable; - const info: TLineInfo): PSym; -// generates an instantiated proc -var - oldPrc, oldMod: PSym; - oldP: PProcCon; - n: PNode; -begin - if c.InstCounter > 1000 then InternalError(fn.ast.info, 'nesting too deep'); - inc(c.InstCounter); - oldP := c.p; // restore later - // NOTE: for access of private fields within generics from a different module - // and other identifiers we fake the current module temporarily! - oldMod := c.module; - c.module := getModule(fn); - result := copySym(fn, false); - include(result.flags, sfFromGeneric); - result.owner := getCurrOwner().owner; - n := copyTree(fn.ast); - result.ast := n; - pushOwner(result); - openScope(c.tab); - if (n.sons[genericParamsPos] = nil) then - InternalError(n.info, 'generateInstance'); - n.sons[namePos] := newSymNode(result); - pushInfoContext(info); - - 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], nil, 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: - GenericCacheAdd(c, fn, result); - addDecl(c, result); - if n.sons[codePos] <> nil then begin - c.p := newProcCon(result); - if result.kind in [skProc, skMethod, skConverter] then begin - addResult(c, result.typ.sons[0], n.info); - addResultNode(c, n); - end; - n.sons[codePos] := semStmtScope(c, n.sons[codePos]); - end - end - else - result := oldPrc; - popInfoContext(); - closeScope(c.tab); // close scope for parameters - popOwner(); - c.p := oldP; // restore - c.module := oldMod; - dec(c.InstCounter); -end; - -procedure checkConstructedType(const info: TLineInfo; t: PType); -begin - if (tfAcyclic in t.flags) - and (skipTypes(t, abstractInst).kind <> tyObject) then - liMessage(info, errInvalidPragmaX, 'acyclic'); - if computeSize(t) < 0 then - liMessage(info, errIllegalRecursionInTypeX, typeToString(t)); - if (t.kind = tyVar) and (t.sons[0].kind = tyVar) then - liMessage(info, errVarVarTypeNotAllowed); -end; - -type - TReplTypeVars = record - c: PContext; - typeMap: TIdTable; // map PType to PType - symMap: TIdTable; // map PSym to PSym - info: TLineInfo; - end; - -function ReplaceTypeVarsT(var cl: TReplTypeVars; t: PType): PType; forward; -function ReplaceTypeVarsS(var cl: TReplTypeVars; s: PSym): PSym; forward; - -function ReplaceTypeVarsN(var cl: TReplTypeVars; n: PNode): PNode; -var - i, Len: int; -begin - result := nil; - if n <> nil then begin - result := copyNode(n); - result.typ := ReplaceTypeVarsT(cl, n.typ); - case n.kind of - nkNone..pred(nkSym), succ(nkSym)..nkNilLit: begin end; - nkSym: begin - result.sym := ReplaceTypeVarsS(cl, n.sym); - end; - else begin - len := sonsLen(n); - if len > 0 then begin - newSons(result, len); - for i := 0 to len-1 do - result.sons[i] := ReplaceTypeVarsN(cl, n.sons[i]); - end - end - end - end -end; - -function ReplaceTypeVarsS(var cl: TReplTypeVars; s: PSym): PSym; -begin - if s = nil then begin result := nil; exit end; - result := PSym(idTableGet(cl.symMap, s)); - if (result = nil) then begin - result := copySym(s, false); - include(result.flags, sfFromGeneric); - idTablePut(cl.symMap, s, result); - result.typ := ReplaceTypeVarsT(cl, s.typ); - result.owner := s.owner; - result.ast := ReplaceTypeVarsN(cl, s.ast); - end -end; - -function lookupTypeVar(cl: TReplTypeVars; t: PType): PType; -begin - result := PType(idTableGet(cl.typeMap, t)); - if result = nil then - liMessage(t.sym.info, errCannotInstantiateX, typeToString(t)) - else if result.kind = tyGenericParam then - InternalError(cl.info, 'substitution with generic parameter'); -end; - -function ReplaceTypeVarsT(var cl: TReplTypeVars; t: PType): PType; -var - i: int; - body, newbody, x, header: PType; -begin - result := t; - if t = nil then exit; - case t.kind of - tyGenericParam: begin - result := lookupTypeVar(cl, t); - end; - tyGenericInvokation: begin - body := t.sons[0]; - if body.kind <> tyGenericBody then - InternalError(cl.info, 'no generic body'); - header := nil; - for i := 1 to sonsLen(t)-1 do begin - if t.sons[i].kind = tyGenericParam then begin - x := lookupTypeVar(cl, t.sons[i]); - if header = nil then header := copyType(t, t.owner, false); - header.sons[i] := x; - end - else - x := t.sons[i]; - idTablePut(cl.typeMap, body.sons[i-1], x); - end; - // cycle detection: - if header = nil then header := t; - result := searchInstTypes(gInstTypes, header); - if result <> nil then exit; - - result := newType(tyGenericInst, t.sons[0].owner); - for i := 0 to sonsLen(t)-1 do begin - // if one of the params is not concrete, we cannot do anything - // but we already raised an error! - addSon(result, header.sons[i]); - end; - // add these before recursive calls: - idTablePut(gInstTypes, header, result); - - newbody := ReplaceTypeVarsT(cl, lastSon(body)); - newbody.n := ReplaceTypeVarsN(cl, lastSon(body).n); - addSon(result, newbody); - //writeln(output, ropeToStr(Typetoyaml(newbody))); - checkConstructedType(cl.info, newbody); - end; - tyGenericBody: begin - InternalError(cl.info, 'ReplaceTypeVarsT: tyGenericBody'); - result := ReplaceTypeVarsT(cl, lastSon(t)); - end - else begin - if containsGenericType(t) then begin - result := copyType(t, t.owner, false); - for i := 0 to sonsLen(result)-1 do - result.sons[i] := ReplaceTypeVarsT(cl, result.sons[i]); - result.n := ReplaceTypeVarsN(cl, result.n); - if result.Kind in GenericTypes then - liMessage(cl.info, errCannotInstantiateX, TypeToString(t, preferName)); - //writeln(output, ropeToStr(Typetoyaml(result))); - //checkConstructedType(cl.info, result); - end - end - end -end; - -function instGenericContainer(c: PContext; n: PNode; header: PType): PType; -var - cl: TReplTypeVars; -begin - InitIdTable(cl.symMap); - InitIdTable(cl.typeMap); - cl.info := n.info; - cl.c := c; - result := ReplaceTypeVarsT(cl, header); -end; - -function generateTypeInstance(p: PContext; const pt: TIdTable; - arg: PNode; t: PType): PType; -var - cl: TReplTypeVars; -begin - InitIdTable(cl.symMap); - copyIdTable(cl.typeMap, pt); - cl.info := arg.info; - cl.c := p; - pushInfoContext(arg.info); - result := ReplaceTypeVarsT(cl, t); - popInfoContext(); -end; - -function partialSpecialization(c: PContext; n: PNode; s: PSym): PNode; -begin - result := n; -end; diff --git a/nim/semstmts.pas b/nim/semstmts.pas deleted file mode 100755 index 1ece72023..000000000 --- a/nim/semstmts.pas +++ /dev/null @@ -1,1116 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -// this module does the semantic checking of statements - -function semWhen(c: PContext; n: PNode): PNode; -var - i: int; - it, e: PNode; -begin - result := nil; - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if it = nil then illFormedAst(n); - case it.kind of - nkElifBranch: begin - checkSonsLen(it, 2); - e := semConstExpr(c, it.sons[0]); - checkBool(e); - 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; - nkElse: begin - checkSonsLen(it, 1); - if result = nil then result := semStmt(c, it.sons[0]) - // do not open a new scope! - end; - else illFormedAst(n) - end - end; - 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 allocation after the - // ``when`` statement. - IDsynchronizationPoint(200); -end; - -function semIf(c: PContext; n: PNode): PNode; -var - i: int; - it: PNode; -begin - result := n; - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if it = nil then illFormedAst(n); - case it.kind of - nkElifBranch: begin - checkSonsLen(it, 2); - openScope(c.tab); - it.sons[0] := semExprWithType(c, it.sons[0]); - checkBool(it.sons[0]); - it.sons[1] := semStmt(c, it.sons[1]); - closeScope(c.tab); - end; - nkElse: begin - if sonsLen(it) = 1 then it.sons[0] := semStmtScope(c, it.sons[0]) - else illFormedAst(it) - end; - else illFormedAst(n) - end - end -end; - -function semDiscard(c: PContext; n: PNode): PNode; -begin - result := n; - checkSonsLen(n, 1); - n.sons[0] := semExprWithType(c, n.sons[0]); - if n.sons[0].typ = nil then liMessage(n.info, errInvalidDiscard); -end; - -function semBreakOrContinue(c: PContext; n: PNode): PNode; -var - s: PSym; - x: PNode; -begin - result := n; - checkSonsLen(n, 1); - if n.sons[0] <> nil then begin - case n.sons[0].kind of - nkIdent: s := lookUp(c, n.sons[0]); - nkSym: s := n.sons[0].sym; - else illFormedAst(n) - end; - 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) - end - else if (c.p.nestedLoopCounter <= 0) and (c.p.nestedBlockCounter <= 0) then - liMessage(n.info, errInvalidControlFlowX, - renderTree(n, {@set}[renderNoComments])) -end; - -function semBlock(c: PContext; n: PNode): PNode; -var - labl: PSym; -begin - result := n; - Inc(c.p.nestedBlockCounter); - checkSonsLen(n, 2); - openScope(c.tab); // BUGFIX: label is in the scope of block! - if n.sons[0] <> nil then begin - labl := newSymS(skLabel, n.sons[0], c); - addDecl(c, labl); - n.sons[0] := newSymNode(labl); // BUGFIX - end; - n.sons[1] := semStmt(c, n.sons[1]); - closeScope(c.tab); - Dec(c.p.nestedBlockCounter); -end; - -function semAsm(con: PContext; n: PNode): PNode; -var - str, sub: string; - a, b, c: int; - e: PSym; - marker: char; -begin - result := n; - checkSonsLen(n, 2); - marker := pragmaAsm(con, n.sons[0]); - if marker = #0 then marker := '`'; // default marker - case n.sons[1].kind of - nkStrLit, nkRStrLit, nkTripleStrLit: begin - result := copyNode(n); - str := n.sons[1].strVal; - if str = '' then liMessage(n.info, errEmptyAsm); - // now parse the string literal and substitute symbols: - a := strStart; - repeat - b := strutils.find(str, marker, a); - if b < strStart then - sub := ncopy(str, a) - else - sub := ncopy(str, a, b-1); - if sub <> '' then - addSon(result, newStrNode(nkStrLit, sub)); - - if b < strStart then break; - c := strutils.find(str, marker, b+1); - if c < strStart then - sub := ncopy(str, b+1) - else - sub := ncopy(str, b+1, c-1); - if sub <> '' then begin - e := SymtabGet(con.tab, getIdent(sub)); - if e <> nil then begin - if e.kind = skStub then loadStub(e); - addSon(result, newSymNode(e)) - end - else - addSon(result, newStrNode(nkStrLit, sub)); - end; - if c < strStart then break; - a := c+1; - until false; - end; - else illFormedAst(n) - end -end; - -function semWhile(c: PContext; n: PNode): PNode; -begin - result := n; - checkSonsLen(n, 2); - openScope(c.tab); - n.sons[0] := semExprWithType(c, n.sons[0]); - CheckBool(n.sons[0]); - inc(c.p.nestedLoopCounter); - n.sons[1] := semStmt(c, n.sons[1]); - dec(c.p.nestedLoopCounter); - closeScope(c.tab); -end; - -function semCase(c: PContext; n: PNode): PNode; -var - i, len: int; - covered: biggestint; - // for some types we count to check if all cases have been covered - chckCovered: boolean; - x: PNode; -begin - // check selector: - result := n; - checkMinSonsLen(n, 2); - openScope(c.tab); - n.sons[0] := semExprWithType(c, n.sons[0]); - chckCovered := false; - covered := 0; - case skipTypes(n.sons[0].Typ, abstractVarRange).Kind of - tyInt..tyInt64, tyChar, tyEnum: chckCovered := true; - tyFloat..tyFloat128, tyString: begin end - else liMessage(n.info, errSelectorMustBeOfCertainTypes); - end; - for i := 1 to sonsLen(n)-1 do begin - x := n.sons[i]; - case x.kind of - nkOfBranch: begin - checkMinSonsLen(x, 2); - semCaseBranch(c, n, x, i, covered); - len := sonsLen(x); - x.sons[len-1] := semStmtScope(c, x.sons[len-1]); - end; - nkElifBranch: begin - chckCovered := false; - checkSonsLen(x, 2); - x.sons[0] := semExprWithType(c, x.sons[0]); - checkBool(x.sons[0]); - x.sons[1] := semStmtScope(c, x.sons[1]) - end; - nkElse: begin - chckCovered := false; - checkSonsLen(x, 1); - x.sons[0] := semStmtScope(c, x.sons[0]) - end; - else illFormedAst(x); - end; - end; - if chckCovered and (covered <> lengthOrd(n.sons[0].typ)) then - liMessage(n.info, errNotAllCasesCovered); - closeScope(c.tab); -end; - -function semAsgn(c: PContext; n: PNode): PNode; -var - le: PType; - a: PNode; - id: PIdent; -begin - checkSonsLen(n, 2); - a := n.sons[0]; - case a.kind of - nkDotExpr: begin - // r.f = x - // --> `f=` (r, x) - checkSonsLen(a, 2); - id := considerAcc(a.sons[1]); - result := newNodeI(nkCall, n.info); - addSon(result, newIdentNode(getIdent(id.s+'='), n.info)); - addSon(result, semExpr(c, a.sons[0])); - addSon(result, semExpr(c, n.sons[1])); - result := semDirectCallAnalyseEffects(c, result, {@set}[]); - if result <> nil then begin - fixAbstractType(c, result); - analyseIfAddressTakenInCall(c, result); - exit; - end - end; - nkBracketExpr: begin - // a[i..j] = x - // --> `[..]=`(a, i, j, x) - result := newNodeI(nkCall, n.info); - checkSonsLen(a, 2); - if a.sons[1].kind = nkRange then begin - checkSonsLen(a.sons[1], 2); - addSon(result, newIdentNode(getIdent(whichSliceOpr(a.sons[1])+'='), - n.info)); - addSon(result, semExpr(c, a.sons[0])); - addSonIfNotNil(result, semExpr(c, a.sons[1].sons[0])); - addSonIfNotNil(result, semExpr(c, a.sons[1].sons[1])); - addSon(result, semExpr(c, n.sons[1])); - result := semDirectCallAnalyseEffects(c, result, {@set}[]); - if result <> nil then begin - fixAbstractType(c, result); - analyseIfAddressTakenInCall(c, result); - exit; - end - end - else begin - addSon(result, newIdentNode(getIdent('[]='), n.info)); - addSon(result, semExpr(c, a.sons[0])); - addSon(result, semExpr(c, a.sons[1])); - addSon(result, semExpr(c, n.sons[1])); - result := semDirectCallAnalyseEffects(c, result, {@set}[]); - if result <> nil then begin - fixAbstractType(c, result); - analyseIfAddressTakenInCall(c, result); - exit; - end - end; - end; - else begin end; - end; - n.sons[0] := semExprWithType(c, n.sons[0], {@set}[efLValue]); - n.sons[1] := semExprWithType(c, n.sons[1]); - le := n.sons[0].typ; - if (skipTypes(le, {@set}[tyGenericInst]).kind <> tyVar) - and (IsAssignable(n.sons[0]) = arNone) then begin - // Direct assignment to a discriminant is allowed! - liMessage(n.sons[0].info, errXCannotBeAssignedTo, - renderTree(n.sons[0], {@set}[renderNoComments])); - end - else begin - n.sons[1] := fitNode(c, le, n.sons[1]); - fixAbstractType(c, n); - end; - result := n; -end; - -function SemReturn(c: PContext; n: PNode): PNode; -var - restype: PType; - a: PNode; // temporary assignment for code generator -begin - result := n; - checkSonsLen(n, 1); - if not (c.p.owner.kind in [skConverter, skMethod, skProc, skMacro]) then - liMessage(n.info, errXNotAllowedHere, '''return'''); - if (n.sons[0] <> nil) then begin - n.sons[0] := SemExprWithType(c, n.sons[0]); - // check for type compatibility: - restype := c.p.owner.typ.sons[0]; - if (restype <> nil) then begin - a := newNodeI(nkAsgn, n.sons[0].info); - - n.sons[0] := fitNode(c, restype, n.sons[0]); - // optimize away ``return result``, because it would be transformed - // to ``result = result; return``: - if (n.sons[0].kind = nkSym) and (sfResult in n.sons[0].sym.flags) then - begin - n.sons[0] := nil; - end - else begin - 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; - end - end - else - liMessage(n.info, errCannotReturnExpr); - end; -end; - -function SemYield(c: PContext; n: PNode): PNode; -var - restype: PType; -begin - result := n; - checkSonsLen(n, 1); - if (c.p.owner = nil) or (c.p.owner.kind <> skIterator) then - liMessage(n.info, errYieldNotAllowedHere); - if (n.sons[0] <> nil) then begin - n.sons[0] := SemExprWithType(c, n.sons[0]); - // check for type compatibility: - restype := c.p.owner.typ.sons[0]; - if (restype <> nil) then begin - n.sons[0] := fitNode(c, restype, n.sons[0]); - if (n.sons[0].typ = nil) then InternalError(n.info, 'semYield'); - end - else - liMessage(n.info, errCannotReturnExpr); - end -end; - -function fitRemoveHiddenConv(c: PContext; typ: Ptype; n: PNode): PNode; -begin - result := fitNode(c, typ, n); - if (result.kind in [nkHiddenStdConv, nkHiddenSubConv]) then begin - changeType(result.sons[1], typ); - result := result.sons[1]; - end - else if not sameType(result.typ, typ) then - changeType(result, typ) -end; - -function semVar(c: PContext; n: PNode): PNode; -var - i, j, len: int; - a, b, def: PNode; - typ, tup: PType; - v: PSym; -begin - result := copyNode(n); - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if (a.kind <> nkIdentDefs) and (a.kind <> nkVarTuple) then IllFormedAst(a); - checkMinSonsLen(a, 3); - len := sonsLen(a); - if a.sons[len-2] <> nil then - typ := semTypeNode(c, a.sons[len-2], nil) - else - 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 := fitNode(c, typ, def) - else typ := def.typ; - end - else - def := nil; - if not typeAllowed(typ, skVar) then begin - //debug(typ); - liMessage(a.info, errXisNoType, typeToString(typ)); - end; - tup := skipTypes(typ, {@set}[tyGenericInst]); - if a.kind = nkVarTuple then begin - if tup.kind <> tyTuple then liMessage(a.info, errXExpected, 'tuple'); - if len-2 <> sonsLen(tup) then - liMessage(a.info, errWrongNumberOfVariables); - b := newNodeI(nkVarTuple, a.info); - newSons(b, len); - b.sons[len-2] := nil; // no type desc - b.sons[len-1] := def; - addSon(result, b); - end; - for j := 0 to len-3 do begin - if (c.p.owner.kind = skModule) then begin - v := semIdentWithPragma(c, skVar, a.sons[j], {@set}[sfStar, sfMinus]); - include(v.flags, sfGlobal); - end - else - v := semIdentWithPragma(c, skVar, a.sons[j], {@set}[]); - if v.flags * [sfStar, sfMinus] <> {@set}[] then - include(v.flags, sfInInterface); - addInterfaceDecl(c, v); - if a.kind <> nkVarTuple then begin - v.typ := typ; - b := newNodeI(nkIdentDefs, a.info); - addSon(b, newSymNode(v)); - addSon(b, nil); // no type description - addSon(b, copyTree(def)); - addSon(result, b); - end - else begin - v.typ := tup.sons[j]; - b.sons[j] := newSymNode(v); - end - end - end -end; - -function semConst(c: PContext; n: PNode): PNode; -var - a, def, b: PNode; - i: int; - v: PSym; - typ: PType; -begin - result := copyNode(n); - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if (a.kind <> nkConstDef) then IllFormedAst(a); - checkSonsLen(a, 3); - if (c.p.owner.kind = skModule) then begin - v := semIdentWithPragma(c, skConst, a.sons[0], {@set}[sfStar, sfMinus]); - include(v.flags, sfGlobal); - end - else - v := semIdentWithPragma(c, skConst, a.sons[0], {@set}[]); - - if a.sons[1] <> nil then typ := semTypeNode(c, a.sons[1], nil) - else typ := nil; - def := semAndEvalConstExpr(c, a.sons[2]); - // check type compability between def.typ and typ: - if (typ <> nil) then begin - def := fitRemoveHiddenConv(c, typ, def); - end - else typ := def.typ; - if not typeAllowed(typ, skConst) then - liMessage(a.info, errXisNoType, typeToString(typ)); - - v.typ := typ; - v.ast := def; // no need to copy - if v.flags * [sfStar, sfMinus] <> {@set}[] then - include(v.flags, sfInInterface); - addInterfaceDecl(c, v); - b := newNodeI(nkConstDef, a.info); - addSon(b, newSymNode(v)); - addSon(b, nil); // no type description - addSon(b, copyTree(def)); - addSon(result, b); - end; -end; - -function semFor(c: PContext; n: PNode): PNode; -var - i, len: int; - v, countup: PSym; - iter: PType; - countupNode, call: PNode; -begin - result := n; - checkMinSonsLen(n, 3); - len := sonsLen(n); - openScope(c.tab); - if n.sons[len-2].kind = nkRange then begin - checkSonsLen(n.sons[len-2], 2); - // convert ``in 3..5`` to ``in countup(3, 5)`` - countupNode := newNodeI(nkCall, n.sons[len-2].info); - countUp := StrTableGet(magicsys.systemModule.Tab, getIdent('countup')); - if (countUp = nil) then - liMessage(countupNode.info, errSystemNeeds, 'countup'); - newSons(countupNode, 3); - countupnode.sons[0] := newSymNode(countup); - countupNode.sons[1] := n.sons[len-2].sons[0]; - countupNode.sons[2] := n.sons[len-2].sons[1]; - - n.sons[len-2] := countupNode; - end; - n.sons[len-2] := semExprWithType(c, n.sons[len-2], {@set}[efWantIterator]); - call := n.sons[len-2]; - if (call.kind <> nkCall) or (call.sons[0].kind <> nkSym) - or (call.sons[0].sym.kind <> skIterator) then - liMessage(n.sons[len-2].info, errIteratorExpected); - iter := skipTypes(n.sons[len-2].typ, {@set}[tyGenericInst]); - if iter.kind <> tyTuple then begin - if len <> 3 then liMessage(n.info, errWrongNumberOfVariables); - v := newSymS(skForVar, n.sons[0], c); - v.typ := iter; - n.sons[0] := newSymNode(v); - addDecl(c, v); - end - else begin - if len-2 <> sonsLen(iter) then liMessage(n.info, errWrongNumberOfVariables); - for i := 0 to len-3 do begin - v := newSymS(skForVar, n.sons[i], c); - v.typ := iter.sons[i]; - n.sons[i] := newSymNode(v); - addDecl(c, v); - end - end; - // semantic checking for the sub statements: - Inc(c.p.nestedLoopCounter); - n.sons[len-1] := SemStmt(c, n.sons[len-1]); - closeScope(c.tab); - Dec(c.p.nestedLoopCounter); -end; - -function semRaise(c: PContext; n: PNode): PNode; -var - typ: PType; -begin - result := n; - checkSonsLen(n, 1); - if n.sons[0] <> nil then begin - n.sons[0] := semExprWithType(c, n.sons[0]); - typ := n.sons[0].typ; - if (typ.kind <> tyRef) or (typ.sons[0].kind <> tyObject) then - liMessage(n.info, errExprCannotBeRaised) - end; -end; - -function semTry(c: PContext; n: PNode): PNode; -var - i, j, len: int; - a: PNode; - typ: PType; - check: TIntSet; -begin - result := n; - checkMinSonsLen(n, 2); - n.sons[0] := semStmtScope(c, n.sons[0]); - IntSetInit(check); - for i := 1 to sonsLen(n)-1 do begin - a := n.sons[i]; - checkMinSonsLen(a, 1); - len := sonsLen(a); - if a.kind = nkExceptBranch then begin - for j := 0 to len-2 do begin - typ := semTypeNode(c, a.sons[j], nil); - if typ.kind = tyRef then typ := typ.sons[0]; - if (typ.kind <> tyObject) then - liMessage(a.sons[j].info, errExprCannotBeRaised); - 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); - end - end - else if a.kind <> nkFinally then - illFormedAst(n); - // last child of an nkExcept/nkFinally branch is a statement: - a.sons[len-1] := semStmtScope(c, a.sons[len-1]); - end; -end; - -function semGenericParamList(c: PContext; n: PNode; father: PType = nil): PNode; -var - i, j, L: int; - s: PSym; - a, def: PNode; - typ: PType; -begin - result := copyNode(n); - if n.kind <> nkGenericParams then - InternalError(n.info, 'semGenericParamList'); - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind <> nkIdentDefs then illFormedAst(n); - L := sonsLen(a); - def := a.sons[L-1]; - if a.sons[L-2] <> nil then - typ := semTypeNode(c, a.sons[L-2], nil) - else if def <> nil then - typ := newTypeS(tyExpr, c) - else - typ := nil; - for j := 0 to L-3 do begin - if (typ = nil) or (typ.kind = tyTypeDesc) then begin - s := newSymS(skType, a.sons[j], c); - s.typ := newTypeS(tyGenericParam, c) - end - else begin - s := newSymS(skGenericParam, a.sons[j], c); - s.typ := typ - end; - s.ast := def; - s.typ.sym := s; - if father <> nil then addSon(father, s.typ); - s.position := i; - addSon(result, newSymNode(s)); - addDecl(c, s); - end - end -end; - -procedure addGenericParamListToScope(c: PContext; n: PNode); -var - i: int; - a: PNode; -begin - if n.kind <> nkGenericParams then - InternalError(n.info, 'addGenericParamListToScope'); - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind <> nkSym then internalError(a.info, 'addGenericParamListToScope'); - addDecl(c, a.sym) - end -end; - -function SemTypeSection(c: PContext; n: PNode): PNode; -var - i: int; - s: PSym; - t, body: PType; - a: PNode; -begin - result := n; - // process the symbols on the left side for the whole type section, before - // we even look at the type definitions on the right - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if (a.kind <> nkTypeDef) then IllFormedAst(a); - checkSonsLen(a, 3); - if (c.p.owner.kind = skModule) then begin - s := semIdentWithPragma(c, skType, a.sons[0], {@set}[sfStar, sfMinus]); - include(s.flags, sfGlobal); - end - else - s := semIdentWithPragma(c, skType, a.sons[0], {@set}[]); - if s.flags * [sfStar, sfMinus] <> {@set}[] then - include(s.flags, sfInInterface); - s.typ := newTypeS(tyForward, c); - s.typ.sym := s; - // process pragmas: - if a.sons[0].kind = nkPragmaExpr then - pragma(c, s, a.sons[0].sons[1], typePragmas); - // add it here, so that recursive types are possible: - addInterfaceDecl(c, s); - a.sons[0] := newSymNode(s); - end; - - // process the right side of the types: - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if a.kind = nkCommentStmt then continue; - if (a.kind <> nkTypeDef) then IllFormedAst(a); - checkSonsLen(a, 3); - if (a.sons[0].kind <> nkSym) then IllFormedAst(a); - s := a.sons[0].sym; - if (s.magic = mNone) and (a.sons[2] = nil) then - liMessage(a.info, errImplOfXexpected, 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. In generic types, - // symbol lookup needs to be done here. - openScope(c.tab); - pushOwner(s); - s.typ.kind := tyGenericBody; - if s.typ.containerID <> 0 then - InternalError(a.info, 'semTypeSection: containerID'); - s.typ.containerID := getID(); - a.sons[1] := semGenericParamList(c, a.sons[1], s.typ); - addSon(s.typ, nil); // to be filled out later - s.ast := a; - body := semTypeNode(c, a.sons[2], nil); - if body <> nil then body.sym := s; - s.typ.sons[sonsLen(s.typ)-1] := body; - //debug(s.typ); - popOwner(); - closeScope(c.tab); - end - else if a.sons[2] <> nil then begin - // process the type's body: - pushOwner(s); - t := semTypeNode(c, a.sons[2], s.typ); - if (t <> s.typ) and (s.typ <> nil) then - internalError(a.info, 'semTypeSection()'); - s.typ := t; - s.ast := a; - popOwner(); - 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; - checkConstructedType(s.info, s.typ); - end - end -end; - -procedure semParamList(c: PContext; n, genericParams: PNode; s: PSym); -begin - s.typ := semProcTypeNode(c, n, genericParams, nil); -end; - -procedure addParams(c: PContext; n: PNode); -var - i: int; -begin - for i := 1 to sonsLen(n)-1 do begin - if (n.sons[i].kind <> nkSym) then InternalError(n.info, 'addParams'); - addDecl(c, n.sons[i].sym); - end -end; - -procedure semBorrow(c: PContext; n: PNode; s: PSym); -var - b: PSym; -begin - // search for the correct alias: - b := SearchForBorrowProc(c, s, c.tab.tos-2); - if b = nil then liMessage(n.info, errNoSymbolToBorrowFromFound); - // store the alias: - n.sons[codePos] := newSymNode(b); -end; - -procedure sideEffectsCheck(c: PContext; s: PSym); -begin - if [sfNoSideEffect, sfSideEffect] * s.flags = - [sfNoSideEffect, sfSideEffect] then - liMessage(s.info, errXhasSideEffects, s.name.s); -end; - -procedure addResult(c: PContext; t: PType; const info: TLineInfo); -var - s: PSym; -begin - if t <> nil then begin - 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 -end; - -procedure addResultNode(c: PContext; n: PNode); -begin - if c.p.resultSym <> nil then addSon(n, newSymNode(c.p.resultSym)); -end; - -function semLambda(c: PContext; n: PNode): PNode; -var - s: PSym; - oldP: PProcCon; -begin - result := n; - checkSonsLen(n, codePos+1); - s := newSym(skProc, getIdent(':anonymous'), getCurrOwner()); - s.info := n.info; - - oldP := c.p; // restore later - s.ast := n; - n.sons[namePos] := newSymNode(s); - - pushOwner(s); - openScope(c.tab); - if (n.sons[genericParamsPos] <> nil) then illFormedAst(n); - // process parameters: - if n.sons[paramsPos] <> nil then begin - semParamList(c, n.sons[ParamsPos], nil, s); - addParams(c, s.typ.n); - end - else begin - s.typ := newTypeS(tyProc, c); - addSon(s.typ, nil); - end; - - // we are in a nested proc: - s.typ.callConv := ccClosure; - if n.sons[pragmasPos] <> nil then - pragma(c, s, n.sons[pragmasPos], lambdaPragmas); - - s.options := gOptions; - if n.sons[codePos] <> nil then begin - if sfImportc in s.flags then - liMessage(n.sons[codePos].info, errImplOfXNotAllowed, s.name.s); - c.p := newProcCon(s); - addResult(c, s.typ.sons[0], n.info); - n.sons[codePos] := semStmtScope(c, n.sons[codePos]); - addResultNode(c, n); - end - else - liMessage(n.info, errImplOfXexpected, s.name.s); - closeScope(c.tab); // close scope for parameters - popOwner(); - c.p := oldP; // restore - result.typ := s.typ; -end; - -function semProcAux(c: PContext; n: PNode; kind: TSymKind; - const validPragmas: TSpecialWords): PNode; -var - s, proto: PSym; - oldP: PProcCon; - gp: PNode; -begin - result := n; - checkSonsLen(n, codePos+1); - if c.p.owner.kind = skModule then begin - s := semIdentVis(c, kind, n.sons[0], {@set}[sfStar]); - include(s.flags, sfGlobal); - end - else - s := semIdentVis(c, kind, n.sons[0], {@set}[]); - n.sons[namePos] := newSymNode(s); - oldP := c.p; // restore later - if sfStar in s.flags then include(s.flags, sfInInterface); - s.ast := n; - - pushOwner(s); - openScope(c.tab); - if n.sons[genericParamsPos] <> nil then begin - n.sons[genericParamsPos] := semGenericParamList(c, n.sons[genericParamsPos]); - gp := n.sons[genericParamsPos] - end - else - gp := newNodeI(nkGenericParams, n.info); - // process parameters: - if n.sons[paramsPos] <> nil then begin - semParamList(c, n.sons[ParamsPos], gp, s); - if sonsLen(gp) > 0 then n.sons[genericParamsPos] := gp; - addParams(c, s.typ.n); - end - else begin - s.typ := newTypeS(tyProc, c); - addSon(s.typ, nil); - end; - - proto := SearchForProc(c, s, c.tab.tos-2); // -2 because we have a scope open - // for parameters - if proto = nil then begin - if oldP.owner.kind <> skModule then // we are in a nested proc - s.typ.callConv := ccClosure - else - s.typ.callConv := lastOptionEntry(c).defaultCC; - // add it here, so that recursive procs are possible: - // -2 because we have a scope open for parameters - if kind in OverloadableSyms then - addInterfaceOverloadableSymAt(c, s, c.tab.tos-2) - else - addDeclAt(c, s, c.tab.tos-2); - if n.sons[pragmasPos] <> nil then - pragma(c, s, n.sons[pragmasPos], validPragmas) - end - else begin - if n.sons[pragmasPos] <> nil then - liMessage(n.sons[pragmasPos].info, errPragmaOnlyInHeaderOfProc); - 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 := proto.typ; - s := proto; - 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; - proto.ast := n; // needed for code generation - popOwner(); - pushOwner(s); - end; - - s.options := gOptions; - if n.sons[codePos] <> nil then begin - if [sfImportc, sfBorrow] * s.flags <> [] then - liMessage(n.sons[codePos].info, errImplOfXNotAllowed, s.name.s); - if (n.sons[genericParamsPos] = nil) then begin - c.p := newProcCon(s); - if (s.typ.sons[0] <> nil) and (kind <> skIterator) then - addResult(c, s.typ.sons[0], n.info); - n.sons[codePos] := semStmtScope(c, n.sons[codePos]); - if (s.typ.sons[0] <> nil) and (kind <> skIterator) then - addResultNode(c, n); - end - else begin - if (s.typ.sons[0] <> nil) and (kind <> skIterator) then - addDecl(c, newSym(skUnknown, getIdent('result'), nil)); - n.sons[codePos] := semGenericStmtScope(c, n.sons[codePos]); - end - end - else begin - if proto <> nil then - liMessage(n.info, errImplOfXexpected, proto.name.s); - if [sfImportc, sfBorrow] * s.flags = [] then Include(s.flags, sfForward) - else if sfBorrow in s.flags then - semBorrow(c, n, s); - end; - sideEffectsCheck(c, s); - closeScope(c.tab); // close scope for parameters - popOwner(); - c.p := oldP; // restore -end; - -function semIterator(c: PContext; n: PNode): PNode; -var - t: PType; - s: PSym; -begin - result := semProcAux(c, n, skIterator, iteratorPragmas); - s := result.sons[namePos].sym; - t := s.typ; - if t.sons[0] = nil then liMessage(n.info, errXNeedsReturnType, 'iterator'); - if n.sons[codePos] = nil then liMessage(n.info, errImplOfXexpected, s.name.s); -end; - -function semProc(c: PContext; n: PNode): PNode; -begin - result := semProcAux(c, n, skProc, procPragmas); -end; - -function semMethod(c: PContext; n: PNode): PNode; -begin - if not isTopLevel(c) then - liMessage(n.info, errXOnlyAtModuleScope, 'method'); - result := semProcAux(c, n, skMethod, methodPragmas); -end; - -function semConverterDef(c: PContext; n: PNode): PNode; -var - t: PType; - s: PSym; -begin - if not isTopLevel(c) then - liMessage(n.info, errXOnlyAtModuleScope, 'converter'); - checkSonsLen(n, codePos+1); - if n.sons[genericParamsPos] <> nil then - liMessage(n.info, errNoGenericParamsAllowedForX, 'converter'); - result := semProcAux(c, n, skConverter, converterPragmas); - s := result.sons[namePos].sym; - t := s.typ; - if t.sons[0] = nil then liMessage(n.info, errXNeedsReturnType, 'converter'); - if sonsLen(t) <> 2 then liMessage(n.info, errXRequiresOneArgument, 'converter'); - addConverter(c, s); -end; - -function semMacroDef(c: PContext; n: PNode): PNode; -var - t: PType; - s: PSym; -begin - checkSonsLen(n, codePos+1); - if n.sons[genericParamsPos] <> nil then - liMessage(n.info, errNoGenericParamsAllowedForX, 'macro'); - result := semProcAux(c, n, skMacro, macroPragmas); - s := result.sons[namePos].sym; - t := s.typ; - if t.sons[0] = nil then liMessage(n.info, errXNeedsReturnType, 'macro'); - if sonsLen(t) <> 2 then liMessage(n.info, errXRequiresOneArgument, 'macro'); - if n.sons[codePos] = nil then liMessage(n.info, errImplOfXexpected, s.name.s); -end; - -function evalInclude(c: PContext; n: PNode): PNode; -var - i, fileIndex: int; - f: 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]); - fileIndex := includeFilename(f); - if IntSetContainsOrIncl(c.includedFiles, fileIndex) then - liMessage(n.info, errRecursiveDependencyX, f); - addSon(result, semStmt(c, gIncludeFile(f))); - IntSetExcl(c.includedFiles, fileIndex); - 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 - // must be last statements in a block: - LastBlockStmts = {@set}[nkRaiseStmt, nkReturnStmt, nkBreakStmt, - nkContinueStmt]; -var - len, i, j: int; -begin - result := n; - if n = nil then exit; - if nfSem in n.flags then exit; - case n.kind of - nkAsgn: result := semAsgn(c, n); - nkCall, nkInfix, nkPrefix, nkPostfix, nkCommand, nkMacroStmt, nkCallStrLit: - result := semCommand(c, n); - nkEmpty, nkCommentStmt, nkNilLit: begin end; - nkBlockStmt: result := semBlock(c, n); - nkStmtList: begin - len := sonsLen(n); - for i := 0 to len-1 do begin - n.sons[i] := semStmt(c, n.sons[i]); - if (n.sons[i].kind in LastBlockStmts) then begin - for j := i+1 to len-1 do - case n.sons[j].kind of - nkPragma, nkCommentStmt, nkNilLit, nkEmpty: begin end; - else liMessage(n.sons[j].info, errStmtInvalidAfterReturn); - end - end - end - end; - nkRaiseStmt: result := semRaise(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); - 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); - nkPragma: pragma(c, c.p.owner, n, stmtPragmas); - nkIteratorDef: result := semIterator(c, n); - nkProcDef: result := semProc(c, n); - nkMethodDef: result := semMethod(c, n); - nkConverterDef: result := semConverterDef(c, n); - nkMacroDef: result := semMacroDef(c, n); - nkTemplateDef: result := semTemplateDef(c, n); - nkImportStmt: begin - if not isTopLevel(c) then - liMessage(n.info, errXOnlyAtModuleScope, 'import'); - result := evalImport(c, n); - end; - nkFromStmt: begin - if not isTopLevel(c) then - liMessage(n.info, errXOnlyAtModuleScope, 'from'); - result := evalFrom(c, n); - end; - nkIncludeStmt: begin - if not isTopLevel(c) then - liMessage(n.info, errXOnlyAtModuleScope, 'include'); - result := evalInclude(c, n); - end; - 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; -begin - openScope(c.tab); - result := semStmt(c, n); - closeScope(c.tab); -end; diff --git a/nim/semtempl.pas b/nim/semtempl.pas deleted file mode 100755 index fc7e12a73..000000000 --- a/nim/semtempl.pas +++ /dev/null @@ -1,270 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -function isExpr(n: PNode): bool; -// returns true if ``n`` looks like an expression -var - i: int; -begin - if n = nil then begin result := false; exit end; - case n.kind of - nkIdent..nkNilLit: result := true; - nkCall..nkPassAsOpenArray: begin - for i := 0 to sonsLen(n)-1 do - if not isExpr(n.sons[i]) then begin - result := false; exit - end; - result := true - end - else result := false - end -end; - -function isTypeDesc(n: PNode): bool; -// returns true if ``n`` looks like a type desc -var - i: int; -begin - if n = nil then begin result := false; exit end; - case n.kind of - nkIdent, nkSym, nkType: result := true; - nkDotExpr, nkBracketExpr: begin - for i := 0 to sonsLen(n)-1 do - if not isTypeDesc(n.sons[i]) then begin - result := false; exit - end; - result := true - end; - nkTypeOfExpr..nkEnumTy: result := true; - else result := false - end -end; - -function evalTemplateAux(c: PContext; templ, actual: PNode; sym: PSym): PNode; -var - i: int; - p: PSym; -begin - if templ = nil then begin result := nil; exit end; - case templ.kind of - nkSym: begin - p := templ.sym; - if (p.kind = skParam) and (p.owner.id = sym.id) then - result := copyTree(actual.sons[p.position]) - else - result := copyNode(templ) - end; - nkNone..nkIdent, nkType..nkNilLit: // atom - result := copyNode(templ); - else begin - result := copyNode(templ); - newSons(result, sonsLen(templ)); - for i := 0 to sonsLen(templ)-1 do - result.sons[i] := evalTemplateAux(c, templ.sons[i], actual, sym); - end - end -end; - -var - evalTemplateCounter: int = 0; // to prevend endless recursion in templates - // instantation - -function evalTemplateArgs(c: PContext; n: PNode; s: PSym): PNode; -var - f, a, i: int; - arg: PNode; -begin - f := sonsLen(s.typ); - // if the template has zero arguments, it can be called without ``()`` - // `n` is then a nkSym or something similar - case n.kind of - nkCall, nkInfix, nkPrefix, nkPostfix, nkCommand, nkCallStrLit: - a := sonsLen(n); - else a := 0 - end; - if a > f then liMessage(n.info, errWrongNumberOfArguments); - result := copyNode(n); - for i := 1 to f-1 do begin - if i < a then - arg := n.sons[i] - else - arg := copyTree(s.typ.n.sons[i].sym.ast); - if arg = nil then liMessage(n.info, errWrongNumberOfArguments); - if not (s.typ.sons[i].kind in [tyTypeDesc, tyStmt, tyExpr]) then begin - // concrete type means semantic checking for argument: - arg := fitNode(c, s.typ.sons[i], semExprWithType(c, arg)); - end; - addSon(result, arg); - end -end; - -function evalTemplate(c: PContext; n: PNode; sym: PSym): PNode; -var - args: PNode; -begin - inc(evalTemplateCounter); - if evalTemplateCounter > 100 then - liMessage(n.info, errTemplateInstantiationTooNested); - // replace each param by the corresponding node: - args := evalTemplateArgs(c, n, sym); - result := evalTemplateAux(c, sym.ast.sons[codePos], args, sym); - dec(evalTemplateCounter); -end; - -function symChoice(c: PContext; n: PNode; s: PSym): PNode; -var - a: PSym; - o: TOverloadIter; - i: int; -begin - i := 0; - a := initOverloadIter(o, c, n); - while a <> nil do begin - a := nextOverloadIter(o, c, n); - inc(i); - end; - if i <= 1 then begin - result := newSymNode(s); - result.info := n.info; - markUsed(n, s); - end - else begin - // semantic checking requires a type; ``fitNode`` deals with it - // appropriately - result := newNodeIT(nkSymChoice, n.info, newTypeS(tyNone, c)); - a := initOverloadIter(o, c, n); - while a <> nil do begin - addSon(result, newSymNode(a)); - a := nextOverloadIter(o, c, n); - end; - //liMessage(n.info, warnUser, s.name.s + ' is here symchoice'); - end -end; - -function resolveTemplateParams(c: PContext; n: PNode; withinBind: bool; - var toBind: TIntSet): PNode; -var - i: int; - s: PSym; -begin - if n = nil then begin result := nil; exit end; - case n.kind of - nkIdent: begin - if not withinBind and not IntSetContains(toBind, n.ident.id) then begin - s := SymTabLocalGet(c.Tab, n.ident); - if (s <> nil) then begin - result := newSymNode(s); - result.info := n.info - end - else - result := n - end - else begin - IntSetIncl(toBind, n.ident.id); - result := symChoice(c, n, lookup(c, n)) - end - end; - nkSym..nkNilLit: // atom - result := n; - nkBind: - result := resolveTemplateParams(c, n.sons[0], true, toBind); - else begin - result := n; - for i := 0 to sonsLen(n)-1 do - result.sons[i] := resolveTemplateParams(c, n.sons[i], withinBind, toBind); - end - end -end; - -function transformToExpr(n: PNode): PNode; -var - i, realStmt: int; -begin - result := n; - case n.kind of - nkStmtList: begin - realStmt := -1; - for i := 0 to sonsLen(n)-1 do begin - case n.sons[i].kind of - nkCommentStmt, nkEmpty, nkNilLit: begin end; - else begin - if realStmt = -1 then realStmt := i - else realStmt := -2 - end - end - end; - if realStmt >= 0 then - result := transformToExpr(n.sons[realStmt]) - else - n.kind := nkStmtListExpr; - end; - nkBlockStmt: n.kind := nkBlockExpr; - //nkIfStmt: n.kind := nkIfExpr; // this is not correct! - else begin end - end -end; - -function semTemplateDef(c: PContext; n: PNode): PNode; -var - s: PSym; - toBind: TIntSet; -begin - if c.p.owner.kind = skModule then begin - s := semIdentVis(c, skTemplate, n.sons[0], {@set}[sfStar]); - include(s.flags, sfGlobal); - end - else - s := semIdentVis(c, skTemplate, n.sons[0], {@set}[]); - if sfStar in s.flags then include(s.flags, sfInInterface); - // check parameter list: - pushOwner(s); - openScope(c.tab); - n.sons[namePos] := newSymNode(s); - - // check that no pragmas exist: - if n.sons[pragmasPos] <> nil then - liMessage(n.info, errNoPragmasAllowedForX, 'template'); - // check that no generic parameters exist: - if n.sons[genericParamsPos] <> nil then - liMessage(n.info, errNoGenericParamsAllowedForX, 'template'); - if (n.sons[paramsPos] = nil) then begin - // use ``stmt`` as implicit result type - s.typ := newTypeS(tyProc, c); - s.typ.n := newNodeI(nkFormalParams, n.info); - addSon(s.typ, newTypeS(tyStmt, c)); - addSon(s.typ.n, newNodeIT(nkType, n.info, s.typ.sons[0])); - end - else begin - semParamList(c, n.sons[ParamsPos], nil, s); - if n.sons[paramsPos].sons[0] = nil then begin - // use ``stmt`` as implicit result type - s.typ.sons[0] := newTypeS(tyStmt, c); - s.typ.n.sons[0] := newNodeIT(nkType, n.info, s.typ.sons[0]); - end - end; - addParams(c, s.typ.n); - - // resolve parameters: - IntSetInit(toBind); - n.sons[codePos] := resolveTemplateParams(c, n.sons[codePos], false, toBind); - if not (s.typ.sons[0].kind in [tyStmt, tyTypeDesc]) then - n.sons[codePos] := transformToExpr(n.sons[codePos]); - - // only parameters are resolved, no type checking is performed - closeScope(c.tab); - popOwner(); - s.ast := n; - - result := n; - if n.sons[codePos] = nil then - liMessage(n.info, errImplOfXexpected, s.name.s); - // add identifier of template as a last step to not allow - // recursive templates - addInterfaceDecl(c, s); -end; diff --git a/nim/semtypes.pas b/nim/semtypes.pas deleted file mode 100755 index e2a0d2185..000000000 --- a/nim/semtypes.pas +++ /dev/null @@ -1,874 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -// this module does the semantic checking of type declarations - -function fitNode(c: PContext; formal: PType; arg: PNode): PNode; -begin - result := IndexTypesMatch(c, formal, arg.typ, arg); - if result = nil then typeMismatch(arg, formal, arg.typ); -end; - -function newOrPrevType(kind: TTypeKind; prev: PType; c: PContext): PType; -begin - if prev = nil then - result := newTypeS(kind, c) - else begin - result := prev; - if result.kind = tyForward then result.kind := kind - end -end; - -function semEnum(c: PContext; n: PNode; prev: PType): PType; -var - i: int; - counter, x: BiggestInt; - e: PSym; - base: PType; - v: PNode; -begin - counter := 0; - base := nil; - result := newOrPrevType(tyEnum, prev, c); - 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); - if base.kind <> tyEnum then - liMessage(n.sons[0].info, errInheritanceOnlyWithEnums); - counter := lastOrd(base)+1; - end; - addSon(result, base); - for i := 1 to sonsLen(n)-1 do begin - case n.sons[i].kind of - nkEnumFieldDef: begin - e := newSymS(skEnumField, n.sons[i].sons[0], c); - v := semConstExpr(c, n.sons[i].sons[1]); - x := getOrdValue(v); - if i <> 1 then begin - if (x <> counter) then - include(result.flags, tfEnumHasWholes); - if x < counter then - liMessage(n.sons[i].info, errInvalidOrderInEnumX, e.name.s); - end; - counter := x; - end; - nkSym: e := n.sons[i].sym; - nkIdent: begin - e := newSymS(skEnumField, n.sons[i], c); - end; - else - illFormedAst(n); - end; - e.typ := result; - 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)); - addDeclAt(c, e, c.tab.tos-1); - inc(counter); - end; -end; - -function semSet(c: PContext; n: PNode; prev: PType): PType; -var - base: PType; -begin - result := newOrPrevType(tySet, prev, c); - if sonsLen(n) = 2 then begin - base := semTypeNode(c, n.sons[1], nil); - addSon(result, base); - if base.kind = tyGenericInst then base := lastSon(base); - if base.kind <> tyGenericParam then begin - if not isOrdinalType(base) then liMessage(n.info, errOrdinalTypeExpected); - if lengthOrd(base) > MaxSetElements then liMessage(n.info, errSetTooBig); - end - end - else - liMessage(n.info, errXExpectsOneTypeParam, 'set'); -end; - -function semContainer(c: PContext; n: PNode; - kind: TTypeKind; const kindStr: string; - prev: PType): PType; -var - base: PType; -begin - result := newOrPrevType(kind, prev, c); - if sonsLen(n) = 2 then begin - base := semTypeNode(c, n.sons[1], nil); - addSon(result, base); - end - else - liMessage(n.info, errXExpectsOneTypeParam, kindStr); -end; - -function semAnyRef(c: PContext; n: PNode; - kind: TTypeKind; const kindStr: string; prev: PType): PType; -var - base: PType; -begin - result := newOrPrevType(kind, prev, c); - if sonsLen(n) = 1 then begin - base := semTypeNode(c, n.sons[0], nil); - addSon(result, base); - end - else - liMessage(n.info, errXExpectsOneTypeParam, kindStr); -end; - -function semVarType(c: PContext; n: PNode; prev: PType): PType; -var - base: PType; -begin - result := newOrPrevType(tyVar, prev, c); - if sonsLen(n) = 1 then begin - base := semTypeNode(c, n.sons[0], nil); - if base.kind = tyVar then liMessage(n.info, errVarVarTypeNotAllowed); - addSon(result, base); - end - else - liMessage(n.info, errXExpectsOneTypeParam, 'var'); -end; - -function semDistinct(c: PContext; n: PNode; prev: PType): PType; -begin - result := newOrPrevType(tyDistinct, prev, c); - if sonsLen(n) = 1 then - addSon(result, semTypeNode(c, n.sons[0], nil)) - else - liMessage(n.info, errXExpectsOneTypeParam, 'distinct'); -end; - -function semRangeAux(c: PContext; n: PNode; prev: PType): PType; -var - a, b: PNode; -begin - if (n.kind <> nkRange) then InternalError(n.info, 'semRangeAux'); - checkSonsLen(n, 2); - result := newOrPrevType(tyRange, prev, c); - 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 - liMessage(n.info, errPureTypeMismatch); - if not (a.typ.kind in [tyInt..tyInt64, tyEnum, tyBool, tyChar, - tyFloat..tyFloat128]) then - liMessage(n.info, errOrdinalTypeExpected); - if enumHasWholes(a.typ) then - liMessage(n.info, errEnumXHasWholes, a.typ.sym.name.s); - if not leValue(a, b) then - liMessage(n.Info, errRangeIsEmpty); - addSon(result.n, a); - addSon(result.n, b); - addSon(result, b.typ); -end; - -function semRange(c: PContext; n: PNode; prev: PType): PType; -begin - result := nil; - if sonsLen(n) = 2 then begin - if n.sons[1].kind = nkRange then - result := semRangeAux(c, n.sons[1], prev) - else - liMessage(n.sons[0].info, errRangeExpected); - end - else - liMessage(n.info, errXExpectsOneTypeParam, 'range'); -end; - -function semArray(c: PContext; n: PNode; prev: PType): PType; -var - indx, base: PType; -begin - result := newOrPrevType(tyArray, prev, c); - if sonsLen(n) = 3 then begin // 3 = length(array indx base) - if n.sons[1].kind = nkRange then indx := semRangeAux(c, n.sons[1], nil) - else indx := semTypeNode(c, n.sons[1], nil); - addSon(result, indx); - if indx.kind = tyGenericInst then indx := lastSon(indx); - if indx.kind <> tyGenericParam then begin - if not isOrdinalType(indx) then - liMessage(n.sons[1].info, errOrdinalTypeExpected); - if enumHasWholes(indx) then - liMessage(n.sons[1].info, errEnumXHasWholes, indx.sym.name.s); - end; - base := semTypeNode(c, n.sons[2], nil); - addSon(result, base); - end - else - liMessage(n.info, errArrayExpectsTwoTypeParams); -end; - -function semOrdinal(c: PContext; n: PNode; prev: PType): PType; -var - base: PType; -begin - result := newOrPrevType(tyOrdinal, prev, c); - if sonsLen(n) = 2 then begin - base := semTypeNode(c, n.sons[1], nil); - if base.kind <> tyGenericParam then begin - if not isOrdinalType(base) then - liMessage(n.sons[1].info, errOrdinalTypeExpected); - end; - addSon(result, base); - end - else - liMessage(n.info, errXExpectsOneTypeParam, 'ordinal'); -end; - -function semTypeIdent(c: PContext; n: PNode): PSym; -begin - result := qualifiedLookup(c, n, true); - if (result <> nil) then begin - markUsed(n, result); - if result.kind <> skType then liMessage(n.info, errTypeExpected); - end - else - liMessage(n.info, errIdentifierExpected); -end; - -function semTuple(c: PContext; n: PNode; prev: PType): PType; -var - i, j, len, counter: int; - typ: PType; - check: TIntSet; - a: PNode; - field: PSym; -begin - result := newOrPrevType(tyTuple, prev, c); - result.n := newNodeI(nkRecList, n.info); - IntSetInit(check); - counter := 0; - for i := 0 to sonsLen(n)-1 do begin - a := n.sons[i]; - if (a.kind <> nkIdentDefs) then IllFormedAst(a); - checkMinSonsLen(a, 3); - len := sonsLen(a); - if a.sons[len-2] <> nil then - typ := semTypeNode(c, a.sons[len-2], nil) - else - liMessage(a.info, errTypeExpected); - if a.sons[len-1] <> nil then - liMessage(a.sons[len-1].info, errInitHereNotAllowed); - for j := 0 to len-3 do begin - field := newSymS(skField, a.sons[j], c); - field.typ := typ; - field.position := counter; - inc(counter); - if IntSetContainsOrIncl(check, field.name.id) then - liMessage(a.sons[j].info, errAttemptToRedefine, field.name.s); - addSon(result.n, newSymNode(field)); - addSon(result, typ); - end - end -end; - -function semGeneric(c: PContext; n: PNode; s: PSym; prev: PType): PType; -var - i: int; - elem: PType; - isConcrete: bool; -begin - if (s.typ = nil) or (s.typ.kind <> tyGenericBody) then - liMessage(n.info, errCannotInstantiateX, s.name.s); - result := newOrPrevType(tyGenericInvokation, prev, c); - if (s.typ.containerID = 0) then InternalError(n.info, 'semtypes.semGeneric'); - if sonsLen(n) <> sonsLen(s.typ) then - liMessage(n.info, errWrongNumberOfArguments); - addSon(result, s.typ); - isConcrete := true; - // iterate over arguments: - for i := 1 to sonsLen(n)-1 do begin - elem := semTypeNode(c, n.sons[i], nil); - if elem.kind = tyGenericParam then isConcrete := false; - addSon(result, elem); - end; - if isConcrete then begin - if s.ast = nil then liMessage(n.info, errCannotInstantiateX, s.name.s); - result := instGenericContainer(c, n, result); - end -end; - -function semIdentVis(c: PContext; kind: TSymKind; n: PNode; - const allowed: TSymFlags): PSym; -// identifier with visibility -var - v: PIdent; -begin - result := nil; - if n.kind = nkPostfix then begin - if (sonsLen(n) = 2) and (n.sons[0].kind = nkIdent) then begin - result := newSymS(kind, n.sons[1], c); - v := n.sons[0].ident; - if (sfStar in allowed) and (v.id = ord(wStar)) then - include(result.flags, sfStar) - else if (sfMinus in allowed) and (v.id = ord(wMinus)) then - include(result.flags, sfMinus) - else - liMessage(n.sons[0].info, errInvalidVisibilityX, v.s); - end - else - illFormedAst(n); - end - else - result := newSymS(kind, n, c); -end; - -function semIdentWithPragma(c: PContext; kind: TSymKind; - n: PNode; const allowed: TSymFlags): PSym; -begin - if n.kind = nkPragmaExpr then begin - checkSonsLen(n, 2); - result := semIdentVis(c, kind, n.sons[0], allowed); - case kind of - skType: begin - // process pragmas later, because result.typ has not been set yet - end; - skField: pragma(c, result, n.sons[1], fieldPragmas); - skVar: pragma(c, result, n.sons[1], varPragmas); - skConst: pragma(c, result, n.sons[1], constPragmas); - else begin end - end - end - else - result := semIdentVis(c, kind, n, allowed); -end; - -procedure checkForOverlap(c: PContext; t, ex: PNode; branchIndex: int); -var - j, i: int; -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 begin - //MessageOut(renderTree(t)); - liMessage(ex.info, errDuplicateCaseLabel); - end -end; - -procedure semBranchExpr(c: PContext; t: PNode; var ex: PNode); -begin - ex := semConstExpr(c, ex); - checkMinSonsLen(t, 1); - if (cmpTypes(t.sons[0].typ, ex.typ) <= isConvertible) then begin - typeMismatch(ex, t.sons[0].typ, ex.typ); - end; -end; - -procedure SemCaseBranch(c: PContext; t, branch: PNode; - branchIndex: int; var covered: biggestInt); -var - i: int; - b: PNode; -begin - for i := 0 to sonsLen(branch)-2 do begin - b := branch.sons[i]; - if b.kind = nkRange then 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 begin - //MessageOut(renderTree(t)); - liMessage(b.info, errRangeIsEmpty); - end; - covered := covered + getOrdValue(b.sons[1]) - getOrdValue(b.sons[0]) + 1; - end - else begin - semBranchExpr(c, t, branch.sons[i]); // NOT: `b`, because of var-param! - inc(covered); - end; - checkForOverlap(c, t, branch.sons[i], branchIndex) - end -end; - -procedure semRecordNodeAux(c: PContext; n: PNode; - var check: TIntSet; - var pos: int; father: PNode; - rectype: PSym); forward; - -procedure semRecordCase(c: PContext; n: PNode; - var check: TIntSet; - var pos: int; father: PNode; rectype: PSym); -var - i: int; - covered: biggestint; - chckCovered: boolean; - a, b: PNode; - typ: PType; -begin - a := copyNode(n); - checkMinSonsLen(n, 2); - semRecordNodeAux(c, n.sons[0], check, pos, a, rectype); - if a.sons[0].kind <> nkSym then - internalError('semRecordCase: dicriminant is no symbol'); - include(a.sons[0].sym.flags, sfDiscriminant); - covered := 0; - typ := skipTypes(a.sons[0].Typ, abstractVar); - if not isOrdinalType(typ) then - liMessage(n.info, errSelectorMustBeOrdinal); - if firstOrd(typ) < 0 then - liMessage(n.info, errOrdXMustNotBeNegative, a.sons[0].sym.name.s); - if lengthOrd(typ) > $7fff then - liMessage(n.info, errLenXinvalid, a.sons[0].sym.name.s); - chckCovered := true; - for i := 1 to sonsLen(n)-1 do begin - b := copyTree(n.sons[i]); - case n.sons[i].kind of - nkOfBranch: begin - checkMinSonsLen(b, 2); - semCaseBranch(c, a, b, i, covered); - end; - nkElse: begin - chckCovered := false; - checkSonsLen(b, 1); - end; - else illFormedAst(n); - end; - delSon(b, sonsLen(b)-1); - semRecordNodeAux(c, lastSon(n.sons[i]), check, pos, b, rectype); - addSon(a, b); - end; - if chckCovered and (covered <> lengthOrd(a.sons[0].typ)) then - liMessage(a.info, errNotAllCasesCovered); - addSon(father, a); -end; - -procedure semRecordNodeAux(c: PContext; n: PNode; var check: TIntSet; - var pos: int; father: PNode; rectype: PSym); -var - i, len: int; - f: PSym; // new field - a, it, e, branch: PNode; - typ: PType; -begin - if n = nil then exit; // BUGFIX: nil is possible - case n.kind of - nkRecWhen: begin - branch := nil; // the branch to take - for i := 0 to sonsLen(n)-1 do begin - it := n.sons[i]; - if it = nil then illFormedAst(n); - case it.kind of - nkElifBranch: begin - checkSonsLen(it, 2); - e := semConstExpr(c, it.sons[0]); - checkBool(e); - if (e.kind <> nkIntLit) then - InternalError(e.info, 'semRecordNodeAux'); - if (e.intVal <> 0) and (branch = nil) then - branch := it.sons[1] - end; - nkElse: begin - checkSonsLen(it, 1); - if branch = nil then branch := it.sons[0]; - end; - else illFormedAst(n) - end - end; - if branch <> nil then - semRecordNodeAux(c, branch, check, pos, father, rectype); - end; - 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 - else a := copyNode(n); - for i := 0 to sonsLen(n)-1 do begin - semRecordNodeAux(c, n.sons[i], check, pos, a, rectype); - end; - if a <> father then addSon(father, a); - end; - nkIdentDefs: begin - checkMinSonsLen(n, 3); - len := sonsLen(n); - 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 - liMessage(n.info, errTypeExpected); - typ := semTypeNode(c, n.sons[len-2], nil); - for i := 0 to sonsLen(n)-3 do begin - f := semIdentWithPragma(c, skField, n.sons[i], {@set}[sfStar, sfMinus]); - f.typ := typ; - f.position := pos; - if (rectype <> nil) - and ([sfImportc, sfExportc] * rectype.flags <> []) - and (f.loc.r = nil) then begin - f.loc.r := toRope(f.name.s); - f.flags := f.flags + ([sfImportc, sfExportc] * rectype.flags); - end; - inc(pos); - if IntSetContainsOrIncl(check, f.name.id) then - liMessage(n.sons[i].info, errAttemptToRedefine, f.name.s); - if a = nil then addSon(father, newSymNode(f)) - else addSon(a, newSymNode(f)) - end; - if a <> nil then addSon(father, a); - end; - else illFormedAst(n); - end -end; - -procedure addInheritedFieldsAux(c: PContext; var check: TIntSet; - var pos: int; n: PNode); -var - i: int; -begin - case n.kind of - nkRecCase: begin - 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 - nkOfBranch, nkElse: begin - addInheritedFieldsAux(c, check, pos, lastSon(n.sons[i])); - end; - else internalError(n.info, - 'addInheritedFieldsAux(record case branch)'); - end - end; - end; - nkRecList: begin - for i := 0 to sonsLen(n)-1 do begin - addInheritedFieldsAux(c, check, pos, n.sons[i]); - end; - end; - nkSym: begin - IntSetIncl(check, n.sym.name.id); - inc(pos); - end; - else - InternalError(n.info, 'addInheritedFieldsAux()'); - end; -end; - -procedure addInheritedFields(c: PContext; var check: TIntSet; var pos: int; - obj: PType); -begin - if (sonsLen(obj) > 0) and (obj.sons[0] <> nil) then - addInheritedFields(c, check, pos, obj.sons[0]); - addInheritedFieldsAux(c, check, pos, obj.n); -end; - -function semObjectNode(c: PContext; n: PNode; prev: PType): PType; -var - check: TIntSet; - base: PType; - pos: int; -begin - IntSetInit(check); - pos := 0; - // n.sons[0] contains the pragmas (if any). We process these later... - checkSonsLen(n, 3); - if n.sons[1] <> nil then begin - base := semTypeNode(c, n.sons[1].sons[0], nil); - if base.kind = tyObject then - addInheritedFields(c, check, pos, base) - else - liMessage(n.sons[1].info, errInheritanceOnlyWithNonFinalObjects); - end - else - base := nil; - if n.kind <> nkObjectTy then InternalError(n.info, 'semObjectNode'); - result := newOrPrevType(tyObject, prev, c); - addSon(result, base); - result.n := newNodeI(nkRecList, n.info); - semRecordNodeAux(c, n.sons[2], check, pos, result.n, result.sym); - if (base <> nil) and (tfFinal in base.flags) then - liMessage(n.sons[1].info, errInheritanceOnlyWithNonFinalObjects); -end; - -function addTypeVarsOfGenericBody(c: PContext; t: PType; genericParams: PNode; - var cl: TIntSet): PType; -var - i, L: int; - s: PSym; -begin - result := t; - if (t = nil) then exit; - if IntSetContainsOrIncl(cl, t.id) then exit; - case t.kind of - tyGenericBody: begin - result := newTypeS(tyGenericInvokation, c); - addSon(result, t); - for i := 0 to sonsLen(t)-2 do begin - if t.sons[i].kind <> tyGenericParam then - InternalError('addTypeVarsOfGenericBody'); - s := copySym(t.sons[i].sym); - s.position := sonsLen(genericParams); - addDecl(c, s); - addSon(genericParams, newSymNode(s)); - addSon(result, t.sons[i]); - end; - end; - tyGenericInst: begin - L := sonsLen(t)-1; - t.sons[L] := addTypeVarsOfGenericBody(c, t.sons[L], genericParams, cl); - end; - tyGenericInvokation: begin - for i := 1 to sonsLen(t)-1 do - t.sons[i] := addTypeVarsOfGenericBody(c, t.sons[i], genericParams, cl); - end - else begin - for i := 0 to sonsLen(t)-1 do - t.sons[i] := addTypeVarsOfGenericBody(c, t.sons[i], genericParams, cl); - end - end -end; - -function paramType(c: PContext; n, genericParams: PNode; - var cl: TIntSet): PType; -begin - result := semTypeNode(c, n, nil); - if (genericParams <> nil) and (sonsLen(genericParams) = 0) then - result := addTypeVarsOfGenericBody(c, result, genericParams, cl); -end; - -function semProcTypeNode(c: PContext; n, genericParams: PNode; - prev: PType): PType; -var - i, j, len, counter: int; - a, def, res: PNode; - typ: PType; - arg: PSym; - check, cl: TIntSet; -begin - checkMinSonsLen(n, 1); - result := newOrPrevType(tyProc, prev, c); - result.callConv := lastOptionEntry(c).defaultCC; - result.n := newNodeI(nkFormalParams, n.info); - if (genericParams <> nil) and (sonsLen(genericParams) = 0) then - IntSetInit(cl); - if n.sons[0] = nil then begin - addSon(result, nil); // return type - addSon(result.n, newNodeI(nkType, n.info)); // BUGFIX: nkType must exist! - // XXX but it does not, if n.sons[paramsPos] == nil? - end - else begin - addSon(result, nil); - res := newNodeI(nkType, n.info); - addSon(result.n, res); - end; - IntSetInit(check); - counter := 0; - for i := 1 to sonsLen(n)-1 do begin - a := n.sons[i]; - if (a.kind <> nkIdentDefs) then IllFormedAst(a); - checkMinSonsLen(a, 3); - len := sonsLen(a); - if a.sons[len-2] <> nil then - typ := paramType(c, a.sons[len-2], genericParams, cl) - else - typ := nil; - if a.sons[len-1] <> nil then begin - def := semExprWithType(c, a.sons[len-1]); - // check type compability between def.typ and typ: - if (typ <> nil) then begin - if (cmpTypes(typ, def.typ) < isConvertible) then begin - typeMismatch(a.sons[len-1], typ, def.typ); - end; - def := fitNode(c, typ, def); - end - else typ := def.typ; - end - else - def := nil; - for j := 0 to len-3 do begin - arg := newSymS(skParam, a.sons[j], c); - arg.typ := typ; - arg.position := counter; - inc(counter); - arg.ast := copyTree(def); - if IntSetContainsOrIncl(check, arg.name.id) then - liMessage(a.sons[j].info, errAttemptToRedefine, arg.name.s); - addSon(result.n, newSymNode(arg)); - addSon(result, typ); - end - end; - // NOTE: semantic checking of the result type needs to be done here! - if n.sons[0] <> nil then begin - result.sons[0] := paramType(c, n.sons[0], genericParams, cl); - res.typ := result.sons[0]; - 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; - t: PType; -begin - result := nil; - if n = nil then exit; - case n.kind of - nkTypeOfExpr: begin - result := semExprWithType(c, n, {@set}[efAllowType]).typ; - end; - nkPar: begin - if sonsLen(n) = 1 then result := semTypeNode(c, n.sons[0], prev) - else liMessage(n.info, errTypeExpected); - end; - nkBracketExpr: begin - checkMinSonsLen(n, 2); - s := semTypeIdent(c, n.sons[0]); - case s.magic of - mArray: result := semArray(c, n, prev); - mOpenArray: result := semContainer(c, n, tyOpenArray, 'openarray', prev); - mRange: result := semRange(c, n, prev); - mSet: result := semSet(c, n, prev); - mOrdinal: result := semOrdinal(c, n, prev); - mSeq: result := semContainer(c, n, tySequence, 'seq', prev); - else result := semGeneric(c, n, s, prev); - end - end; - nkIdent, nkDotExpr, nkAccQuoted: begin - s := semTypeIdent(c, n); - if s.typ = nil then - liMessage(n.info, errTypeExpected); - if prev = nil then - result := s.typ - else begin - assignType(prev, s.typ); - prev.id := s.typ.id; - result := prev; - end - end; - nkSym: begin - if (n.sym.kind = skType) and (n.sym.typ <> nil) then begin - t := n.sym.typ; - if prev = nil then - result := t - else begin - assignType(prev, t); - result := prev; - end; - markUsed(n, n.sym); - end - else - liMessage(n.info, errTypeExpected); - end; - nkObjectTy: result := semObjectNode(c, n, prev); - nkTupleTy: result := semTuple(c, n, prev); - nkRefTy: result := semAnyRef(c, n, tyRef, 'ref', prev); - nkPtrTy: result := semAnyRef(c, n, tyPtr, 'ptr', prev); - nkVarTy: result := semVarType(c, n, prev); - nkDistinctTy: result := semDistinct(c, n, prev); - nkProcTy: begin - checkSonsLen(n, 2); - result := semProcTypeNode(c, n.sons[0], nil, prev); - // dummy symbol for `pragma`: - s := newSymS(skProc, newIdentNode(getIdent('dummy'), n.info), c); - s.typ := result; - pragma(c, s, n.sons[1], procTypePragmas); - 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); - 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); - mExpr: setMagicType(m, tyExpr, 0); - mStmt: setMagicType(m, tyStmt, 0); - mTypeDesc: setMagicType(m, tyTypeDesc, 0); - mArray, mOpenArray, mRange, mSet, mSeq, mOrdinal: exit; - else liMessage(m.info, errTypeExpected); - end; - //registerSysType(m.typ); -end; diff --git a/nim/sigmatch.pas b/nim/sigmatch.pas deleted file mode 100755 index 45a29fc29..000000000 --- a/nim/sigmatch.pas +++ /dev/null @@ -1,964 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// - -// This module implements the signature matching for resolving -// the call to overloaded procs, generic procs and operators. - -type - TCandidateState = (csEmpty, csMatch, csNoMatch); - TCandidate = record - exactMatches: int; - subtypeMatches: int; - intConvMatches: int; // conversions to int are not as expensive - convMatches: int; - genericMatches: int; - state: TCandidateState; - callee: PType; // may not be nil! - calleeSym: PSym; // may be nil - call: PNode; // modified call - bindings: TIdTable; // maps sym-ids to types - baseTypeMatch: bool; // needed for conversions from T to openarray[T] - // for example - end; - TTypeRelation = (isNone, isConvertible, isIntConv, isSubtype, - isGeneric, isEqual); - // order is important! - -procedure initCandidate(out c: TCandidate; callee: PType); -begin - c.exactMatches := 0; - c.subtypeMatches := 0; - c.convMatches := 0; - c.intConvMatches := 0; - c.genericMatches := 0; - c.state := csEmpty; - c.callee := callee; - c.calleeSym := nil; - c.call := nil; - c.baseTypeMatch := false; - initIdTable(c.bindings); - //assert(c.callee <> nil); -end; - -procedure copyCandidate(var a: TCandidate; const b: TCandidate); -begin - a.exactMatches := b.exactMatches; - a.subtypeMatches := b.subtypeMatches; - a.convMatches := b.convMatches; - a.intConvMatches := b.intConvMatches; - a.genericMatches := b.genericMatches; - a.state := b.state; - a.callee := b.callee; - a.calleeSym := b.calleeSym; - a.call := copyTree(b.call); - a.baseTypeMatch := b.baseTypeMatch; - copyIdTable(a.bindings, b.bindings); -end; - -function cmpCandidates(const a, b: TCandidate): int; -begin - result := a.exactMatches - b.exactMatches; - if result <> 0 then exit; - result := a.genericMatches - b.genericMatches; - 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; - -procedure writeMatches(const c: TCandidate); -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; - -function getNotFoundError(c: PContext; n: PNode): string; -// Gives a detailed error message; this is seperated from semDirectCall, -// as semDirectCall is already pretty slow (and we need this information only -// in case of an error). -var - sym: PSym; - o: TOverloadIter; - i: int; - candidates: string; -begin - result := msgKindToString(errTypeMismatch); - for i := 1 to sonsLen(n)-1 do begin - //debug(n.sons[i].typ); - add(result, typeToString(n.sons[i].typ)); - if i <> sonsLen(n)-1 then add(result, ', '); - end; - addChar(result, ')'); - candidates := ''; - sym := initOverloadIter(o, c, n.sons[0]); - while sym <> nil do begin - if sym.kind in [skProc, skMethod, skIterator, skConverter] then begin - add(candidates, getProcHeader(sym)); - add(candidates, nl) - end; - sym := nextOverloadIter(o, c, n.sons[0]); - end; - if candidates <> '' then - add(result, nl +{&} msgKindToString(errButExpected) +{&} nl - +{&} candidates); -end; - -function typeRel(var mapping: TIdTable; f, a: PType): TTypeRelation; overload; - forward; - -function concreteType(const mapping: TIdTable; t: PType): PType; -begin - case t.kind of - tyArrayConstr: begin // make it an array - result := newType(tyArray, t.owner); - addSon(result, t.sons[0]); // XXX: t.owner is wrong for ID! - addSon(result, t.sons[1]); // XXX: semantic checking for the type? - end; - tyNil: result := nil; // what should it be? - tyGenericParam: begin - result := t; - while true do begin - result := PType(idTableGet(mapping, t)); - if result = nil then InternalError('lookup failed'); - if result.kind <> tyGenericParam then break - end - end; - else result := t // Note: empty is valid here - end -end; - -function handleRange(f, a: PType; min, max: TTypeKind): TTypeRelation; -var - k: TTypeKind; -begin - if a.kind = f.kind then - result := isEqual - else begin - k := skipTypes(a, {@set}[tyRange]).kind; - if k = f.kind then - result := isSubtype - 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 := skipTypes(a, {@set}[tyRange]).kind; - if k = f.kind then - result := isSubtype - else if (k >= tyFloat) and (k <= tyFloat128) then - result := isConvertible - else - result := isNone - end -end; - -function isObjectSubtype(a, f: PType): bool; -var - t: PType; -begin - t := a; - while (t <> nil) and (t.id <> f.id) do t := base(t); - result := t <> nil -end; - -function minRel(a, b: TTypeRelation): TTypeRelation; -begin - if a <= b then result := a else result := b -end; - -function tupleRel(var mapping: TIdTable; f, a: PType): TTypeRelation; -var - i: int; - x, y: PSym; - m: TTypeRelation; -begin - result := isNone; - if sonsLen(a) = sonsLen(f) then begin - result := isEqual; - for i := 0 to sonsLen(f)-1 do begin - m := typeRel(mapping, f.sons[i], a.sons[i]); - if m < isSubtype then begin result := isNone; exit end; - result := minRel(result, m); - end; - if (f.n <> nil) and (a.n <> nil) then begin - for i := 0 to sonsLen(f.n)-1 do begin - // check field names: - if f.n.sons[i].kind <> nkSym then InternalError(f.n.info, 'tupleRel'); - if a.n.sons[i].kind <> nkSym then InternalError(a.n.info, 'tupleRel'); - x := f.n.sons[i].sym; - y := a.n.sons[i].sym; - if x.name.id <> y.name.id then begin - result := isNone; exit - end - end - end - end -end; - -function typeRel(var mapping: TIdTable; f, a: PType): TTypeRelation; -var - x, concrete: PType; - i: Int; - m: TTypeRelation; -begin // is a subtype of f? - result := isNone; - assert(f <> nil); - assert(a <> nil); - if (a.kind = tyGenericInst) and not - (skipTypes(f, {@set}[tyVar]).kind in [tyGenericBody, tyGenericInvokation]) - then begin - result := typeRel(mapping, f, lastSon(a)); - exit - end; - if (a.kind = tyVar) and (f.kind <> tyVar) then begin - result := typeRel(mapping, f, a.sons[0]); - exit - end; - case f.kind of - tyEnum: begin - if (a.kind = f.kind) and (a.id = f.id) then result := isEqual - else if (skipTypes(a, {@set}[tyRange]).id = f.id) then result := isSubtype - end; - tyBool, tyChar: begin - if (a.kind = f.kind) then result := isEqual - else if skipTypes(a, {@set}[tyRange]).kind = f.kind then - result := isSubtype - end; - tyRange: begin - if (a.kind = f.kind) then begin - result := typeRel(mapping, base(a), base(f)); - if result < isGeneric then result := isNone - end - else if skipTypes(f, {@set}[tyRange]).kind = a.kind then - result := isConvertible // a convertible to f - end; - tyInt: result := handleRange(f, a, tyInt8, tyInt32); - 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 := 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 - result := typeRel(mapping, base(f), base(a)) - else - result := typeRel(mapping, base(f), a) - end; - tyArray, tyArrayConstr: begin // tyArrayConstr cannot happen really, but - // we wanna be safe here - case a.kind of - tyArray: begin - result := minRel(typeRel(mapping, f.sons[0], a.sons[0]), - typeRel(mapping, f.sons[1], a.sons[1])); - if result < isGeneric then result := isNone; - end; - tyArrayConstr: begin - result := typeRel(mapping, f.sons[1], a.sons[1]); - 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; - else begin end - end - end; - tyOpenArray: begin - case a.Kind of - tyOpenArray: begin - result := typeRel(mapping, base(f), base(a)); - if result < isGeneric then result := isNone - end; - tyArrayConstr: begin - 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: 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 (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 - end - end; - tySequence: begin - case a.Kind of - tyNil: result := isSubtype; - tySequence: 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 < isGeneric then result := isNone - end - end; - else begin end - end - end; - tyOrdinal: begin - if isOrdinalType(a) then begin - if a.kind = tyOrdinal then x := a.sons[0] else x := a; - result := typeRel(mapping, f.sons[0], x); - if result < isGeneric then result := isNone - end - end; - tyForward: InternalError('forward type in typeRel()'); - tyNil: begin - if a.kind = f.kind then result := isEqual - end; - tyTuple: begin - if a.kind = tyTuple then result := tupleRel(mapping, f, a); - end; - tyObject: begin - if a.kind = tyObject then begin - if a.id = f.id then result := isEqual - else if isObjectSubtype(a, f) then result := isSubtype - end - end; - tyDistinct: begin - if (a.kind = tyDistinct) and (a.id = f.id) then result := isEqual; - end; - tySet: begin - 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 - end - end; - tyPtr: begin - case a.kind of - tyPtr: begin - result := typeRel(mapping, base(f), base(a)); - if result <= isConvertible then result := isNone - end; - tyNil: result := isSubtype - else begin end - end - end; - tyRef: begin - case a.kind of - tyRef: begin - result := typeRel(mapping, base(f), base(a)); - if result <= isConvertible then result := isNone - end; - tyNil: result := isSubtype - else begin end - end - end; - tyProc: begin - case a.kind of - tyNil: result := isSubtype; - tyProc: begin - if (sonsLen(f) = sonsLen(a)) and (f.callconv = a.callconv) then begin - // Note: We have to do unification for the parameters before the - // return type! - result := isEqual; // start with maximum; also correct for no - // params at all - for i := 1 to sonsLen(f)-1 do begin - m := typeRel(mapping, f.sons[i], a.sons[i]); - if (m = isNone) and (typeRel(mapping, a.sons[i], - f.sons[i]) = isSubtype) then begin - // allow ``f.son`` as subtype of ``a.son``! - result := isConvertible; - end - else if m < isSubtype then begin - result := isNone; exit - end - else result := minRel(m, result) - end; - if f.sons[0] <> nil then begin - if a.sons[0] <> nil then begin - m := typeRel(mapping, f.sons[0], a.sons[0]); - // Subtype is sufficient for return types! - if m < isSubtype then result := isNone - else if m = isSubtype then result := isConvertible - else result := minRel(m, result) - end - else - result := isNone - end - else if a.sons[0] <> nil then - result := isNone; - if (tfNoSideEffect in f.flags) and not (tfNoSideEffect in a.flags) then - result := isNone - end - end - else begin end - end - end; - tyPointer: begin - case a.kind of - tyPointer: result := isEqual; - tyNil: result := isSubtype; - tyRef, tyPtr, tyProc, tyCString: result := isConvertible; - else begin end - end - end; - tyString: begin - case a.kind of - tyString: result := isEqual; - tyNil: result := isSubtype; - else begin end - end - end; - tyCString: begin - // conversion from string to cstring is automatic: - case a.Kind of - tyCString: result := isEqual; - tyNil: result := isSubtype; - tyString: result := isConvertible; - tyPtr: if a.sons[0].kind = tyChar then result := isConvertible; - tyArray: begin - if (firstOrd(a.sons[0]) = 0) - and (skipTypes(a.sons[0], {@set}[tyRange]).kind in [tyInt..tyInt64]) - and (a.sons[1].kind = tyChar) then - result := isConvertible; - end - else begin end - end - end; - - tyEmpty: begin - if a.kind = tyEmpty then result := isEqual; - end; - tyGenericInst: begin - result := typeRel(mapping, lastSon(f), a); - end; (* - tyGenericBody: begin - x := PType(idTableGet(mapping, f)); - if x = nil then begin - assert(f.containerID <> 0); - if (a.kind = tyGenericInst) and (f.containerID = a.containerID) and - (sonsLen(a) = sonsLen(f)) then begin - for i := 0 to sonsLen(f)-2 do begin - if typeRel(mapping, f.sons[i], a.sons[i]) < isGeneric then exit; - end; - result := isGeneric; - idTablePut(mapping, f, a); - end - end - else begin - result := typeRel(mapping, x, a) // check if it fits - end - end; *) - tyGenericBody: begin - result := typeRel(mapping, lastSon(f), a); - end; - tyGenericInvokation: begin - assert(f.sons[0].kind = tyGenericBody); - if a.kind = tyGenericInvokation then begin - InternalError('typeRel: tyGenericInvokation -> tyGenericInvokation'); - end; - if (a.kind = tyGenericInst) then begin - if (f.sons[0].containerID = a.sons[0].containerID) - and (sonsLen(a)-1 = sonsLen(f)) then begin - assert(a.sons[0].kind = tyGenericBody); - for i := 1 to sonsLen(f)-1 do begin - if a.sons[i].kind = tyGenericParam then begin - InternalError('wrong instantiated type!'); - end; - if typeRel(mapping, f.sons[i], a.sons[i]) < isGeneric then exit; - end; - result := isGeneric; - end (* - else begin - MessageOut('came here: ' + toString(sonsLen(f)) + ' ' + - toString(sonsLen(a)) + ' '+ - toString(f.sons[0].containerID) + ' '+ - toString(a.sons[0].containerID)); - end *) - end - else begin - result := typeRel(mapping, f.sons[0], a); - if result <> isNone then begin - // we steal the generic parameters from the tyGenericBody: - for i := 1 to sonsLen(f)-1 do begin - x := PType(idTableGet(mapping, f.sons[0].sons[i-1])); - if (x = nil) or (x.kind = tyGenericParam) then - InternalError('wrong instantiated type!'); - idTablePut(mapping, f.sons[i], x); - end - end - end - end; - tyGenericParam: begin - x := PType(idTableGet(mapping, f)); - if x = nil then begin - if sonsLen(f) = 0 then begin // no constraints - concrete := concreteType(mapping, a); - if concrete <> nil then begin - //MessageOut('putting: ' + f.sym.name.s); - idTablePut(mapping, f, concrete); - result := isGeneric - end; - end - else begin - InternalError(f.sym.info, 'has constraints: ' + f.sym.name.s); - // check constraints: - for i := 0 to sonsLen(f)-1 do begin - if typeRel(mapping, f.sons[i], a) >= isSubtype then begin - concrete := concreteType(mapping, a); - if concrete <> nil then begin - idTablePut(mapping, f, concrete); - result := isGeneric - end; - break - end - end - end - end - else if a.kind = tyEmpty then - result := isGeneric - else if x.kind = tyGenericParam then - result := isGeneric - else - result := typeRel(mapping, x, a) // check if it fits - end; - tyExpr, tyStmt, tyTypeDesc: begin - if a.kind = f.kind then result := isEqual - else - case a.kind of - tyExpr, tyStmt, tyTypeDesc: result := isGeneric; - tyNil: result := isSubtype; - else begin end - end - end; - else internalError('typeRel(' +{&} typeKindToStr[f.kind] +{&} ')'); - end -end; - -function cmpTypes(f, a: PType): TTypeRelation; -var - mapping: TIdTable; -begin - InitIdTable(mapping); - result := typeRel(mapping, f, a); -end; - -function getInstantiatedType(c: PContext; arg: PNode; const m: TCandidate; - f: PType): PType; -begin - result := PType(idTableGet(m.bindings, f)); - if result = nil then begin - result := generateTypeInstance(c, m.bindings, arg, f); - end; - if result = nil then InternalError(arg.info, 'getInstantiatedType'); -end; - -function implicitConv(kind: TNodeKind; f: PType; arg: PNode; - const m: TCandidate; c: PContext): PNode; -begin - result := newNodeI(kind, arg.info); - if containsGenericType(f) then - result.typ := getInstantiatedType(c, arg, m, f) - else - result.typ := f; - if result.typ = nil then InternalError(arg.info, 'implicitConv'); - addSon(result, nil); - addSon(result, arg); -end; - -function userConvMatch(c: PContext; var m: TCandidate; f, a: PType; - arg: PNode): PNode; -var - i: int; - src, dest: PType; - s: PNode; -begin - result := nil; - for i := 0 to length(c.converters)-1 do begin - src := c.converters[i].typ.sons[1]; - dest := c.converters[i].typ.sons[0]; - if (typeRel(m.bindings, f, dest) = isEqual) and - (typeRel(m.bindings, src, a) = isEqual) then begin - s := newSymNode(c.converters[i]); - s.typ := c.converters[i].typ; - s.info := arg.info; - result := newNodeIT(nkHiddenCallConv, arg.info, s.typ.sons[0]); - addSon(result, s); - addSon(result, copyTree(arg)); - inc(m.convMatches); - exit - end - end -end; - -function ParamTypesMatchAux(c: PContext; var m: TCandidate; f, a: PType; - arg: PNode): PNode; -var - r: TTypeRelation; -begin - r := typeRel(m.bindings, f, a); - case r of - isConvertible: 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); - end; - isGeneric: begin - inc(m.genericMatches); - result := copyTree(arg); - result.typ := getInstantiatedType(c, arg, m, f); - // BUG: f may not be the right key! - if (skipTypes(result.typ, abstractVar).kind in [tyTuple, tyOpenArray]) then - // BUGFIX: must pass length implicitely - result := implicitConv(nkHiddenStdConv, f, copyTree(arg), m, c); - // BUGFIX: use ``result.typ`` and not `f` here - end; - isEqual: begin - inc(m.exactMatches); - result := copyTree(arg); - if (skipTypes(f, abstractVar).kind in [tyTuple, tyOpenArray]) then - // BUGFIX: must pass length implicitely - result := implicitConv(nkHiddenStdConv, f, copyTree(arg), m, c); - end; - isNone: begin - result := userConvMatch(c, m, f, a, arg); - // check for a base type match, which supports openarray[T] without [] - // constructor in a call: - if (result = nil) and (f.kind = tyOpenArray) then begin - r := typeRel(m.bindings, base(f), a); - if r >= isGeneric then begin - inc(m.convMatches); - result := copyTree(arg); - if r = isGeneric then - result.typ := getInstantiatedType(c, arg, m, base(f)); - m.baseTypeMatch := true; - end - else - result := userConvMatch(c, m, base(f), a, arg); - end - end - end -end; - -function ParamTypesMatch(c: PContext; var m: TCandidate; f, a: PType; - arg: PNode): PNode; -var - i, cmp, best: int; - x, y, z: TCandidate; - r: TTypeRelation; -begin - if (arg = nil) or (arg.kind <> nkSymChoice) then begin - result := ParamTypesMatchAux(c, m, f, a, arg) - end - else begin - // CAUTION: The order depends on the used hashing scheme. Thus it is - // incorrect to simply use the first fitting match. However, to implement - // this correctly is inefficient. We have to copy `m` here to be able to - // roll back the side effects of the unification algorithm. - initCandidate(x, m.callee); - initCandidate(y, m.callee); - initCandidate(z, m.callee); - x.calleeSym := m.calleeSym; - y.calleeSym := m.calleeSym; - z.calleeSym := m.calleeSym; - best := -1; - for i := 0 to sonsLen(arg)-1 do begin - // iterators are not first class yet, so ignore them - if arg.sons[i].sym.kind in {@set}[skProc, skMethod, skConverter] then begin - copyCandidate(z, m); - r := typeRel(z.bindings, f, arg.sons[i].typ); - if r <> isNone then begin - case x.state of - csEmpty, csNoMatch: begin x := z; best := i; x.state := csMatch; end; - csMatch: begin - cmp := cmpCandidates(x, z); - if cmp < 0 then begin best := i; x := z end // z is better than x - else if cmp = 0 then y := z // z is as good as x - else begin end // z is worse than x - end - end - end - end - end; - if x.state = csEmpty then - result := nil - else if (y.state = csMatch) and (cmpCandidates(x, y) = 0) then begin - if x.state <> csMatch then InternalError(arg.info, 'x.state is not csMatch'); - // ambiguous: more than one symbol fits - result := nil - end - else begin - // only one valid interpretation found: - markUsed(arg, arg.sons[best].sym); - result := ParamTypesMatchAux(c, m, f, arg.sons[best].typ, arg.sons[best]); - end - end -end; - -function IndexTypesMatch(c: PContext; f, a: PType; arg: PNode): PNode; -var - m: TCandidate; -begin - initCandidate(m, f); - result := paramTypesMatch(c, m, f, a, arg) -end; - -procedure setSon(father: PNode; at: int; son: PNode); -begin - if sonsLen(father) <= at then - setLength(father.sons, at+1); - father.sons[at] := son; -end; - -procedure matches(c: PContext; n: PNode; var m: TCandidate); -var - f: int; // iterates over formal parameters - a: int; // iterates over the actual given arguments - formalLen: int; - marker: TIntSet; - container, arg: PNode; // constructed container - formal: PSym; -begin - f := 1; - a := 1; - m.state := csMatch; // until proven otherwise - m.call := newNodeI(nkCall, n.info); - m.call.typ := base(m.callee); // may be nil - formalLen := sonsLen(m.callee.n); - addSon(m.call, copyTree(n.sons[0])); - IntSetInit(marker); - container := nil; - formal := nil; - while a < sonsLen(n) do begin - if n.sons[a].kind = nkExprEqExpr then begin - // named param - // check if m.callee has such a param: - if n.sons[a].sons[0].kind <> nkIdent then begin - liMessage(n.sons[a].info, errNamedParamHasToBeIdent); - m.state := csNoMatch; - exit - end; - formal := getSymFromList(m.callee.n, n.sons[a].sons[0].ident, 1); - if formal = nil then begin - // no error message! - m.state := csNoMatch; - exit; - end; - if IntSetContainsOrIncl(marker, formal.position) then begin - // already in namedParams: - liMessage(n.sons[a].info, errCannotBindXTwice, formal.name.s); - m.state := csNoMatch; - exit - end; - m.baseTypeMatch := false; - arg := ParamTypesMatch(c, m, formal.typ, n.sons[a].typ, - n.sons[a].sons[1]); - if (arg = nil) then begin m.state := csNoMatch; exit end; - if m.baseTypeMatch then begin - assert(container = nil); - container := newNodeI(nkBracket, n.sons[a].info); - addSon(container, arg); - setSon(m.call, formal.position+1, container); - if f <> formalLen-1 then container := nil; - end - else begin - setSon(m.call, formal.position+1, arg); - end - end - else begin - // unnamed param - if f >= formalLen then begin // too many arguments? - if tfVarArgs in m.callee.flags then begin - // is ok... but don't increment any counters... - if skipTypes(n.sons[a].typ, abstractVar).kind = tyString then - // conversion to cstring - addSon(m.call, implicitConv(nkHiddenStdConv, - getSysType(tyCString), copyTree(n.sons[a]), m, c)) - else - addSon(m.call, copyTree(n.sons[a])); - end - else if formal <> nil then begin - m.baseTypeMatch := false; - arg := ParamTypesMatch(c, m, formal.typ, n.sons[a].typ, n.sons[a]); - if (arg <> nil) and m.baseTypeMatch and (container <> nil) then begin - addSon(container, arg); - end - else begin - m.state := csNoMatch; - exit - end; - end - else begin - m.state := csNoMatch; - exit - end - end - else begin - if m.callee.n.sons[f].kind <> nkSym then - InternalError(n.sons[a].info, 'matches'); - formal := m.callee.n.sons[f].sym; - if IntSetContainsOrIncl(marker, formal.position) then begin - // already in namedParams: - liMessage(n.sons[a].info, errCannotBindXTwice, formal.name.s); - m.state := csNoMatch; - exit - end; - m.baseTypeMatch := false; - arg := ParamTypesMatch(c, m, formal.typ, n.sons[a].typ, n.sons[a]); - if (arg = nil) then begin m.state := csNoMatch; exit end; - if m.baseTypeMatch then begin - assert(container = nil); - container := newNodeI(nkBracket, n.sons[a].info); - addSon(container, arg); - setSon(m.call, formal.position+1, - implicitConv(nkHiddenStdConv, formal.typ, container, m, c)); - if f <> formalLen-1 then container := nil; - end - else begin - setSon(m.call, formal.position+1, arg); - end - end - end; - inc(a); - inc(f); - end; - // iterate over all formal params and check all are provided: - f := 1; - while f < sonsLen(m.callee.n) do begin - formal := m.callee.n.sons[f].sym; - if not IntSetContainsOrIncl(marker, formal.position) then begin - if formal.ast = nil then begin // no default value - m.state := csNoMatch; break - end - else begin - // use default value: - setSon(m.call, formal.position+1, copyTree(formal.ast)); - end - end; - inc(f); - end -end; - -function sameMethodDispatcher(a, b: PSym): bool; -var - aa, bb: PNode; -begin - result := false; - if (a.kind = skMethod) and (b.kind = skMethod) then begin - aa := lastSon(a.ast); - bb := lastSon(b.ast); - if (aa.kind = nkSym) and (bb.kind = nkSym) and - (aa.sym = bb.sym) then result := true - end -end; - -function semDirectCall(c: PContext; n: PNode; filter: TSymKinds): PNode; -var - sym: PSym; - o: TOverloadIter; - x, y, z: TCandidate; - cmp: int; -begin - //liMessage(n.info, warnUser, renderTree(n)); - sym := initOverloadIter(o, c, n.sons[0]); - result := nil; - if sym = nil then exit; - initCandidate(x, sym.typ); - x.calleeSym := sym; - initCandidate(y, sym.typ); - y.calleeSym := sym; - while sym <> nil do begin - if sym.kind in filter then begin - initCandidate(z, sym.typ); - z.calleeSym := sym; - matches(c, n, z); - if z.state = csMatch then begin - case x.state of - csEmpty, csNoMatch: x := z; - csMatch: begin - cmp := cmpCandidates(x, z); - if cmp < 0 then x := z // z is better than x - else if cmp = 0 then y := z // z is as good as x - else begin end // z is worse than x - end - end - end - end; - sym := nextOverloadIter(o, c, n.sons[0]) - end; - if x.state = csEmpty then begin - // no overloaded proc found - // do not generate an error yet; the semantic checking will check for - // an overloaded () operator - end - else if (y.state = csMatch) and (cmpCandidates(x, y) = 0) - and not sameMethodDispatcher(x.calleeSym, y.calleeSym) then begin - if x.state <> csMatch then - InternalError(n.info, 'x.state is not csMatch'); - //writeMatches(x); - //writeMatches(y); - liMessage(n.Info, errGenerated, - format(msgKindToString(errAmbiguousCallXYZ), - [getProcHeader(x.calleeSym), - getProcHeader(y.calleeSym), x.calleeSym.Name.s])) - end - else begin - // only one valid interpretation found: - markUsed(n, x.calleeSym); - if x.calleeSym.ast = nil then - internalError(n.info, 'calleeSym.ast is nil'); // XXX: remove this check! - if x.calleeSym.ast.sons[genericParamsPos] <> nil then begin - // a generic proc! - x.calleeSym := generateInstance(c, x.calleeSym, x.bindings, n.info); - x.callee := x.calleeSym.typ; - end; - result := x.call; - result.sons[0] := newSymNode(x.calleeSym); - result.typ := x.callee.sons[0]; - end -end; diff --git a/nim/strutils.pas b/nim/strutils.pas deleted file mode 100755 index 96c07d365..000000000 --- a/nim/strutils.pas +++ /dev/null @@ -1,755 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit strutils; - -interface - -{$include 'config.inc'} - -uses - sysutils, nsystem; - -type - EInvalidFormatStr = class(Exception) - end; - -const - StrStart = 1; - -function normalize(const s: string): string; -function cmpIgnoreStyle(const x, y: string): int; -function cmp(const x, y: string): int; -function cmpIgnoreCase(const x, y: string): int; - -function format(const f: string; const args: array of string): string; -procedure addf(var result: string; const f: string; args: array of string); - -function toHex(x: BiggestInt; len: int): string; -function toOctal(value: Char): string; -function toOct(x: BiggestInt; len: int): string; -function toBin(x: BiggestInt; len: int): string; - - -procedure addChar(var s: string; c: Char); -function toInt(const s: string): int; -function toBiggestInt(const s: string): BiggestInt; - -function toString(i: BiggestInt): string; overload; - -//function toString(i: int): string; overload; -function ToStringF(const r: Real): string; overload; -function ToString(b: Boolean): string; overload; -function ToString(b: PChar): string; overload; - -function IntToStr(i: BiggestInt; minChars: int): string; - -function find(const s, sub: string; start: int = 1): int; overload; -function replace(const s, search, by: string): string; -procedure deleteStr(var s: string; first, last: int); - -function ToLower(const s: string): string; -function toUpper(c: Char): Char; overload; -function toUpper(s: string): string; overload; - -function parseInt(const s: string): int; -function parseBiggestInt(const s: string): BiggestInt; -function ParseFloat(const s: string; checkEnd: Boolean = True): Real; - -function repeatChar(count: int; c: Char = ' '): string; - -function split(const s: string; const seps: TCharSet): TStringSeq; - -function startsWith(const s, prefix: string): bool; -function endsWith(const s, postfix: string): bool; - -const - WhiteSpace = [' ', #9..#13]; - -function strip(const s: string; const chars: TCharSet = WhiteSpace): string; -function allCharsInSet(const s: string; const theSet: TCharSet): bool; - -function quoteIfContainsWhite(const s: string): string; -procedure addSep(var dest: string; sep: string = ', '); - -implementation - -procedure addSep(var dest: string; sep: string = ', '); -begin - if length(dest) > 0 then add(dest, sep) -end; - -function quoteIfContainsWhite(const s: string): string; -begin - if ((find(s, ' ') >= strStart) - or (find(s, #9) >= strStart)) and (s[strStart] <> '"') then - result := '"' +{&} s +{&} '"' - else - result := s -end; - -function allCharsInSet(const s: string; const theSet: TCharSet): bool; -var - i: int; -begin - for i := strStart to length(s)+strStart-1 do - if not (s[i] in theSet) then begin result := false; exit end; - result := true -end; - -function strip(const s: string; const chars: TCharSet = WhiteSpace): string; -var - a, b, last: int; -begin - a := strStart; - last := length(s) + strStart - 1; - while (a <= last) and (s[a] in chars) do inc(a); - b := last; - while (b >= strStart) and (s[b] in chars) do dec(b); - if a <= b then - result := ncopy(s, a, b) - else - result := ''; -end; - -function startsWith(const s, prefix: string): bool; -var - i, j: int; -begin - result := false; - if length(s) >= length(prefix) then begin - i := 1; - j := 1; - while (i <= length(s)) and (j <= length(prefix)) do begin - if s[i] <> prefix[j] then exit; - inc(i); - inc(j); - end; - result := j > length(prefix); - end -end; - -function endsWith(const s, postfix: string): bool; -var - i, j: int; -begin - result := false; - if length(s) >= length(postfix) then begin - i := length(s); - j := length(postfix); - while (i >= 1) and (j >= 1) do begin - if s[i] <> postfix[j] then exit; - dec(i); - dec(j); - end; - result := j = 0; - end -end; - -function split(const s: string; const seps: TCharSet): TStringSeq; -var - first, last, len: int; -begin - first := 1; - last := 1; - setLength(result, 0); - while last <= length(s) do begin - while (last <= length(s)) and (s[last] in seps) do inc(last); - first := last; - while (last <= length(s)) and not (s[last] in seps) do inc(last); - if first >= last-1 then begin - len := length(result); - setLength(result, len+1); - result[len] := ncopy(s, first, last-1); - end - end -end; - -function repeatChar(count: int; c: Char = ' '): string; -var - i: int; -begin - result := newString(count); - for i := strStart to count+strStart-1 do result[i] := c -end; - -function cmp(const x, y: string): int; -var - aa, bb: char; - a, b: PChar; - i, j: int; -begin - i := 0; - j := 0; - a := PChar(x); // this is correct even for x = '' - b := PChar(y); - repeat - aa := a[i]; - bb := b[j]; - result := ord(aa) - ord(bb); - if (result <> 0) or (aa = #0) then break; - inc(i); - inc(j); - until false -end; - -procedure deleteStr(var s: string; first, last: int); -begin - delete(s, first, last - first + 1); -end; - -function toUpper(c: Char): Char; -begin - if (c >= 'a') and (c <= 'z') then - result := Chr(Ord(c) - Ord('a') + Ord('A')) - else - result := c -end; - -function ToString(b: Boolean): string; -begin - if b then result := 'true' - else result := 'false' -end; - -function toOctal(value: Char): string; -var - i: int; - val: int; -begin - val := ord(value); - result := newString(3); - for i := strStart+2 downto strStart do begin - result[i] := Chr(val mod 8 + ord('0')); - val := val div 8 - end; -end; - -function ToLower(const s: string): string; -var - i: int; -begin - result := ''; - for i := strStart to length(s)+StrStart-1 do - if s[i] in ['A'..'Z'] then - result := result + Chr(Ord(s[i]) + Ord('a') - Ord('A')) - else - result := result + s[i] -end; - -function toUpper(s: string): string; -var - i: int; -begin - result := ''; - for i := strStart to length(s)+StrStart-1 do - if s[i] in ['a'..'z'] then - result := result + Chr(Ord(s[i]) - Ord('a') + Ord('A')) - else - result := result + s[i] -end; - -function find(const s, sub: string; start: int = 1): int; -var - i, j, M, N: int; -begin - M := length(sub); N := length(s); - i := start; j := 1; - if i > N then - result := 0 - else begin - repeat - if s[i] = sub[j] then begin - Inc(i); Inc(j); - end - else begin - i := i - j + 2; - j := 1 - end - until (j > M) or (i > N); - if j > M then result := i - M - else result := 0 - end -end; - -function replace(const s, search, by: string): string; -var - i, j: int; -begin - result := ''; - i := 1; - repeat - j := find(s, search, i); - if j = 0 then begin - // copy the rest: - result := result + copy(s, i, length(s) - i + 1); - break - end; - result := result + copy(s, i, j - i) + by; - i := j + length(search) - until false -end; - -function ToStringF(const r: Real): string; -var - i: int; -begin - result := sysutils.format('%g', [r]); - i := pos(',', result); - if i > 0 then result[i] := '.' // long standing bug! - else if (cmpIgnoreStyle(result, 'nan') = 0) then // BUGFIX - result := 'NAN' - else if (cmpIgnoreStyle(result, 'inf') = 0) or - (cmpIgnoreStyle(result, '+inf') = 0) then - // FPC 2.1.1 seems to write +Inf ..., so here we go - result := 'INF' - else if (cmpIgnoreStyle(result, '-inf') = 0) then - result := '-INF' // another BUGFIX - else if pos('.', result) = 0 then - result := result + '.0' -end; - -function toInt(const s: string): int; -var - code: int; -begin - Val(s, result, code) -end; - -function toHex(x: BiggestInt; len: int): string; -const - HexChars: array [0..$F] of Char = '0123456789ABCDEF'; -var - j: int; - mask, shift: BiggestInt; -begin - assert(len > 0); - SetLength(result, len); - mask := $F; - shift := 0; - for j := len + strStart-1 downto strStart do begin - result[j] := HexChars[(x and mask) shr shift]; - shift := shift + 4; - mask := mask shl 4; - end; -end; - -function toOct(x: BiggestInt; len: int): string; -var - j: int; - mask, shift: BiggestInt; -begin - assert(len > 0); - result := newString(len); - mask := 7; - shift := 0; - for j := len + strStart-1 downto strStart do begin - result[j] := chr(((x and mask) shr shift) + ord('0')); - shift := shift + 3; - mask := mask shl 3; - end; -end; - -function toBin(x: BiggestInt; len: int): string; -var - j: int; - mask, shift: BiggestInt; -begin - assert(len > 0); - result := newString(len); - mask := 1; - shift := 0; - for j := len + strStart-1 downto strStart do begin - result[j] := chr(((x and mask) shr shift) + ord('0')); - shift := shift + 1; - mask := mask shl 1; - end; -end; - -procedure addChar(var s: string; c: Char); -{@ignore} -// delphi produces suboptimal code for "s := s + c" -{$ifndef fpc} -var - len: int; -{$endif} -{@emit} -begin -{@ignore} -{$ifdef fpc} - s := s + c -{$else} - {$ifopt H+} - len := length(s); - setLength(s, len + 1); - PChar(Pointer(s))[len] := c - {$else} - s := s + c - {$endif} -{$endif} -{@emit - s &= c -} -end; - -function IntToStr(i: BiggestInt; minChars: int): string; -var - j: int; -begin - result := sysutils.IntToStr(i); - for j := 1 to minChars - length(result) do - result := '0' + result; -end; - -function toBiggestInt(const s: string): BiggestInt; -begin -{$ifdef dephi} - result := ''; - str(i : 1, result); -{$else} - result := StrToInt64(s); -{$endif} -end; - -function toString(i: BiggestInt): string; overload; -begin - result := sysUtils.intToStr(i); -end; - -function ToString(b: PChar): string; overload; -begin - result := string(b); -end; - -function normalize(const s: string): string; -var - i: int; -begin - result := ''; - for i := strStart to length(s)+StrStart-1 do - if s[i] in ['A'..'Z'] then - result := result + Chr(Ord(s[i]) + Ord('a') - Ord('A')) - else if s[i] <> '_' then - result := result + s[i] -end; - -function cmpIgnoreCase(const x, y: string): int; -var - aa, bb: char; - a, b: PChar; - i, j: int; -begin - i := 0; - j := 0; - a := PChar(x); // this is correct even for x = '' - b := PChar(y); - repeat - aa := a[i]; - bb := b[j]; - if aa in ['A'..'Z'] then aa := Chr(Ord(aa) + Ord('a') - Ord('A')); - if bb in ['A'..'Z'] then bb := Chr(Ord(bb) + Ord('a') - Ord('A')); - result := ord(aa) - ord(bb); - if (result <> 0) or (a[i] = #0) then break; - inc(i); - inc(j); - until false -end; - -function cmpIgnoreStyle(const x, y: string): int; -// this is a hotspot in the compiler! -// it took 14% of total runtime! -// So we optimize the heck out of it! -var - aa, bb: char; - a, b: PChar; - i, j: int; -begin - i := 0; - j := 0; - a := PChar(x); // this is correct even for x = '' - b := PChar(y); - repeat - while a[i] = '_' do inc(i); - while b[j] = '_' do inc(j); - aa := a[i]; - bb := b[j]; - if aa in ['A'..'Z'] then aa := Chr(Ord(aa) + Ord('a') - Ord('A')); - if bb in ['A'..'Z'] then bb := Chr(Ord(bb) + Ord('a') - Ord('A')); - result := ord(aa) - ord(bb); - if (result <> 0) or (a[i] = #0) then break; - inc(i); - inc(j); - until false -end; - -function find(const x: string; const inArray: array of string): int; overload; -var - i: int; - y: string; -begin - y := normalize(x); - i := 0; - while i < high(inArray) do begin - if y = normalize(inArray[i]) then begin - result := i; exit - end; - inc(i, 2); // increment by 2, else a security whole! - end; - result := -1 -end; - -procedure addf(var result: string; const f: string; args: array of string); -const - PatternChars = ['a'..'z', 'A'..'Z', '0'..'9', '_', #128..#255]; -var - i, j, x, num: int; -begin - i := 1; - num := 0; - while i <= length(f) do - if f[i] = '$' then begin - case f[i+1] of - '#': begin - inc(i, 2); - add(result, args[num]); - inc(num); - end; - '$': begin - addChar(result, '$'); - inc(i, 2); - end; - '1'..'9': begin - num := ord(f[i+1]) - ord('0'); - add(result, args[num - 1]); - inc(i, 2); - end; - '{': begin - j := i+1; - while (j <= length(f)) and (f[j] <> '}') do inc(j); - x := find(ncopy(f, i+2, j-1), args); - if (x >= 0) and (x < high(args)) then add(result, args[x+1]) - else raise EInvalidFormatStr.create(''); - i := j+1 - end; - 'a'..'z', 'A'..'Z', #128..#255, '_': begin - j := i+1; - while (j <= length(f)) and (f[j] in PatternChars) do inc(j); - x := find(ncopy(f, i+1, j-1), args); - if (x >= 0) and (x < high(args)) then add(result, args[x+1]) - else raise EInvalidFormatStr.create(ncopy(f, i+1, j-1)); - i := j - end - else raise EInvalidFormatStr.create(''); - end - end - else begin - addChar(result, f[i]); - inc(i) - end -end; - -function format(const f: string; const args: array of string): string; -begin - result := ''; - addf(result, f, args) -end; - -{@ignore} -{$ifopt Q-} {$Q+} -{$else} {$define Q_off} -{$endif} -{@emit} -// this must be compiled with overflow checking turned on: -function rawParseInt(const a: string; var index: int): BiggestInt; -// index contains the start position at proc entry; end position will be -// in index before the proc returns; index = -1 on error (no number at all) -var - i: int; - sign: BiggestInt; - s: string; -begin - s := a + #0; // to avoid the sucking range check errors - i := index; // a local i is more efficient than accessing an in out parameter - sign := 1; - if s[i] = '+' then inc(i) - else if s[i] = '-' then begin - inc(i); - sign := -1 - end; - - if s[i] in ['0'..'9'] then begin - result := 0; - while s[i] in ['0'..'9'] do begin - result := result * 10 + ord(s[i]) - ord('0'); - inc(i); - while s[i] = '_' do inc(i) // underscores are allowed and ignored - end; - result := result * sign; - index := i; // store index back - end - else begin - index := -1; - result := 0 - end -end; -{@ignore} -{$ifdef Q_off} -{$Q-} // turn it off again!!! -{$endif} -{@emit} - -function parseInt(const s: string): int; -var - index: int; - res: BiggestInt; -begin - index := strStart; - res := rawParseInt(s, index); - if index = -1 then - raise EInvalidValue.create('') -{$ifdef cpu32} - //else if (res < low(int)) or (res > high(int)) then - // raise EOverflow.create('') -{$endif} - else - result := int(res) // convert to smaller int type -end; - -function parseBiggestInt(const s: string): BiggestInt; -var - index: int; - res: BiggestInt; -begin - index := strStart; - result := rawParseInt(s, index); - if index = -1 then raise EInvalidValue.create('') -end; - -{@ignore} -{$ifopt Q+} {$Q-} -{$else} {$define Q_on} -{$endif} -{@emit} -// this function must be computed without overflow checking -function parseNimInt(const a: string): biggestInt; -var - i: int; -begin - i := StrStart; - result := rawParseInt(a, i); - if i = -1 then raise EInvalidValue.create(''); -end; - -function ParseFloat(const s: string; checkEnd: Boolean = True): Real; -var - hd, esign, sign: Real; - exponent, i, code: int; - flags: cardinal; -begin - result := 0.0; - code := 1; - exponent := 0; - esign := 1; - flags := 0; - sign := 1; - case s[code] of - '+': inc(code); - '-': begin - sign := -1; - 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; - result := result * 10.0 + toFloat(ord(s[code])-ord('0')); - inc(code); - while (code <= length(s)) and (s[code] = '_') do inc(code); - end; - { Decimal ? } - if (length(s) >= code) and (s[code] = '.') then begin - hd := 1.0; - inc(code); - while (length(s)>=code) and (s[code] in ['0'..'9']) do begin - { Read fractional part. } - flags := flags or 2; - result := result * 10.0 + toFloat(ord(s[code])-ord('0')); - hd := hd * 10.0; - inc(code); - while (code <= length(s)) and (s[code] = '_') do inc(code); - end; - result := result / hd; - end; - { Again, read int and fractional part } - if flags = 0 then - raise EInvalidValue.create('invalid float: ' + s); - { Exponent ? } - if (length(s) >= code) and (upcase(s[code]) = 'E') then begin - inc(code); - if Length(s) >= code then - if s[code] = '+' then - inc(code) - else - if s[code] = '-' then begin - esign := -1; - inc(code); - end; - if (length(s) < code) or not (s[code] in ['0'..'9']) then - raise EInvalidValue.create(''); - while (length(s) >= code) and (s[code] in ['0'..'9']) do begin - exponent := exponent * 10; - exponent := exponent + ord(s[code])-ord('0'); - inc(code); - while (code <= length(s)) and (s[code] = '_') do inc(code); - end; - end; - { Calculate Exponent } - hd := 1.0; - for i := 1 to exponent do hd := hd * 10.0; - if esign > 0 then - result := result * hd - else - result := result / hd; - { Not all characters are read ? } - if checkEnd and (length(s) >= code) then - raise EInvalidValue.create('invalid float: ' + s); - { evaluate sign } - result := result * sign; -end; - -{@ignore} -{$ifdef Q_on} -{$Q+} // turn it on again! -{$endif} -{@emit -@pop # overflowChecks -} - -end. diff --git a/nim/syntaxes.pas b/nim/syntaxes.pas deleted file mode 100755 index 158ab8ea2..000000000 --- a/nim/syntaxes.pas +++ /dev/null @@ -1,234 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit syntaxes; - -// Implements the dispatcher for the different parsers. -{$include 'config.inc'} - -interface - -uses - nsystem, strutils, llstream, ast, astalgo, idents, scanner, options, msgs, - pnimsyn, pbraces, ptmplsyn, filters, rnimsyn; - -type - TFilterKind = (filtNone, filtTemplate, filtReplace, filtStrip); - TParserKind = (skinStandard, skinBraces, skinEndX); - -const - parserNames: array [TParserKind] of string = ('standard', 'braces', 'endx'); - filterNames: array [TFilterKind] of string = ('none', 'stdtmpl', 'replace', - 'strip'); - -type - TParsers = record - skin: TParserKind; - parser: TParser; - end; - -{@ignore} -function ParseFile(const filename: string): PNode; -{@emit -function ParseFile(const filename: string): PNode; procvar; -} - -procedure openParsers(var p: TParsers; const filename: string; - inputstream: PLLStream); -procedure closeParsers(var p: TParsers); -function parseAll(var p: TParsers): PNode; - -function parseTopLevelStmt(var p: TParsers): 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: TParsers; - f: TBinaryFile; -begin - if not OpenFile(f, filename) then begin - rawMessage(errCannotOpenFile, filename); - exit - end; - OpenParsers(p, filename, LLStreamOpen(f)); - result := ParseAll(p); - CloseParsers(p); -end; - -function parseAll(var p: TParsers): PNode; -begin - case p.skin of - skinStandard: result := pnimsyn.parseAll(p.parser); - skinBraces: result := pbraces.parseAll(p.parser); - skinEndX: InternalError('parser to implement'); - // skinEndX: result := pendx.parseAll(p.parser); - end -end; - -function parseTopLevelStmt(var p: TParsers): PNode; -begin - case p.skin of - skinStandard: result := pnimsyn.parseTopLevelStmt(p.parser); - skinBraces: result := pbraces.parseTopLevelStmt(p.parser); - skinEndX: InternalError('parser to implement'); - //skinEndX: result := pendx.parseTopLevelStmt(p.parser); - end -end; - -function UTF8_BOM(const s: string): int; -begin - if (s[strStart] = #239) and (s[strStart+1] = #187) - and (s[strStart+2] = #191) then result := 3 - else result := 0 -end; - -function containsShebang(const s: string; i: int): bool; -var - j: int; -begin - result := false; - if (s[i] = '#') and (s[i+1] = '!') then begin - j := i+2; - while s[j] in WhiteSpace do inc(j); - result := s[j] = '/' - end -end; - -function parsePipe(const filename: string; inputStream: PLLStream): PNode; -var - line: string; - s: PLLStream; - i: int; - q: TParser; -begin - result := nil; - s := LLStreamOpen(filename, fmRead); - if s <> nil then begin - line := LLStreamReadLine(s) {@ignore} + #0 {@emit}; - i := UTF8_Bom(line) + strStart; - if containsShebang(line, i) then begin - line := LLStreamReadLine(s) {@ignore} + #0 {@emit}; - i := strStart; - end; - if (line[i] = '#') and (line[i+1] = '!') then begin - inc(i, 2); - while line[i] in WhiteSpace do inc(i); - OpenParser(q, filename, LLStreamOpen(ncopy(line, i))); - result := pnimsyn.parseAll(q); - CloseParser(q); - end; - LLStreamClose(s); - end -end; - -function getFilter(ident: PIdent): TFilterKind; -var - i: TFilterKind; -begin - for i := low(TFilterKind) to high(TFilterKind) do - if IdentEq(ident, filterNames[i]) then begin - result := i; exit - end; - result := filtNone -end; - -function getParser(ident: PIdent): TParserKind; -var - i: TParserKind; -begin - for i := low(TParserKind) to high(TParserKind) do - if IdentEq(ident, parserNames[i]) then begin - result := i; exit - end; - rawMessage(errInvalidDirectiveX, ident.s); -end; - -function getCallee(n: PNode): PIdent; -begin - if (n.kind = nkCall) and (n.sons[0].kind = nkIdent) then - result := n.sons[0].ident - else if n.kind = nkIdent then result := n.ident - else rawMessage(errXNotAllowedHere, renderTree(n)); -end; - -function applyFilter(var p: TParsers; n: PNode; const filename: string; - input: PLLStream): PLLStream; -var - ident: PIdent; - f: TFilterKind; -begin - ident := getCallee(n); - f := getFilter(ident); - case f of - filtNone: begin - p.skin := getParser(ident); - result := input - end; - filtTemplate: result := filterTmpl(input, filename, n); - filtStrip: result := filterStrip(input, filename, n); - filtReplace: result := filterReplace(input, filename, n); - end; - if f <> filtNone then begin - if gVerbosity >= 2 then begin - rawMessage(hintCodeBegin); - messageOut(result.s); - rawMessage(hintCodeEnd); - end - end -end; - -function evalPipe(var p: TParsers; n: PNode; const filename: string; - start: PLLStream): PLLStream; -var - i: int; -begin - result := start; - if n = nil then exit; - if (n.kind = nkInfix) and (n.sons[0].kind = nkIdent) - and IdentEq(n.sons[0].ident, '|'+'') then begin - for i := 1 to 2 do begin - if n.sons[i].kind = nkInfix then - result := evalPipe(p, n.sons[i], filename, result) - else - result := applyFilter(p, n.sons[i], filename, result) - end - end - else if n.kind = nkStmtList then - result := evalPipe(p, n.sons[0], filename, result) - else - result := applyFilter(p, n, filename, result) -end; - -procedure openParsers(var p: TParsers; const filename: string; - inputstream: PLLStream); -var - pipe: PNode; - s: PLLStream; -begin - p.skin := skinStandard; - pipe := parsePipe(filename, inputStream); - if pipe <> nil then - s := evalPipe(p, pipe, filename, inputStream) - else - s := inputStream; - case p.skin of - skinStandard, skinBraces, skinEndX: - pnimsyn.openParser(p.parser, filename, s); - end -end; - -procedure closeParsers(var p: TParsers); -begin - pnimsyn.closeParser(p.parser); -end; - -end. diff --git a/nim/tigen.pas b/nim/tigen.pas deleted file mode 100755 index 687b70920..000000000 --- a/nim/tigen.pas +++ /dev/null @@ -1,47 +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 tigen; - -// Type information generator. It transforms types into the AST of walker -// procs. This is used by the code generators. - -interface - -{$include 'config.inc'} - -uses - nsystem, ast, astalgo, strutils, nhashes, trees, treetab, platform, magicsys, - options, msgs, crc, idents, lists, types, rnimsyn; - -function gcWalker(t: PType): PNode; -function initWalker(t: PType): PNode; -function asgnWalker(t: PType): PNode; -function reprWalker(t: PType): PNode; - -implementation - -function gcWalker(t: PType): PNode; -begin -end; - -function initWalker(t: PType): PNode; -begin -end; - -function asgnWalker(t: PType): PNode; -begin -end; - -function reprWalker(t: PType): PNode; -begin -end; - -end. - diff --git a/nim/transf.pas b/nim/transf.pas deleted file mode 100755 index a0f07d51d..000000000 --- a/nim/transf.pas +++ /dev/null @@ -1,964 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// 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 -// * inlines constants -// * performes contant folding -// * introduces nkHiddenDeref, nkHiddenSubConv, etc. -// * introduces method dispatchers - -interface - -{$include 'config.inc'} - -uses - sysutils, nsystem, charsets, strutils, - lists, options, ast, astalgo, trees, treetab, evals, - msgs, nos, idents, rnimsyn, types, passes, semfold, magicsys, cgmeth; - -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 newTransCon(): PTransCon; -begin - 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 getCurrOwner(c: PTransf): PSym; -begin - if c.transCon <> nil then result := c.transCon.owner - else result := c.module; -end; - -function newTemp(c: PTransf; typ: PType; const info: TLineInfo): PSym; -begin - result := newSym(skTemp, getIdent(genPrefix), getCurrOwner(c)); - result.info := info; - result.typ := skipTypes(typ, {@set}[tyGenericInst]); - include(result.flags, sfFromGeneric); -end; - -// -------------------------------------------------------------------------- - -function transform(c: PTransf; n: PNode): PNode; forward; - -(* - -Transforming iterators into non-inlined versions is pretty hard, but -unavoidable for not bloating the code too much. If we had direct access to -the program counter, things'd be much easier. -:: - - iterator items(a: string): char = - var i = 0 - while i < length(a): - yield a[i] - inc(i) - - for ch in items("hello world"): # `ch` is an iteration variable - echo(ch) - -Should be transformed into:: - - type - TItemsClosure = record - i: int - state: int - proc items(a: string, c: var TItemsClosure): char = - case c.state - of 0: goto L0 # very difficult without goto! - of 1: goto L1 # can be implemented by GCC's computed gotos - - block L0: - c.i = 0 - while c.i < length(a): - c.state = 1 - return a[i] - block L1: inc(c.i) - -More efficient, but not implementable:: - - type - TItemsClosure = record - i: int - pc: pointer - - proc items(a: string, c: var TItemsClosure): char = - goto c.pc - c.i = 0 - while c.i < length(a): - c.pc = label1 - return a[i] - label1: inc(c.i) -*) - -function newAsgnStmt(c: PTransf; le, ri: PNode): PNode; -begin - result := newNodeI(nkFastAsgn, ri.info); - addSon(result, le); - addSon(result, ri); -end; - -function transformSym(c: PTransf; n: PNode): PNode; -var - tc: PTransCon; - b: PNode; -begin - if (n.kind <> nkSym) then internalError(n.info, 'transformSym'); - tc := c.transCon; - if sfBorrow in n.sym.flags then begin - // simply exchange the symbol: - b := n.sym.ast.sons[codePos]; - if b.kind <> nkSym then - internalError(n.info, 'wrong AST for borrowed symbol'); - b := newSymNode(b.sym); - b.info := n.info; - end - else - b := n; - //writeln('transformSym', n.sym.id : 5); - while tc <> nil do begin - result := IdNodeTableGet(tc.mapping, b.sym); - if result <> nil then exit; - //write('not found in: '); - //writeIdNodeTable(tc.mapping); - tc := tc.next - end; - result := b; - case b.sym.kind of - skConst, skEnumField: begin // BUGFIX: skEnumField was missing - if not (skipTypes(b.sym.typ, abstractInst).kind in ConstantDataTypes) then begin - result := getConstExpr(c.module, b); - if result = nil then InternalError(b.info, 'transformSym: const'); - end - end - else begin end - end -end; - -procedure transformContinueAux(c: PTransf; n: PNode; labl: PSym; - var counter: int); -var - i: int; -begin - if n = nil then exit; - case n.kind of - nkEmpty..nkNilLit, nkForStmt, nkWhileStmt: begin end; - nkContinueStmt: begin - n.kind := nkBreakStmt; - addSon(n, newSymNode(labl)); - inc(counter); - end; - else begin - for i := 0 to sonsLen(n)-1 do - transformContinueAux(c, n.sons[i], labl, counter); - end - end -end; - -function transformContinue(c: PTransf; n: PNode): PNode; -// we transform the continue statement into a block statement -var - i, counter: int; - x: PNode; - labl: PSym; -begin - result := n; - for i := 0 to sonsLen(n)-1 do - result.sons[i] := transform(c, n.sons[i]); - counter := 0; - labl := newSym(skLabel, nil, getCurrOwner(c)); - labl.name := getIdent(genPrefix +{&} ToString(labl.id)); - labl.info := result.info; - transformContinueAux(c, result, labl, counter); - if counter > 0 then begin - x := newNodeI(nkBlockStmt, result.info); - addSon(x, newSymNode(labl)); - addSon(x, result); - result := x - end -end; - -function skipConv(n: PNode): PNode; -begin - case n.kind of - nkObjUpConv, nkObjDownConv, nkPassAsOpenArray, nkChckRange, - nkChckRangeF, nkChckRange64: - result := n.sons[0]; - nkHiddenStdConv, nkHiddenSubConv, nkConv: result := n.sons[1]; - else result := n - end -end; - -function newTupleAccess(tup: PNode; i: int): PNode; -var - lit: PNode; -begin - result := newNodeIT(nkBracketExpr, tup.info, tup.typ.sons[i]); - addSon(result, copyTree(tup)); - lit := newNodeIT(nkIntLit, tup.info, getSysType(tyInt)); - lit.intVal := i; - addSon(result, lit); -end; - -procedure unpackTuple(c: PTransf; n, father: PNode); -var - i: int; -begin - // XXX: BUG: what if `n` is an expression with side-effects? - for i := 0 to sonsLen(n)-1 do begin - addSon(father, newAsgnStmt(c, c.transCon.forStmt.sons[i], - transform(c, newTupleAccess(n, i)))); - end -end; - -function transformYield(c: PTransf; n: PNode): PNode; -var - e: PNode; - i: int; -begin - result := newNodeI(nkStmtList, n.info); - e := n.sons[0]; - if skipTypes(e.typ, {@set}[tyGenericInst]).kind = tyTuple then begin - e := skipConv(e); - if e.kind = nkPar then begin - for i := 0 to sonsLen(e)-1 do begin - addSon(result, newAsgnStmt(c, c.transCon.forStmt.sons[i], - transform(c, copyTree(e.sons[i])))); - end - end - else - unpackTuple(c, e, result); - end - else begin - e := transform(c, copyTree(e)); - addSon(result, newAsgnStmt(c, c.transCon.forStmt.sons[0], e)); - end; - // add body of the for loop: - addSon(result, transform(c, lastSon(c.transCon.forStmt))); -end; - -function inlineIter(c: PTransf; n: PNode): PNode; -var - i, j, L: int; - it: PNode; - newVar: PSym; -begin - result := n; - if n = nil then exit; - case n.kind of - nkEmpty..nkNilLit: begin - result := transform(c, copyTree(n)); - end; - nkYieldStmt: result := transformYield(c, n); - nkVarSection: begin - result := copyTree(n); - for i := 0 to sonsLen(result)-1 do begin - it := result.sons[i]; - if it.kind = nkCommentStmt then continue; - if it.kind = nkIdentDefs then begin - if (it.sons[0].kind <> nkSym) then - InternalError(it.info, 'inlineIter'); - newVar := copySym(it.sons[0].sym); - include(newVar.flags, sfFromGeneric); - // fixes a strange bug for rodgen: - //include(it.sons[0].sym.flags, sfFromGeneric); - newVar.owner := getCurrOwner(c); - IdNodeTablePut(c.transCon.mapping, it.sons[0].sym, newSymNode(newVar)); - it.sons[0] := newSymNode(newVar); - it.sons[2] := transform(c, it.sons[2]); - end - else begin - if it.kind <> nkVarTuple then - InternalError(it.info, 'inlineIter: not nkVarTuple'); - L := sonsLen(it); - for j := 0 to L-3 do begin - newVar := copySym(it.sons[j].sym); - include(newVar.flags, sfFromGeneric); - newVar.owner := getCurrOwner(c); - IdNodeTablePut(c.transCon.mapping, it.sons[j].sym, - newSymNode(newVar)); - it.sons[j] := newSymNode(newVar); - end; - assert(it.sons[L-2] = nil); - it.sons[L-1] := transform(c, it.sons[L-1]); - end - end - end - else begin - result := copyNode(n); - for i := 0 to sonsLen(n)-1 do addSon(result, inlineIter(c, n.sons[i])); - result := transform(c, result); - end - end -end; - -procedure addVar(father, v: PNode); -var - vpart: PNode; -begin - vpart := newNodeI(nkIdentDefs, v.info); - addSon(vpart, v); - addSon(vpart, nil); - addSon(vpart, nil); - addSon(father, vpart); -end; - -function transformAddrDeref(c: PTransf; n: PNode; a, b: TNodeKind): PNode; -var - m: PNode; -begin - case n.sons[0].kind of - nkObjUpConv, nkObjDownConv, nkPassAsOpenArray, nkChckRange, - nkChckRangeF, nkChckRange64: begin - m := n.sons[0].sons[0]; - if (m.kind = a) or (m.kind = b) then begin - // addr ( nkPassAsOpenArray ( deref ( x ) ) ) --> nkPassAsOpenArray(x) - n.sons[0].sons[0] := m.sons[0]; - result := transform(c, n.sons[0]); - exit - end - end; - nkHiddenStdConv, nkHiddenSubConv, nkConv: begin - m := n.sons[0].sons[1]; - if (m.kind = a) or (m.kind = b) then begin - // addr ( nkConv ( deref ( x ) ) ) --> nkConv(x) - n.sons[0].sons[1] := m.sons[0]; - result := transform(c, n.sons[0]); - exit - end - end; - else begin - if (n.sons[0].kind = a) or (n.sons[0].kind = b) then begin - // addr ( deref ( x )) --> x - result := transform(c, n.sons[0].sons[0]); - exit - end - end - end; - n.sons[0] := transform(c, n.sons[0]); - result := n; -end; - -function transformConv(c: PTransf; n: PNode): PNode; -var - source, dest: PType; - diff: int; -begin - n.sons[1] := transform(c, n.sons[1]); - result := n; - // numeric types need range checks: - dest := skipTypes(n.typ, abstractVarRange); - source := skipTypes(n.sons[1].typ, abstractVarRange); - case dest.kind of - tyInt..tyInt64, tyEnum, tyChar, tyBool: begin - if (firstOrd(dest) <= firstOrd(source)) and - (lastOrd(source) <= lastOrd(dest)) then begin - // BUGFIX: simply leave n as it is; we need a nkConv node, - // but no range check: - result := n; - end - else begin // generate a range check: - if (dest.kind = tyInt64) or (source.kind = tyInt64) then - result := newNodeIT(nkChckRange64, n.info, n.typ) - else - result := newNodeIT(nkChckRange, n.info, n.typ); - dest := skipTypes(n.typ, abstractVar); - addSon(result, n.sons[1]); - addSon(result, newIntTypeNode(nkIntLit, firstOrd(dest), source)); - addSon(result, newIntTypeNode(nkIntLit, lastOrd(dest), source)); - end - end; - tyFloat..tyFloat128: begin - if skipTypes(n.typ, abstractVar).kind = tyRange then begin - result := newNodeIT(nkChckRangeF, n.info, n.typ); - dest := skipTypes(n.typ, abstractVar); - addSon(result, n.sons[1]); - addSon(result, copyTree(dest.n.sons[0])); - addSon(result, copyTree(dest.n.sons[1])); - end - end; - tyOpenArray: begin - result := newNodeIT(nkPassAsOpenArray, n.info, n.typ); - addSon(result, n.sons[1]); - end; - tyCString: begin - if source.kind = tyString then begin - result := newNodeIT(nkStringToCString, n.info, n.typ); - addSon(result, n.sons[1]); - end; - end; - tyString: begin - if source.kind = tyCString then begin - result := newNodeIT(nkCStringToString, n.info, n.typ); - addSon(result, n.sons[1]); - end; - end; - tyRef, tyPtr: begin - dest := skipTypes(dest, abstractPtrs); - source := skipTypes(source, abstractPtrs); - if source.kind = tyObject then begin - diff := inheritanceDiff(dest, source); - if diff < 0 then begin - result := newNodeIT(nkObjUpConv, n.info, n.typ); - addSon(result, n.sons[1]); - end - else if diff > 0 then begin - result := newNodeIT(nkObjDownConv, n.info, n.typ); - addSon(result, n.sons[1]); - end - else result := n.sons[1]; - end - end; - // conversions between different object types: - tyObject: begin - diff := inheritanceDiff(dest, source); - if diff < 0 then begin - result := newNodeIT(nkObjUpConv, n.info, n.typ); - addSon(result, n.sons[1]); - end - else if diff > 0 then begin - result := newNodeIT(nkObjDownConv, n.info, n.typ); - addSon(result, n.sons[1]); - end - else result := n.sons[1]; - end; (* - tyArray, tySeq: begin - if skipGeneric(dest - end; *) - tyGenericParam, tyOrdinal: result := n.sons[1]; - // happens sometimes for generated assignments, etc. - else begin end - end; -end; - -function skipPassAsOpenArray(n: PNode): PNode; -begin - result := n; - while result.kind = nkPassAsOpenArray do result := result.sons[0] -end; - -type - TPutArgInto = (paDirectMapping, paFastAsgn, paVarAsgn); - -function putArgInto(arg: PNode; formal: PType): TPutArgInto; -// This analyses how to treat the mapping "formal <-> arg" in an -// inline context. -var - i: int; -begin - if skipTypes(formal, abstractInst).kind = tyOpenArray then begin - result := paDirectMapping; // XXX really correct? - // what if ``arg`` has side-effects? - exit - end; - case arg.kind of - nkEmpty..nkNilLit: result := paDirectMapping; - nkPar, nkCurly, nkBracket: begin - result := paFastAsgn; - for i := 0 to sonsLen(arg)-1 do - if putArgInto(arg.sons[i], formal) <> paDirectMapping then - exit; - result := paDirectMapping; - end; - else begin - if skipTypes(formal, abstractInst).kind = tyVar then - result := paVarAsgn - else - result := paFastAsgn - end - end -end; - -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 - i, len: int; - call, v, body, arg: PNode; - newC: PTransCon; - temp, formal: PSym; -begin - 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]); - v := newNodeI(nkVarSection, n.info); - for i := 0 to len-3 do addVar(v, copyTree(n.sons[i])); // declare new vars - addSon(result, v); - newC := newTransCon(); - call := n.sons[len-2]; - if (call.kind <> nkCall) or (call.sons[0].kind <> nkSym) then - InternalError(call.info, 'transformFor'); - newC.owner := call.sons[0].sym; - newC.forStmt := n; - 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 - arg := skipPassAsOpenArray(transform(c, call.sons[i])); - formal := skipTypes(newC.owner.typ, abstractInst).n.sons[i].sym; - //if IdentEq(newc.Owner.name, 'items') then - // liMessage(arg.info, warnUser, 'items: ' + nodeKindToStr[arg.kind]); - case putArgInto(arg, formal.typ) of - paDirectMapping: IdNodeTablePut(newC.mapping, formal, arg); - paFastAsgn: begin - // generate a temporary and produce an assignment statement: - temp := newTemp(c, formal.typ, formal.info); - addVar(v, newSymNode(temp)); - addSon(result, newAsgnStmt(c, newSymNode(temp), arg)); - IdNodeTablePut(newC.mapping, formal, newSymNode(temp)); - end; - paVarAsgn: begin - assert(skipTypes(formal.typ, abstractInst).kind = tyVar); - InternalError(arg.info, 'not implemented: pass to var parameter'); - end; - end; - end; - body := newC.owner.ast.sons[codePos]; - pushInfoContext(n.info); - addSon(result, inlineIter(c, body)); - popInfoContext(); - popTransCon(c); -end; - -function getMagicOp(call: PNode): TMagic; -begin - if (call.sons[0].kind = nkSym) - and (call.sons[0].sym.kind in [skProc, skMethod, skConverter]) then - result := call.sons[0].sym.magic - else - result := mNone -end; - -procedure gatherVars(c: PTransf; n: PNode; var marked: TIntSet; - owner: PSym; container: PNode); -// gather used vars for closure generation -var - i: int; - s: PSym; - found: bool; -begin - if n = nil then exit; - case n.kind of - nkSym: begin - s := n.sym; - found := false; - case s.kind of - skVar: found := not (sfGlobal in s.flags); - skTemp, skForVar, skParam: found := true; - else begin end; - end; - if found and (owner.id <> s.owner.id) - and not IntSetContainsOrIncl(marked, s.id) then begin - include(s.flags, sfInClosure); - addSon(container, copyNode(n)); // DON'T make a copy of the symbol! - end - end; - nkEmpty..pred(nkSym), succ(nkSym)..nkNilLit: begin end; - else begin - for i := 0 to sonsLen(n)-1 do - gatherVars(c, n.sons[i], marked, owner, container); - end - end -end; - -(* - # example: - proc map(f: proc (x: int): int {.closure}, a: seq[int]): seq[int] = - result = @[] - for elem in a: - add result, f(a) - - proc addList(a: seq[int], y: int): seq[int] = - result = map(lambda (x: int): int = return x + y, a) - - should generate --> - - proc map(f: proc(x: int): int, closure: pointer, - a: seq[int]): seq[int] = - result = @[] - for elem in a: - add result, f(a, closure) - - type - PMyClosure = ref object - y: var int - - proc myLambda(x: int, closure: pointer) = - var cl = cast[PMyClosure](closure) - return x + cl.y - - proc addList(a: seq[int], y: int): seq[int] = - var - cl: PMyClosure - new(cl) - cl.y = y - result = map(myLambda, cast[pointer](cl), a) - - - or (but this is not easier and not binary compatible with C!) --> - - type - PClosure = ref object of TObject - f: proc (x: int, c: PClosure): int - - proc map(f: PClosure, a: seq[int]): seq[int] = - result = @[] - for elem in a: - add result, f.f(a, f) - - type - PMyClosure = ref object of PClosure - y: var int - - proc myLambda(x: int, cl: PMyClosure) = - return x + cl.y - - proc addList(a: seq[int], y: int): seq[int] = - var - cl: PMyClosure - new(cl) - cl.y = y - cl.f = myLambda - result = map(cl, a) -*) - -procedure addFormalParam(routine: PSym; param: PSym); -begin - addSon(routine.typ, param.typ); - addSon(routine.ast.sons[paramsPos], newSymNode(param)); -end; - -function indirectAccess(a, b: PSym): PNode; -// returns a^ .b as a node -var - x, y, deref: PNode; -begin - x := newSymNode(a); - y := newSymNode(b); - deref := newNodeI(nkDerefExpr, x.info); - deref.typ := x.typ.sons[0]; - addSon(deref, x); - result := newNodeI(nkDotExpr, x.info); - addSon(result, deref); - addSon(result, y); - result.typ := y.typ; -end; - -function transformLambda(c: PTransf; n: PNode): PNode; -var - marked: TIntSet; - closure: PNode; - s, param: PSym; - cl, p: PType; - i: int; - newC: PTransCon; -begin - result := n; - IntSetInit(marked); - 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); - // add closure type to the param list (even if closure is empty!): - cl := newType(tyObject, s); - cl.n := closure; - addSon(cl, nil); // no super class - p := newType(tyRef, s); - addSon(p, cl); - param := newSym(skParam, getIdent(genPrefix + 'Cl'), s); - param.typ := p; - addFormalParam(s, param); - // all variables that are accessed should be accessed by the new closure - // parameter: - if sonsLen(closure) > 0 then begin - newC := newTransCon(); - for i := 0 to sonsLen(closure)-1 do begin - IdNodeTablePut(newC.mapping, closure.sons[i].sym, - indirectAccess(param, closure.sons[i].sym)) - end; - pushTransCon(c, newC); - n.sons[codePos] := transform(c, n.sons[codePos]); - popTransCon(c); - end; - // Generate code to allocate and fill the closure. This has to be done in - // the outer routine! -end; - -function transformCase(c: PTransf; n: PNode): PNode; -// removes `elif` branches of a case stmt -// adds ``else: nil`` if needed for the code generator -var - len, i, j: int; - ifs, elsen: PNode; -begin - len := sonsLen(n); - i := len-1; - 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); - if (n.sons[i].kind <> nkOfBranch) then - InternalError(n.sons[i].info, 'transformCase'); - ifs := newNodeI(nkIfStmt, n.sons[i+1].info); - elsen := newNodeI(nkElse, ifs.info); - for j := i+1 to len-1 do addSon(ifs, n.sons[j]); - setLength(n.sons, i+2); - addSon(elsen, ifs); - n.sons[i+1] := elsen; - end - else if (n.sons[len-1].kind <> nkElse) and - not (skipTypes(n.sons[0].Typ, abstractVarRange).Kind in - [tyInt..tyInt64, tyChar, tyEnum]) then begin - //MessageOut(renderTree(n)); - elsen := newNodeI(nkElse, n.info); - addSon(elsen, newNodeI(nkNilLit, n.info)); - addSon(n, elsen) - end; - result := n; - for j := 0 to sonsLen(n)-1 do result.sons[j] := transform(c, n.sons[j]); -end; - -function transformArrayAccess(c: PTransf; n: PNode): PNode; -var - i: int; -begin - result := copyTree(n); - result.sons[0] := skipConv(result.sons[0]); - result.sons[1] := skipConv(result.sons[1]); - for i := 0 to sonsLen(result)-1 do - result.sons[i] := transform(c, result.sons[i]); -end; - -function getMergeOp(n: PNode): PSym; -begin - result := nil; - case n.kind of - nkCall, nkHiddenCallConv, nkCommand, nkInfix, nkPrefix, nkPostfix, - nkCallStrLit: 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], nil); - inc(j) - end; - addSon(result, a); - end; - if sonsLen(result) = 2 then - result := result.sons[1]; - end - else if (result.sons[0].kind = nkSym) - and (result.sons[0].sym.kind = skMethod) then begin - // use the dispatcher for the call: - result := methodCall(result); - end - (* - else if result.sons[0].kind = nkSym then begin - // optimization still too aggressive - op := result.sons[0].sym; - if (op.magic = mNone) and (op.kind = skProc) - and ([sfSideEffect, sfForward, sfNoReturn, sfImportc] * op.flags = []) - then begin - for i := 1 to sonsLen(result)-1 do - if not isConstExpr(result.sons[i]) then exit; - // compile-time evaluation: - a := evalConstExpr(c.module, result); - if (a <> nil) and (a.kind <> nkEmpty) then begin - messageout('evaluated at compile time: ' + rendertree(result)); - result := a - end - end - end *) -end; - -function transform(c: PTransf; n: PNode): PNode; -var - i: int; - cnst: PNode; -begin - result := n; - if n = nil then exit; - //if ToLinenumber(n.info) = 32 then - // MessageOut(RenderTree(n)); - case n.kind of - nkSym: begin - result := transformSym(c, n); - exit - end; - nkEmpty..pred(nkSym), succ(nkSym)..nkNilLit: begin - // nothing to be done for leaves - end; - nkBracketExpr: result := transformArrayAccess(c, n); - nkLambda: result := transformLambda(c, n); - nkForStmt: result := transformFor(c, n); - nkCaseStmt: result := transformCase(c, n); - nkProcDef, nkMethodDef, nkIteratorDef, nkMacroDef: begin - if n.sons[genericParamsPos] = nil then begin - n.sons[codePos] := transform(c, n.sons[codePos]); - if n.kind = nkMethodDef then - methodDef(n.sons[namePos].sym); - end - end; - nkWhileStmt: begin - 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, - nkCallStrLit: - 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); - nkDiscardStmt: begin - for i := 0 to sonsLen(n)-1 do - result.sons[i] := transform(c, n.sons[i]); - if isConstExpr(result.sons[0]) then - result := newNode(nkCommentStmt) - end; - 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.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/transtmp.pas b/nim/transtmp.pas deleted file mode 100755 index 15a07f5a2..000000000 --- a/nim/transtmp.pas +++ /dev/null @@ -1,149 +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 a transformator. It transforms the syntax tree -// to ease the work of the code generators. Does the transformation to -// introduce temporaries to split up complex expressions. -// THIS MODULE IS NOT USED! - -procedure transInto(c: PContext; var dest: PNode; father, src: PNode); forward; -// transforms the expression `src` into the destination `dest`. Uses `father` -// for temorary statements. If dest = nil, the expression is put into a -// temporary. - -function transTmp(c: PContext; father, src: PNode): PNode; -// convienence proc -begin - result := nil; - transInto(c, result, father, src); -end; - -function newLabel(c: PContext): PSym; -begin - inc(gTmpId); - result := newSym(skLabel, getIdent(genPrefix +{&} ToString(gTmpId), - c.transCon.owner)); -end; - -function fewCmps(s: PNode): bool; -// this function estimates whether it is better to emit code -// for constructing the set or generating a bunch of comparisons directly -begin - assert(s.kind in [nkSetConstr, nkConstSetConstr]); - if (s.typ.size <= platform.intSize) and - (s.kind = nkConstSetConstr) then - result := false // it is better to emit the set generation code - else if skipRange(s.typ.sons[0]).Kind in [tyInt..tyInt64] then - result := true // better not emit the set if int is basetype! - else - result := sonsLen(s) <= 8 // 8 seems to be a good value -end; - -function transformIn(c: PContext; father, n: PNode): PNode; -var - a, b, e, setc: PNode; - destLabel, label2: PSym; -begin - if (n.sons[1].kind = nkSetConstr) and fewCmps(n.sons[1]) then begin - // a set constructor but not a constant set: - // do not emit the set, but generate a bunch of comparisons - result := newSymNode(newTemp(c, n.typ, n.info)); - e := transTmp(c, father, n.sons[2]); - setc := n.sons[1]; - destLabel := newLabel(c); - for i := 0 to sonsLen(setc)-1 do begin - if setc.sons[i].kind = nkRange then begin - a := transTmp(c, father, setc.sons[i].sons[0]); - b := transTmp(c, father, setc.sons[i].sons[1]); - label2 := newLabel(c); - addSon(father, newLt(result, e, a)); // e < a? --> goto end - addSon(father, newCondJmp(result, label2)); - addSon(father, newLe(result, e, b)); // e <= b? --> goto set end - addSon(father, newCondJmp(result, destLabel)); - addSon(father, newLabelNode(label2)); - end - else begin - a := transTmp(c, father, setc.sons[i]); - addSon(father, newEq(result, e, a)); - addSon(father, newCondJmp(result, destLabel)); - end - end; - addSon(father, newLabelNode(destLabel)); - end - else begin - result := n; - end -end; - -procedure transformOp2(c: PContext; var dest: PNode; father, n: PNode); -var - a, b: PNode; -begin - if dest = nil then dest := newSymNode(newTemp(c, n.typ, n.info)); - a := transTmp(c, father, n.sons[1]); - b := transTmp(c, father, n.sons[2]); - addSon(father, newAsgnStmt(dest, newOp2(n, a, b))); -end; - -procedure transformOp1(c: PContext; var dest: PNode; father, n: PNode); -var - a: PNode; -begin - if dest = nil then dest := newSymNode(newTemp(c, n.typ, n.info)); - a := transTmp(c, father, n.sons[1]); - addSon(father, newAsgnStmt(dest, newOp1(n, a))); -end; - -procedure genTypeInfo(c: PContext; initSection: PNode); -begin - -end; - -procedure genNew(c: PContext; father, n: PNode); -begin - // how do we handle compilerprocs? - -end; - -function transformCase(c: PContext; father, n: PNode): PNode; -var - ty: PType; - e: PNode; -begin - ty := skipGeneric(n.sons[0].typ); - if ty.kind = tyString then begin - // transform a string case to a bunch of comparisons: - result := newNodeI(nkIfStmt, n); - e := transTmp(c, father, n.sons[0]); - - end - else result := n -end; - - -procedure transInto(c: PContext; var dest: PNode; father, src: PNode); -begin - if src = nil then exit; - if (src.typ <> nil) and (src.typ.kind = tyGenericInst) then - src.typ := skipGeneric(src.typ); - case src.kind of - nkIdent..nkNilLit: begin - if dest = nil then dest := copyTree(src) - else begin - // generate assignment: - addSon(father, newAsgnStmt(dest, src)); - end - end; - nkCall, nkCommand, nkCallStrLit: begin - - end; - - - end; -end; diff --git a/nim/trees.pas b/nim/trees.pas deleted file mode 100755 index 0e0c04a22..000000000 --- a/nim/trees.pas +++ /dev/null @@ -1,214 +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 trees; - -// tree helper routines - -interface - -{$include 'config.inc'} - -uses - nsystem, ast, astalgo, scanner, msgs, strutils; - -function getMagic(op: PNode): TMagic; - -// function getConstExpr(const t: TNode; out res: TNode): Boolean; - -function isConstExpr(n: PNode): Boolean; - - -function flattenTree(root: PNode; op: TMagic): PNode; - -function TreeToSym(t: PNode): PSym; - -procedure SwapOperands(op: PNode); -function getOpSym(op: PNode): PSym; - -function getProcSym(call: PNode): PSym; - -function ExprStructuralEquivalent(a, b: PNode): Boolean; - -function sameTree(a, b: PNode): boolean; -function cyclicTree(n: PNode): boolean; - -implementation - -function hasSon(father, son: PNode): boolean; -var - i: int; -begin - for i := 0 to sonsLen(father)-1 do - if father.sons[i] = son then begin result := true; exit end; - result := false -end; - -function cyclicTreeAux(n, s: PNode): boolean; -var - i, m: int; -begin - if n = nil then begin result := false; exit end; - if hasSon(s, n) then begin result := true; exit end; - m := sonsLen(s); - addSon(s, n); - if not (n.kind in [nkEmpty..nkNilLit]) then - for i := 0 to sonsLen(n)-1 do - if cyclicTreeAux(n.sons[i], s) then begin - result := true; exit - end; - result := false; - delSon(s, m); -end; - -function cyclicTree(n: PNode): boolean; -var - s: PNode; -begin - s := newNodeI(nkEmpty, n.info); - result := cyclicTreeAux(n, s); -end; - -function ExprStructuralEquivalent(a, b: PNode): Boolean; -var - i: int; -begin - result := false; - if a = b then begin - result := true - end - else if (a <> nil) and (b <> nil) and (a.kind = b.kind) then - case a.kind of - nkSym: // don't go nuts here: same symbol as string is enough: - result := a.sym.name.id = b.sym.name.id; - nkIdent: - result := a.ident.id = b.ident.id; - nkCharLit..nkInt64Lit: - result := a.intVal = b.intVal; - nkFloatLit..nkFloat64Lit: - result := a.floatVal = b.floatVal; - nkStrLit..nkTripleStrLit: - result := a.strVal = b.strVal; - nkEmpty, nkNilLit, nkType: result := true; - else if sonsLen(a) = sonsLen(b) then begin - for i := 0 to sonsLen(a)-1 do - if not ExprStructuralEquivalent(a.sons[i], b.sons[i]) then exit; - result := true - end - end -end; - -function sameTree(a, b: PNode): Boolean; -var - i: int; -begin - result := false; - if a = b then begin - result := true - 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 <> 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: - result := a.sym.name.id = b.sym.name.id; - nkIdent: - result := a.ident.id = b.ident.id; - nkCharLit..nkInt64Lit: - result := a.intVal = b.intVal; - nkFloatLit..nkFloat64Lit: - result := a.floatVal = b.floatVal; - nkStrLit..nkTripleStrLit: - result := a.strVal = b.strVal; - nkEmpty, nkNilLit, nkType: result := true; - else if sonsLen(a) = sonsLen(b) then begin - for i := 0 to sonsLen(a)-1 do - if not sameTree(a.sons[i], b.sons[i]) then exit; - result := true - end - end - end -end; - -function getProcSym(call: PNode): PSym; -begin - result := call.sons[0].sym; -end; - -function getOpSym(op: PNode): PSym; -begin - if not (op.kind in [nkCall, nkHiddenCallConv, nkCommand, nkCallStrLit]) then - result := nil - else begin - if (sonsLen(op) <= 0) then InternalError(op.info, 'getOpSym'); - if op.sons[0].Kind = nkSym then result := op.sons[0].sym - else result := nil - end -end; - -function getMagic(op: PNode): TMagic; -begin - case op.kind of - nkCall, nkHiddenCallConv, nkCommand, nkCallStrLit: begin - case op.sons[0].Kind of - nkSym: begin - result := op.sons[0].sym.magic; - end; - else result := mNone - end - end; - else - result := mNone - end -end; - -function TreeToSym(t: PNode): PSym; -begin - result := t.sym -end; - -function isConstExpr(n: PNode): Boolean; -begin - result := (n.kind in [nkCharLit..nkInt64Lit, nkStrLit..nkTripleStrLit, - nkFloatLit..nkFloat64Lit, nkNilLit]) - or (nfAllConst in n.flags) -end; - -procedure flattenTreeAux(d, a: PNode; op: TMagic); -var - i: int; -begin - if (getMagic(a) = op) then // BUGFIX - for i := 1 to sonsLen(a)-1 do // BUGFIX - flattenTreeAux(d, a.sons[i], op) - else - // a is a "leaf", so add it: - addSon(d, copyTree(a)) -end; - -function flattenTree(root: PNode; op: TMagic): PNode; -begin - result := copyNode(root); - if (getMagic(root) = op) then begin // BUGFIX: forget to copy prc - addSon(result, copyNode(root.sons[0])); - flattenTreeAux(result, root, op) - end -end; - -procedure SwapOperands(op: PNode); -var - tmp: PNode; -begin - tmp := op.sons[1]; - op.sons[1] := op.sons[2]; - op.sons[2] := tmp; -end; - -end. diff --git a/nim/treetab.pas b/nim/treetab.pas deleted file mode 100755 index 31d7aa0cf..000000000 --- a/nim/treetab.pas +++ /dev/null @@ -1,189 +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 treetab; - -// Implements a table from trees to trees. Does structural equavilent checking. - -interface - -{$include 'config.inc'} - -uses - nsystem, nhashes, ast, astalgo, types; - -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 - -function hashTree(n: PNode): THash; -var - i: int; -begin - result := 0; - if n = nil then exit; - result := ord(n.kind); - case n.kind of - nkEmpty, nkNilLit, nkType: begin end; - nkIdent: result := concHash(result, n.ident.h); - nkSym: result := concHash(result, n.sym.name.h); - nkCharLit..nkInt64Lit: begin - if (n.intVal >= low(int)) and (n.intVal <= high(int)) then - result := concHash(result, int(n.intVal)); - end; - nkFloatLit..nkFloat64Lit: begin - if (n.floatVal >= -1000000.0) and (n.floatVal <= 1000000.0) then - result := concHash(result, toInt(n.floatVal)); - end; - nkStrLit..nkTripleStrLit: - result := concHash(result, GetHashStr(n.strVal)); - else begin - for i := 0 to sonsLen(n)-1 do - result := concHash(result, hashTree(n.sons[i])); - end - end -end; - -function TreesEquivalent(a, b: PNode): Boolean; -var - i: int; -begin - result := false; - if a = b then begin - result := true - end - else if (a <> nil) and (b <> nil) and (a.kind = b.kind) then begin - case a.kind of - nkEmpty, nkNilLit, nkType: result := true; - nkSym: - result := a.sym.id = b.sym.id; - nkIdent: - result := a.ident.id = b.ident.id; - nkCharLit..nkInt64Lit: - result := a.intVal = b.intVal; - nkFloatLit..nkFloat64Lit: - result := a.floatVal = b.floatVal; - nkStrLit..nkTripleStrLit: - result := a.strVal = b.strVal; - else if sonsLen(a) = sonsLen(b) then begin - for i := 0 to sonsLen(a)-1 do - if not TreesEquivalent(a.sons[i], b.sons[i]) then exit; - result := true - end - end; - if result then result := sameTypeOrNil(a.typ, b.typ); - end -end; - -function NodeTableRawGet(const t: TNodeTable; k: THash; key: PNode): int; -var - h: THash; -begin - h := k and high(t.data); - while t.data[h].key <> nil do begin - if (t.data[h].h = k) and TreesEquivalent(t.data[h].key, key) then begin - result := h; exit - end; - h := nextTry(h, high(t.data)) - end; - result := -1 -end; - -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 := low(int) -end; - -procedure NodeTableRawInsert(var data: TNodePairSeq; k: THash; - key: PNode; val: int); -var - h: THash; -begin - h := k and high(data); - while data[h].key <> nil do h := nextTry(h, high(data)); - assert(data[h].key = nil); - data[h].h := k; - data[h].key := key; - data[h].val := val; -end; - -procedure NodeTablePut(var t: TNodeTable; key: PNode; val: 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); - t.data[index].val := 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 - 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 - 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); - result := val; - inc(t.counter) - end; -end; - -end. diff --git a/nim/types.pas b/nim/types.pas deleted file mode 100755 index a881b2f11..000000000 --- a/nim/types.pas +++ /dev/null @@ -1,1295 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit types; - -// this module contains routines for accessing and iterating over types - -interface - -{$include 'config.inc'} - -uses - nsystem, ast, astalgo, trees, msgs, strutils, platform; - -function firstOrd(t: PType): biggestInt; -function lastOrd(t: PType): biggestInt; -function lengthOrd(t: PType): biggestInt; - -type - TPreferedDesc = (preferName, preferDesc); -function TypeToString(typ: PType; prefer: TPreferedDesc = preferName): string; -function getProcHeader(sym: PSym): string; - -function base(t: PType): PType; - - -// ------------------- type iterator: ---------------------------------------- -type - TTypeIter = function (t: PType; closure: PObject): bool; - // should return true if the iteration should stop - - TTypeMutator = function (t: PType; closure: PObject): PType; - // copy t and mutate it - - TTypePredicate = function (t: PType): bool; - -function IterOverType(t: PType; iter: TTypeIter; closure: PObject): bool; -// Returns result of `iter`. - -function mutateType(t: PType; iter: TTypeMutator; closure: PObject): PType; -// Returns result of `iter`. - - -function SameType(x, y: PType): Boolean; -function SameTypeOrNil(a, b: PType): Boolean; -function equalOrDistinctOf(x, y: PType): bool; - -type - TParamsEquality = (paramsNotEqual, // parameters are not equal - paramsEqual, // parameters are equal - paramsIncompatible); // they are equal, but their - // identifiers or their return - // type differ (i.e. they cannot be - // overloaded) - // this used to provide better error messages -function equalParams(a, b: PNode): TParamsEquality; -// returns whether the parameter lists of the procs a, b are exactly the same - - -function isOrdinalType(t: PType): Boolean; -function enumHasWholes(t: PType): Boolean; - -const - abstractPtrs = {@set}[tyVar, tyPtr, tyRef, tyGenericInst, tyDistinct, tyOrdinal]; - abstractVar = {@set}[tyVar, tyGenericInst, tyDistinct, tyOrdinal]; - abstractRange = {@set}[tyGenericInst, tyRange, tyDistinct, tyOrdinal]; - abstractVarRange = {@set}[tyGenericInst, tyRange, tyVar, tyDistinct, tyOrdinal]; - abstractInst = {@set}[tyGenericInst, tyDistinct, tyOrdinal]; - -function skipTypes(t: PType; kinds: TTypeKinds): 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; - -function getOrdValue(n: PNode): biggestInt; - - -function computeSize(typ: PType): biggestInt; -function getSize(typ: PType): biggestInt; - -function isPureObject(typ: PType): boolean; - -function inheritanceDiff(a, b: PType): int; -// | returns: 0 iff `a` == `b` -// | returns: -x iff `a` is the x'th direct superclass of `b` -// | returns: +x iff `a` is the x'th direct subclass of `b` -// | returns: `maxint` iff `a` and `b` are not compatible at all - - -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. - -function typeAllowed(t: PType; kind: TSymKind): bool; - -implementation - -function InvalidGenericInst(f: PType): bool; -begin - result := (f.kind = tyGenericInst) and (lastSon(f) = nil); -end; - -function inheritanceDiff(a, b: PType): int; -var - x, y: PType; -begin - // conversion to superclass? - x := a; - result := 0; - while (x <> nil) do begin - if x.id = b.id then exit; - x := x.sons[0]; - dec(result); - end; - // conversion to baseclass? - y := b; - result := 0; - while (y <> nil) do begin - if y.id = a.id then exit; - y := y.sons[0]; - inc(result); - end; - result := high(int); -end; - -function isPureObject(typ: PType): boolean; -var - t: PType; -begin - t := typ; - while t.sons[0] <> nil do t := t.sons[0]; - result := (t.sym <> nil) and (sfPure in t.sym.flags); -end; - -function getOrdValue(n: PNode): biggestInt; -begin - case n.kind of - nkCharLit..nkInt64Lit: result := n.intVal; - nkNilLit: result := 0; - else begin - liMessage(n.info, errOrdinalTypeExpected); - result := 0 - end - end -end; - -function isCompatibleToCString(a: PType): bool; -begin - result := false; - if a.kind = tyArray then - if (firstOrd(a.sons[0]) = 0) - and (skipTypes(a.sons[0], {@set}[tyRange]).kind in [tyInt..tyInt64]) - and (a.sons[1].kind = tyChar) then - result := true -end; - -function getProcHeader(sym: PSym): string; -var - i: int; - n, p: PNode; -begin - result := sym.name.s + '('; - n := sym.typ.n; - for i := 1 to sonsLen(n)-1 do begin - p := n.sons[i]; - if (p.kind <> nkSym) then InternalError('getProcHeader'); - add(result, p.sym.name.s); - add(result, ': '); - add(result, typeToString(p.sym.typ)); - if i <> sonsLen(n)-1 then add(result, ', '); - end; - addChar(result, ')'); - if n.sons[0].typ <> nil then - result := result +{&} ': ' +{&} typeToString(n.sons[0].typ); -end; - -function elemType(t: PType): PType; -begin - assert(t <> nil); - case t.kind of - tyGenericInst, tyDistinct: result := elemType(lastSon(t)); - tyArray, tyArrayConstr: result := t.sons[1]; - else result := t.sons[0]; - end; - assert(result <> nil); -end; - -function skipGeneric(t: PType): PType; -begin - result := t; - while result.kind = tyGenericInst do result := lastSon(result) -end; - -function skipRange(t: PType): PType; -begin - result := t; - while result.kind = tyRange do result := base(result) -end; - -function skipAbstract(t: PType): PType; -begin - result := t; - while result.kind in [tyRange, tyGenericInst] do - result := lastSon(result); -end; - -function skipVar(t: PType): PType; -begin - result := t; - while result.kind = tyVar do result := result.sons[0]; -end; - -function skipVarGeneric(t: PType): PType; -begin - result := t; - while result.kind in [tyGenericInst, tyVar] do result := lastSon(result); -end; - -function skipPtrsGeneric(t: PType): PType; -begin - result := t; - while result.kind in [tyGenericInst, tyVar, tyPtr, tyRef] do - result := lastSon(result); -end; - -function skipVarGenericRange(t: PType): PType; -begin - result := t; - while result.kind in [tyGenericInst, tyVar, tyRange] do - result := lastSon(result); -end; - -function skipGenericRange(t: PType): PType; -begin - result := t; - while result.kind in [tyGenericInst, tyVar, tyRange] do - result := lastSon(result); -end; - -function skipTypes(t: PType; kinds: TTypeKinds): PType; -begin - result := t; - while result.kind in kinds do result := lastSon(result); -end; - -function isOrdinalType(t: PType): Boolean; -begin - assert(t <> nil); - result := (t.Kind in [tyChar, tyInt..tyInt64, tyBool, tyEnum]) - or (t.Kind in [tyRange, tyOrdinal]) and isOrdinalType(t.sons[0]); -end; - -function enumHasWholes(t: PType): Boolean; -var - b: PType; -begin - b := t; - while b.kind = tyRange do b := b.sons[0]; - result := (b.Kind = tyEnum) and (tfEnumHasWholes in b.flags) -end; - -function iterOverTypeAux(var marker: TIntSet; t: PType; iter: TTypeIter; - closure: PObject): bool; forward; - -function iterOverNode(var marker: TIntSet; n: PNode; iter: TTypeIter; - closure: PObject): bool; -var - i: int; -begin - result := false; - if n <> nil then begin - case n.kind of - nkNone..nkNilLit: begin // a leaf - result := iterOverTypeAux(marker, n.typ, iter, closure); - end; - else begin - for i := 0 to sonsLen(n)-1 do begin - result := iterOverNode(marker, n.sons[i], iter, closure); - if result then exit; - end - end - end - end -end; - -function iterOverTypeAux(var marker: TIntSet; t: PType; iter: TTypeIter; - closure: PObject): bool; -var - i: int; -begin - result := false; - if t = nil then exit; - result := iter(t, closure); - if result then exit; - if not IntSetContainsOrIncl(marker, t.id) then begin - case t.kind of - tyGenericInst, tyGenericBody: - result := iterOverTypeAux(marker, lastSon(t), iter, closure); - else begin - for i := 0 to sonsLen(t)-1 do begin - result := iterOverTypeAux(marker, t.sons[i], iter, closure); - if result then exit; - end; - if t.n <> nil then result := iterOverNode(marker, t.n, iter, closure) - end - end - end -end; - -function IterOverType(t: PType; iter: TTypeIter; closure: PObject): bool; -var - marker: TIntSet; -begin - IntSetInit(marker); - result := iterOverTypeAux(marker, t, iter, closure); -end; - -function searchTypeForAux(t: PType; predicate: TTypePredicate; - var marker: TIntSet): bool; forward; - -function searchTypeNodeForAux(n: PNode; p: TTypePredicate; - var marker: TIntSet): bool; -var - i: int; -begin - result := false; - case n.kind of - nkRecList: begin - for i := 0 to sonsLen(n)-1 do begin - result := searchTypeNodeForAux(n.sons[i], p, marker); - if result then exit - end - end; - nkRecCase: begin - assert(n.sons[0].kind = nkSym); - result := searchTypeNodeForAux(n.sons[0], p, marker); - if result then exit; - for i := 1 to sonsLen(n)-1 do begin - case n.sons[i].kind of - nkOfBranch, nkElse: begin - result := searchTypeNodeForAux(lastSon(n.sons[i]), p, marker); - if result then exit; - end; - else internalError('searchTypeNodeForAux(record case branch)'); - end - end - end; - nkSym: begin - result := searchTypeForAux(n.sym.typ, p, marker); - end; - else internalError(n.info, 'searchTypeNodeForAux()'); - end; -end; - -function searchTypeForAux(t: PType; predicate: TTypePredicate; - var marker: TIntSet): bool; -// iterates over VALUE types! -var - i: int; -begin - result := false; - if t = nil then exit; - if IntSetContainsOrIncl(marker, t.id) then exit; - result := Predicate(t); - if result then exit; - case t.kind of - tyObject: begin - result := searchTypeForAux(t.sons[0], predicate, marker); - if not result then - result := searchTypeNodeForAux(t.n, predicate, marker); - end; - tyGenericInst, tyDistinct: - result := searchTypeForAux(lastSon(t), predicate, marker); - tyArray, tyArrayConstr, tySet, tyTuple: begin - for i := 0 to sonsLen(t)-1 do begin - result := searchTypeForAux(t.sons[i], predicate, marker); - if result then exit - end - end - else begin end - end -end; - -function searchTypeFor(t: PType; predicate: TTypePredicate): bool; -var - marker: TIntSet; -begin - IntSetInit(marker); - result := searchTypeForAux(t, predicate, marker); -end; - -function isObjectPredicate(t: PType): bool; -begin - result := t.kind = tyObject -end; - -function containsObject(t: PType): bool; -begin - result := searchTypeFor(t, isObjectPredicate); -end; - -function isObjectWithTypeFieldPredicate(t: PType): bool; -begin - result := (t.kind = tyObject) and (t.sons[0] = nil) - and not ((t.sym <> nil) and (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, tyDistinct: - 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]; -end; - -function containsGarbageCollectedRef(typ: PType): Boolean; -// returns true if typ contains a reference, sequence or string (all the things -// that are garbage-collected) -begin - result := searchTypeFor(typ, isGBCRef); -end; - -function isHiddenPointer(t: PType): bool; -begin - result := t.kind in [tyString, tySequence]; -end; - -function containsHiddenPointer(typ: PType): Boolean; -// returns true if typ contains a string, table or sequence (all the things -// that need to be copied deeply) -begin - result := searchTypeFor(typ, isHiddenPointer); -end; - -function canFormAcycleAux(var marker: TIntSet; typ: 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; typ: PType; startId: int): bool; -var - i: int; - t: PType; -begin - result := false; - if typ = nil then exit; - if tfAcyclic in typ.flags then exit; - t := skipTypes(typ, abstractInst); - if tfAcyclic in t.flags then exit; - case 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; - -function mutateNode(var marker: TIntSet; n: PNode; iter: TTypeMutator; - closure: PObject): PNode; -var - i: int; -begin - result := nil; - if n <> nil then begin - result := copyNode(n); - result.typ := mutateTypeAux(marker, n.typ, iter, closure); - case n.kind of - nkNone..nkNilLit: begin // a leaf - end; - else begin - for i := 0 to sonsLen(n)-1 do - addSon(result, mutateNode(marker, n.sons[i], iter, closure)); - end - end - end -end; - -function mutateTypeAux(var marker: TIntSet; t: PType; iter: TTypeMutator; - closure: PObject): PType; -var - i: int; -begin - result := nil; - if t = nil then exit; - result := iter(t, closure); - if not IntSetContainsOrIncl(marker, t.id) then begin - for i := 0 to sonsLen(t)-1 do begin - result.sons[i] := mutateTypeAux(marker, result.sons[i], iter, closure); - if (result.sons[i] = nil) and (result.kind = tyGenericInst) then - assert(false); - end; - if t.n <> nil then - result.n := mutateNode(marker, t.n, iter, closure) - end; - assert(result <> nil); -end; - -function mutateType(t: PType; iter: TTypeMutator; closure: PObject): PType; -var - marker: TIntSet; -begin - IntSetInit(marker); - result := mutateTypeAux(marker, t, iter, closure); -end; - -function rangeToStr(n: PNode): string; -begin - assert(n.kind = nkRange); - result := ValueToString(n.sons[0]) + '..' +{&} ValueToString(n.sons[1]) -end; - -function TypeToString(typ: PType; prefer: TPreferedDesc = preferName): string; -const - typeToStr: array [TTypeKind] of string = ( - 'None', 'bool', 'Char', 'empty', 'Array Constructor [$1]', 'nil', 'expr', - 'stmt', 'typeDesc', - 'GenericInvokation', - 'GenericBody', 'GenericInst', 'GenericParam', 'distinct $1', - 'enum', 'ordinal[$1]', - 'array[$1, $2]', 'object', 'tuple', 'set[$1]', 'range[$1]', - 'ptr ', 'ref ', 'var ', 'seq[$1]', 'proc', 'pointer', - 'OpenArray[$1]', 'string', 'CString', 'Forward', - 'int', 'int8', 'int16', 'int32', 'int64', - 'float', 'float32', 'float64', 'float128' - ); -var - t: PType; - i: int; - prag: string; -begin - t := typ; - result := ''; - if t = nil then exit; - if (prefer = preferName) and (t.sym <> nil) then begin - result := t.sym.Name.s; - exit - end; - case t.Kind of - tyGenericInst: - result := typeToString(lastSon(t), prefer); - tyArray: begin - if t.sons[0].kind = tyRange then - result := 'array[' +{&} rangeToStr(t.sons[0].n) +{&} ', ' - +{&} typeToString(t.sons[1]) +{&} ']' - else - result := 'array[' +{&} typeToString(t.sons[0]) +{&} ', ' - +{&} typeToString(t.sons[1]) +{&} ']' - end; - tyGenericInvokation, tyGenericBody: begin - result := typeToString(t.sons[0]) + '['; - for i := 1 to sonsLen(t)-1 do begin - if i > 1 then add(result, ', '); - add(result, typeToString(t.sons[i])); - end; - addChar(result, ']'); - end; - tyArrayConstr: - result := 'Array constructor[' +{&} rangeToStr(t.sons[0].n) +{&} ', ' - +{&} typeToString(t.sons[1]) +{&} ']'; - tySequence: result := 'seq[' +{&} typeToString(t.sons[0]) +{&} ']'; - tyOrdinal: result := 'ordinal[' +{&} typeToString(t.sons[0]) +{&} ']'; - tySet: result := 'set[' +{&} typeToString(t.sons[0]) +{&} ']'; - tyOpenArray: result := 'openarray[' +{&} typeToString(t.sons[0]) +{&} ']'; - tyDistinct: result := 'distinct ' +{&} typeToString(t.sons[0], preferName); - tyTuple: begin - // we iterate over t.sons here, because t.n may be nil - result := 'tuple['; - if t.n <> nil then begin - assert(sonsLen(t.n) = sonsLen(t)); - for i := 0 to sonsLen(t.n)-1 do begin - assert(t.n.sons[i].kind = nkSym); - add(result, t.n.sons[i].sym.name.s +{&} ': ' - +{&} typeToString(t.sons[i])); - if i < sonsLen(t.n)-1 then add(result, ', '); - end - end - else begin - for i := 0 to sonsLen(t)-1 do begin - add(result, typeToString(t.sons[i])); - if i < sonsLen(t)-1 then add(result, ', '); - end - end; - addChar(result, ']') - end; - tyPtr, tyRef, tyVar: - result := typeToStr[t.kind] +{&} typeToString(t.sons[0]); - tyRange: begin - result := 'range ' +{&} rangeToStr(t.n); - end; - tyProc: begin - result := 'proc ('; - for i := 1 to sonsLen(t)-1 do begin - add(result, typeToString(t.sons[i])); - if i < sonsLen(t)-1 then add(result, ', '); - end; - addChar(result, ')'); - if t.sons[0] <> nil then - add(result, ': ' +{&} TypeToString(t.sons[0])); - if t.callConv <> ccDefault then prag := CallingConvToStr[t.callConv] - else prag := ''; - if tfNoSideEffect in t.flags then begin - addSep(prag); - add(prag, 'noSideEffect') - end; - if length(prag) <> 0 then add(result, '{.' +{&} prag +{&} '.}'); - end; - else begin - result := typeToStr[t.kind] - end - end -end; - -function resultType(t: PType): PType; -begin - assert(t.kind = tyProc); - result := t.sons[0] // nil is allowed -end; - -function base(t: PType): PType; -begin - result := t.sons[0] -end; - -function firstOrd(t: PType): biggestInt; -begin - case t.kind of - tyBool, tyChar, tySequence, tyOpenArray: result := 0; - tySet, tyVar: result := firstOrd(t.sons[0]); - tyArray, tyArrayConstr: begin - result := firstOrd(t.sons[0]); - end; - tyRange: begin - assert(t.n <> nil); - // range directly given: - assert(t.n.kind = nkRange); - result := getOrdValue(t.n.sons[0]) - end; - tyInt: begin - if platform.intSize = 4 then result := -(2147483646) - 2 - else result := $8000000000000000; - end; - tyInt8: result := -128; - tyInt16: result := -32768; - tyInt32: result := -2147483646 - 2; - tyInt64: result := $8000000000000000; - tyEnum: begin - // if basetype <> nil then return firstOrd of basetype - if (sonsLen(t) > 0) and (t.sons[0] <> nil) then - result := firstOrd(t.sons[0]) - else begin - assert(t.n.sons[0].kind = nkSym); - result := t.n.sons[0].sym.position; - end; - end; - tyGenericInst, tyDistinct: result := firstOrd(lastSon(t)); - else begin - InternalError('invalid kind for first(' +{&} - typeKindToStr[t.kind] +{&} ')'); - result := 0; - end - end -end; - -function lastOrd(t: PType): biggestInt; -begin - case t.kind of - tyBool: result := 1; - tyChar: result := 255; - tySet, tyVar: result := lastOrd(t.sons[0]); - tyArray, tyArrayConstr: begin - result := lastOrd(t.sons[0]); - end; - tyRange: begin - assert(t.n <> nil); - // range directly given: - assert(t.n.kind = nkRange); - result := getOrdValue(t.n.sons[1]); - end; - tyInt: begin - if platform.intSize = 4 then result := $7FFFFFFF - else result := $7FFFFFFFFFFFFFFF; - end; - tyInt8: result := $7F; - tyInt16: result := $7FFF; - tyInt32: result := $7FFFFFFF; - tyInt64: result := $7FFFFFFFFFFFFFFF; - tyEnum: begin - assert(t.n.sons[sonsLen(t.n)-1].kind = nkSym); - result := t.n.sons[sonsLen(t.n)-1].sym.position; - end; - tyGenericInst, tyDistinct: result := firstOrd(lastSon(t)); - else begin - InternalError('invalid kind for last(' +{&} - typeKindToStr[t.kind] +{&} ')'); - result := 0; - end - end -end; - -function lengthOrd(t: PType): biggestInt; -begin - case t.kind of - tyInt64, tyInt32, tyInt: result := lastOrd(t); - tyDistinct: result := lengthOrd(t.sons[0]); - else result := lastOrd(t) - firstOrd(t) + 1; - end -end; - -function equalParam(a, b: PSym): TParamsEquality; -begin - if SameTypeOrNil(a.typ, b.typ) then begin - if (a.ast = b.ast) then - result := paramsEqual - else if (a.ast <> nil) and (b.ast <> nil) then begin - if ExprStructuralEquivalent(a.ast, b.ast) then result := paramsEqual - else result := paramsIncompatible - end - else if (a.ast <> nil) then - result := paramsEqual - else if (b.ast <> nil) then - result := paramsIncompatible - end - else - result := paramsNotEqual -end; - -function equalParams(a, b: PNode): TParamsEquality; -var - i, len: int; - m, n: PSym; -begin - result := paramsEqual; - len := sonsLen(a); - if len <> sonsLen(b) then - result := paramsNotEqual - else begin - for i := 1 to len-1 do begin - m := a.sons[i].sym; - n := b.sons[i].sym; - assert((m.kind = skParam) and (n.kind = skParam)); - case equalParam(m, n) of - paramsNotEqual: begin result := paramsNotEqual; exit end; - paramsEqual: begin end; - paramsIncompatible: result := paramsIncompatible; - end; - if (m.name.id <> n.name.id) then begin // BUGFIX - result := paramsNotEqual; exit // paramsIncompatible; - // continue traversal! If not equal, we can return immediately; else - // it stays incompatible - end - end; - // check their return type: - if not SameTypeOrNil(a.sons[0].typ, b.sons[0].typ) then - if (a.sons[0].typ = nil) or (b.sons[0].typ = nil) then - result := paramsNotEqual // one proc has a result, the other not is OK - else - result := paramsIncompatible // overloading by different - // result types does not work - end -end; - -function SameTypeOrNil(a, b: PType): Boolean; -begin - if a = b then - result := true - else begin - if (a = nil) or (b = nil) then result := false - else result := SameType(a, b) - end -end; - -function SameLiteral(x, y: PNode): Boolean; -begin - result := false; - if x.kind = y.kind then - case x.kind of - nkCharLit..nkInt64Lit: - result := x.intVal = y.intVal; - nkFloatLit..nkFloat64Lit: - result := x.floatVal = y.floatVal; - nkNilLit: - result := true - else assert(false); - end -end; - -function SameRanges(a, b: PNode): Boolean; -begin - result := SameLiteral(a.sons[0], b.sons[0]) and - SameLiteral(a.sons[1], b.sons[1]) -end; - -function sameTuple(a, b: PType; DistinctOf: bool): boolean; -// two tuples are equivalent iff the names, types and positions are the same; -// however, both types may not have any field names (t.n may be nil) which -// complicates the matter a bit. -var - i: int; - x, y: PSym; -begin - if sonsLen(a) = sonsLen(b) then begin - result := true; - for i := 0 to sonsLen(a)-1 do begin - if DistinctOf then - result := equalOrDistinctOf(a.sons[i], b.sons[i]) - else - result := SameType(a.sons[i], b.sons[i]); - if not result then exit - end; - if (a.n <> nil) and (b.n <> nil) then begin - for i := 0 to sonsLen(a.n)-1 do begin - // check field names: - if a.n.sons[i].kind <> nkSym then InternalError(a.n.info, 'sameTuple'); - if b.n.sons[i].kind <> nkSym then InternalError(b.n.info, 'sameTuple'); - x := a.n.sons[i].sym; - y := b.n.sons[i].sym; - result := x.name.id = y.name.id; - if not result then break - end - end - end - else - result := false; -end; - -function SameType(x, y: PType): Boolean; -var - i: int; - a, b: PType; -begin - if x = y then begin result := true; exit end; - a := skipTypes(x, {@set}[tyGenericInst]); - b := skipTypes(y, {@set}[tyGenericInst]); - 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, tyExpr, tyStmt, tyTypeDesc: - result := true; - tyEnum, tyForward, tyObject, tyDistinct: - result := (a.id = b.id); - tyTuple: - result := sameTuple(a, b, false); - tyGenericInst: - result := sameType(lastSon(a), lastSon(b)); - tyGenericParam, tyGenericInvokation, tyGenericBody, tySequence, tyOrdinal, - tyOpenArray, tySet, tyRef, tyPtr, tyVar, tyArrayConstr, - tyArray, tyProc: begin - if sonsLen(a) = sonsLen(b) then begin - result := true; - for i := 0 to sonsLen(a)-1 do begin - result := SameTypeOrNil(a.sons[i], b.sons[i]); // BUGFIX - if not result then exit - end; - if result and (a.kind = tyProc) then - result := a.callConv = b.callConv // BUGFIX - end - else - result := false; - end; - tyRange: begin - result := SameTypeOrNil(a.sons[0], b.sons[0]) - and SameValue(a.n.sons[0], b.n.sons[0]) - and SameValue(a.n.sons[1], b.n.sons[1]) - end; - tyNone: result := false; - end -end; - -function equalOrDistinctOf(x, y: PType): bool; -var - i: int; - a, b: PType; -begin - if x = y then begin result := true; exit end; - if (x = nil) or (y = nil) then begin result := false; exit end; - a := skipTypes(x, {@set}[tyGenericInst]); - b := skipTypes(y, {@set}[tyGenericInst]); - assert(a <> nil); - assert(b <> nil); - if a.kind <> b.kind then begin - if a.kind = tyDistinct then a := a.sons[0]; - if a.kind <> b.kind then begin result := false; exit end - end; - case a.Kind of - tyEmpty, tyChar, tyBool, tyNil, tyPointer, tyString, tyCString, - tyInt..tyFloat128, tyExpr, tyStmt, tyTypeDesc: - result := true; - tyEnum, tyForward, tyObject, tyDistinct: - result := (a.id = b.id); - tyTuple: - result := sameTuple(a, b, true); - tyGenericInst: - result := equalOrDistinctOf(lastSon(a), lastSon(b)); - tyGenericParam, tyGenericInvokation, tyGenericBody, tySequence, tyOrdinal, - tyOpenArray, tySet, tyRef, tyPtr, tyVar, tyArrayConstr, - tyArray, tyProc: begin - if sonsLen(a) = sonsLen(b) then begin - result := true; - for i := 0 to sonsLen(a)-1 do begin - result := equalOrDistinctOf(a.sons[i], b.sons[i]); - if not result then exit - end; - if result and (a.kind = tyProc) then - result := a.callConv = b.callConv - end - else - result := false; - end; - tyRange: begin - result := equalOrDistinctOf(a.sons[0], b.sons[0]) - and SameValue(a.n.sons[0], b.n.sons[0]) - and SameValue(a.n.sons[1], b.n.sons[1]) - end; - tyNone: result := false; - end -end; - -function typeAllowedAux(var marker: TIntSet; typ: PType; - kind: TSymKind): bool; forward; - -function typeAllowedNode(var marker: TIntSet; n: PNode; kind: TSymKind): bool; -var - i: int; -begin - result := true; - if n <> nil then begin - result := typeAllowedAux(marker, n.typ, kind); - if not result then debug(n.typ); - if result then - case n.kind of - nkNone..nkNilLit: begin end; - else begin - for i := 0 to sonsLen(n)-1 do begin - result := typeAllowedNode(marker, n.sons[i], kind); - if not result then exit - end - end - end - end -end; - -function typeAllowedAux(var marker: TIntSet; typ: PType; kind: TSymKind): bool; -var - i: int; - t, t2: PType; -begin - assert(kind in [skVar, skConst, skParam]); - result := true; - if typ = nil then exit; - // if we have already checked the type, return true, because we stop the - // evaluation if something is wrong: - if IntSetContainsOrIncl(marker, typ.id) then exit; - t := skipTypes(typ, abstractInst); - case t.kind of - tyVar: begin - t2 := skipTypes(t.sons[0], abstractInst); - case t2.kind of - tyVar: result := false; // ``var var`` is always an invalid type: - tyOpenArray: result := (kind = skParam) and - typeAllowedAux(marker, t2, kind); - else result := (kind <> skConst) and - typeAllowedAux(marker, t2, kind); - end - end; - tyProc: begin - for i := 1 to sonsLen(t)-1 do begin - result := typeAllowedAux(marker, t.sons[i], skParam); - if not result then exit; - end; - if t.sons[0] <> nil then - result := typeAllowedAux(marker, t.sons[0], skVar) - end; - tyExpr, tyStmt, tyTypeDesc: result := true; - tyGenericBody, tyGenericParam, tyForward, tyNone, tyGenericInvokation: begin - result := false; - //InternalError('shit found'); - end; - tyEmpty, tyNil: result := kind = skConst; - tyString, tyBool, tyChar, tyEnum, tyInt..tyFloat128, tyCString, tyPointer: - result := true; - tyOrdinal: result := kind = skParam; - tyGenericInst, tyDistinct: - result := typeAllowedAux(marker, lastSon(t), kind); - tyRange: - result := skipTypes(t.sons[0], abstractInst).kind in - [tyChar, tyEnum, tyInt..tyFloat128]; - tyOpenArray: - result := (kind = skParam) and typeAllowedAux(marker, t.sons[0], skVar); - tySequence: result := (kind <> skConst) - and typeAllowedAux(marker, t.sons[0], skVar) - or (t.sons[0].kind = tyEmpty); - tyArray: result := typeAllowedAux(marker, t.sons[1], skVar); - tyPtr, tyRef: result := typeAllowedAux(marker, t.sons[0], skVar); - tyArrayConstr, tyTuple, tySet: begin - for i := 0 to sonsLen(t)-1 do begin - result := typeAllowedAux(marker, t.sons[i], kind); - if not result then exit - end; - end; - tyObject: begin - for i := 0 to sonsLen(t)-1 do begin - result := typeAllowedAux(marker, t.sons[i], skVar); - if not result then exit - end; - if t.n <> nil then result := typeAllowedNode(marker, t.n, skVar); - end; - end -end; - -function typeAllowed(t: PType; kind: TSymKind): bool; -var - marker: TIntSet; -begin - IntSetInit(marker); - result := typeAllowedAux(marker, t, kind); -end; - -function align(address, alignment: biggestInt): biggestInt; -begin - result := (address + (alignment-1)) and not (alignment-1); -end; - -// we compute the size of types lazily: -function computeSizeAux(typ: PType; var a: biggestInt): biggestInt; forward; - -function computeRecSizeAux(n: PNode; var a, currOffset: biggestInt): biggestInt; -var - maxAlign, maxSize, b, res: biggestInt; - i: int; -begin - case n.kind of - nkRecCase: begin - assert(n.sons[0].kind = nkSym); - result := computeRecSizeAux(n.sons[0], a, currOffset); - maxSize := 0; - maxAlign := 1; - for i := 1 to sonsLen(n)-1 do begin - case n.sons[i].kind of - nkOfBranch, nkElse: begin - res := computeRecSizeAux(lastSon(n.sons[i]), b, currOffset); - if res < 0 then begin result := res; exit end; - maxSize := max(maxSize, res); - maxAlign := max(maxAlign, b); - end; - else internalError('computeRecSizeAux(record case branch)'); - end - end; - currOffset := align(currOffset, maxAlign) + maxSize; - result := align(result, maxAlign) + maxSize; - a := maxAlign; - end; - nkRecList: begin - result := 0; - maxAlign := 1; - for i := 0 to sonsLen(n)-1 do begin - res := computeRecSizeAux(n.sons[i], b, currOffset); - if res < 0 then begin result := res; exit end; - currOffset := align(currOffset, b) + res; - result := align(result, b) + res; - if b > maxAlign then maxAlign := b; - end; - //result := align(result, maxAlign); - // XXX: check GCC alignment for this! - a := maxAlign; - end; - nkSym: begin - result := computeSizeAux(n.sym.typ, a); - n.sym.offset := int(currOffset); - end; - else begin - InternalError('computeRecSizeAux()'); - a := 1; result := -1 - end - end -end; - -function computeSizeAux(typ: PType; var a: biggestInt): biggestInt; -var - i: int; - res, maxAlign, len, currOffset: biggestInt; -begin - if typ.size = -2 then begin - // we are already computing the size of the type - // --> illegal recursion in type - result := -2; - exit - end; - if typ.size >= 0 then begin // size already computed - result := typ.size; - a := typ.align; - exit - end; - typ.size := -2; // mark as being computed - case typ.kind of - tyInt: begin result := IntSize; a := result; end; - tyInt8, tyBool, tyChar: begin result := 1; a := result; end; - tyInt16: begin result := 2; a := result; end; - tyInt32, tyFloat32: begin result := 4; a := result; end; - tyInt64, tyFloat64: begin result := 8; a := result; end; - tyFloat: begin result := floatSize; a := result; end; - tyProc: begin - if typ.callConv = ccClosure then result := 2 * ptrSize - else result := ptrSize; - a := ptrSize; - end; - tyNil, tyCString, tyString, tySequence, tyPtr, tyRef, - tyOpenArray: begin result := ptrSize; a := result; end; - tyArray, tyArrayConstr: begin - result := lengthOrd(typ.sons[0]) * computeSizeAux(typ.sons[1], a); - end; - tyEnum: begin - if firstOrd(typ) < 0 then - result := 4 // use signed int32 - else begin - len := lastOrd(typ); // BUGFIX: use lastOrd! - if len+1 < shlu(1, 8) then result := 1 - else if len+1 < shlu(1, 16) then result := 2 - else if len+1 < shlu(biggestInt(1), 32) then result := 4 - else result := 8; - end; - a := result; - end; - tySet: begin - len := lengthOrd(typ.sons[0]); - if len <= 8 then result := 1 - else if len <= 16 then result := 2 - else if len <= 32 then result := 4 - else if len <= 64 then result := 8 - else if align(len, 8) mod 8 = 0 then result := align(len, 8) div 8 - else result := align(len, 8) div 8 + 1; // BUGFIX! - a := result; - end; - tyRange: result := computeSizeAux(typ.sons[0], a); - tyTuple: begin - result := 0; - maxAlign := 1; - for i := 0 to sonsLen(typ)-1 do begin - res := computeSizeAux(typ.sons[i], a); - if res < 0 then begin result := res; exit end; - maxAlign := max(maxAlign, a); - result := align(result, a) + res; - end; - result := align(result, maxAlign); - a := maxAlign; - end; - tyObject: begin - if typ.sons[0] <> nil then begin - result := computeSizeAux(typ.sons[0], a); - if result < 0 then exit; - maxAlign := a - end - else if isObjectWithTypeFieldPredicate(typ) then begin - result := intSize; maxAlign := result; - end - else begin - result := 0; maxAlign := 1 - end; - currOffset := result; - result := computeRecSizeAux(typ.n, a, currOffset); - if result < 0 then exit; - if a < maxAlign then a := maxAlign; - result := align(result, a); - end; - tyGenericInst, tyDistinct, tyGenericBody: begin - result := computeSizeAux(lastSon(typ), a); - end; - else begin - //internalError('computeSizeAux()'); - result := -1; - end - end; - typ.size := result; - typ.align := int(a); -end; - -function computeSize(typ: PType): biggestInt; -var - a: biggestInt; -begin - a := 1; - result := computeSizeAux(typ, a); -end; - -function getSize(typ: PType): biggestInt; -begin - result := computeSize(typ); - if result < 0 then - InternalError('getSize(' +{&} typekindToStr[typ.kind] +{&} ')'); -end; - -end. diff --git a/nim/wordrecg.pas b/nim/wordrecg.pas deleted file mode 100755 index c18969877..000000000 --- a/nim/wordrecg.pas +++ /dev/null @@ -1,220 +0,0 @@ -// -// -// The Nimrod Compiler -// (c) Copyright 2009 Andreas Rumpf -// -// See the file "copying.txt", included in this -// distribution, for details about the copyright. -// -unit wordrecg; - -// This module contains a word recognizer, i.e. a simple -// procedure which maps special words to an enumeration. -// It is primarily needed because Pascal's case statement -// does not support strings. Without this the code would -// be slow and unreadable. - -interface - -{$include 'config.inc'} - -uses - nsystem, nhashes, strutils, idents; - -type - TSpecialWord = (wInvalid, - // these are mapped to Nimrod keywords: - //[[[cog - //from string import split, capitalize - //keywords = split(open("data/keywords.txt").read()) - //idents = "" - //strings = "" - //i = 1 - //for k in keywords: - // 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, - wBind, wBlock, wBreak, wCase, - wCast, wConst, wContinue, wConverter, - wDiscard, wDistinct, wDiv, wElif, - wElse, wEnd, wEnum, wExcept, - wFinally, wFor, wFrom, wGeneric, - wIf, wImplies, wImport, wIn, - wInclude, wIs, wIsnot, wIterator, - wLambda, wMacro, wMethod, wMod, - wNil, wNot, wNotin, wObject, - wOf, wOr, wOut, wProc, - wPtr, wRaise, wRef, wReturn, - wShl, wShr, wTemplate, wTry, - wTuple, wType, wVar, wWhen, - wWhile, wWith, wWithout, wXor, - wYield, - //[[[end]]] - // other special tokens: - wColon, wEquals, wDot, wDotDot, wHat, - wStar, wMinus, - // pragmas and command line options: - wMagic, wTypeCheck, wFinal, wProfiler, - wObjChecks, wImportc, wExportc, wAlign, wNodecl, wPure, - wVolatile, wRegister, wSideeffect, wHeader, wNosideeffect, wNoreturn, - wMerge, wLib, wDynlib, wCompilerproc, wProcVar, wFatal, - wError, wWarning, wHint, wLine, wPush, wPop, - wDefine, wUndef, wLinedir, wStacktrace, wLinetrace, wParallelBuild, - wLink, wCompile, wLinksys, wDeprecated, wVarargs, - wByref, wCallconv, wBreakpoint, wDebugger, wNimcall, wStdcall, - 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, wDeadCodeElim, wSafecode, wCompileTime, - wGc, wRefc, wBoehm, wA, wOpt, wO, - wApp, wConsole, wGui, wPassc, wT, wPassl, - wL, wListcmd, wGendoc, wGenmapping, - wOs, wCpu, wGenerate, wG, wC, wCpp, - wBorrow, wRun, wR, wVerbosity, wV, wHelp, - wH, wSymbolFiles, wFieldChecks, wX, wVersion, wAdvanced, - wSkipcfg, wSkipProjCfg, wCc, wGenscript, wCheckPoint, wCheckPoints, - wNoMain, - wSubsChar, wAcyclic, wIndex, - // commands: - wCompileToC, wCompileToCpp, wCompileToEcmaScript, wCompileToLLVM, - wPretty, wDoc, wPas, - wGenDepend, wListDef, wCheck, wParse, wScan, wBoot, wLazy, - wRst2html, wRst2tex, wI, - // special for the preprocessor of configuration files: - wWrite, wPutEnv, wPrependEnv, wAppendEnv, - // additional Pascal keywords: - wArray, wBegin, wClass, - wConstructor, wDestructor, wDo, wDownto, - wExports, wFinalization, wFunction, wGoto, - wImplementation, wInherited, wInitialization, wInterface, - wLabel, wLibrary, wPacked, - wProcedure, wProgram, wProperty, wRecord, wRepeat, wResourcestring, - wSet, wThen, wThreadvar, wTo, wUnit, wUntil, - wUses, - // Pascal special tokens: - wExternal, wOverload, wFar, wAssembler, wForward, wIfdef, wIfndef, - wEndif - ); - TSpecialWords = set of TSpecialWord; -const - oprLow = ord(wColon); - oprHigh = ord(wHat); - specialWords: array [low(TSpecialWord)..high(TSpecialWord)] of string = ('', - // keywords: - //[[[cog - //cog.out(strings) - //]]] - 'addr', 'and', 'as', 'asm', - 'bind', 'block', 'break', 'case', - 'cast', 'const', 'continue', 'converter', - 'discard', 'distinct', 'div', 'elif', - 'else', 'end', 'enum', 'except', - 'finally', 'for', 'from', 'generic', - 'if', 'implies', 'import', 'in', - 'include', 'is', 'isnot', 'iterator', - 'lambda', 'macro', 'method', 'mod', - 'nil', 'not', 'notin', 'object', - 'of', 'or', 'out', 'proc', - 'ptr', 'raise', 'ref', 'return', - 'shl', 'shr', 'template', 'try', - 'tuple', 'type', 'var', 'when', - 'while', 'with', 'without', 'xor', - 'yield', - //[[[end]]] - // other special tokens: - ':'+'', '='+'', '.'+'', '..', '^'+'', - '*'+'', '-'+'', - // pragmas and command line options: - 'magic', 'typecheck', 'final', 'profiler', - 'objchecks', 'importc', 'exportc', 'align', 'nodecl', 'pure', - 'volatile', 'register', 'sideeffect', 'header', 'nosideeffect', 'noreturn', - 'merge', 'lib', 'dynlib', 'compilerproc', 'procvar', 'fatal', - 'error', 'warning', 'hint', 'line', 'push', 'pop', - 'define', 'undef', 'linedir', 'stacktrace', 'linetrace', 'parallelbuild', - 'link', 'compile', 'linksys', 'deprecated', 'varargs', - 'byref', 'callconv', 'breakpoint', 'debugger', 'nimcall', 'stdcall', - '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'+'', 'deadcodeelim', 'safecode', 'compiletime', - 'gc', 'refc', 'boehm', 'a'+'', 'opt', 'o'+'', - 'app', 'console', 'gui', 'passc', 't'+'', 'passl', - 'l'+'', 'listcmd', 'gendoc', 'genmapping', - 'os', 'cpu', 'generate', 'g'+'', 'c'+'', 'cpp', - 'borrow', 'run', 'r'+'', 'verbosity', 'v'+'', 'help', - 'h'+'', 'symbolfiles', 'fieldchecks', 'x'+'', 'version', 'advanced', - 'skipcfg', 'skipprojcfg', 'cc', 'genscript', 'checkpoint', 'checkpoints', - 'nomain', - 'subschar', 'acyclic', 'index', - // commands: - 'compiletoc', 'compiletocpp', 'compiletoecmascript', 'compiletollvm', - 'pretty', 'doc', 'pas', 'gendepend', 'listdef', 'check', 'parse', - 'scan', 'boot', 'lazy', 'rst2html', 'rst2tex', 'i'+'', - - // special for the preprocessor of configuration files: - 'write', 'putenv', 'prependenv', 'appendenv', - - 'array', 'begin', 'class', - 'constructor', 'destructor', 'do', 'downto', - 'exports', 'finalization', 'function', 'goto', - 'implementation', 'inherited', 'initialization', 'interface', - 'label', 'library', 'packed', - 'procedure', 'program', 'property', 'record', 'repeat', 'resourcestring', - 'set', 'then', 'threadvar', 'to', 'unit', 'until', - 'uses', - - // Pascal special tokens - 'external', 'overload', 'far', 'assembler', 'forward', 'ifdef', 'ifndef', - 'endif' - ); - -function whichKeyword(id: PIdent): TSpecialWord; overload; -function whichKeyword(const id: String): TSpecialWord; overload; - -function findStr(const a: array of string; const s: string): int; - -implementation - -function findStr(const a: array of string; const s: string): int; -var - i: int; -begin - for i := low(a) to high(a) do - if cmpIgnoreStyle(a[i], s) = 0 then begin result := i; exit end; - result := -1; -end; - -function whichKeyword(const id: String): TSpecialWord; overload; -begin - result := whichKeyword(getIdent(id)) -end; - -function whichKeyword(id: PIdent): TSpecialWord; overload; -begin - if id.id < 0 then result := wInvalid - else result := TSpecialWord(id.id); -end; - -procedure initSpecials(); -var - s: TSpecialWord; -begin - // initialize the keywords: - for s := succ(low(specialWords)) to high(specialWords) do - getIdent(specialWords[s], - getNormalizedHash(specialWords[s])).id := ord(s) -end; - -initialization - initSpecials(); -end. |