diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index d40cd982d8..9a1671b126 100644 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -53,8 +53,9 @@ HELP: 1string HELP: >string { $values { "seq" "a sequence of characters" } { "str" string } } -{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; +{ $description "Outputs a freshly-allocated string with the same elements as a given sequence, by interpreting the sequence elements as Unicode code points." } +{ $notes "This operation is only appropriate if the underlying sequence holds Unicode code points, which is rare unless it is a " { $link slice } " of another string. To convert a sequence of bytes to a string, use the words documented in " { $link "io.encodings.string" } "." } +{ $errors "Throws an error if the sequence contains elements other than integers." } ; HELP: resize-string ( n str -- newstr ) { $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } } diff --git a/extra/infix/ast/ast.factor b/extra/infix/ast/ast.factor new file mode 100644 index 0000000000..0bc22feeb7 --- /dev/null +++ b/extra/infix/ast/ast.factor @@ -0,0 +1,8 @@ +IN: infix.ast + +TUPLE: ast-number value ; +TUPLE: ast-local name ; +TUPLE: ast-array name index ; +TUPLE: ast-function name arguments ; +TUPLE: ast-op left right op ; +TUPLE: ast-negation term ; diff --git a/extra/infix/infix-docs.factor b/extra/infix/infix-docs.factor new file mode 100644 index 0000000000..7a4febb514 --- /dev/null +++ b/extra/infix/infix-docs.factor @@ -0,0 +1,38 @@ +USING: help.syntax help.markup prettyprint locals ; +IN: infix + +HELP: [infix +{ $syntax "[infix ... infix]" } +{ $description "Parses the infix code inside the brackets, converts it to stack code and executes it." } +{ $examples + { $example + "USING: infix prettyprint ;" + "IN: scratchpad" + "[infix 8+2*3 infix] ." + "14" + } $nl + { $link POSTPONE: [infix } " isn't that useful by itself, as it can only access literal numbers and no variables. It is designed to be used together with locals; for example with " { $link POSTPONE: :: } " :" + { $example + "USING: infix locals math.functions prettyprint ;" + "IN: scratchpad" + ":: quadratic-equation ( a b c -- z- z+ )" + " [infix (-b-sqrt(b*b-4*a*c)) / (2*a) infix]" + " [infix (-b+sqrt(b*b-4*a*c)) / (2*a) infix] ;" + "1 0 -1 quadratic-equation . ." + "1.0\n-1.0" + } +} ; + +HELP: [infix| +{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" } +{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." } +{ $examples + { $example + "USING: infix prettyprint ;" + "IN: scratchpad" + "[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ." + "452.16" + } +} ; + +{ POSTPONE: [infix POSTPONE: [infix| } related-words diff --git a/extra/infix/infix-tests.factor b/extra/infix/infix-tests.factor new file mode 100644 index 0000000000..5ee6468131 --- /dev/null +++ b/extra/infix/infix-tests.factor @@ -0,0 +1,45 @@ +USING: infix infix.private kernel locals math math.functions +tools.test ; +IN: infix.tests + +[ 0 ] [ [infix 0 infix] ] unit-test +[ 0.5 ] [ [infix 3.0/6 infix] ] unit-test +[ 1+2/3 ] [ [infix 5/3 infix] ] unit-test +[ 3 ] [ [infix 2*7%3+1 infix] ] unit-test +[ 1 ] [ [infix 2- + 1 + -5* + 0 infix] ] unit-test + +[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] | + r*r*pi infix] ] unit-test +[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test +[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test +[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test + +[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test +[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test +[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test +[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test + +[ 0.0 ] [ [infix sin(0) infix] ] unit-test +[ 10 ] [ [infix lcm(2,5) infix] ] unit-test +[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test + +[ f ] [ 2 \ gcd check-word ] unit-test ! multiple return values +[ f ] [ 1 \ drop check-word ] unit-test ! no return value +[ f ] [ 1 \ lcm check-word ] unit-test ! takes 2 args +: no-stack-effect-declared + ; +[ 0 \ no-stack-effect-declared check-word ] must-fail + +: qux ( -- x ) 2 ; +[ t ] [ 0 \ qux check-word ] unit-test +[ 8 ] [ [infix qux()*3+2 infix] ] unit-test +: foobar ( x -- y ) 1 + ; +[ t ] [ 1 \ foobar check-word ] unit-test +[ 4 ] [ [infix foobar(3*5%12) infix] ] unit-test +: stupid_function ( x x x x x -- y ) + + + + ; +[ t ] [ 5 \ stupid_function check-word ] unit-test +[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test + +[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor new file mode 100644 index 0000000000..31cd1cbe1f --- /dev/null +++ b/extra/infix/infix.factor @@ -0,0 +1,99 @@ +USING: accessors assocs combinators combinators.short-circuit +effects fry infix.parser infix.ast kernel locals.parser +locals.types math multiline namespaces parser quotations +sequences summary words ; +IN: infix + +local-word ( string -- word ) + locals get at? [ local-not-defined ] unless ; + +: select-op ( string -- word ) + { + { "+" [ [ + ] ] } + { "-" [ [ - ] ] } + { "*" [ [ * ] ] } + { "/" [ [ / ] ] } + [ drop [ mod ] ] + } case ; + +GENERIC: infix-codegen ( ast -- quot/number ) + +M: ast-number infix-codegen value>> ; + +M: ast-local infix-codegen + name>> >local-word ; + +M: ast-array infix-codegen + [ index>> infix-codegen prepare-operand ] + [ name>> >local-word ] bi '[ @ _ nth ] ; + +M: ast-op infix-codegen + [ left>> infix-codegen ] [ right>> infix-codegen ] + [ op>> select-op ] tri + 2over [ number? ] both? [ call ] [ + [ [ prepare-operand ] bi@ ] dip '[ @ @ @ ] + ] if ; + +M: ast-negation infix-codegen + term>> infix-codegen + { + { [ dup number? ] [ neg ] } + { [ dup callable? ] [ '[ @ neg ] ] } + [ '[ _ neg ] ] ! local word + } cond ; + +ERROR: bad-stack-effect word ; +M: bad-stack-effect summary + drop "Words used in infix must declare a stack effect and return exactly one value" ; + +: check-word ( argcount word -- ? ) + dup stack-effect [ ] [ bad-stack-effect ] ?if + [ in>> length ] [ out>> length ] bi + [ = ] dip 1 = and ; + +: find-and-check ( args argcount string -- quot ) + dup search [ ] [ no-word ] ?if + [ nip ] [ check-word ] 2bi + [ 1quotation compose ] [ bad-stack-effect ] if ; + +: arguments-codegen ( seq -- quot ) + dup empty? [ drop [ ] ] [ + [ infix-codegen prepare-operand ] + [ compose ] map-reduce + ] if ; + +M: ast-function infix-codegen + [ arguments>> [ arguments-codegen ] [ length ] bi ] + [ name>> ] bi find-and-check ; + +: [infix-parse ( end -- result/quot ) + parse-multiline-string build-infix-ast + infix-codegen prepare-operand ; +PRIVATE> + +: [infix + "infix]" [infix-parse parsed \ call parsed ; parsing + + + +: [infix| + "|" parse-bindings "infix]" parse-infix-locals + parsed-lambda ; parsing diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor new file mode 100644 index 0000000000..0a0288c41b --- /dev/null +++ b/extra/infix/parser/parser-tests.factor @@ -0,0 +1,175 @@ +USING: infix.ast infix.parser infix.tokenizer tools.test ; +IN: infix.parser.tests + +\ parse-infix must-infer +\ build-infix-ast must-infer + +[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test +[ T{ ast-negation f T{ ast-number { value 1 } } } ] +[ "-1" build-infix-ast ] unit-test +[ T{ ast-op + { left + T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } + } + } + { right T{ ast-number { value 4 } } } + { op "+" } +} ] [ "1+2+4" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "*" } + } + } + { op "+" } +} ] [ "1+2*3" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } +} ] [ "(1+2)" build-infix-ast ] unit-test + +[ T{ ast-local { name "foo" } } ] [ "foo" build-infix-ast ] unit-test +[ "-" build-infix-ast ] must-fail + +[ T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } + } + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "%" } + } + } + } +} ] [ "foo (1+ 2,2%3) " build-infix-ast ] unit-test + +[ T{ ast-op + { left + T{ ast-op + { left + T{ ast-function + { name "bar" } + { arguments V{ } } + } + } + { right + T{ ast-array + { name "baz" } + { index + T{ ast-op + { left + T{ ast-op + { left + T{ ast-number + { value 2 } + } + } + { right + T{ ast-number + { value 3 } + } + } + { op "/" } + } + } + { right + T{ ast-number { value 4 } } + } + { op "+" } + } + } + } + } + { op "+" } + } + } + { right T{ ast-number { value 2 } } } + { op "/" } +} ] [ "(bar() + baz[2/ 3+4 ] )/2" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "/" } + } + } + { op "+" } +} ] [ "1\n+\n2\r/\t3" build-infix-ast ] unit-test + +[ T{ ast-negation + { term + T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-number { value 2 } } + T{ ast-negation + { term T{ ast-number { value 3 } } } + } + } + } + } + } +} ] [ "-foo(+2,-3)" build-infix-ast ] unit-test + +[ T{ ast-array + { name "arr" } + { index + T{ ast-op + { left + T{ ast-negation + { term + T{ ast-op + { left + T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-number + { value 2 } + } + } + } + } + } + { right + T{ ast-negation + { term + T{ ast-number + { value 1 } + } + } + } + } + { op "+" } + } + } + } + } + { right T{ ast-number { value 3 } } } + { op "/" } + } + } +} ] [ "+arr[-(foo(2)+-1)/3]" build-infix-ast ] unit-test + +[ "foo bar baz" build-infix-ast ] must-fail +[ "1+2/4+" build-infix-ast ] must-fail +[ "quaz(2/3,)" build-infix-ast ] must-fail diff --git a/extra/infix/parser/parser.factor b/extra/infix/parser/parser.factor new file mode 100644 index 0000000000..beaf3c335d --- /dev/null +++ b/extra/infix/parser/parser.factor @@ -0,0 +1,30 @@ +USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences +strings vectors ; +IN: infix.parser + +EBNF: parse-infix +Number = . ?[ ast-number? ]? +Identifier = . ?[ string? ]? +Array = Identifier:i "[" Sum:s "]" => [[ i s ast-array boa ]] +Function = Identifier:i "(" FunArgs?:a ")" => [[ i a [ V{ } ] unless* ast-function boa ]] + +FunArgs = FunArgs:a "," Sum:s => [[ s a push a ]] + | Sum:s => [[ s 1vector ]] + +Terminal = ("-"|"+"):op Terminal:term => [[ term op "-" = [ ast-negation boa ] when ]] + | "(" Sum:s ")" => [[ s ]] + | Number | Array | Function + | Identifier => [[ ast-local boa ]] + +Product = Product:p ("*"|"/"|"%"):op Terminal:term => [[ p term op ast-op boa ]] + | Terminal + +Sum = Sum:s ("+"|"-"):op Product:p => [[ s p op ast-op boa ]] + | Product + +End = !(.) +Expression = Sum End +;EBNF + +: build-infix-ast ( string -- ast ) + tokenize-infix parse-infix ; diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor new file mode 100644 index 0000000000..7e1fb005ef --- /dev/null +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -0,0 +1,20 @@ +USING: infix.ast infix.tokenizer tools.test ; +IN: infix.tokenizer.tests + +\ tokenize-infix must-infer +[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test +[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test +[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ] +[ "3/(3+4)" tokenize-infix ] unit-test +[ V{ "foo" CHAR: ( "x" CHAR: , "y" CHAR: , "z" CHAR: ) } ] [ "foo(x,y,z)" tokenize-infix ] unit-test +[ V{ "arr" CHAR: [ "x" CHAR: + T{ ast-number f 3 } CHAR: ] } ] +[ "arr[x+3]" tokenize-infix ] unit-test +[ "1.0.4" tokenize-infix ] must-fail +[ V{ CHAR: + CHAR: ] T{ ast-number f 3.4 } CHAR: , "bar" } ] +[ "+]3.4,bar" tokenize-infix ] unit-test +[ V{ "baz_34c" } ] [ "baz_34c" tokenize-infix ] unit-test +[ V{ T{ ast-number f 34 } "c_baz" } ] [ "34c_baz" tokenize-infix ] unit-test +[ V{ CHAR: ( T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: ) } ] +[ "(1+2)" tokenize-infix ] unit-test +[ V{ T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: / T{ ast-number f 3 } } ] +[ "1\n+\r2\t/ 3" tokenize-infix ] unit-test diff --git a/extra/infix/tokenizer/tokenizer.factor b/extra/infix/tokenizer/tokenizer.factor new file mode 100644 index 0000000000..8c1a1b4a18 --- /dev/null +++ b/extra/infix/tokenizer/tokenizer.factor @@ -0,0 +1,21 @@ +USING: infix.ast kernel peg peg.ebnf math.parser sequences +strings ; +IN: infix.tokenizer + +EBNF: tokenize-infix +Letter = [a-zA-Z] +Digit = [0-9] +Digits = Digit+ +Number = Digits '.' Digits => [[ concat >string string>number ast-number boa ]] + | Digits => [[ >string string>number ast-number boa ]] +Space = " " | "\n" | "\r" | "\t" +Spaces = Space* => [[ ignore ]] +NameFirst = Letter | "_" => [[ CHAR: _ ]] +NameRest = NameFirst | Digit +Name = NameFirst NameRest* => [[ first2 swap prefix >string ]] +Special = [+*/%(),] | "-" => [[ CHAR: - ]] + | "[" => [[ CHAR: [ ]] | "]" => [[ CHAR: ] ]] +Tok = Spaces (Name | Number | Special ) +End = !(.) +Toks = Tok* Spaces End +;EBNF