steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-02-07 21:23:53 -06:00
parent f08c8dd66d 36e5536110
commit c5a3241dae
9 changed files with 439 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
core/strings/strings-docs.factor
View File

@ -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 } }

8
extra/infix/ast/ast.factor Normal file
View File

@ -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 ;

38
extra/infix/infix-docs.factor Normal file
View File

@ -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

45
extra/infix/infix-tests.factor Normal file
View File

@ -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

99
extra/infix/infix.factor Normal file
View File

@ -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
<PRIVATE
: prepare-operand ( term -- quot )
dup callable? [ 1quotation ] unless ;
ERROR: local-not-defined name ;
M: local-not-defined summary
drop "local is not defined" ;
: at? ( key assoc -- value/key ? )
dupd at* [ nip t ] [ drop f ] if ;
: >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
<PRIVATE
: parse-infix-locals ( assoc end -- quot )
[
in-lambda? on
[ dup [ locals set ] [ push-locals ] bi ] dip
[infix-parse prepare-operand swap pop-locals
] with-scope ;
PRIVATE>
: [infix|
"|" parse-bindings "infix]" parse-infix-locals <let>
parsed-lambda ; parsing

175
extra/infix/parser/parser-tests.factor Normal file
View File

@ -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

30
extra/infix/parser/parser.factor Normal file
View File

@ -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 ;

20
extra/infix/tokenizer/tokenizer-tests.factor Normal file
View File

@ -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

21
extra/infix/tokenizer/tokenizer.factor Normal file
View File

@ -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