diff options
Diffstat (limited to 'nim/astalgo.pas')
| -rwxr-xr-x | nim/astalgo.pas | 1294 |
1 files changed, 0 insertions, 1294 deletions
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. |