diff --git a/src/grammar/ast.ts b/src/grammar/ast.ts index 536d31346..7d5976cba 100644 --- a/src/grammar/ast.ts +++ b/src/grammar/ast.ts @@ -57,17 +57,26 @@ export type AstAsmFunctionDef = { name: AstId; return: AstType | null; params: AstTypedParameter[]; - instructions: AstAsmInstruction[]; + expressions: AstAsmExpression[]; id: number; loc: SrcInfo; }; -export type AstAsmInstruction = string; export type AstAsmShuffle = { args: AstId[]; ret: AstNumber[]; }; +export type AstAsmExpression = + | AstAsmExpressionList + | string; + +export type AstAsmExpressionList = { + kind: "asm_expr_list"; + expressions: AstAsmExpression[]; + loc: SrcInfo; +}; + export type AstFunctionDecl = { kind: "function_decl"; attributes: AstFunctionAttribute[]; diff --git a/src/grammar/compare.ts b/src/grammar/compare.ts index d744caecc..2d8364d83 100644 --- a/src/grammar/compare.ts +++ b/src/grammar/compare.ts @@ -51,7 +51,7 @@ import { AstNode, AstFuncId, AstAsmFunctionDef, - AstAsmInstruction, + AstAsmExpression, AstDestructMapping, AstStatementDestruct, } from "./ast"; @@ -850,8 +850,8 @@ export class AstComparator { } private compareAsmInstructions( - instructions1: AstAsmInstruction[], - instructions2: AstAsmInstruction[], + instructions1: AstAsmExpression[], + instructions2: AstAsmExpression[], ): boolean { if (instructions1.length !== instructions2.length) { return false; diff --git a/src/grammar/grammar.ohm b/src/grammar/grammar.ohm index 2f17501e4..3680ba9e7 100644 --- a/src/grammar/grammar.ohm +++ b/src/grammar/grammar.ohm @@ -22,7 +22,7 @@ Tact { ModuleFunction = FunctionDefinition | AsmFunction - AsmFunction = "asm" AsmShuffle? FunctionAttribute* fun id Parameters (":" Type)? "{" AsmInstruction* "}" + AsmFunction = "asm" AsmShuffle? FunctionAttribute* fun id Parameters (":" Type)? "{" AsmExpression* "}" ModuleConstant = ConstantDefinition @@ -99,20 +99,62 @@ Tact { | external "(" Parameter? ")" "{" Statement* "}" --externalRegular | external "(" stringLiteral ")" "{" Statement* "}" --externalComment - AsmInstruction = "[" &#whiteSpace AsmInstruction* "]" &#whiteSpace --internal - | "{" &#whiteSpace AsmInstruction* "}" &#whiteSpace --list - | "({)" &#whiteSpace AsmInstruction* "(})" &#whiteSpace --listNoStateCheck - | ("abort\"" | ".\"" | "+\"" | "\"") (~"\"" any)* "\"" &#whiteSpace --string - | "'" &#whiteSpace asmInstruction --tick - | "char" &#whiteSpace (~whiteSpace any) &#whiteSpace --char - | ("x{" | "B{") ~#whiteSpace hexDigit* ~#whiteSpace ("_" ~#whiteSpace)? "}" &#whiteSpace --hexLiteral - | "b{" ~#whiteSpace binDigit* ~#whiteSpace "}" &#whiteSpace --binLiteral - | asmInstruction --custom + // FIXME: grammar.ts, prettyPrinter.ts, hash.ts, compare.ts + AsmExpression = "{" &#whiteSpace AsmExpression* "}" &#whiteSpace --list + | "SETEXITALT:<{" &#whiteSpace AsmExpression* AsmBlockEnd --setExitAlt + | "ATEXITALT:<{" &#whiteSpace AsmExpression* AsmBlockEnd --atExitAlt + | "ATEXIT:<{" &#whiteSpace AsmExpression* AsmBlockEnd --atExit + | "PROCINLINE:<{" &#whiteSpace AsmExpression* AsmBlockEnd --procInline + | "PROCREF:<{" &#whiteSpace AsmExpression* AsmBlockEnd --procRef + | "PROC:<{" &#whiteSpace AsmExpression* AsmBlockEnd --proc + | "CONT:<{" &#whiteSpace AsmExpression* AsmBlockEnd --cont + | "WHILEBRK:<{" &#whiteSpace AsmExpression* AsmDo AsmBlockEnd --whileBrk + | "WHILE:<{" &#whiteSpace AsmExpression* AsmDo AsmBlockEnd --while + | "UNTILBRK:<{" &#whiteSpace AsmExpression* AsmBlockEnd --untilBrk + | "UNTIL:<{" &#whiteSpace AsmExpression* AsmBlockEnd --until + | "AGAINBRK:<{" &#whiteSpace AsmExpression* AsmBlockEnd --againBrk + | "AGAIN:<{" &#whiteSpace AsmExpression* AsmBlockEnd --again + | "REPEATBRK:<{" &#whiteSpace AsmExpression* AsmBlockEnd --repeatBrk + | "REPEAT:<{" &#whiteSpace AsmExpression* AsmBlockEnd --repeat + | "TRY:<{" &#whiteSpace AsmExpression* "}>CATCH<{" &#whiteSpace AsmExpression* AsmBlockEnd --tryCatch + | "IFNOTJMP:<{" &#whiteSpace AsmExpression* AsmElse AsmBlockEnd --ifNotJmpWithElse + | "IFNOTJMP:<{" &#whiteSpace AsmExpression* AsmBlockEnd --ifNotJmp + | "IFNOT:<{" &#whiteSpace AsmExpression* AsmElse AsmBlockEnd --ifNotWithElse + | "IFNOT:<{" &#whiteSpace AsmExpression* AsmBlockEnd --ifNot + | "IFJMP:<{" &#whiteSpace AsmExpression* AsmElse AsmBlockEnd --ifJmpWithElse + | "IFJMP:<{" &#whiteSpace AsmExpression* AsmBlockEnd --ifJmp + | AsmPrimitive + | "IF:<{" &#whiteSpace AsmExpression* AsmElse AsmBlockEnd --ifWithElse + | "IF:<{" &#whiteSpace AsmExpression* AsmBlockEnd --if + | AsmPrimitive + + // Common parts, not standalone instructions or words + AsmElse = "}>ELSE<{" &#whiteSpace AsmExpression* --block + | "}>ELSE:" &#whiteSpace AsmExpression* --colon + AsmDo = "}>DO<{" &#whiteSpace AsmExpression* --block + | "}>DO:" &#whiteSpace AsmExpression* --colon + // TODO(grammar.ts): check that --cont version matches the prefix + AsmBlockEnd = "}>" #asmWord &#whiteSpace --cont + | "}>" &#whiteSpace --base + + // Various instructions not forming a block + // TODO(grammar.ts): perform checks for inner contents of the string + AsmPrimitive = "\"" (~"\"" any)* "\"" &#whiteSpace --string + | ("x{" | "B{") ~#whiteSpace hexDigit* ~#whiteSpace ("_" ~#whiteSpace)? "}" &#whiteSpace --hexLiteral + | "b{" ~#whiteSpace binDigit* ~#whiteSpace "}" &#whiteSpace --binLiteral + // TODO(grammar.ts): limit up to 15 + | "c" #(digit digit?) &#whiteSpace --controlRegister + // TODO(grammar.ts): limit up to 15 + | "s" #(digit digit?) &#whiteSpace --stackRegister + // TODO(grammar.ts): limit up to 255 + | digit #(digit digit?)? &#whiteSpace "s()" &#whiteSpace --stackRegister255 + | digit+ &#whiteSpace --number + | asmInstruction --custom // Instructions exclude some begin and end words to ensure correct parse - asmInstruction = ~(("[" | "]" | "{" | "}" | "({)" | "(})") ~asmWord) asmWord + asmInstruction = ~(("{" | "}") ~asmWord) asmWord - // A chunk of non-whitespace characters forms a word in Fift + // A chunk of non-whitespace characters forms a word asmWord = (~whiteSpace any)+ Statement = StatementLet diff --git a/src/grammar/grammar.spec.ts b/src/grammar/grammar.spec.ts index 31a5bdadf..47616705c 100644 --- a/src/grammar/grammar.spec.ts +++ b/src/grammar/grammar.spec.ts @@ -1,5 +1,5 @@ import { parse } from "./grammar"; -import { AstModule, SrcInfo, __DANGER_resetNodeId } from "./ast"; +import { SrcInfo, __DANGER_resetNodeId } from "./ast"; import { loadCases } from "../utils/loadCases"; expect.addSnapshotSerializer({ @@ -12,20 +12,6 @@ describe("grammar", () => { __DANGER_resetNodeId(); }); - // Test parsing of known Fift projects, wrapped in asm functions of Tact - for (const r of loadCases(__dirname + "/test-asm/")) { - it("should parse " + r.name, () => { - const parsed: AstModule | undefined = parse( - r.code, - "", - "user", - ); - - // Don't produce snapshots - expect(parsed).toBeDefined(); - }); - } - for (const r of loadCases(__dirname + "/test/")) { it("should parse " + r.name, () => { expect(parse(r.code, "", "user")).toMatchSnapshot(); diff --git a/src/grammar/grammar.ts b/src/grammar/grammar.ts index 2048e5139..111ee2235 100644 --- a/src/grammar/grammar.ts +++ b/src/grammar/grammar.ts @@ -344,7 +344,7 @@ semantics.addOperation("astOfItem", { _optColon, optReturnType, _lbrace, - asmInstructions, + asmExpressions, _rbrace, ) { const shuffle = optAsmShuffle.children[0]?.astsOfAsmShuffle() ?? { @@ -363,8 +363,8 @@ semantics.addOperation("astOfItem", { name: funId.astOfExpression(), return: unwrapOptNode(optReturnType, (t) => t.astOfType()), params: funParameters.astsOfList(), - instructions: asmInstructions.children.map((s) => - s.astOfAsmInstruction(), + expressions: asmExpressions.children.map((s) => + s.astOfAsmExpression(), ), loc: createRef(this), }); @@ -502,11 +502,19 @@ semantics.addOperation("astOfItem", { }, }); -// Beginnings of the possible future AST for Fift-asm -semantics.addOperation("astOfAsmInstruction", { +// TVM instructions +semantics.addOperation("astOfAsmExpression", { asmInstruction(word) { + // TODO: make a node here! return word.sourceString; }, + AsmExpression(expression) { + return expression.astOfAsmExpression(); + }, + AsmExpression_list(_lbrace, _ws1, _arg2, _rbrace, _ws2) { + // TODO: make a node here! + return ''; + }, AsmInstruction(instruction) { return instruction.astOfAsmInstruction(); }, diff --git a/src/grammar/hash.ts b/src/grammar/hash.ts index 3a1582f13..10ceee6e9 100644 --- a/src/grammar/hash.ts +++ b/src/grammar/hash.ts @@ -23,7 +23,7 @@ import { AstFieldDecl, AstNode, AstAsmFunctionDef, - AstAsmInstruction, + AstAsmExpression, } from "./ast"; import { createHash } from "crypto"; import { throwInternalCompilerError } from "../errors"; @@ -312,7 +312,7 @@ export class AstHasher { return hashedStatements.join("|"); } - private hashInstructions(instructions: AstAsmInstruction[]): string { + private hashInstructions(instructions: AstAsmExpression[]): string { return instructions.join("|"); } diff --git a/src/grammar/test-asm/embed-asm-fif.tact b/src/grammar/test-asm/embed-asm-fif.tact deleted file mode 100644 index de29f1eae..000000000 --- a/src/grammar/test-asm/embed-asm-fif.tact +++ /dev/null @@ -1,1655 +0,0 @@ -/// Tests parsing of Asm.fif by embedding its contents -asm fun embedAsmFif() { - library TVM_Asm - // simple TVM Assembler - namespace Asm - Asm definitions - "0.4.5" constant asm-fif-version - - variable @atend - variable @was-split - false @was-split ! - { "not in asm context" abort } @atend ! - { `normal eq? not abort"must be terminated by }>" } : @normal? - { context@ @atend @ 2 { @atend ! context! @normal? } does @atend ! } : @pushatend - { @pushatend Asm - { }> b> } : }>c - { }>c s - { @atend @ 2 { true @was-split ! @atend ! rot b> ref, swap @endblk } does @atend ! = -rot <= and } : 2x<= - { 2 pick brembitrefs 1- 2x<= } : @havebitrefs - { @havebits ' @| ifnot } : @ensurebits - { @havebitrefs ' @| ifnot } : @ensurebitrefs - { rot over @ensurebits -rot u, } : @simpleuop - { tuck sbitrefs @ensurebitrefs swap s, } : @addop - { tuck bbitrefs @ensurebitrefs swap b+ } : @addopb - ' @addopb : @inline - { 1 ' @addop does create } : @Defop - { 1 { } : si() - // x mi ma -- ? - { rot tuck >= -rot <= and } : @range - { rot tuck < -rot > or } : @-range - { @-range abort"Out of range" } : @rangechk - { dup 0 < over 255 > or abort"Invalid stack register number" si() } : s() - { si() constant } : @Sreg - -2 @Sreg s(-2) - -1 @Sreg s(-1) - 0 @Sreg s0 - 1 @Sreg s1 - 2 @Sreg s2 - 3 @Sreg s3 - 4 @Sreg s4 - 5 @Sreg s5 - 6 @Sreg s6 - 7 @Sreg s7 - 8 @Sreg s8 - 9 @Sreg s9 - 10 @Sreg s10 - 11 @Sreg s11 - 12 @Sreg s12 - 13 @Sreg s13 - 14 @Sreg s14 - 15 @Sreg s15 - { dup 0 < over 7 > or abort"Invalid control register number" } : c() - { c() constant } : @Creg - 0 @Creg c0 - 1 @Creg c1 - 2 @Creg c2 - 3 @Creg c3 - 4 @Creg c4 - 5 @Creg c5 - 7 @Creg c7 - { abort"not a stack register" 12 i@+ s> } : @bigsridx - { @bigsridx dup 16 >= over 0< or abort"stack register s0..s15 expected" } : @sridx - { rot @bigsridx tuck < -rot tuck > rot or abort"stack register out of range" } : @sridxrange - { swap @bigsridx + dup 16 >= over 0< or abort"stack register out of range" } : @sridx+ - { swap 0xcc <> over 7 > or over 6 = or abort"not a control register c0..c5 or c7" } : @cridx - { = - { tuck 16 >= - { = and - { 15 and abort"integer too large" 8 + 2dup fits } until - > 2- 5 u, -rot i, - } cond - } cond - } cond - @addopb } dup : PUSHINT : INT - { dup 256 = abort"use PUSHNAN instead of 256 PUSHPOW2" = or abort"invalid slice padding" - swap 1 1 u, 0 rot u, } : @scomplete - { tuck sbitrefs swap 26 + swap @havebitrefs not - { PUSHREFSLICE } - { over sbitrefs 2dup 123 0 2x<= - { drop tuck 4 + 3 >> swap x{8B} s, over 4 u, 3 roll s, - -rot 3 << 4 + swap - @scomplete } - { 2dup 1 >= swap 248 <= and - { rot x{8C} s, swap 1- 2 u, over 7 + 3 >> tuck 5 u, 3 roll s, - -rot 3 << 1 + swap - @scomplete } - { rot x{8D} s, swap 3 u, over 2 + 3 >> tuck 7 u, 3 roll s, - -rot 3 << 6 + swap - @scomplete - } cond - } cond - } cond - } dup : PUSHSLICE : SLICE - // ( b' -- ? ) - { bbitrefs or 0= } : @cont-empty? - { bbits 7 and 0= } : @cont-aligned? - // ( b b' -- ? ) - { bbitrefs over 7 and { 2drop drop false } { - swap 16 + swap @havebitrefs nip - } cond - } : @cont-fits? - // ( b b' -- ? ) - { bbitrefs over 7 and { 2drop drop false } { - 32 1 pair+ @havebitrefs nip - } cond - } : @cont-ref-fit? - // ( b b' b'' -- ? ) - { over @cont-aligned? over @cont-aligned? and not { 2drop drop false } { - bbitrefs rot bbitrefs pair+ swap 32 + swap @havebitrefs nip - } cond - } : @two-cont-fit? - { 2dup @cont-fits? not - { b> PUSHREFCONT } - { swap over bbitrefs 2dup 120 0 2x<= - { drop swap x{9} s, swap 3 >> 4 u, swap b+ } - { rot x{8F_} s, swap 2 u, swap 3 >> 7 u, swap b+ } cond - } cond - } dup : PUSHCONT : CONT - { }> PUSHCONT } : }>CONT - { { @normal? PUSHCONT } @doafter<{ } : CONT:<{ - - // arithmetic operations - { 2 { rot dup 8 fits - { nip = { rot drop -rot PUSHINT swap LSHIFT# } { - { drop PUSHINT } { - not pow2decomp swap -1 = { nip PUSHPOW2DEC } { - drop PUSHINT - } cond } cond } cond } cond } cond } cond - } dup : PUSHINTX : INTX - - // integer comparison - x{B8} @Defop SGN - x{B9} @Defop LESS - x{BA} @Defop EQUAL - x{BB} @Defop LEQ - x{BC} @Defop GREATER - x{BD} @Defop NEQ - x{BE} @Defop GEQ - x{BF} @Defop CMP - x{C0} x{BA} @Defop(8i,alt) EQINT - x{C000} @Defop ISZERO - x{C1} x{B9} @Defop(8i,alt) LESSINT - { 1+ LESSINT } : LEQINT - x{C100} @Defop ISNEG - x{C101} @Defop ISNPOS - x{C2} x{BC} @Defop(8i,alt) GTINT - { 1- GTINT } : GEQINT - x{C200} @Defop ISPOS - x{C2FF} @Defop ISNNEG - x{C3} x{BD} @Defop(8i,alt) NEQINT - x{C300} @Defop ISNZERO - x{C4} @Defop ISNAN - x{C5} @Defop CHKNAN - - // other comparison - x{C700} @Defop SEMPTY - x{C701} @Defop SDEMPTY - x{C702} @Defop SREMPTY - x{C703} @Defop SDFIRST - x{C704} @Defop SDLEXCMP - x{C705} @Defop SDEQ - x{C708} @Defop SDPFX - x{C709} @Defop SDPFXREV - x{C70A} @Defop SDPPFX - x{C70B} @Defop SDPPFXREV - x{C70C} @Defop SDSFX - x{C70D} @Defop SDSFXREV - x{C70E} @Defop SDPSFX - x{C70F} @Defop SDPSFXREV - x{C710} @Defop SDCNTLEAD0 - x{C711} @Defop SDCNTLEAD1 - x{C712} @Defop SDCNTTRAIL0 - x{C713} @Defop SDCNTTRAIL1 - - // cell serialization (Builder manipulation primitives) - x{C8} @Defop NEWC - x{C9} @Defop ENDC - x{CA} @Defop(8u+1) STI - x{CB} @Defop(8u+1) STU - x{CC} @Defop STREF - x{CD} dup @Defop STBREFR @Defop ENDCST - x{CE} @Defop STSLICE - x{CF00} @Defop STIX - x{CF01} @Defop STUX - x{CF02} @Defop STIXR - x{CF03} @Defop STUXR - x{CF04} @Defop STIXQ - x{CF05} @Defop STUXQ - x{CF06} @Defop STIXRQ - x{CF07} @Defop STUXRQ - x{CF08} @Defop(8u+1) STI_l - x{CF09} @Defop(8u+1) STU_l - x{CF0A} @Defop(8u+1) STIR - x{CF0B} @Defop(8u+1) STUR - x{CF0C} @Defop(8u+1) STIQ - x{CF0D} @Defop(8u+1) STUQ - x{CF0E} @Defop(8u+1) STIRQ - x{CF0F} @Defop(8u+1) STURQ - x{CF10} @Defop STREF_l - x{CF11} @Defop STBREF - x{CF12} @Defop STSLICE_l - x{CF13} @Defop STB - x{CF14} @Defop STREFR - x{CF15} @Defop STBREFR_l - x{CF16} @Defop STSLICER - x{CF17} dup @Defop STBR @Defop BCONCAT - x{CF18} @Defop STREFQ - x{CF19} @Defop STBREFQ - x{CF1A} @Defop STSLICEQ - x{CF1B} @Defop STBQ - x{CF1C} @Defop STREFRQ - x{CF1D} @Defop STBREFRQ - x{CF1E} @Defop STSLICERQ - x{CF1F} dup @Defop STBRQ @Defop BCONCATQ - x{CF20} @Defop(ref) STREFCONST - { > tuck 3 u, 3 roll s, - -rot 3 << 2 + swap - @scomplete } - { 2drop swap PUSHSLICE STSLICER } cond - } cond - } : STSLICECONST - x{CF81} @Defop STZERO - x{CF83} @Defop STONE - - // cell deserialization (CellSlice primitives) - x{D0} @Defop CTOS - x{D1} @Defop ENDS - x{D2} @Defop(8u+1) LDI - x{D3} @Defop(8u+1) LDU - x{D4} @Defop LDREF - x{D5} @Defop LDREFRTOS - x{D6} @Defop(8u+1) LDSLICE - x{D700} @Defop LDIX - x{D701} @Defop LDUX - x{D702} @Defop PLDIX - x{D703} @Defop PLDUX - x{D704} @Defop LDIXQ - x{D705} @Defop LDUXQ - x{D706} @Defop PLDIXQ - x{D707} @Defop PLDUXQ - x{D708} @Defop(8u+1) LDI_l - x{D709} @Defop(8u+1) LDU_l - x{D70A} @Defop(8u+1) PLDI - x{D70B} @Defop(8u+1) PLDU - x{D70C} @Defop(8u+1) LDIQ - x{D70D} @Defop(8u+1) LDUQ - x{D70E} @Defop(8u+1) PLDIQ - x{D70F} @Defop(8u+1) PLDUQ - { dup 31 and abort"argument must be a multiple of 32" 5 >> 1- - > swap x{D72A_} s, over 7 u, 3 roll s, - -rot 3 << 3 + swap - @scomplete } : SDBEGINS:imm - { tuck sbitrefs abort"no references allowed in slice" dup 26 <= - { drop > swap x{D72E_} s, over 7 u, 3 roll s, - -rot 3 << 3 + swap - @scomplete } : SDBEGINSQ:imm - { tuck sbitrefs abort"no references allowed in slice" dup 26 <= - { drop rot 2 } { - swap @| swap 2dup @cont-fits? { rot 1 } { - b> rot 2 - } cond } cond } cond } cond - [] execute - } : @run-cont-op - { triple 1 ' @run-cont-op does create } : @def-cont-op - { DROP } { PUSHCONT IF } { IFREF } @def-cont-op IF-cont - { IFRET } { PUSHCONT IFJMP } { IFJMPREF } @def-cont-op IFJMP-cont - { DROP } { PUSHCONT IFNOT } { IFNOTREF } @def-cont-op IFNOT-cont - { IFNOTRET } { PUSHCONT IFNOTJMP } { IFNOTJMPREF } @def-cont-op IFNOTJMP-cont - { dup 2over rot } : 3dup - - recursive IFELSE-cont2 { - dup @cont-empty? { drop IF-cont } { - over @cont-empty? { nip IFNOT-cont } { - 3dup @two-cont-fit? { -rot PUSHCONT swap PUSHCONT IFELSE } { - 3dup nip @cont-ref-fit? { rot swap PUSHCONT swap b> IFREFELSE } { - 3dup drop @cont-ref-fit? { -rot PUSHCONT swap b> IFELSEREF } { - rot 32 2 @havebitrefs { rot b> rot b> IFREFELSEREF } { - @| -rot IFELSE-cont2 - } cond } cond } cond } cond } cond } cond - } swap ! - - { }> IF-cont } : }>IF - { }> IFNOT-cont } : }>IFNOT - { }> IFJMP-cont } : }>IFJMP - { }> IFNOTJMP-cont } : }>IFNOTJMP - { { @normal? IFJMP-cont } @doafter<{ } : IFJMP:<{ - { { @normal? IFNOTJMP-cont } @doafter<{ } : IFNOTJMP:<{ - { `else @endblk } : }>ELSE<{ - { `else: @endblk } : }>ELSE: - { 1 { swap @normal? swap IFELSE-cont2 } does @doafter<{ } : @doifelse - { 1 { swap @normal? IFELSE-cont2 } does @doafter<{ } : @doifnotelse - { - { dup `else eq? - { drop @doifelse } - { dup `else: eq? - { drop IFJMP-cont } - { @normal? IF-cont - } cond - } cond - } @doafter<{ - } : IF:<{ - { - { dup `else eq? - { drop @doifnotelse } - { dup `else: eq? - { drop IFNOTJMP-cont } - { @normal? IFNOT-cont - } cond - } cond - } @doafter<{ - } : IFNOT:<{ - - x{E304} @Defop CONDSEL - x{E305} @Defop CONDSELCHK - x{E308} @Defop IFRETALT - x{E309} @Defop IFNOTRETALT - { DO<{ - { `do: @endblk } : }>DO: - { }> PUSHCONT REPEAT } : }>REPEAT - { { @normal? PUSHCONT REPEAT } @doafter<{ } : REPEAT:<{ - { }> PUSHCONT UNTIL } : }>UNTIL - { { @normal? PUSHCONT UNTIL } @doafter<{ } : UNTIL:<{ - { PUSHCONT { @normal? PUSHCONT WHILE } @doafter<{ } : @dowhile - { - { dup `do eq? - { drop @dowhile } - { `do: eq? not abort"`}>DO<{` expected" PUSHCONT WHILEEND - } cond - } @doafter<{ - } : WHILE:<{ - { }> PUSHCONT AGAIN } : }>AGAIN - { { @normal? PUSHCONT AGAIN } @doafter<{ } : AGAIN:<{ - - x{E314} @Defop REPEATBRK - x{E315} @Defop REPEATENDBRK - x{E316} @Defop UNTILBRK - x{E317} dup @Defop UNTILENDBRK @Defop UNTILBRK: - x{E318} @Defop WHILEBRK - x{E319} @Defop WHILEENDBRK - x{E31A} @Defop AGAINBRK - x{E31B} dup @Defop AGAINENDBRK @Defop AGAINBRK: - - { }> PUSHCONT REPEATBRK } : }>REPEATBRK - { { @normal? PUSHCONT REPEATBRK } @doafter<{ } : REPEATBRK:<{ - { }> PUSHCONT UNTILBRK } : }>UNTILBRK - { { @normal? PUSHCONT UNTILBRK } @doafter<{ } : UNTILBRK:<{ - { PUSHCONT { @normal? PUSHCONT WHILEBRK } @doafter<{ } : @dowhile - { - { dup `do eq? - { drop @dowhile } - { `do: eq? not abort"`}>DO<{` expected" PUSHCONT WHILEENDBRK - } cond - } @doafter<{ - } : WHILEBRK:<{ - { }> PUSHCONT AGAINBRK } : }>AGAINBRK - { { @normal? PUSHCONT AGAINBRK } @doafter<{ } : AGAINBRK:<{ - - - // - // continuation stack manipulation and continuation creation - // - { PUSHCONT ATEXIT } : }>ATEXIT - { { @normal? PUSHCONT ATEXIT } @doafter<{ } : ATEXIT:<{ - x{EDF4} @Defop ATEXITALT - { }> PUSHCONT ATEXITALT } : }>ATEXITALT - { { @normal? PUSHCONT ATEXITALT } @doafter<{ } : ATEXITALT:<{ - x{EDF5} @Defop SETEXITALT - { }> PUSHCONT SETEXITALT } : }>SETEXITALT - { { @normal? PUSHCONT SETEXITALT } @doafter<{ } : SETEXITALT:<{ - x{EDF6} @Defop THENRET - x{EDF7} @Defop THENRETALT - x{EDF8} @Defop INVERT - x{EDF9} @Defop BOOLEVAL - x{EDFA} @Defop SAMEALT - x{EDFB} @Defop SAMEALTSAVE - // x{EE} is BLESSARGS - // - // dictionary subroutine call/jump primitives - { c3 PUSH EXECUTE } : CALLVAR - { c3 PUSH JMPX } : JMPVAR - { c3 PUSH } : PREPAREVAR - { dup 14 ufits { - dup 8 ufits { - CATCH<{ - { PUSHCONT { @normal? PUSHCONT TRY } @doafter<{ } : @trycatch - { - { `catch eq? not abort"`}>CATCH<{` expected" @trycatch - } @doafter<{ - } : TRY:<{ - // - // dictionary manipulation - ' NULL : NEWDICT - ' ISNULL : DICTEMPTY - ' STSLICE : STDICTS - x{F400} dup @Defop STDICT @Defop STOPTREF - x{F401} dup @Defop SKIPDICT @Defop SKIPOPTREF - x{F402} @Defop LDDICTS - x{F403} @Defop PLDDICTS - x{F404} dup @Defop LDDICT @Defop LDOPTREF - x{F405} dup @Defop PLDDICT @Defop PLDOPTREF - x{F406} @Defop LDDICTQ - x{F407} @Defop PLDDICTQ - - x{F40A} @Defop DICTGET - x{F40B} @Defop DICTGETREF - x{F40C} @Defop DICTIGET - x{F40D} @Defop DICTIGETREF - x{F40E} @Defop DICTUGET - x{F40F} @Defop DICTUGETREF - - x{F412} @Defop DICTSET - x{F413} @Defop DICTSETREF - x{F414} @Defop DICTISET - x{F415} @Defop DICTISETREF - x{F416} @Defop DICTUSET - x{F417} @Defop DICTUSETREF - x{F41A} @Defop DICTSETGET - x{F41B} @Defop DICTSETGETREF - x{F41C} @Defop DICTISETGET - x{F41D} @Defop DICTISETGETREF - x{F41E} @Defop DICTUSETGET - x{F41F} @Defop DICTUSETGETREF - - x{F422} @Defop DICTREPLACE - x{F423} @Defop DICTREPLACEREF - x{F424} @Defop DICTIREPLACE - x{F425} @Defop DICTIREPLACEREF - x{F426} @Defop DICTUREPLACE - x{F427} @Defop DICTUREPLACEREF - x{F42A} @Defop DICTREPLACEGET - x{F42B} @Defop DICTREPLACEGETREF - x{F42C} @Defop DICTIREPLACEGET - x{F42D} @Defop DICTIREPLACEGETREF - x{F42E} @Defop DICTUREPLACEGET - x{F42F} @Defop DICTUREPLACEGETREF - - x{F432} @Defop DICTADD - x{F433} @Defop DICTADDREF - x{F434} @Defop DICTIADD - x{F435} @Defop DICTIADDREF - x{F436} @Defop DICTUADD - x{F437} @Defop DICTUADDREF - x{F43A} @Defop DICTADDGET - x{F43B} @Defop DICTADDGETREF - x{F43C} @Defop DICTIADDGET - x{F43D} @Defop DICTIADDGETREF - x{F43E} @Defop DICTUADDGET - x{F43F} @Defop DICTUADDGETREF - - x{F441} @Defop DICTSETB - x{F442} @Defop DICTISETB - x{F443} @Defop DICTUSETB - x{F445} @Defop DICTSETGETB - x{F446} @Defop DICTISETGETB - x{F447} @Defop DICTUSETGETB - - x{F449} @Defop DICTREPLACEB - x{F44A} @Defop DICTIREPLACEB - x{F44B} @Defop DICTUREPLACEB - x{F44D} @Defop DICTREPLACEGETB - x{F44E} @Defop DICTIREPLACEGETB - x{F44F} @Defop DICTUREPLACEGETB - - x{F451} @Defop DICTADDB - x{F452} @Defop DICTIADDB - x{F453} @Defop DICTUADDB - x{F455} @Defop DICTADDGETB - x{F456} @Defop DICTIADDGETB - x{F457} @Defop DICTUADDGETB - - x{F459} @Defop DICTDEL - x{F45A} @Defop DICTIDEL - x{F45B} @Defop DICTUDEL - - x{F462} @Defop DICTDELGET - x{F463} @Defop DICTDELGETREF - x{F464} @Defop DICTIDELGET - x{F465} @Defop DICTIDELGETREF - x{F466} @Defop DICTUDELGET - x{F467} @Defop DICTUDELGETREF - - x{F469} @Defop DICTGETOPTREF - x{F46A} @Defop DICTIGETOPTREF - x{F46B} @Defop DICTUGETOPTREF - x{F46D} @Defop DICTSETGETOPTREF - x{F46E} @Defop DICTISETGETOPTREF - x{F46F} @Defop DICTUSETGETOPTREF - - x{F470} @Defop PFXDICTSET - x{F471} @Defop PFXDICTREPLACE - x{F472} @Defop PFXDICTADD - x{F473} @Defop PFXDICTDEL - - x{F474} @Defop DICTGETNEXT - x{F475} @Defop DICTGETNEXTEQ - x{F476} @Defop DICTGETPREV - x{F477} @Defop DICTGETPREVEQ - x{F478} @Defop DICTIGETNEXT - x{F479} @Defop DICTIGETNEXTEQ - x{F47A} @Defop DICTIGETPREV - x{F47B} @Defop DICTIGETPREVEQ - x{F47C} @Defop DICTUGETNEXT - x{F47D} @Defop DICTUGETNEXTEQ - x{F47E} @Defop DICTUGETPREV - x{F47F} @Defop DICTUGETPREVEQ - - x{F482} @Defop DICTMIN - x{F483} @Defop DICTMINREF - x{F484} @Defop DICTIMIN - x{F485} @Defop DICTIMINREF - x{F486} @Defop DICTUMIN - x{F487} @Defop DICTUMINREF - x{F48A} @Defop DICTMAX - x{F48B} @Defop DICTMAXREF - x{F48C} @Defop DICTIMAX - x{F48D} @Defop DICTIMAXREF - x{F48E} @Defop DICTUMAX - x{F48F} @Defop DICTUMAXREF - - x{F492} @Defop DICTREMMIN - x{F493} @Defop DICTREMMINREF - x{F494} @Defop DICTIREMMIN - x{F495} @Defop DICTIREMMINREF - x{F496} @Defop DICTUREMMIN - x{F497} @Defop DICTUREMMINREF - x{F49A} @Defop DICTREMMAX - x{F49B} @Defop DICTREMMAXREF - x{F49C} @Defop DICTIREMMAX - x{F49D} @Defop DICTIREMMAXREF - x{F49E} @Defop DICTUREMMAX - x{F49F} @Defop DICTUREMMAXREF - - x{F4A0} @Defop DICTIGETJMP - x{F4A1} @Defop DICTUGETJMP - x{F4A2} @Defop DICTIGETEXEC - x{F4A3} @Defop DICTUGETEXEC - { dup sbitrefs tuck 1 > swap 1 <> or abort"not a dictionary" swap 1 u@ over <> abort"not a dictionary" } : @chkdicts - { dup null? tuck { idict! - not abort"cannot add key to procedure info dictionary" - @procinfo ! - } : @procinfo! - // ( x v1 v2 -- ) - { not 2 pick @procinfo@ and xor swap @procinfo! } : @procinfo~! - // ( s i f -- ) - { over @procdictkeylen fits not abort"procedure index out of range" - over swap dup @procinfo~! 2dup @proclistadd - 1 'nop does swap 0 (create) - } : @declproc - { 1 'nop does swap 0 (create) } : @declglobvar - { @proccnt @ 1+ dup @proccnt ! 1 @declproc } : @newproc - { @gvarcnt @ 1+ dup @gvarcnt ! @declglobvar } : @newglobvar - variable @oldcurrent variable @oldctx - Fift-wordlist dup @oldcurrent ! @oldctx ! - { current@ @oldcurrent ! context@ @oldctx ! Asm definitions - @proccnt @ @proclist @ @procdict @ @procinfo @ @gvarcnt @ @parent-state @ current@ @oldcurrent @ @oldctx @ - 9 tuple @parent-state ! - hole current! - 0 =: main @proclist null! @proccnt 0! @gvarcnt 0! - { bl word @newproc } : NEWPROC - { bl word dup (def?) ' drop ' @newproc cond } : DECLPROC - { bl word dup find - { nip execute <> abort"method redefined with different id" } - { swap 17 @declproc } - cond } : DECLMETHOD - { bl word @newglobvar } : DECLGLOBVAR - "main" 0 @proclistadd - dictnew dup @procdict ! - @procinfo ! 16 0 @procinfo! - } : PROGRAM{ - { over sbits < { s>c } : }END> - { }END> b> } : }END>c - { }END>c s - - 0 constant recv_internal - -1 constant recv_external - -2 constant run_ticktock - -3 constant split_prepare - -4 constant split_install - - { asm-mode 0 3 ~! } : asm-no-remove-unused - { asm-mode 1 1 ~! } : asm-remove-unused // enabled by default - { asm-mode 3 3 ~! } : asm-warn-remove-unused - { asm-mode 4 4 ~! } : asm-warn-inline-mix - { asm-mode 0 4 ~! } : asm-no-warn-inline-mix // disabled by default - { asm-mode 8 8 ~! } : asm-warn-unused - { asm-mode 0 8 ~! } : asm-no-warn-unused // disabled by default - - // ( c -- ) add vm library for later use with runvmcode - { spec } : hash>libref - // ( c -- c' ) - { hash hash>libref } : >libref - - { dup "." $pos dup -1 = - { drop 0 } - { $| 1 $| nip swap (number) 1- abort"invalid version" - dup dup 0 < swap 999 > or abort"invalid version" - } - cond - } : parse-version-level - - { - 0 swap - "." $+ - { swap 1000 * swap parse-version-level rot + swap } 3 times - "" $= not abort"invalid version" - } : parse-asm-fif-version - - { - dup =: required-version parse-asm-fif-version - asm-fif-version parse-asm-fif-version - = 1+ { - "Required Asm.fif version: " @' required-version "; actual Asm.fif version: " asm-fif-version $+ $+ $+ abort - } if - } : require-asm-fif-version - - { - dup =: required-version parse-asm-fif-version - asm-fif-version parse-asm-fif-version - swap - >= 1+ { - "Required Asm.fif version: " @' required-version "; actual Asm.fif version: " asm-fif-version $+ $+ $+ abort - } if - } : require-asm-fif-version>= - - - Fift definitions Asm - ' <{ : <{ - ' PROGRAM{ : PROGRAM{ - ' asm-fif-version : asm-fif-version - ' require-asm-fif-version : require-asm-fif-version - ' require-asm-fif-version>= : require-asm-fif-version>= - Fift -} diff --git a/src/grammar/test-asm/embed-fift-fif.tact b/src/grammar/test-asm/embed-fift-fif.tact deleted file mode 100644 index f8fc844b7..000000000 --- a/src/grammar/test-asm/embed-fift-fif.tact +++ /dev/null @@ -1,150 +0,0 @@ -/// Tests parsing of Fift.fif by embedding its contents -asm fun embedFiftFif() { - { 0 word drop 0 'nop } :: // - { char " word 1 { swap { abort } if drop } } ::_ abort" - { { bl word dup "" $= abort"comment extends after end of file" "*/" $= } until 0 'nop } :: /* - // { bl word 1 2 ' (create) } "::" 1 (create) - // { bl word 0 2 ' (create) } :: : - // { bl word 2 2 ' (create) } :: :_ - // { bl word 3 2 ' (create) } :: ::_ - // { bl word 0 (create) } : create - // { bl word (forget) } : forget - { bl word 1 ' (forget) } :: [forget] - { char " word 1 ' type } ::_ ." - { char } word x>B 1 'nop } ::_ B{ - { swap ({) over 2+ -roll swap (compile) (}) } : does - { 1 'nop does create } : constant - { 2 'nop does create } : 2constant - { hole constant } : variable - 10 constant ten - { bl word 1 { find 0= abort"word not found" } } :: (') - { bl word find not abort"-?" 0 swap } :: [compile] - { bl word 1 { - dup find { " -?" $+ abort } ifnot nip execute - } } :: @' - { bl word 1 { swap 1 'nop does swap 0 (create) } - } :: =: - { bl word 1 { -rot 2 'nop does swap 0 (create) } - } :: 2=: - { } : s>c - { s>c hashB } : shash - // to be more efficiently re-implemented in C++ in the future - { dup 0< ' negate if } : abs - { 2dup > ' swap if } : minmax - { minmax drop } : min - { minmax nip } : max - "" constant <# - ' $reverse : #> - { swap 10 /mod char 0 + rot swap hold } : # - { { # over 0<= } until } : #s - { 0< { char - hold } if } : sign - // { dup abs <# #s rot sign #> nip } : (.) - // { (.) type } : ._ - // { ._ space } : . - { dup 10 < { 48 } { 55 } cond + } : Digit - { dup 10 < { 48 } { 87 } cond + } : digit - // x s b -- x' s' - { rot swap /mod Digit rot swap hold } : B# - { rot swap /mod digit rot swap hold } : b# - { 16 B# } : X# - { 16 b# } : x# - // x s b -- 0 s' - { -rot { 2 pick B# over 0<= } until rot drop } : B#s - { -rot { 2 pick b# over 0<= } until rot drop } : b#s - { 16 B#s } : X#s - { 16 b#s } : x#s - variable base - { 10 base ! } : decimal - { 16 base ! } : hex - { 8 base ! } : octal - { 2 base ! } : binary - { base @ B# } : Base# - { base @ b# } : base# - { base @ B#s } : Base#s - { base @ b#s } : base#s - // x w -- s - { over abs <# rot 1- ' X# swap times X#s rot sign #> nip } : (0X.) - { over abs <# rot 1- ' x# swap times x#s rot sign #> nip } : (0x.) - { (0X.) type } : 0X._ - { 0X._ space } : 0X. - { (0x.) type } : 0x._ - { 0x._ space } : 0x. - { bl (-trailing) } : -trailing - { char 0 (-trailing) } : -trailing0 - { char " word 1 ' $+ } ::_ +" - { find 0<> dup ' nip if } : (def?) - { bl word 1 ' (def?) } :: def? - { bl word 1 { (def?) not } } :: undef? - { def? ' skip-to-eof if } : skip-ifdef - { bl word dup (def?) { drop skip-to-eof } { 'nop swap 0 (create) } cond } : library - { bl word dup (def?) { 2drop skip-to-eof } { swap 1 'nop does swap 0 (create) } cond } : library-version - { hole dup 1 'nop does swap 1 { context! } does bl word tuck 0 (create) +"-wordlist" 0 (create) } : namespace - { context@ current! } : definitions - { char ) word "$" swap $+ 1 { find 0= abort"undefined parameter" execute } } ::_ $( - // b s -- ? - { sbitrefs rot brembitrefs rot >= -rot <= and } : s-fits? - // b s x -- ? - { swap sbitrefs -rot + rot brembitrefs -rot <= -rot <= and } : s-fits-with? - { 0 swap ! } : 0! - { tuck @ + swap ! } : +! - { tuck @ swap - swap ! } : -! - { 1 swap +! } : 1+! - { -1 swap +! } : 1-! - { null swap ! } : null! - { not 2 pick @ and xor swap ! } : ~! - 0 tuple constant nil - { 1 tuple } : single - { 2 tuple } : pair - { 3 tuple } : triple - { 1 untuple } : unsingle - { 2 untuple } : unpair - { 3 untuple } : untriple - { over tuple? { swap count = } { 2drop false } cond } : tuple-len? - { 0 tuple-len? } : nil? - { 1 tuple-len? } : single? - { 2 tuple-len? } : pair? - { 3 tuple-len? } : triple? - { 0 [] } : first - { 1 [] } : second - { 2 [] } : third - ' pair : cons - ' unpair : uncons - { 0 [] } : car - { 1 [] } : cdr - { cdr car } : cadr - { cdr cdr } : cddr - { cdr cdr car } : caddr - { null ' cons rot times } : list - { -rot pair swap ! } : 2! - { @ unpair } : 2@ - { true (atom) drop } : atom - { bl word atom 1 'nop } ::_ ` - { hole dup 1 { @ execute } does create } : recursive - { 0 { 1+ dup 1 ' $() does over (.) "$" swap $+ 0 (create) } rot times drop } : :$1..n - { 10 hold } : +cr - { 9 hold } : +tab - { "" swap { 0 word 2dup $cmp } { rot swap $+ +cr swap } while 2drop } : scan-until-word - { 0 word -trailing scan-until-word 1 'nop } ::_ $<< - { 0x40 runvmx } : runvmcode - { 0x48 runvmx } : gasrunvmcode - { 0xc8 runvmx } : gas2runvmcode - { 0x43 runvmx } : runvmdict - { 0x4b runvmx } : gasrunvmdict - { 0xcb runvmx } : gas2runvmdict - { 0x45 runvmx } : runvm - { 0x4d runvmx } : gasrunvm - { 0xcd runvmx } : gas2runvm - { 0x55 runvmx } : runvmctx - { 0x5d runvmx } : gasrunvmctx - { 0xdd runvmx } : gas2runvmctx - { 0x75 runvmx } : runvmctxact - { 0x7d runvmx } : gasrunvmctxact - { 0xfd runvmx } : gas2runvmctxact - { 0x35 runvmx } : runvmctxactq - { 0x3d runvmx } : gasrunvmctxactq -} - -// NOTE: FiftExt.fif isn't added to the test suite, because of two reasons: -// 1. It shadows the most important instructions for parsing: { and } -// That is, that shadowing uses out-of-place } and {, which cannot be allowed in the current (stackless and non-typechecking) version of the parser -// 2. That file isn't included into any smart contracts in TON monorepo (except for tests). Moreover, in third-party code on Github, it occurs only once — in a test .fif code, not the actual one. diff --git a/src/grammar/test-asm/embed-other-libs-fif.tact b/src/grammar/test-asm/embed-other-libs-fif.tact deleted file mode 100644 index d077d8a39..000000000 --- a/src/grammar/test-asm/embed-other-libs-fif.tact +++ /dev/null @@ -1,1207 +0,0 @@ -// -// Color.fif -// - -/// Tests parsing of Color.fif by embedding its contents -asm fun embedColorFif() { - library Color - { 27 emit } : esc - { char " word 27 chr swap $+ 1 ' type does create } :_ make-esc" - make-esc"[0m" ^reset - make-esc"[30m" ^black - make-esc"[31m" ^red - make-esc"[32m" ^green - make-esc"[33m" ^yellow - make-esc"[34m" ^blue - make-esc"[35m" ^magenta - make-esc"[36m" ^cyan - make-esc"[37m" ^white - // bold - make-esc"[30;1m" ^Black - make-esc"[31;1m" ^Red - make-esc"[32;1m" ^Green - make-esc"[33;1m" ^Yellow - make-esc"[34;1m" ^Blue - make-esc"[35;1m" ^Magenta - make-esc"[36;1m" ^Cyan - make-esc"[37;1m" ^White -} - -// -// Disasm.fif -// - -/// Tests parsing of Disasm.fif by embedding its contents -asm fun embedDisasmFif() { - library TVM_Disasm - // simple TVM Disassembler - "Lists.fif" include - - variable 'disasm - { 'disasm @ execute } : disasm // disassemble a slice - // usage: x{74B0} disasm - - variable @dismode @dismode 0! - { rot over @ and rot xor swap ! } : andxor! - { -2 0 @dismode andxor! } : stack-disasm // output 's1 s4 XCHG' - { -2 1 @dismode andxor! } : std-disasm // output 'XCHG s1, s4' - { -3 2 @dismode andxor! } : show-vm-code - { -3 0 @dismode andxor! } : hide-vm-code - { @dismode @ 1 and 0= } : stack-disasm? - - variable @indent @indent 0! - { ' space @indent @ 2* times } : .indent - { @indent 1+! } : +indent - { @indent 1-! } : -indent - - { " " $pos } : spc-pos - { dup " " $pos swap "," $pos dup 0< { drop } { - over 0< { nip } { min } cond } cond - } : spc-comma-pos - { { dup spc-pos 0= } { 1 $| nip } while } : -leading - { -leading -trailing dup spc-pos dup 0< { - drop dup $len { atom single } { drop nil } cond } { - $| swap atom swap -leading 2 { over spc-comma-pos dup 0>= } { - swap 1+ -rot $| 1 $| nip -leading rot - } while drop tuple - } cond - } : parse-op - { dup "s-1" $= { drop "s(-1)" true } { - dup "s-2" $= { drop "s(-2)" true } { - dup 1 $| swap "x" $= { nip "x{" swap $+ +"}" true } { - 2drop false } cond } cond } cond - } : adj-op-arg - { over count over <= { drop } { 2dup [] adj-op-arg { swap []= } { drop } cond } cond } : adj-arg[] - { 1 adj-arg[] 2 adj-arg[] 3 adj-arg[] - dup first - dup `XCHG eq? { - drop dup count 2 = { tpop swap "s0" , swap , } if } { - dup `LSHIFT eq? { - drop dup count 2 = stack-disasm? and { second `LSHIFT# swap pair } if } { - dup `RSHIFT eq? { - drop dup count 2 = stack-disasm? and { second `RSHIFT# swap pair } if } { - drop - } cond } cond } cond - } : adjust-op - - variable @cp @cp 0! - variable @curop - variable @contX variable @contY variable @cdict - - { atom>$ type } : .atom - { dup first .atom dup count 1 > { space 0 over count 2- { 1+ 2dup [] type .", " } swap times 1+ [] type } { drop } cond } : std-show-op - { 0 over count 1- { 1+ 2dup [] type space } swap times drop first .atom } : stk-show-op - { @dismode @ 2 and { .indent ."// " @curop @ csr. } if } : .curop? - { .curop? .indent @dismode @ 1 and ' std-show-op ' stk-show-op cond cr - } : show-simple-op - { dup 4 u@ 9 = { 8 u@+ swap 15 and 3 << s@ } { - dup 7 u@ 0x47 = { 7 u@+ nip 2 u@+ 7 u@+ -rot 3 << swap sr@ } { - dup 8 u@ 0x8A = { ref@ " cr } : show-cont-op - { swap scont-swap ":<{" show-cont-bodyx scont-swap - "" show-cont-bodyx .indent ."}>" cr } : show-cont2-op - - { @contX @ null? { "CONT" show-cont-op } ifnot - } : flush-contX - { @contY @ null? { scont-swap "CONT" show-cont-op scont-swap } ifnot - } : flush-contY - { flush-contY flush-contX } : flush-cont - { @contX @ null? not } : have-cont? - { @contY @ null? not } : have-cont2? - { flush-contY @contY ! scont-swap } : save-cont-body - - { @cdict ! } : save-const-dict - { @cdict null! } : flush-dict - { @cdict @ null? not } : have-dict? - - { flush-cont .indent type .":<{" cr - @curop @ ref@ " cr - } : show-ref-op - { flush-contY .indent rot type .":<{" cr - @curop @ ref@ " cr - } : show-cont-ref-op - { flush-cont .indent swap type .":<{" cr - @curop @ ref@+ " cr - } : show-ref2-op - - { flush-cont first atom>$ dup 5 $| drop "DICTI" $= swap - .indent type ." {" cr +indent @cdict @ @cdict null! unpair - rot { - swap .indent . ."=> <{" cr +indent disasm -indent .indent ."}>" cr true - } swap ' idictforeach ' dictforeach cond drop - -indent .indent ."}" cr - } : show-const-dict-op - - ( `PUSHCONT `PUSHREFCONT ) constant @PushContL - ( `REPEAT `UNTIL `IF `IFNOT `IFJMP `IFNOTJMP ) constant @CmdC1 - ( `IFREF `IFNOTREF `IFJMPREF `IFNOTJMPREF `CALLREF `JMPREF ) constant @CmdR1 - ( `DICTIGETJMP `DICTIGETJMPZ `DICTUGETJMP `DICTUGETJMPZ `DICTIGETEXEC `DICTUGETEXEC ) constant @JmpDictL - { dup first `DICTPUSHCONST eq? { - flush-cont @curop @ get-const-dict save-const-dict show-simple-op } { - dup first @JmpDictL list-member? have-dict? and { - flush-cont show-const-dict-op } { - flush-dict - dup first @PushContL list-member? { - drop @curop @ get-cont-body save-cont-body } { - dup first @CmdC1 list-member? have-cont? and { - flush-contY first atom>$ .curop? show-cont-op } { - dup first @CmdR1 list-member? { - flush-cont first atom>$ dup $len 3 - $| drop .curop? show-ref-op } { - dup first `WHILE eq? have-cont2? and { - drop "WHILE" "}>DO<{" .curop? show-cont2-op } { - dup first `IFELSE eq? have-cont2? and { - drop "IF" "}>ELSE<{" .curop? show-cont2-op } { - dup first dup `IFREFELSE eq? swap `IFELSEREF eq? or have-cont? and { - first `IFREFELSE eq? "IF" "}>ELSE<{" rot .curop? show-cont-ref-op } { - dup first `IFREFELSEREF eq? { - drop "IF" "}>ELSE<{" .curop? show-ref2-op } { - flush-cont show-simple-op - } cond } cond } cond } cond } cond } cond } cond } cond } cond - } : show-op - { dup @cp @ (vmoplen) dup 0> { 65536 /mod swap sr@+ swap dup @cp @ (vmopdump) parse-op swap s> true } { drop false } cond } : fetch-one-op - { { fetch-one-op } { swap @curop ! adjust-op show-op } while } : disasm-slice - { { disasm-slice dup sbitrefs 1- or 0= } { ref@ = { 2dup [] 3 pick 2 pick [] equal? { 1+ } { drop -1 } cond - } if } rot times - nip nip 0>= - } { drop 2drop false } cond - } { 2drop false } cond - } { eqv? } cond - } swap ! - // (a1 .. an) -- (an .. a1) - { null swap { dup null? not } { uncons swap rot cons swap } while drop } : list-reverse - // (a1 .. an) -- an Computes last element of non-empty list l - { { uncons dup null? { drop true } { nip false } cond } until } : list-last - // l l' -- l++l' Concatenates two lists - recursive list+ { - over null? { nip } { swap uncons rot list+ cons } cond - } swap ! - // l l' -- l'' -1 or 0, where l = l' ++ l'' - // Removes prefix from list - { { dup null? { drop true true } { - swap dup null? { 2drop false true } { // l' l - uncons swap rot uncons -rot equal? { false } { - 2drop false true - } cond } cond } cond } until - } : list- - // (a1 .. an) -- a1 .. an n Explodes a list - { 0 { over null? not } { swap uncons rot 1+ } while nip } : explode-list - // (a1 .. an) x -- a1 .. an n x Explodes a list under the topmost element - { swap explode-list dup 1+ roll } : explode-list-1 - // l -- t Transforms a list into a tuple with the same elements - { explode-list tuple } : list>tuple - // a1 ... an n x -- (a1 .. an) x - { null swap rot { -rot cons swap } swap times } : mklist-1 - // (s1 ... sn) -- s1+...+sn Concatenates a list of strings - { "" { over null? not } { swap uncons -rot $+ } while nip - } : concat-string-list - // (x1 ... xn) -- x1+...+xn Sums a list of integers - { 0 { over null? not } { swap uncons -rot + } while nip - } : sum-list - // (a1 ... an) a e -- e(...e(e(a,a1),a2),...),an) - { -rot { over null? not } { swap uncons -rot 3 pick execute } while nip nip - } : foldl - // (a1 ... an) e -- e(...e(e(a1,a2),a3),...),an) - { swap uncons swap rot foldl } : foldl-ne - // (a1 ... an) a e -- e(a1,e(a2,...,e(an,a)...)) - recursive foldr { - rot dup null? { 2drop } { - uncons -rot 2swap swap 3 pick foldr rot execute - } cond - } swap ! - // (a1 ... an) e -- e(a1,e(a2,...,e(a[n-1],an)...)) - recursive foldr-ne { - over cdr null? { drop car } { - swap uncons 2 pick foldr-ne rot execute - } cond - } swap ! - // (l1 ... ln) -- l1++...++ln Concatenates a list of lists - { dup null? { ' list+ foldr-ne } ifnot } : concat-list-lists - // (a1 .. an . t) n -- t Computes the n-th tail of a list - { ' cdr swap times } : list-tail - // (a0 .. an ..) n -- an Computes the n-th element of a list - { list-tail car } : list-ref - // l -- ? - { { dup null? { drop true true } { - dup pair? { cdr false } { - drop false true - } cond } cond } until - } : list? - // l -- n - { 0 { over null? not } { 1+ swap uncons nip swap } while nip - } : list-length - // l e -- t // returns tail of l after first member that satisfies e - { swap { - dup null? { nip true } { - tuck car over execute { drop true } { - swap cdr false - } cond } cond } until - } : list-tail-from - // a l -- t // tail of l after first occurence of a using eq? - { swap 1 ' eq? does list-tail-from } : list-member-eq - { swap 1 ' eqv? does list-tail-from } : list-member-eqv - { swap 1 ' equal? does list-tail-from } : list-member-equal - // a l -- ? - { list-member-eq null? not } : list-member? - { list-member-eqv null? not } : list-member-eqv? - // l -- a -1 or 0 // returns car l if l is non-empty - { dup null? { drop false } { car true } cond - } : safe-car - { dup null? { drop false } { car second true } cond - } : get-first-value - // l e -- v -1 or 0 - { list-tail-from safe-car } : assoc-gen - { list-tail-from get-first-value } : assoc-gen-x - // a l -- (a.v) -1 or 0 -- returns first entry (a . v) in l - { swap 1 { swap first eq? } does assoc-gen } : assq - { swap 1 { swap first eqv? } does assoc-gen } : assv - { swap 1 { swap first equal? } does assoc-gen } : assoc - // a l -- v -1 or 0 -- returns v from first entry (a . v) in l - { swap 1 { swap first eq? } does assoc-gen-x } : assq-val - { swap 1 { swap first eqv? } does assoc-gen-x } : assv-val - { swap 1 { swap first equal? } does assoc-gen-x } : assoc-val - // (a1 .. an) e -- (e(a1) .. e(an)) - recursive list-map { - over null? { drop } { - swap uncons -rot over execute -rot list-map cons - } cond - } swap ! - - variable ctxdump variable curctx - // (a1 .. an) e -- executes e for a1, ..., an - { ctxdump @ curctx @ ctxdump 2! curctx 2! - { curctx 2@ over null? not } { swap uncons rot tuck curctx 2! execute } - while 2drop ctxdump 2@ curctx ! ctxdump ! - } : list-foreach - forget ctxdump forget curctx - - // - // Experimental implementation of `for` loops with index - // - variable loopdump variable curloop - { curloop @ loopdump @ loopdump 2! } : push-loop-ctx - { loopdump 2@ loopdump ! curloop ! } : pop-loop-ctx - // ilast i0 e -- executes e for i=i0,i0+1,...,ilast-1 - { -rot 2dup > { - push-loop-ctx { - triple dup curloop ! first execute curloop @ untriple 1+ 2dup <= - } until pop-loop-ctx - } if 2drop drop - } : for - // ilast i0 e -- same as 'for', but pushes current index i before executing e - { -rot 2dup > { - push-loop-ctx { - triple dup curloop ! untriple nip swap execute curloop @ untriple 1+ 2dup <= - } until pop-loop-ctx - } if 2drop drop - } : for-i - // ( -- i ) Returns innermost loop index - { curloop @ third } : i - // ( -- j ) Returns outer loop index - { loopdump @ car third } : j - { loopdump @ cadr third } : k - forget curloop forget loopdump - - // - // create Lisp-style lists using words "(" and ")" - // - variable ') - 'nop box constant ', - { ") without (" abort } ') ! - { ') @ execute } : ) - anon constant dot-marker - // m x1 ... xn t m -- (x1 ... xn . t) - { swap - { -rot 2dup eq? not } - { over dot-marker eq? abort"invalid dotted list" - swap rot cons } while 2drop - } : list-tail-until-marker - // m x1 ... xn m -- (x1 ... xn) - { null swap list-tail-until-marker } : list-until-marker - { over dot-marker eq? { nip 2dup eq? abort"invalid dotted list" } - { null swap } cond - list-tail-until-marker - } : list-until-marker-ext - { ') @ ', @ } : ops-get - { ', ! ') ! } : ops-set - { anon dup ops-get 3 { ops-set list-until-marker-ext } does ') ! 'nop ', ! - } : ( - // test of Lisp-style lists - // ( 42 ( `+ 9 ( `* 3 4 ) ) "test" ) .l cr - // ( `eq? ( `* 3 4 ) 3 4 * ) .l cr - // `alpha ( `beta `gamma `delta ) cons .l cr - // { ( `eq? ( `* 3 5 pick ) 3 4 roll * ) } : 3*sample - // 17 3*sample .l cr - - // similar syntax _( x1 .. xn ) for tuples - { 2 { 1+ 2dup pick eq? } until 3 - nip } : count-to-marker - { count-to-marker tuple nip } : tuple-until-marker - { anon dup ops-get 3 { ops-set tuple-until-marker } does ') ! 'nop ', ! } : _( - // test of tuples - // _( _( 2 "two" ) _( 3 "three" ) _( 4 "four" ) ) .dump cr - - // pseudo-Lisp tokenizer - "()[]'" 34 hold constant lisp-delims - { lisp-delims 11 (word) } : lisp-token - { null cons `quote swap cons } : do-quote - { 1 { ', @ 2 { 2 { ', ! execute ', @ execute } does ', ! } - does ', ! } does - } : postpone-prefix - { ', @ 1 { ', ! } does ', ! } : postpone-', - ( `( ' ( pair - `) ' ) pair - `[ ' _( pair - `] ' ) pair - `' ' do-quote postpone-prefix pair - `. ' dot-marker postpone-prefix pair - `" { char " word } pair - `;; { 0 word drop postpone-', } pair - ) constant lisp-token-dict - variable eol - { eol @ eol 0! anon dup ') @ 'nop 3 - { ops-set list-until-marker-ext true eol ! } does ') ! rot ', ! - { lisp-token dup (number) dup { roll drop } { - drop atom dup lisp-token-dict assq { nip second execute } if - } cond - ', @ execute - eol @ - } until - -rot eol ! execute - } :_ List-generic( - { 'nop 'nop List-generic( } :_ LIST( - // LIST((lambda (x) (+ x 1)) (* 3 4)) - // LIST('(+ 3 4)) - // LIST(2 3 "test" . 9) - // LIST((process '[plus 3 4])) -} - -// -// TonUtil.fif -// - -/// Tests parsing of TonUtil.fif by embedding its contents -asm fun embedTonUtilFif() { - library TonUtil // TON Blockchain Fift Library - "Lists.fif" include - - -1 constant Masterchain - 0 constant Basechain - - // parse workchain id - // ( S -- workchain ) - { (number) 1- abort"workchain id must be an integer" - dup 32 fits not abort"workchain id must fit in 32 bits" - } : parse-workchain-id - - { (number) 1- abort"integer expected" } : parse-int - - { over null? ' swap if drop } : replace-if-null - - // Private key load/generate - // ( fname -- pubkey privkey ) - { dup ."Loading private key from file " type cr - file>B dup Blen 32 <> abort"Private key must be exactly 32 bytes long" - dup priv>pub swap - } : load-keypair - // ( fname -- pubkey privkey ) - { dup file-exists? - { load-keypair } - { dup newkeypair swap rot over swap B>file - rot ."Saved new private key to file " type cr - } cond - } : load-generate-keypair - - // Parse smart-contract address - // ( S -- workchain addr bounce? ) - { $>smca not abort"invalid smart-contract address" - 1 and 0= - } : parse-smc-addr - - // ( x -- ) Displays a 64-digit hex number - { 64 0x. } : 64x. - { 64 0X. } : 64X. - // ( wc addr -- ) Show address in : form - { swap ._ .":" 64x. } : .addr - // ( wc addr flags -- ) Show address in base64url form - { smca>$ type } : .Addr - // ( wc addr fname -- ) Save address to file in 36-byte format - { -rot 256 u>B swap 32 i>B B+ swap B>file } : save-address - // ( wc addr fname -- ) Save address and print message - { dup ."(Saving address to file " type .")" cr save-address - } : save-address-verbose - - // ( fname -- wc addr ) Load address from file - { file>B 32 B| - dup Blen { 32 B>i@ } { drop Basechain } cond - swap 256 B>u@ - } : load-address - // ( fname -- wc addr ) Load address from file and print message - { dup ."(Loading address from file " type .")" cr load-address - } : load-address-verbose - // Parse string as address or load address from file (if string is prefixed by @) - // ( S default-bounce -- workchain addr bounce? ) - { over $len 0= abort"empty smart-contract address" - swap dup 1 $| swap "@" $= - { nip load-address rot } { drop nip parse-smc-addr } cond - } : parse-load-address - - // ( hex-str -- addr ) Parses ADNL address - { dup $len 64 <> abort"ADNL address must consist of exactly 64 hexadecimal characters" - (hex-number) 1 <> abort"ADNL address must consist of 64 hexadecimal characters" - dup 256 ufits not abort"invalid ADNL address" - } : parse-adnl-address - - // ( b wc addr -- b' ) Serializes address into Builder b - { -rot 8 i, swap 256 u, } : addr, - { over 8 fits { rot b{100} s, -rot addr, } { - rot b{110} s, 256 9 u, rot 32 i, swap 256 u, } cond - } : Addr, - - // Gram utilities - 1000000000 constant Gram - { Gram swap */r } : Gram*/ - { Gram * } : Gram* - { (number) dup { 1- ' Gram*/ ' Gram* cond true } if - } : $>GR? - // ( S -- nanograms ) - { $>GR? not abort"not a valid Gram amount" - } : $>GR - { bl word $>GR 1 'nop } ::_ GR$ - // ( nanograms -- S ) - { dup abs <# ' # 9 times char . hold #s rot sign #> - nip -trailing0 } : (.GR) - { (.GR) ."GR$" type } : .GR_ - { .GR_ space } : .GR - - // b x -- b' ( serializes a Gram amount ) - { -1 { 1+ 2dup 8 * ufits } until - rot over 4 u, -rot 8 * u, } : Gram, - // s -- x s' ( deserializes a Gram amount ) - { 4 u@+ swap 8 * u@+ } : Gram@+ - // s -- x - { 4 u@+ swap 8 * u@ } : Gram@ - - // currency collections - // b x --> b' ( serializes a VarUInteger32 ) - { -1 { 1+ 2dup 8 * ufits } until - rot over 5 u, -rot 8 * u, } : VarUInt32, - // s --> x ( deserializes a VarUInteger32 ) - { 5 u@+ swap 8 * u@ } : VarUInt32@ - 32 constant cc-key-bits - ' VarUInt32, : val, - ' VarUInt32@ : val@ - // d k v -- d' - { cc - { dup null? { ."(null)" drop } { val@ ._ } cond } dup : .maybeVarUInt32 : .val - { swap cc-key-bits { rot { ."+" } if .val ."*$" ._ true true } idictforeach drop } : (.cc) - { false (.cc) { ."0" } ifnot } : .cc_ - { .cc_ space } : .cc - { true (.cc) drop } : .+cc_ - { .+cc_ space } : .+cc - { cc-key-bits { rot . ."-> " swap .val .val ."; " true } dictdiff drop cr } : show-cc-diff - { cc-key-bits { val@ swap val@ + val, true } dictmerge } : cc+ - { null swap cc-key-bits { val@ pair swap cons true } idictforeach drop } : cc>list-rev - { cc>list-rev list-reverse } : cc>list - forget val, forget val@ forget .val - - // ( S -- x -1 or 0 ) - { (number) dup 2 = { -rot 2drop } if 1 = } : int? - { int? dup { drop dup 0< { drop false } { true } cond } if } : pos-int? - // ( S -- k v -1 or 0 ) Parses expression * or *$ - { dup "*" $pos dup 0< { 2drop false } { - $| dup $len 2 < { 2drop false } { - 1 $| nip dup 1 $| swap "$" $= { swap } if drop - int? dup { over 32 fits { 2drop false } ifnot } if - not { drop false } { - swap pos-int? not { drop false } { - true - } cond } cond } cond } cond - } : cc-key-value? - // ( S -- D -1 or 0 ) Parses an extra currency collection - // e.g. "10000*$3+7777*$-11" means "10000 units of currency #3 and 7777 units of currency #-11" - { dictnew { // S D - swap dup "+" $pos dup 0< { drop null -rot } { $| 1 $| nip -rot } cond - cc-key-value? { +ccpair over null? dup { rot drop true } if } { 2drop false true } cond - } until - } : $>xcc? - { $>xcc? not abort"invalid extra currency collection" } : $>xcc - { char } word dup $len { $>xcc } { drop dictnew } cond 1 'nop } ::_ CX{ - - // complete currency collections - { $>xcc? { true } { drop false } cond } : end-parse-cc - // ( S -- x D -1 or 0 ) Parses a currency collection - // e.g. "1.2+300*$2" means "1200000000ng plus 300 units of currency #2" - { 0 swap dup "+" $pos dup 0< { drop dup - $>GR? { nip nip dictnew true } { end-parse-cc } cond - } { over swap $| swap $>GR? { 2swap 2drop swap 1 $| nip } { drop - } cond end-parse-cc } cond - } : $>cc? - { $>cc? not abort"invalid currency collection" } : $>cc - { char } word dup $len { $>cc } { drop 0 dictnew } cond 2 'nop } ::_ CC{ - // ( x D -- ) - { swap ?dup { .GR_ .+cc_ } { .cc_ } cond } : .GR+cc_ - { .GR+cc_ space } : .GR+cc - { -rot Gram, swap dict, } : Gram+cc, - - // Libraries - // ( -- D ) New empty library collection - ' dictnew : Libs{ - // ( D -- D ) Return library collection as dictionary - 'nop : }Libs - // ( D c x -- D' ) Add a public/private library c to collection D - { -rot B, swap ref, - } cond - } swap ! - // b S n -- b' - { swap $>B swap append-long-bytes } : append-long-string - // S -- c - { - } : simple-transfer-body - - // ( S -- x ) parse public key - { dup $len 48 <> abort"public key must be 48 characters long" - base64url>B dup Blen 36 <> abort"public key must be 48 characters long" - 34 B| 16 B>u@ over crc16 <> abort"crc16 mismatch in public key" - 16 B>u@+ 0x3ee6 <> abort"invalid tag in public key" - 256 B>u@ - } : parse-pubkey - { bl word parse-pubkey 1 'nop } ::_ PK' - // ( x -- S ) serialize public key - { 256 u>B B{3ee6} swap B+ dup crc16 16 u>B B+ B>base64 } : pubkey>$ - { pubkey>$ type } : .pubkey - - // ( S -- x ) parse validator-encoded public key - { base64>B dup Blen 36 <> abort"public key with magic must be 36 bytes long" - 4 B| swap 32 B>u@ 0xC6B41348 <> abort"unknown magic for public key (not Ed25519)" - } : parse-val-pubkey - { bl word parse-val-pubkey 1 'nop } ::_ VPK' - { char } word base64>B 1 'nop } ::_ B64{ - - // adnl address parser - { 256 u>B B{2D} swap B+ dup crc16 16 u>B B+ } : adnl-preconv - { swap 32 /mod dup 26 < { 65 } { 24 } cond + rot swap hold } : Base32# - { <# ' Base32# 8 times #> } : Base32#*8 - { "" over Blen 5 / { swap 40 B>u@+ Base32#*8 nip rot swap $+ } swap times nip } : B>Base32 - - // ( x -- S ) Converts an adnl-address from a 256-bit integer to a string - { adnl-preconv B>Base32 1 $| nip } : adnl>$ - - { 65 - dup 0>= { -33 and dup 26 < } { 41 + dup 25 > over 32 < and } cond ?dup nip } : Base32-digit? - { Base32-digit? not abort"not a Base32 digit" } : Base32-digit - { 0 { over $len } { swap 1 $| -rot (char) Base32-digit swap 5 << + } while nip } : Base32-number - { B{} { over $len } { swap 8 $| -rot Base32-number 40 u>B B+ } while nip } : Base32>B - - // ( S -- x ) Converts an adnl address from a string to 256-bit integer - { dup $len 55 <> abort"not 55 alphanumeric characters" "F" swap $+ Base32>B - 33 B| 16 B>u@ over crc16 <> abort"crc16 checksum mismatch" - 8 B>u@+ 0x2D <> abort"not a valid adnl address" 256 B>u@ } : $>adnl - - { 65 - dup 0>= { -33 and 10 + dup 16 < } { 17 + dup 0>= over 10 < and } cond ?dup nip } : hex-digit? - // ( S -- x -1 or 0 ) Parses a hexadecimal integer - { dup $len { - 0 { - 4 << swap 1 $| -rot (char) hex-digit? // S a d -1 or S a 0 - { + over $len 0= } { drop -1 true } cond - } until - dup 0< { 2drop false } { nip true } cond - } { drop false } cond - } : hex$>u? - // ( S -- x ) - { hex$>u? not abort"not a hexadecimal number" } : hex$>u - - { dup $len 64 = { hex$>u } { - dup $len 55 = { $>adnl } { - true abort"invalid adnl address" - } cond } cond - } : parse-adnl-addr - { adnl>$ type } : .adnl - { bl word parse-adnl-addr 1 'nop } ::_ adnl: - - // ( x a b -- a<=x<=b ) - { 2 pick >= -rot >= and } : in-range? - - // ( c i -- ? ) Checks whether c is a valid value for config param #i - def? config-valid? { - { nip 0>= { ."warning: cannot check validity of configuration parameter value, use create-state instead of fift to check validity" cr } if - true } : config-valid? - } ifnot - - { dup -1000 = { drop - { - // anycast_info$_ depth:(#<= 30) { depth >= 1 } - // rewrite_pfx:(bits depth) = Anycast; - 30 u@+ swap // get depth - - dup 1 > { - dup 2 roll swap u@+ // get rewrite_pfx - // return depth, rewrite_pfx, slice - } - { - drop // drop depth (<=1) - 0 0 2 roll // set anycast to none - } cond - } - { - 0 0 2 roll // set anycast to none - } cond - } : maybe-anycast - - // Rewrite first bits of addr with anycast info - { // input: anycast depth, rewrite_pfx, workchain, slice, address length - 4 -roll - 3 roll dup dup 0 = { 2drop 2 roll drop } - { - rot swap u@+ swap drop - 3 roll - // Get addr: addr_none$00 / addr_extern$01 / addr_std$10 / addr_var$11 - { // if greater that zero - dup 1 > - { - 2 = - { - // if addr_std$10 - // anycast:(Maybe Anycast) - // workchain_id:int8 - // address:bits256 = MsgAddressInt; - maybe-anycast // get anycast depth, bits, slice - 8 i@+ // get workchain - 256 parse-address-with-anycast - `addr-std swap - } - - { - // if addr_var$11 - // anycast:(Maybe Anycast) - // addr_len:(## 9) - // workchain_id:int32 - // address:(bits addr_len) = MsgAddressInt; - maybe-anycast // get anycast depth, bits, slice - 9 u@+ // get addr_len - 32 i@+ // get workchain - swap 2 -roll // move workchain to neede position - swap parse-address-with-anycast - `addr-var swap - } cond - - } - { - drop // drop header (dup for statment upper) - // if addr_extern$01 - // addr_extern$01 len:(## 9) - // external_address:(bits len) - 9 u@+ swap // bit len - u@+ // external_address - `addr-extern swap - } cond - } - { - swap - // if addr_none$00 - `addr-none swap - } cond - } : addr@+ - - { addr@+ drop } : addr@ - - // User-friendly prints output of addr@ - // (0 A or addr A or wc addr A -- ) - { - dup `addr-none eq? - { 2drop ."addr_none" } - { - `addr-extern eq? - { (dump) type } - { (x.) swap (dump) ":" $+ swap $+ type } - cond - } - cond - } : print-addr // print addr with workchain - - forget maybe-anycast - forget parse-address-with-anycast -} - -// -// Stack.fif -// - -/// Tests parsing of Stack.fif by embedding its contents -asm fun embedStackFif() { - library Stack // advanced stack manupulation library - "Lists.fif" include - // S(a b c - a c 2 a b) would compile to code performing the requested stack manipulation - - // interface to low-level stack manipulation primitives - { (number) 1- abort"index expected" dup 0 < over 255 > or - abort"index 0..255 expected" - } : (idx) - // push(n) : a0 .. an - a0 .. an a0 equivalent to "n pick" - // push(0) = dup, push(1) = over - { 0 char ) word (idx) } ::_ push( - // pop(n) : a0 a1 .. a(n-1) an - an a1 .. a(n-1) - // pop(0) = drop, pop(1) = nip - { 0 char ) word (idx) } ::_ pop( - // xchg(i,j) : equivalent to "i j exch2" - { 0 char , word (idx) char ) word (idx) } ::_ xchg( - // xchg0(i) : equivalent to "i exch" or "xchg(0,i)" - // xchg0(1) = swap - { 0 char ) word (idx) 0 } ::_ xchg0( - forget (idx) - - // parser for stack notation expressions - ")" 34 hold +" -" constant stk-delims - anon constant stk-start - anon constant stk-to - variable stk-mode - { stk-delims 11 (word) } : stk-token - 'nop : mk-lit - // stk-start vn ... v0 -- stk-start ... v0 i where v[i]=v0 - { 0 { - 1+ 2dup 2+ pick dup stk-start eq? { 2drop drop 0 true } { eqv? } cond - } until - } : stk-lookup - // stk-start a1 .. an stk-to b1 .. bm -- [a1 .. an] [b1 .. bm] - { stk-mode @ 0= abort"identifier expected" } : chk-lit - { stk-to list-until-marker stk-mode ! - stk-start list-until-marker stk-mode @ - stk-mode 0! - } : build-stk-effect - { stk-start stk-mode 0! { - stk-token dup ")" $= { drop true } { - dup "-" $= { - drop stk-mode @ abort"duplicate -" true stk-mode ! stk-to false } { - dup 34 chr $= { chk-lit drop char " word mk-lit false } { - dup (number) ?dup { chk-lit 1- { swap mk-lit -rot } if mk-lit nip false } { - atom dup `_ eq? { stk-mode @ abort"identifier expected" false } { - stk-lookup 0= stk-mode @ = { - stk-mode @ { atom>$ +" -?" } { atom>$ +" redefined" } cond abort } { - false - } cond } cond } cond } cond } cond } cond } until - stk-mode @ 0= abort"'-' expected" - build-stk-effect - } :_ parse-stk-list( - - // stack operation list construction - variable op-rlist - { op-rlist null! } : clear-op-list - { op-rlist @ list-reverse } : get-op-list - { op-rlist @ cons op-rlist ! } : issue-op - { minmax `xchg -rot triple } : op-xchg - { `push swap pair } : op-push - { `lit swap pair } : op-lit - { `pop swap pair } : op-pop - 0 op-pop constant op-drop - { 2dup <> { op-xchg issue-op } if } : issue-xchg - { op-push issue-op } : issue-push - { op-lit issue-op } : issue-lit - { op-pop issue-op } : issue-pop - { op-drop issue-op } : issue-drop - { ' issue-drop swap times } : issue-drop-# - - // emulated stack contents - variable emul-stk - { emul-stk @ count } : emul-depth - { emul-depth 1- swap - } : adj-i - { emul-depth 1- tuck swap - swap rot - swap } : adj-ij - // i j -- - { adj-ij 2dup emul-stk @ tuck swap [] swap rot [] rot // i sj si j - emul-stk @ -rot []= swap rot []= emul-stk ! - } : emul-xchg - { emul-stk @ tpop drop emul-stk ! } : emul-drop - // i -- - { 0 emul-xchg emul-drop } : emul-pop - // i -- s[i] - { emul-stk @ swap [] } : emul-stk[] - // i -- si - { adj-i emul-stk[] } : emul-get - { 0 emul-get } : emul-tos - // v i -- ? Check whether s[i]=v - { dup emul-depth < { emul-stk[] eqv? } { 2drop false } cond } : emul[]-eq? - // v -- i or -1 Returns maximum i with s[i]=v - { emul-stk @ dup count { // v s i - ?dup 0= { -1 true } { 1- 2dup [] 3 pick eqv? } cond // v s i' ? - } until nip nip - } : emul-stk-lookup-rev - // i -- - { emul-get emul-stk @ swap , emul-stk ! } : emul-push - { emul-stk @ swap , emul-stk ! } : emul-lit - // show emulated stack contents similarly to .s - { emul-stk @ explode dup 1 reverse ' .l swap times cr } : .e - - // both issue an operation and emulate it - { 2dup issue-xchg emul-xchg } : issue-emul-xchg - { dup issue-push emul-push } : issue-emul-push - { dup issue-lit emul-lit } : issue-emul-lit - { dup issue-pop emul-pop } : issue-emul-pop - { issue-drop emul-drop } : issue-emul-drop - { ' issue-emul-drop swap times } : issue-emul-drop-# - - // b.. s -- b.. s moves tos value to stk[s] - { dup emul-stk[] 2 pick cdr list-member-eqv? { - dup adj-i 0 issue-emul-xchg } { dup adj-i issue-emul-pop } cond - } : move-tos-to - - // new s -- ops registered - { { over null? not } { - // .sl .e get-op-list .l cr - // get-op-list list-length 100 > abort"too long" - emul-depth over > - { over emul-tos swap list-member-eqv? not } { false } cond { - // b.. s tos unneeded - issue-emul-drop } { - over car // b.. s b1 - 2dup swap emul[]-eq? { drop swap cdr swap 1+ } { - dup emul-stk-lookup-rev // b.. s b1 i - dup 0< { // b.. s b1 i not found, must be a literal - drop dup atom? abort"unavailable value" - issue-emul-lit } { - dup 3 pick < { // b.. s b1 i found in bottom s stack values - nip adj-i issue-emul-push // b.. s - dup emul-depth 1- < { move-tos-to } if - } { - emul-depth 1- over = { // b.. s b1 i found in tos - 2drop move-tos-to - } { // b.. s b1 i - nip over adj-ij issue-emul-xchg - } cond } cond } cond } cond } cond } while - nip emul-depth swap - issue-emul-drop-# - } : generate-reorder-ops - - // old new -- op-list - { emul-stk @ op-rlist @ 2swap - swap list>tuple emul-stk ! clear-op-list - 0 generate-reorder-ops get-op-list - -rot op-rlist ! emul-stk ! - } : generate-reorder - { parse-stk-list( generate-reorder } :_ SG( - - // op-list rewriting according to a ruleset - // l f l1 l2 -- l' -1 or l f with l' = l2 + (l - l1) - { push(3) rot list- { list+ nip nip true } { drop } cond - } : try-rule - // l f ll -- l' -1 or l f - { { dup null? not } { uncons 3 -roll unpair try-rule rot } while drop - } : try-ruleset - // l ll -- l' - { swap { over false swap try-ruleset 0= } until nip - } : try-ruleset* - // l ruleset -- l' - recursive try-ruleset*-everywhere { - tuck try-ruleset* dup null? { nip } { - uncons rot try-ruleset*-everywhere cons } cond - } swap ! - LIST( - [([xchg 0 1] [xchg 0 2]) ([rot])] - [([xchg 0 1] [xchg 1 2]) ([-rot])] - [([xchg 0 2] [xchg 1 2]) ([rot])] - [([xchg 0 2] [xchg 0 1]) ([-rot])] - [([xchg 1 2] [xchg 0 1]) ([rot])] - [([xchg 1 2] [xchg 0 2]) ([-rot])] - [([xchg 0 1] [rot]) ([xchg 0 2])] - [([-rot] [xchg 0 1]) ([xchg 0 2])] - [([xchg 0 2] [xchg 1 3]) ([2swap])] - [([xchg 1 3] [xchg 0 2]) ([2swap])] - [([push 1] [push 1]) ([2dup])] - [([push 3] [push 3]) ([2over])] - [([pop 0] [pop 0]) ([2drop])] - [([pop 1] [pop 0]) ([2drop])] - [([xchg 0 1] [push 1]) ([tuck])] - [([rot] [-rot]) ()] - [([-rot] [rot]) ()] - ) constant fift-stack-ruleset - { fift-stack-ruleset try-ruleset*-everywhere } : fift-ops-rewrite - { SG( fift-ops-rewrite } :_ SGF( - - // helpers for creating Fift source strings for one fift-op - // i j -- s - { minmax over { "xchg(" rot (.) $+ +"," swap (.) $+ +")" } - { nip dup 1 = { drop "swap" } { - ?dup { "xchg0(" swap (.) $+ +")" } { "" } cond - } cond } cond - } : source- - // i -- s - { dup 1 = { drop "over" } { - ?dup { "push(" swap (.) $+ +")" } { "dup" } cond - } cond - } : source- - // i -- s - { dup 1 = { drop "nip" } { - ?dup { "pop(" swap (.) $+ +")" } { "drop" } cond - } cond - } : source- - // lit -- s - { dup string? { char " chr swap $+ char " hold } { (.) } cond - } : source- - - // dictionary with all fift op compilation/source creation - { 0 swap (compile) } : fop-compile - ( _( `xchg 2 { fop-compile } { source- swap cons } ) - _( `push 1 { fop-compile } { source- swap cons } ) - _( `pop 1 { fop-compile } { source- swap cons } ) - _( `lit 1 { 1 'nop (compile) } { source- swap cons } ) - _( `rot 0 { ' rot fop-compile } { "rot" swap cons } ) - _( `-rot 0 { ' -rot fop-compile } { "-rot" swap cons } ) - _( `tuck 0 { ' tuck fop-compile } { "tuck" swap cons } ) - _( `2swap 0 { ' 2swap fop-compile } { "2swap" swap cons } ) - _( `2drop 0 { ' 2drop fop-compile } { "2drop" swap cons } ) - _( `2dup 0 { ' 2dup fop-compile } { "2dup" swap cons } ) - _( `2over 0 { ' 2over fop-compile } { "2over" swap cons } ) - ) box constant fift-op-dict - - { dup atom? { atom>$ } { drop "" } cond - "unknown operation " swap $+ abort - } : report-unknown-op - variable 'fop-entry-exec - // process fift-op according to 'fop-entry-exec - // ... op - ... - { dup first dup fift-op-dict @ assq { report-unknown-op } ifnot - dup second 1+ push(3) count <> abort"incorrect param count" - nip swap explode dup roll drop 1- roll // o2 .. on entry - 'fop-entry-exec @ execute - } : process-fift-op - - // compile op-list into Fift wordlist - // wl op-list -- wl' - { { third execute } 'fop-entry-exec ! - swap ' process-fift-op foldl } : compile-fift-op* - // op-list -- e - { fift-ops-rewrite ({) swap compile-fift-op* (}) } : ops>wdef - - // S( - ) compiles a "word" performing required action - { SG( ops>wdef 0 swap } ::_ S( - // 1 2 3 S(a b c - c a b a) .s would print 3 1 2 1 - - // transform op-list into Fift source - // ls op -- ls' - { fift-ops-rewrite - { 3 [] execute } 'fop-entry-exec ! - null ' process-fift-op foldl - dup null? { drop "" } { { +" " swap $+ } foldr-ne } cond - } : ops>$ - { SG( ops>$ 1 'nop } ::_ $S( - { SG( ops>$ type } :_ .$S( - // $S(a b c - b c a c a c) => string "rot 2dup over" - // S(a b c - b c a c a c) => compile/execute block { rot 2dup over } - // $S(_ x y _ - y x) => string "drop pop(2)" - // .$S(x1 x2 - 17 x1) => print string "drop 17 swap" - - // simplify/transform sequences of stack manipulation operations - LIST(. [a b c d e f g h i j]) constant std-stack - { stk-start std-stack explode drop stk-to std-stack explode drop - } : simplify<{ - { build-stk-effect generate-reorder ops>$ } : }>stack - // simplify<{ drop drop over over -13 }>stack => string "2drop 2dup -13" - // simplify<{ 17 rot }>stack => string "swap 17 swap" - // simplify<{ 5 1 reverse }>stack => string "xchg(1,5) xchg(2,4)" -} - -// -// GetOpt.fif -// - -/// Tests parsing of GetOpt.fif by embedding its contents -asm fun embedGetOptFif() { - library GetOpt // Simple command-line options parser - "Lists.fif" include - - // May be used as follows: - // begin-options - // "h" { ."Help Message" 0 halt } short-option - // "v" { parse-int =: verbosity } short-option-arg - // "i" "--interactive" { true =: interactive } short-long-option - // parse-options - - // ( l -- l') computes tail of list l if non-empty; else () - { dup null? ' cdr ifnot } : safe-cdr - // ( l c -- l') deletes first c elements from list l - { ' safe-cdr swap times } : list-delete-first - // ( l n c -- l' ) deletes c elements starting from n-th in list l - recursive list-delete-range { - dup 0<= { 2drop } { - over 0<= { nip list-delete-first } { - swap 1- swap rot uncons 2swap list-delete-range cons - } cond } cond - } swap ! - // ( n c -- ) deletes $n .. $(n+c-1) from the argument list $* - { swap 1- $* @ swap rot list-delete-range $* ! } : $*del.. - // ( s s' -- ? ) checks whether s' is a prefix of s - { tuck $len over $len over >= { $| drop $= } { 2drop drop false } cond - } : $pfx? - // ( s -- ? ) checks whether s is an option (a string beginning with '-') - { dup $len 1 > { "-" $pfx? } { drop false } cond } : is-opt? - // ( s -- ? ) checks whether s is a digit option - { 2 $| drop 1 $| nip $>B 8 B>u@ dup 57 <= swap 48 >= and } : is-digit-opt? - 0 box constant disable-digit-opts - // ( l -- s i or 0 ) finds first string in l beginning with '-' - { 0 { 1+ over null? { 2drop 0 true } { - swap uncons over is-opt? - { disable-digit-opts @ { over is-digit-opt? not } { true } cond } { false } cond - { drop swap true } { nip swap false } cond - } cond } until - } : list-find-opt - // ( -- s i or 0 ) finds first option in cmdline args - { $* @ list-find-opt } : first-opt - ' second : get-opt-flags - ' first : get-opt-exec - // ( s t -- ? ) checks whether short/long option s matches description t - { third $= } : short-option-matches - { dup get-opt-flags 4 and 0= 3 + [] $= - } : long-option-matches - // ( t -- s -1 or 0 ) extracts help message from description - { dup get-opt-flags 4 and 0= 4 + over count over > - { [] true } { 2drop false } cond - } : get-opt-help - // ( s l -- t -1 or 0 ) finds short/long option s in list l - { swap 1 { swap short-option-matches } does assoc-gen - } : lookup-short-option - { swap 1 { swap long-option-matches } does assoc-gen - } : lookup-long-option - // ( s -- s' null or s' s'' ) Splits long option --opt=arg at '=' - { dup "=" $pos 1+ ?dup { tuck $| swap rot 1- $| drop swap } { null } cond - } : split-longopt - // ( l -- f or 0 ) Extracts global option flags from first entry of l - { dup null? { drop 0 } { car get-opt-flags -256 and } cond - } : get-global-option-flags - variable options-list - // ( l -- i or 0 ) - // parses command line arguments according to option description list l - // and returns index i of first incorrect option - { dup options-list ! get-global-option-flags - 256 and disable-digit-opts ! - { first-opt dup 0= { true } { - swap dup "--" $pfx? { // i s - dup $len 2 = { drop dup 1 $*del.. 0 true } { - split-longopt swap options-list @ - lookup-long-option not { drop true } { // i s' t f - dup get-opt-exec swap get-opt-flags 3 and // i s' e f' - 2 pick null? { dup 1 = } { dup 0= negate } cond // i s' e f' f'' - dup 1 = { 2drop 2drop true } { - { drop nip over 1+ $() swap execute 2 $*del.. false } { - ' nip ifnot execute 1 $*del.. false - } cond } cond } cond } cond } { // i s - 1 $| nip { - dup $len 0= { drop 1 $*del.. false true } { - 1 $| swap options-list @ // i s' s l - lookup-short-option not { drop true true } { // i s' t - dup get-opt-exec swap get-opt-flags 3 and // i s' e f' - ?dup 0= { execute false } { - 2 pick $len { drop execute "" false } { - 2 = { nip null swap execute "" false } { // i e - nip over 1+ $() swap execute 2 $*del.. false true - } cond } cond } cond } cond } cond } until - } cond - } cond } until - } : getopt - // ( t -- ) Displays help message for one option - { dup get-opt-flags dup 4 and 2 pick third swap { - ."-" type ."/" over 3 [] type } { - dup $len { dup "--" $pfx? { ."-" } ifnot type } { - drop ."usage: " $0 type - } cond } cond - dup 3 and ?dup { - 2 = { ."[=]" } { ."=" } cond - } if - 8 and { 9 emit } ifnot - get-opt-help { type } { ."No help available" } cond cr - } : show-opt-help - // ( -- ) Displays options help message according to options-list - { options-list @ { dup null? not } { - uncons swap show-opt-help - } while drop - } : show-options-help - // ( l -- ) Parses options and throws an error on failure - { getopt ?dup { - $() "cannot parse command line options near `" swap $+ +"`" - show-options-help abort } if - } : run-getopt - anon constant opt-list-marker - ' opt-list-marker : begin-options - { opt-list-marker list-until-marker } : end-options - { end-options run-getopt } : parse-options - // ( s e -- o ) Creates short/long option s with execution token e - { 0 rot triple } dup : short-option : long-option - // ( s s' e -- o ) Creates a combined short option s and long option s' with execution token e - { 4 2swap 4 tuple } : short-long-option - { 1 rot triple } dup : short-option-arg : long-option-arg - { 2 rot triple } dup : short-option-?arg : long-option-?arg - { 5 2swap 4 tuple } : short-long-option-arg - { 6 2swap 4 tuple } : short-long-option-?arg - // ( o s -- s' ) Adds help message to option - ' , : option-help - // ( s f -- o ) Creates a generic help message - { swap 'nop rot "" 3 roll 4 tuple } : generic-help-setopt - { 0 generic-help-setopt } : generic-help - 256 constant disable-digit-options -} diff --git a/src/prettyPrinter.ts b/src/prettyPrinter.ts index a825ec5f0..06bf61374 100644 --- a/src/prettyPrinter.ts +++ b/src/prettyPrinter.ts @@ -677,7 +677,7 @@ export const ppAstFuncId = (func: A.AstFuncId): string => func.text; export const ppStatementBlock: Printer = (stmts) => (c) => c.braced(stmts.length === 0 ? [c.row("")] : c.list(stmts, ppAstStatement)); -export const ppAsmInstructionsBlock: Printer = +export const ppAsmInstructionsBlock: Printer = (instructions) => (c) => c.braced(instructions.map(c.row));