Merge branch 'master' of git://factorcode.org/git/factor
commit
4aec9d2c46
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
|||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations fry call classes ;
|
||||
accessors combinators effects continuations fry classes ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
|
@ -446,6 +446,8 @@ M: quotation '
|
|||
quotation type-number object tag-number [
|
||||
emit ! array
|
||||
f ' emit ! compiled
|
||||
f ' emit ! cached-effect
|
||||
f ' emit ! cache-counter
|
||||
0 emit ! xt
|
||||
0 emit ! code
|
||||
] emit-object
|
||||
|
|
|
@ -30,7 +30,7 @@ SYMBOL: bootstrap-time
|
|||
[ "bootstrap." prepend require ] each ;
|
||||
|
||||
: count-words ( pred -- )
|
||||
all-words swap count number>string write ;
|
||||
all-words swap count number>string write ; inline
|
||||
|
||||
: print-time ( ms -- )
|
||||
1000 /i
|
||||
|
|
|
@ -1,2 +0,0 @@
|
|||
Daniel Ehrenberg
|
||||
Slava Pestov
|
|
@ -1,47 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax quotations effects words call.private ;
|
||||
IN: call
|
||||
|
||||
ABOUT: "call"
|
||||
|
||||
ARTICLE: "call" "Calling code with known stack effects"
|
||||
"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
|
||||
$nl
|
||||
"Quotations:"
|
||||
{ $subsection POSTPONE: call( }
|
||||
{ $subsection call-effect }
|
||||
"Words:"
|
||||
{ $subsection POSTPONE: execute( }
|
||||
{ $subsection execute-effect }
|
||||
"Unsafe calls:"
|
||||
{ $subsection POSTPONE: execute-unsafe( }
|
||||
{ $subsection execute-effect-unsafe } ;
|
||||
|
||||
HELP: call(
|
||||
{ $syntax "call( stack -- effect )" }
|
||||
{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
|
||||
|
||||
HELP: call-effect
|
||||
{ $values { "quot" quotation } { "effect" effect } }
|
||||
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
|
||||
|
||||
HELP: execute(
|
||||
{ $syntax "execute( stack -- effect )" }
|
||||
{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
|
||||
|
||||
HELP: execute-effect
|
||||
{ $values { "word" word } { "effect" effect } }
|
||||
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
|
||||
|
||||
HELP: execute-unsafe(
|
||||
{ $syntax "execute-unsafe( stack -- effect )" }
|
||||
{ $description "Calls the word on the top of the stack, blindly declaring that it has the given stack effect. The word does not need to be known at compile time." }
|
||||
{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ;
|
||||
HELP: execute-effect-unsafe
|
||||
{ $values { "word" word } { "effect" effect } }
|
||||
{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
|
||||
{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link execute-effect-unsafe } " instead." } ;
|
||||
|
||||
{ call-effect execute-effect execute-effect-unsafe } related-words
|
||||
{ POSTPONE: call( POSTPONE: execute( POSTPONE: execute-unsafe( } related-words
|
|
@ -1,33 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math tools.test call call.private kernel accessors ;
|
||||
IN: call.tests
|
||||
|
||||
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
|
||||
[ 1 2 [ + ] call( -- z ) ] must-fail
|
||||
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
|
||||
[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
|
||||
[ [ + ] call( x y -- z ) ] must-infer
|
||||
|
||||
[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
|
||||
[ 1 2 \ + execute( -- z ) ] must-fail
|
||||
[ 1 2 \ + execute( x y -- z a ) ] must-fail
|
||||
[ \ + execute( x y -- z ) ] must-infer
|
||||
|
||||
: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
|
||||
|
||||
[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
|
||||
[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
|
||||
|
||||
: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
|
||||
|
||||
[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
|
||||
[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
|
||||
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
|
||||
[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
|
||||
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
|
||||
|
||||
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
|
||||
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
|
||||
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
|
||||
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
|
|
@ -1,60 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel macros fry summary sequences sequences.private
|
||||
generalizations accessors continuations effects effects.parser
|
||||
parser words ;
|
||||
IN: call
|
||||
|
||||
ERROR: wrong-values values quot length-required ;
|
||||
|
||||
M: wrong-values summary
|
||||
drop "Wrong number of values returned from quotation" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: firstn-safe ( array quot n -- ... )
|
||||
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
|
||||
|
||||
: parse-call( ( accum word -- accum )
|
||||
[ ")" parse-effect parsed ] dip parsed ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: call-effect ( effect -- quot )
|
||||
[ in>> length ] [ out>> length ] bi
|
||||
'[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
|
||||
|
||||
: call( \ call-effect parse-call( ; parsing
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: execute-effect-unsafe ( word effect -- )
|
||||
drop execute ;
|
||||
|
||||
: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
|
||||
|
||||
: execute-effect-slow ( word effect -- )
|
||||
[ [ execute ] curry ] dip call-effect ; inline
|
||||
|
||||
: cache-hit? ( word ic -- ? ) first-unsafe eq? ; inline
|
||||
|
||||
: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
|
||||
|
||||
: execute-effect-unsafe? ( word effect -- ? )
|
||||
over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
|
||||
|
||||
: cache-miss ( word effect ic -- )
|
||||
[ 2dup execute-effect-unsafe? ] dip
|
||||
'[ [ drop _ set-first ] [ execute-effect-unsafe ] 2bi ]
|
||||
[ execute-effect-slow ] if ; inline
|
||||
|
||||
: execute-effect-ic ( word effect ic -- )
|
||||
#! ic is a mutable cell { effect }
|
||||
3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: execute-effect ( effect -- )
|
||||
{ f } clone '[ _ _ execute-effect-ic ] ;
|
||||
|
||||
: execute( \ execute-effect parse-call( ; parsing
|
|
@ -1 +0,0 @@
|
|||
Calling arbitrary quotations and executing arbitrary words with a static stack effect
|
|
@ -1 +0,0 @@
|
|||
extensions
|
|
@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien stack-checker kernel
|
|||
math namespaces make parser quotations sequences strings words
|
||||
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
|
||||
libc.private parser lexer init core-foundation fry generalizations
|
||||
specialized-arrays.direct.alien call ;
|
||||
specialized-arrays.direct.alien ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
|
@ -8,7 +8,7 @@ IN: cocoa.subclassing
|
|||
|
||||
: init-method ( method -- sel imp types )
|
||||
first3 swap
|
||||
[ sel_registerName ] [ execute ] [ utf8 string>alien ]
|
||||
[ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
|
||||
tri* ;
|
||||
|
||||
: throw-if-false ( obj what -- )
|
||||
|
|
|
@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook
|
|||
embedded? [
|
||||
"alien.remote-control"
|
||||
] [
|
||||
main-vocab-hook get [ call ] [ "listener" ] if*
|
||||
main-vocab-hook get [ call( -- vocab ) ] [ "listener" ] if*
|
||||
] if ;
|
||||
|
||||
: default-cli-args ( -- )
|
||||
|
|
|
@ -464,7 +464,7 @@ TUPLE: callback-context ;
|
|||
dup current-callback eq? [
|
||||
drop
|
||||
] [
|
||||
yield-hook get call wait-to-return
|
||||
yield-hook get call( -- ) wait-to-return
|
||||
] if ;
|
||||
|
||||
: do-callback ( quot token -- )
|
||||
|
|
|
@ -111,7 +111,7 @@ t compile-dependencies? set-global
|
|||
] with-return ;
|
||||
|
||||
: compile-loop ( deque -- )
|
||||
[ (compile) yield-hook get assert-depth ] slurp-deque ;
|
||||
[ (compile) yield-hook get call( -- ) ] slurp-deque ;
|
||||
|
||||
: decompile ( word -- )
|
||||
f 2array 1array modify-code-heap ;
|
||||
|
|
|
@ -20,7 +20,7 @@ CONSTANT: deck-bits 18
|
|||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||
|
|
|
@ -14,7 +14,7 @@ words splitting grouping sorting accessors ;
|
|||
[ t ] [
|
||||
symbolic-stack-trace
|
||||
[ word? ] filter
|
||||
{ baz bar foo throw } tail?
|
||||
{ baz bar foo } tail?
|
||||
] unit-test
|
||||
|
||||
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays sequences math math.order call
|
||||
USING: accessors kernel arrays sequences math math.order
|
||||
math.partial-dispatch generic generic.standard generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry combinators.smart
|
||||
|
|
|
@ -167,7 +167,7 @@ SYMBOL: event-stream-callbacks
|
|||
eventFlags numEvents <direct-int-array>
|
||||
eventIds numEvents <direct-longlong-array>
|
||||
3array flip
|
||||
info event-stream-callbacks get at [ drop ] or call ;
|
||||
info event-stream-callbacks get at [ drop ] or call( changes -- ) ;
|
||||
|
||||
: master-event-source-callback ( -- alien )
|
||||
"void"
|
||||
|
|
|
@ -325,3 +325,5 @@ M: bad-literal-tuple summary drop "Bad literal tuple" ;
|
|||
M: check-mixin-class summary drop "Not a mixin class" ;
|
||||
|
||||
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
|
||||
|
||||
M: wrong-values summary drop "Quotation called with wrong stack effect" ;
|
|
@ -28,7 +28,7 @@ SYMBOL: edit-hook
|
|||
|
||||
: edit-location ( file line -- )
|
||||
[ (normalize-path) ] dip edit-hook get-global
|
||||
[ call ] [ no-edit-hook edit-location ] if* ;
|
||||
[ call( file line -- ) ] [ no-edit-hook edit-location ] if* ;
|
||||
|
||||
ERROR: cannot-find-source definition ;
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: splitting parser compiler.units kernel namespaces
|
|||
debugger io.streams.string fry ;
|
||||
IN: eval
|
||||
|
||||
: parse-string ( str -- )
|
||||
: parse-string ( str -- quot )
|
||||
[ string-lines parse-lines ] with-compilation-unit ;
|
||||
|
||||
: (eval) ( str -- )
|
||||
|
|
|
@ -36,7 +36,7 @@ M: array fake-quotations> [ fake-quotations> ] map ;
|
|||
|
||||
M: object fake-quotations> ;
|
||||
|
||||
: parse-definition* ( -- )
|
||||
: parse-definition* ( accum -- accum )
|
||||
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
|
||||
|
||||
: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences kernel assocs combinators
|
||||
validators http hashtables namespaces fry continuations locals
|
||||
io arrays math boxes splitting urls call
|
||||
io arrays math boxes splitting urls
|
||||
xml.entities
|
||||
http.server
|
||||
http.server.responses
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2008, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math.order namespaces combinators.short-circuit call
|
||||
USING: accessors kernel math.order namespaces combinators.short-circuit
|
||||
html.forms
|
||||
html.templates
|
||||
html.templates.chloe
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel http.server http.server.filters
|
||||
http.server.responses furnace.utilities call ;
|
||||
http.server.responses furnace.utilities ;
|
||||
IN: furnace.referrer
|
||||
|
||||
TUPLE: referrer-check < filter-responder quot ;
|
||||
|
|
|
@ -58,7 +58,7 @@ HELP: npick
|
|||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" }
|
||||
{ $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick 5 narray ." "{ 1 2 3 4 1 }" }
|
||||
"Some core words expressed in terms of " { $link npick } ":"
|
||||
{ $table
|
||||
{ { $link dup } { $snippet "1 npick" } }
|
||||
|
@ -75,7 +75,7 @@ HELP: ndup
|
|||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup 8 narray ." "{ 1 2 3 4 1 2 3 4 }" }
|
||||
"Some core words expressed in terms of " { $link ndup } ":"
|
||||
{ $table
|
||||
{ { $link dup } { $snippet "1 ndup" } }
|
||||
|
@ -91,7 +91,7 @@ HELP: nnip
|
|||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip ." "4" }
|
||||
"Some core words expressed in terms of " { $link nnip } ":"
|
||||
{ $table
|
||||
{ { $link nip } { $snippet "1 nnip" } }
|
||||
|
@ -106,7 +106,7 @@ HELP: ndrop
|
|||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop ." "1" }
|
||||
"Some core words expressed in terms of " { $link ndrop } ":"
|
||||
{ $table
|
||||
{ { $link drop } { $snippet "1 ndrop" } }
|
||||
|
@ -121,7 +121,7 @@ HELP: nrot
|
|||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" }
|
||||
{ $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" }
|
||||
"Some core words expressed in terms of " { $link nrot } ":"
|
||||
{ $table
|
||||
{ { $link swap } { $snippet "1 nrot" } }
|
||||
|
@ -135,7 +135,7 @@ HELP: -nrot
|
|||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" }
|
||||
{ $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" }
|
||||
"Some core words expressed in terms of " { $link -nrot } ":"
|
||||
{ $table
|
||||
{ { $link swap } { $snippet "1 -nrot" } }
|
||||
|
@ -151,8 +151,8 @@ HELP: ndip
|
|||
"stack. The quotation can consume and produce any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" }
|
||||
{ $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" }
|
||||
{ $example "USING: arrays generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip 3array ." "{ 1 1 2 }" }
|
||||
{ $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip 2array ." "{ 2 3 }" }
|
||||
"Some core words expressed in terms of " { $link ndip } ":"
|
||||
{ $table
|
||||
{ { $link dip } { $snippet "1 ndip" } }
|
||||
|
@ -168,7 +168,7 @@ HELP: nslip
|
|||
"removed from the stack, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }
|
||||
"Some core words expressed in terms of " { $link nslip } ":"
|
||||
{ $table
|
||||
{ { $link slip } { $snippet "1 nslip" } }
|
||||
|
@ -184,7 +184,7 @@ HELP: nkeep
|
|||
"saved, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ." "{ 99 1 2 3 4 5 }" }
|
||||
"Some core words expressed in terms of " { $link nkeep } ":"
|
||||
{ $table
|
||||
{ { $link keep } { $snippet "1 nkeep" } }
|
||||
|
|
|
@ -5,7 +5,7 @@ parser prettyprint sequences words words.symbol assocs
|
|||
definitions generic quotations effects slots continuations
|
||||
classes.tuple debugger combinators vocabs help.stylesheet
|
||||
help.topics help.crossref help.markup sorting classes
|
||||
vocabs.loader call ;
|
||||
vocabs.loader ;
|
||||
IN: help
|
||||
|
||||
GENERIC: word-help* ( word -- content )
|
||||
|
@ -140,7 +140,7 @@ help-hook [ [ print-topic ] ] initialize
|
|||
sort-articles [ \ $subsection swap 2array ] map print-element ;
|
||||
|
||||
: $index ( element -- )
|
||||
first call [ ($index) ] unless-empty ;
|
||||
first call( -- seq ) [ ($index) ] unless-empty ;
|
||||
|
||||
: $about ( element -- )
|
||||
first vocab-help [ 1array $subsection ] when* ;
|
||||
|
|
|
@ -7,20 +7,20 @@ combinators combinators.short-circuit splitting debugger
|
|||
hashtables sorting effects vocabs vocabs.loader assocs editors
|
||||
continuations classes.predicate macros math sets eval
|
||||
vocabs.parser words.symbol values grouping unicode.categories
|
||||
sequences.deep call ;
|
||||
sequences.deep ;
|
||||
IN: help.lint
|
||||
|
||||
SYMBOL: vocabs-quot
|
||||
|
||||
: check-example ( element -- )
|
||||
[
|
||||
rest [
|
||||
'[
|
||||
_ rest [
|
||||
but-last "\n" join
|
||||
[ (eval>string) ] call( code -- output )
|
||||
"\n" ?tail drop
|
||||
] keep
|
||||
peek assert=
|
||||
] vocabs-quot get call ;
|
||||
] vocabs-quot get call( quot -- ) ;
|
||||
|
||||
: check-examples ( element -- )
|
||||
\ $example swap elements [ check-example ] each ;
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs
|
|||
hashtables namespaces make parser prettyprint sequences strings
|
||||
io.styles vectors words math sorting splitting classes slots fry
|
||||
sets vocabs help.stylesheet help.topics vocabs.loader quotations
|
||||
combinators call see ;
|
||||
combinators see ;
|
||||
IN: help.markup
|
||||
|
||||
PREDICATE: simple-element < array
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors strings namespaces assocs hashtables io call
|
||||
USING: kernel accessors strings namespaces assocs hashtables io
|
||||
mirrors math fry sequences words continuations
|
||||
xml.entities xml.writer xml.syntax ;
|
||||
IN: html.forms
|
||||
|
|
|
@ -61,6 +61,4 @@ M: funky url-of "http://www.funky-town.com/" swap town>> append ;
|
|||
[ H{ } [ ] with-nesting nl ] make-html-string
|
||||
] unit-test
|
||||
|
||||
[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
|
||||
|
||||
[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test
|
||||
[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
|
|
@ -4,7 +4,7 @@ USING: accessors kernel sequences combinators kernel fry
|
|||
namespaces make classes.tuple assocs splitting words arrays io
|
||||
io.files io.files.info io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors math urls present multiline quotations xml
|
||||
logging call
|
||||
logging
|
||||
xml.data xml.writer xml.syntax strings
|
||||
html.forms
|
||||
html
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces make kernel sequences accessors
|
||||
combinators strings splitting io io.streams.string present
|
||||
xml.writer xml.data xml.entities html.forms call
|
||||
xml.writer xml.data xml.entities html.forms
|
||||
html.templates html.templates.chloe.syntax ;
|
||||
IN: html.templates.chloe.compiler
|
||||
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations sequences kernel namespaces debugger
|
||||
combinators math quotations generic strings splitting accessors
|
||||
assocs fry vocabs.parser parser lexer io io.files call
|
||||
assocs fry vocabs.parser parser lexer io io.files
|
||||
io.streams.string io.encodings.utf8 html.templates ;
|
||||
IN: html.templates.fhtml
|
||||
|
||||
|
@ -65,7 +65,7 @@ DEFER: <% delimiter
|
|||
] with-file-vocabs ;
|
||||
|
||||
: eval-template ( string -- )
|
||||
parse-template call ;
|
||||
parse-template call( -- ) ;
|
||||
|
||||
TUPLE: fhtml path ;
|
||||
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel fry io io.encodings.utf8 io.files
|
||||
debugger prettyprint continuations namespaces boxes sequences
|
||||
arrays strings html io.streams.string assocs call
|
||||
arrays strings html io.streams.string assocs
|
||||
quotations xml.data xml.writer xml.syntax ;
|
||||
IN: html.templates
|
||||
|
||||
|
|
|
@ -6,7 +6,7 @@ sorting logging calendar.format accessors splitting io io.files
|
|||
io.files.info io.directories io.pathnames io.encodings.binary
|
||||
fry xml.entities destructors urls html xml.syntax
|
||||
html.templates.fhtml http http.server http.server.responses
|
||||
http.server.redirection xml.writer call ;
|
||||
http.server.redirection xml.writer ;
|
||||
IN: http.server.static
|
||||
|
||||
TUPLE: file-responder root hook special allow-listings ;
|
||||
|
|
|
@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations
|
|||
continuations debugger classes.tuple namespaces make vectors
|
||||
bit-arrays byte-arrays strings sbufs math.functions macros
|
||||
sequences.private combinators mirrors splitting
|
||||
combinators.short-circuit fry words.symbol generalizations call ;
|
||||
combinators.short-circuit fry words.symbol generalizations ;
|
||||
RENAME: _ fry => __
|
||||
IN: inverse
|
||||
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.encodings io.backend io.ports io.streams.duplex
|
||||
io splitting grouping sequences namespaces kernel
|
||||
destructors math concurrency.combinators accessors
|
||||
destructors math concurrency.combinators accessors fry
|
||||
arrays continuations quotations system vocabs.loader combinators ;
|
||||
IN: io.pipes
|
||||
|
||||
|
@ -29,11 +29,12 @@ HOOK: (pipe) io-backend ( -- pipe )
|
|||
: ?writer ( handle/f -- stream )
|
||||
[ <output-port> &dispose ] [ output-stream get ] if* ;
|
||||
|
||||
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
|
||||
GENERIC: run-pipeline-element ( input-fd output-fd obj -- result )
|
||||
|
||||
M: callable run-pipeline-element
|
||||
[
|
||||
[ [ ?reader ] [ ?writer ] bi* ] dip with-streams*
|
||||
[ [ ?reader ] [ ?writer ] bi* ] dip
|
||||
'[ _ call( -- result ) ] with-streams*
|
||||
] with-destructors ;
|
||||
|
||||
: <pipes> ( n -- pipes )
|
||||
|
|
|
@ -7,7 +7,7 @@ fry accessors arrays io io.sockets io.encodings.ascii
|
|||
io.sockets.secure io.files io.streams.duplex io.timeouts
|
||||
io.encodings threads make concurrency.combinators
|
||||
concurrency.semaphores concurrency.flags
|
||||
combinators.short-circuit call ;
|
||||
combinators.short-circuit ;
|
||||
IN: io.servers.connection
|
||||
|
||||
TUPLE: threaded-server
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
|
|||
namespaces parser lexer sequences strings io.styles
|
||||
vectors words generic system combinators continuations debugger
|
||||
definitions compiler.units accessors colors prettyprint fry
|
||||
sets vocabs.parser call ;
|
||||
sets vocabs.parser ;
|
||||
IN: listener
|
||||
|
||||
GENERIC: stream-read-quot ( stream -- quot/f )
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences math vectors arrays namespaces make
|
||||
quotations promises combinators io lists accessors call ;
|
||||
quotations promises combinators io lists accessors ;
|
||||
IN: lists.lazy
|
||||
|
||||
M: promise car ( promise -- car )
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors models kernel call ;
|
||||
USING: accessors models kernel ;
|
||||
IN: models.arrow
|
||||
|
||||
TUPLE: arrow < model model quot ;
|
||||
|
|
|
@ -5,7 +5,7 @@ sequences quotations vectors namespaces make math assocs
|
|||
continuations peg peg.parsers unicode.categories multiline
|
||||
splitting accessors effects sequences.deep peg.search
|
||||
combinators.short-circuit lexer io.streams.string stack-checker
|
||||
io combinators parser call ;
|
||||
io combinators parser ;
|
||||
IN: peg.ebnf
|
||||
|
||||
: rule ( name word -- parser )
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs
|
|||
io vectors arrays math.parser math.order vectors combinators
|
||||
classes sets unicode.categories compiler.units parser words
|
||||
quotations effects memoize accessors locals effects splitting
|
||||
combinators.short-circuit generalizations call ;
|
||||
combinators.short-circuit generalizations ;
|
||||
IN: peg
|
||||
|
||||
TUPLE: parse-result remaining ast ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel make prettyprint.backend
|
||||
prettyprint.custom regexp regexp.parser regexp.private ;
|
||||
IN: regexp.prettyprint
|
||||
|
||||
M: regexp pprint*
|
||||
[
|
||||
[
|
||||
[ raw>> dup find-regexp-syntax swap % swap % % ]
|
||||
[ options>> options>string % ] bi
|
||||
] "" make
|
||||
] keep present-text ;
|
|
@ -1,10 +1,9 @@
|
|||
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators kernel kernel.private math sequences
|
||||
sequences.private strings sets assocs prettyprint.backend
|
||||
prettyprint.custom make lexer namespaces parser arrays fry locals
|
||||
regexp.parser splitting sorting regexp.ast regexp.negation
|
||||
regexp.compiler compiler.units words call call.private math.ranges ;
|
||||
sequences.private strings sets assocs make lexer namespaces parser
|
||||
arrays fry locals regexp.parser splitting sorting regexp.ast
|
||||
regexp.negation regexp.compiler compiler.units words math.ranges ;
|
||||
IN: regexp
|
||||
|
||||
TUPLE: regexp
|
||||
|
@ -35,7 +34,7 @@ M: lookbehind question>quot ! Returns ( index string -- ? )
|
|||
: match-index-from ( i string regexp -- index/f )
|
||||
! This word is unsafe. It assumes that i is a fixnum
|
||||
! and that string is a string.
|
||||
dup dfa>> execute-unsafe( index string regexp -- i/f ) ; inline
|
||||
dup dfa>> execute( index string regexp -- i/f ) ; inline
|
||||
|
||||
GENERIC: end/start ( string regexp -- end start )
|
||||
M: regexp end/start drop length 0 ;
|
||||
|
@ -68,7 +67,7 @@ PRIVATE>
|
|||
|
||||
: do-next-match ( i string regexp -- i start end ? )
|
||||
dup next-match>>
|
||||
execute-unsafe( i string regexp -- i start end ? ) ; inline
|
||||
execute( i string regexp -- i start end ? ) ; inline
|
||||
|
||||
:: (each-match) ( i string regexp quot: ( start end string -- ) -- )
|
||||
i string regexp do-next-match [| i' start end |
|
||||
|
@ -217,11 +216,8 @@ PRIVATE>
|
|||
: R{ CHAR: } parsing-regexp ; parsing
|
||||
: R| CHAR: | parsing-regexp ; parsing
|
||||
|
||||
M: regexp pprint*
|
||||
[
|
||||
[
|
||||
[ raw>> dup find-regexp-syntax swap % swap % % ]
|
||||
[ options>> options>string % ] bi
|
||||
] "" make
|
||||
] keep present-text ;
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [
|
||||
"regexp.prettyprint" require
|
||||
] when
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,7 @@
|
|||
USING: stack-checker.call-effect tools.test math kernel ;
|
||||
IN: stack-checker.call-effect.tests
|
||||
|
||||
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
|
||||
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
|
||||
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
|
||||
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
|
|
@ -0,0 +1,95 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators combinators.private effects fry
|
||||
kernel kernel.private make sequences continuations quotations
|
||||
stack-checker stack-checker.transforms ;
|
||||
IN: stack-checker.call-effect
|
||||
|
||||
! call( and execute( have complex expansions.
|
||||
|
||||
! call( uses the following strategy:
|
||||
! - Inline caching. If the quotation is the same as last time, just call it unsafely
|
||||
! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
|
||||
! and compare it with declaration. If matches, call it unsafely.
|
||||
! - Fallback. If the above doesn't work, call it and compare the datastack before
|
||||
! and after to make sure it didn't mess anything up.
|
||||
|
||||
! execute( uses a similar strategy.
|
||||
|
||||
TUPLE: inline-cache value ;
|
||||
|
||||
: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline
|
||||
|
||||
SYMBOL: +unknown+
|
||||
|
||||
GENERIC: cached-effect ( quot -- effect )
|
||||
|
||||
M: object cached-effect drop +unknown+ ;
|
||||
|
||||
M: quotation cached-effect
|
||||
dup cached-effect>>
|
||||
[ ] [
|
||||
[ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
|
||||
(>>cached-effect)
|
||||
] ?if ;
|
||||
|
||||
: call-effect-unsafe? ( quot effect -- ? )
|
||||
[ cached-effect ] dip
|
||||
over +unknown+ eq?
|
||||
[ 2drop f ] [ effect<= ] if ; inline
|
||||
|
||||
: (call-effect-slow>quot) ( in out effect -- quot )
|
||||
[
|
||||
[ [ datastack ] dip dip ] %
|
||||
[ [ , ] bi@ \ check-datastack , ] dip
|
||||
'[ _ wrong-values ] , \ unless ,
|
||||
] [ ] make ;
|
||||
|
||||
: call-effect-slow>quot ( effect -- quot )
|
||||
[ in>> length ] [ out>> length ] [ ] tri
|
||||
[ (call-effect-slow>quot) ] keep add-effect-input
|
||||
[ call-effect-unsafe ] 2curry ;
|
||||
|
||||
: call-effect-slow ( quot effect -- ) drop call ;
|
||||
|
||||
\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
|
||||
|
||||
: call-effect-fast ( quot effect inline-cache -- )
|
||||
2over call-effect-unsafe?
|
||||
[ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
|
||||
[ drop call-effect-slow ]
|
||||
if ; inline
|
||||
|
||||
\ call-effect [
|
||||
inline-cache new '[
|
||||
_
|
||||
3dup nip cache-hit? [
|
||||
drop call-effect-unsafe
|
||||
] [
|
||||
call-effect-fast
|
||||
] if
|
||||
]
|
||||
] 0 define-transform
|
||||
|
||||
: execute-effect-slow ( word effect -- )
|
||||
[ '[ _ execute ] ] dip call-effect-slow ; inline
|
||||
|
||||
: execute-effect-unsafe? ( word effect -- ? )
|
||||
over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
|
||||
|
||||
: execute-effect-fast ( word effect inline-cache -- )
|
||||
2over execute-effect-unsafe?
|
||||
[ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
|
||||
[ drop execute-effect-slow ]
|
||||
if ; inline
|
||||
|
||||
: execute-effect-ic ( word effect inline-cache -- )
|
||||
3dup nip cache-hit?
|
||||
[ drop execute-effect-unsafe ]
|
||||
[ execute-effect-fast ]
|
||||
if ; inline
|
||||
|
||||
: execute-effect>quot ( effect -- quot )
|
||||
inline-cache new '[ _ _ execute-effect-ic ] ;
|
||||
|
||||
\ execute-effect [ execute-effect>quot ] 1 define-transform
|
|
@ -11,7 +11,7 @@ strings.private system threads.private classes.tuple
|
|||
classes.tuple.private vectors vectors.private words definitions
|
||||
words.private assocs summary compiler.units system.private
|
||||
combinators locals locals.backend locals.types words.private
|
||||
quotations.private call call.private stack-checker.values
|
||||
quotations.private combinators.private stack-checker.values
|
||||
stack-checker.alien
|
||||
stack-checker.state
|
||||
stack-checker.errors
|
||||
|
@ -135,17 +135,16 @@ M: object infer-call*
|
|||
peek-d literal value>> second 1+ { tuple } <effect>
|
||||
apply-word/effect ;
|
||||
|
||||
: infer-(throw) ( -- )
|
||||
\ (throw)
|
||||
peek-d literal value>> 2 + { "*" } <effect>
|
||||
: infer-effect-unsafe ( word -- )
|
||||
pop-literal nip
|
||||
add-effect-input
|
||||
apply-word/effect ;
|
||||
|
||||
: infer-execute-effect-unsafe ( -- )
|
||||
\ execute
|
||||
pop-literal nip
|
||||
[ in>> "word" suffix ] [ out>> ] [ terminated?>> ] tri
|
||||
effect boa
|
||||
apply-word/effect ;
|
||||
\ execute infer-effect-unsafe ;
|
||||
|
||||
: infer-call-effect-unsafe ( -- )
|
||||
\ call infer-effect-unsafe ;
|
||||
|
||||
: infer-exit ( -- )
|
||||
\ exit (( n -- * )) apply-word/effect ;
|
||||
|
@ -186,10 +185,10 @@ M: object infer-call*
|
|||
{ \ execute [ infer-execute ] }
|
||||
{ \ (execute) [ infer-execute ] }
|
||||
{ \ execute-effect-unsafe [ infer-execute-effect-unsafe ] }
|
||||
{ \ call-effect-unsafe [ infer-call-effect-unsafe ] }
|
||||
{ \ if [ infer-if ] }
|
||||
{ \ dispatch [ infer-dispatch ] }
|
||||
{ \ <tuple-boa> [ infer-<tuple-boa> ] }
|
||||
{ \ (throw) [ infer-(throw) ] }
|
||||
{ \ exit [ infer-exit ] }
|
||||
{ \ load-local [ 1 infer->r ] }
|
||||
{ \ load-locals [ infer-load-locals ] }
|
||||
|
@ -212,9 +211,10 @@ M: object infer-call*
|
|||
|
||||
{
|
||||
declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose
|
||||
execute (execute) execute-effect-unsafe if dispatch <tuple-boa>
|
||||
(throw) exit load-local load-locals get-local drop-locals
|
||||
do-primitive alien-invoke alien-indirect alien-callback
|
||||
execute (execute) call-effect-unsafe execute-effect-unsafe if
|
||||
dispatch <tuple-boa> exit load-local load-locals get-local
|
||||
drop-locals do-primitive alien-invoke alien-indirect
|
||||
alien-callback
|
||||
} [ t "special" set-word-prop ] each
|
||||
|
||||
{ call execute dispatch load-locals get-local drop-locals }
|
||||
|
@ -627,6 +627,9 @@ M: object infer-call*
|
|||
\ datastack { } { array } define-primitive
|
||||
\ datastack make-flushable
|
||||
|
||||
\ check-datastack { array integer integer } { object } define-primitive
|
||||
\ check-datastack make-flushable
|
||||
|
||||
\ retainstack { } { array } define-primitive
|
||||
\ retainstack make-flushable
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io effects namespaces sequences quotations vocabs
|
||||
generic words stack-checker.backend stack-checker.state
|
||||
vocabs.loader generic words stack-checker.backend stack-checker.state
|
||||
stack-checker.known-words stack-checker.transforms
|
||||
stack-checker.errors stack-checker.inlining
|
||||
stack-checker.visitor.dummy ;
|
||||
|
@ -28,3 +28,5 @@ M: callable infer ( quot -- effect )
|
|||
dup subwords [ f "inferred-effect" set-word-prop ] each
|
||||
f "inferred-effect" set-word-prop
|
||||
] each ;
|
||||
|
||||
"stack-checker.call-effect" require
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
|
@ -3,8 +3,8 @@ USING: sequences stack-checker.transforms tools.test math kernel
|
|||
quotations stack-checker accessors combinators words arrays
|
||||
classes classes.tuple ;
|
||||
|
||||
: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
|
||||
: compose-n ( quot -- ) compose-n-quot call ;
|
||||
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
|
||||
: compose-n ( quot n -- ) compose-n-quot call ;
|
||||
\ compose-n [ compose-n-quot ] 2 define-transform
|
||||
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
|
||||
|
||||
|
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors arrays kernel words sequences generic math
|
||||
namespaces make quotations assocs combinators classes.tuple
|
||||
classes.tuple.private effects summary hashtables classes generic
|
||||
sets definitions generic.standard slots.private continuations locals
|
||||
generalizations stack-checker.backend stack-checker.state
|
||||
stack-checker.visitor stack-checker.errors stack-checker.values
|
||||
USING: fry accessors arrays kernel kernel.private combinators.private
|
||||
words sequences generic math namespaces make quotations assocs
|
||||
combinators classes.tuple classes.tuple.private effects summary
|
||||
hashtables classes generic sets definitions generic.standard
|
||||
slots.private continuations locals generalizations
|
||||
stack-checker.backend stack-checker.state stack-checker.visitor
|
||||
stack-checker.errors stack-checker.values
|
||||
stack-checker.recursive-state ;
|
||||
IN: stack-checker.transforms
|
||||
|
||||
|
@ -141,8 +142,12 @@ CONSTANT: bit-member-n 256
|
|||
dup bit-member? [
|
||||
bit-member-quot
|
||||
] [
|
||||
[ literalize [ t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ case ] curry
|
||||
dup length 4 <= [
|
||||
[ drop f ] swap
|
||||
[ literalize [ t ] ] { } map>assoc linear-case-quot
|
||||
] [
|
||||
unique [ key? ] curry
|
||||
] if
|
||||
] if ;
|
||||
|
||||
\ member? [
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2005 Mackenzie Straight.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays hashtables heaps kernel kernel.private math
|
||||
namespaces sequences vectors continuations continuations.private
|
||||
dlists assocs system combinators init boxes accessors
|
||||
math.order deques strings quotations fry ;
|
||||
dlists assocs system combinators combinators.private init boxes
|
||||
accessors math.order deques strings quotations fry ;
|
||||
IN: threads
|
||||
|
||||
SYMBOL: initial-thread
|
||||
|
@ -126,7 +126,7 @@ DEFER: stop
|
|||
{ } set-retainstack
|
||||
{ } set-datastack
|
||||
self quot>> [ call stop ] call-clear
|
||||
] 2 (throw) ;
|
||||
] (( namestack thread -- * )) call-effect-unsafe ;
|
||||
|
||||
DEFER: next
|
||||
|
||||
|
@ -160,7 +160,7 @@ DEFER: next
|
|||
PRIVATE>
|
||||
|
||||
: stop ( -- )
|
||||
self [ exit-handler>> call ] [ unregister-thread ] bi next ;
|
||||
self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi next ;
|
||||
|
||||
: suspend ( quot state -- obj )
|
||||
[
|
||||
|
|
|
@ -39,13 +39,13 @@ ERROR: cannot-annotate-twice word ;
|
|||
dup def>> "unannotated-def" set-word-prop ;
|
||||
|
||||
: (annotate) ( word quot -- )
|
||||
[ dup def>> ] dip call define ; inline
|
||||
[ dup def>> ] dip call( old -- new ) define ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: annotate ( word quot -- )
|
||||
[ method-spec>word check-annotate-twice ] dip
|
||||
[ over save-unannotated-def (annotate) ] with-compilation-unit ; inline
|
||||
[ over save-unannotated-def (annotate) ] with-compilation-unit ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax words alien.c-types assocs
|
||||
kernel call call.private tools.deploy.config ;
|
||||
kernel combinators combinators.private tools.deploy.config ;
|
||||
IN: tools.deploy
|
||||
|
||||
ARTICLE: "prepare-deploy" "Preparing to deploy an application"
|
||||
|
@ -28,7 +28,7 @@ ARTICLE: "tools.deploy.caveats" "Deploy tool caveats"
|
|||
{ $heading "Behavior of " { $link boa } }
|
||||
"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
|
||||
{ $heading "Behavior of " { $link POSTPONE: execute( } }
|
||||
"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-unsafe( } "."
|
||||
"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
|
||||
{ $heading "Error reporting" }
|
||||
"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
|
||||
{ $heading "Choosing the right deploy flags" }
|
||||
|
|
|
@ -1,10 +1,9 @@
|
|||
IN: tools.deploy.tests
|
||||
USING: tools.test system io.pathnames io.files io.files.info
|
||||
io.files.temp kernel tools.deploy.config
|
||||
tools.deploy.config.editor tools.deploy.backend math sequences
|
||||
io.launcher arrays namespaces continuations layouts accessors
|
||||
io.encodings.ascii urls math.parser io.directories
|
||||
tools.deploy.test ;
|
||||
io.files.temp kernel tools.deploy.config tools.deploy.config.editor
|
||||
tools.deploy.backend math sequences io.launcher arrays namespaces
|
||||
continuations layouts accessors io.encodings.ascii urls math.parser
|
||||
io.directories tools.deploy.test ;
|
||||
|
||||
[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
|
||||
|
||||
|
@ -27,6 +26,8 @@ os macosx? [
|
|||
[ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test
|
||||
] when
|
||||
|
||||
[ t ] [ "benchmark.regex-dna" shake-and-bake 1200000 small-enough? ] unit-test
|
||||
|
||||
{
|
||||
"tools.deploy.test.1"
|
||||
"tools.deploy.test.2"
|
||||
|
|
|
@ -54,11 +54,8 @@ IN: tools.deploy.shaker
|
|||
] when ;
|
||||
|
||||
: strip-call ( -- )
|
||||
"call" vocab [
|
||||
"Stripping stack effect checking from call( and execute(" show
|
||||
"vocab:tools/deploy/shaker/strip-call.factor"
|
||||
run-file
|
||||
] when ;
|
||||
"Stripping stack effect checking from call( and execute(" show
|
||||
"vocab:tools/deploy/shaker/strip-call.factor" run-file ;
|
||||
|
||||
: strip-cocoa ( -- )
|
||||
"cocoa" vocab [
|
||||
|
@ -122,6 +119,7 @@ IN: tools.deploy.shaker
|
|||
"inline"
|
||||
"inlined-block"
|
||||
"input-classes"
|
||||
"instances"
|
||||
"interval"
|
||||
"intrinsics"
|
||||
"lambda"
|
||||
|
@ -344,7 +342,8 @@ IN: tools.deploy.shaker
|
|||
] 2each ;
|
||||
|
||||
: compress-quotations ( -- )
|
||||
[ quotation? ] [ remain-compiled ] "quotations" compress ;
|
||||
[ quotation? ] [ remain-compiled ] "quotations" compress
|
||||
[ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
|
||||
|
||||
: compress-strings ( -- )
|
||||
[ string? ] [ ] "strings" compress ;
|
||||
|
|
|
@ -2,7 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: tools.deploy.shaker.call
|
||||
|
||||
IN: call
|
||||
USE: call.private
|
||||
IN: combinators
|
||||
USE: combinators.private
|
||||
|
||||
: call-effect ( word effect -- ) call-effect-unsafe ; inline
|
||||
|
||||
: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
|
|
@ -1,10 +1,12 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: call math.parser io math ;
|
||||
USING: math.parser io math ;
|
||||
IN: tools.deploy.test.12
|
||||
|
||||
: execute-test ( a b w -- c ) execute( a b -- c ) ;
|
||||
|
||||
: foo ( -- ) 1 2 \ + execute-test number>string print ;
|
||||
: call-test ( a b q -- c ) call( a b -- c ) ;
|
||||
|
||||
: foo ( -- ) 1 2 \ + execute-test 4 [ * ] call-test number>string print ;
|
||||
|
||||
MAIN: foo
|
|
@ -23,7 +23,7 @@ SYMBOL: this-test
|
|||
[ this-test get failure ] recover
|
||||
] [
|
||||
call
|
||||
] if ;
|
||||
] if ; inline
|
||||
|
||||
: unit-test ( output input -- )
|
||||
[ 2array ] 2keep '[
|
||||
|
|
|
@ -244,11 +244,7 @@ C: <vocab-author> vocab-author
|
|||
} cleave ;
|
||||
|
||||
: keyed-vocabs ( str quot -- seq )
|
||||
all-vocabs [
|
||||
swap [
|
||||
[ [ 2dup ] dip swap call member? ] filter
|
||||
] dip swap
|
||||
] assoc-map 2nip ; inline
|
||||
[ all-vocabs ] 2dip '[ [ _ swap @ member? ] filter ] assoc-map ; inline
|
||||
|
||||
: tagged ( tag -- assoc )
|
||||
[ vocab-tags ] keyed-vocabs ;
|
||||
|
|
|
@ -139,7 +139,6 @@ SYMBOL: +stopped+
|
|||
{ dip [ (step-into-dip) ] }
|
||||
{ 2dip [ (step-into-2dip) ] }
|
||||
{ 3dip [ (step-into-3dip) ] }
|
||||
{ (throw) [ drop (step-into-quot) ] }
|
||||
{ execute [ (step-into-execute) ] }
|
||||
{ if [ (step-into-if) ] }
|
||||
{ dispatch [ (step-into-dispatch) ] }
|
||||
|
|
|
@ -17,7 +17,8 @@ M: bad-tr summary
|
|||
[ [ ascii? ] all? ] both? [ bad-tr ] unless ;
|
||||
|
||||
: compute-tr ( quot from to -- mapping )
|
||||
zip [ 128 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline
|
||||
[ 128 ] 3dip zip
|
||||
'[ [ _ call( x -- y ) _ at ] keep or ] B{ } map-as ; inline
|
||||
|
||||
: tr-hints ( word -- )
|
||||
{ { byte-array } { string } } "specializer" set-word-prop ;
|
||||
|
|
|
@ -8,7 +8,7 @@ ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
|
|||
ui.backend.cocoa.views core-foundation core-foundation.run-loop
|
||||
core-graphics.types threads math.rectangles fry libc
|
||||
generalizations alien.c-types cocoa.views
|
||||
combinators io.thread locals call ;
|
||||
combinators io.thread locals ;
|
||||
IN: ui.backend.cocoa
|
||||
|
||||
TUPLE: handle ;
|
||||
|
|
|
@ -2,8 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays definitions kernel sequences strings
|
||||
math assocs words generic namespaces make assocs quotations
|
||||
splitting ui.gestures unicode.case unicode.categories tr fry
|
||||
call ;
|
||||
splitting ui.gestures unicode.case unicode.categories tr fry ;
|
||||
IN: ui.commands
|
||||
|
||||
SYMBOL: +nullary+
|
||||
|
|
|
@ -6,7 +6,7 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
|
|||
ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks
|
||||
ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid
|
||||
ui.pens.image ui.pens.tile math.rectangles locals fry
|
||||
combinators.smart call ;
|
||||
combinators.smart ;
|
||||
IN: ui.gadgets.buttons
|
||||
|
||||
TUPLE: button < border pressed? selected? quot ;
|
||||
|
|
|
@ -413,8 +413,7 @@ editor "caret-motion" f {
|
|||
} define-command-map
|
||||
|
||||
: clear-editor ( editor -- )
|
||||
#! The with-datastack is a kludge to make it infer. Stupid.
|
||||
model>> 1array [ clear-doc ] with-datastack drop ;
|
||||
model>> clear-doc ;
|
||||
|
||||
: select-all ( editor -- ) doc-elt select-elt ;
|
||||
|
||||
|
@ -619,7 +618,7 @@ TUPLE: action-field < field quot ;
|
|||
[ editor>> editor-string ]
|
||||
[ editor>> clear-editor ]
|
||||
[ quot>> ]
|
||||
tri call ;
|
||||
tri call( string -- ) ;
|
||||
|
||||
action-field H{
|
||||
{ T{ key-down f f "RET" } [ invoke-action-field ] }
|
||||
|
|
|
@ -10,7 +10,7 @@ ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
|
|||
ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
|
||||
ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks
|
||||
ui.gadgets.icons ui.gadgets.grid-lines ui.baseline-alignment
|
||||
colors call io.styles ;
|
||||
colors io.styles ;
|
||||
IN: ui.gadgets.panes
|
||||
|
||||
TUPLE: pane < track
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs continuations kernel math models
|
||||
call namespaces opengl sequences io combinators
|
||||
combinators.short-circuit fry math.vectors math.rectangles cache
|
||||
ui.gadgets ui.gestures ui.render ui.text ui.text.private
|
||||
ui.backend ui.gadgets.tracks ui.commands ;
|
||||
namespaces opengl sequences io combinators combinators.short-circuit
|
||||
fry math.vectors math.rectangles cache ui.gadgets ui.gestures
|
||||
ui.render ui.text ui.text.private ui.backend ui.gadgets.tracks
|
||||
ui.commands ;
|
||||
IN: ui.gadgets.worlds
|
||||
|
||||
TUPLE: world < track
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: accessors arrays assocs kernel math math.order models
|
|||
namespaces make sequences words strings system hashtables math.parser
|
||||
math.vectors classes.tuple classes boxes calendar alarms combinators
|
||||
sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
|
||||
unicode.categories combinators.short-circuit call ;
|
||||
unicode.categories combinators.short-circuit ;
|
||||
IN: ui.gestures
|
||||
|
||||
GENERIC: handle-gesture ( gesture gadget -- ? )
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays definitions kernel ui.commands
|
||||
ui.gestures sequences strings math words generic namespaces
|
||||
hashtables help.markup quotations assocs fry call linked-assocs ;
|
||||
hashtables help.markup quotations assocs fry linked-assocs ;
|
||||
IN: ui.operations
|
||||
|
||||
SYMBOL: +keyboard+
|
||||
|
|
|
@ -105,5 +105,5 @@ walker-gadget "multitouch" f {
|
|||
|
||||
[
|
||||
dup find-walker-window dup
|
||||
[ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
|
||||
[ raise-window 3drop ] [ drop '[ _ _ _ walker-window ] with-ui ] if
|
||||
] show-walker-hook set-global
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs io kernel math models namespaces make dlists
|
||||
deques sequences threads sequences words continuations init call
|
||||
deques sequences threads sequences words continuations init
|
||||
combinators hashtables concurrency.flags sets accessors calendar fry
|
||||
destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
|
||||
ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text
|
||||
|
|
|
@ -82,9 +82,9 @@ HELP: parse-host
|
|||
{ $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: prettyprint urls kernel ;"
|
||||
"\"sbcl.org:80\" parse-host .s 2drop"
|
||||
"\"sbcl.org\"\n80"
|
||||
"USING: arrays kernel prettyprint urls ;"
|
||||
"\"sbcl.org:80\" parse-host 2array ."
|
||||
"{ \"sbcl.org\" 80 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences math arrays locals fry accessors
|
||||
lists splitting call make combinators.short-circuit namespaces
|
||||
lists splitting make combinators.short-circuit namespaces
|
||||
grouping splitting.monotonic ;
|
||||
IN: wrap
|
||||
|
||||
|
|
|
@ -12,7 +12,7 @@ IN: xmode.loader.syntax
|
|||
|
||||
: RULE:
|
||||
scan scan-word scan-word [
|
||||
parse-definition { } make
|
||||
[ parse-definition call( -- ) ] { } make
|
||||
swap [ (parse-rule-tag) ] 2curry
|
||||
] dip swap define-tag ; parsing
|
||||
|
||||
|
|
|
@ -140,9 +140,6 @@ bootstrapping? on
|
|||
"word" "words" create register-builtin
|
||||
"byte-array" "byte-arrays" create register-builtin
|
||||
|
||||
! For predicate classes
|
||||
"predicate-instance?" "classes.predicate" create drop
|
||||
|
||||
! We need this before defining c-ptr below
|
||||
"f" "syntax" lookup { } define-builtin
|
||||
|
||||
|
@ -243,6 +240,8 @@ bi
|
|||
"quotation" "quotations" create {
|
||||
{ "array" { "array" "arrays" } read-only }
|
||||
{ "compiled" read-only }
|
||||
"cached-effect"
|
||||
"cache-counter"
|
||||
} define-builtin
|
||||
|
||||
"dll" "alien" create {
|
||||
|
@ -491,7 +490,6 @@ tuple
|
|||
{ "set-alien-double" "alien.accessors" }
|
||||
{ "alien-cell" "alien.accessors" }
|
||||
{ "set-alien-cell" "alien.accessors" }
|
||||
{ "(throw)" "kernel.private" }
|
||||
{ "alien-address" "alien" }
|
||||
{ "set-slot" "slots.private" }
|
||||
{ "string-nth" "strings.private" }
|
||||
|
@ -533,6 +531,7 @@ tuple
|
|||
{ "gc-reset" "memory" }
|
||||
{ "jit-compile" "quotations" }
|
||||
{ "load-locals" "locals.backend" }
|
||||
{ "check-datastack" "kernel.private" }
|
||||
}
|
||||
[ [ first2 ] dip make-primitive ] each-index
|
||||
|
||||
|
|
|
@ -78,6 +78,8 @@ IN: bootstrap.syntax
|
|||
"call-next-method"
|
||||
"initial:"
|
||||
"read-only"
|
||||
"call("
|
||||
"execute("
|
||||
} [ "syntax" create drop ] each
|
||||
|
||||
"t" "syntax" lookup define-symbol
|
||||
|
|
|
@ -18,10 +18,4 @@ M: positive abs ;
|
|||
|
||||
[ 10 ] [ -10 abs ] unit-test
|
||||
[ 10 ] [ 10 abs ] unit-test
|
||||
[ 0 ] [ 0 abs ] unit-test
|
||||
|
||||
PREDICATE: blah < word blah eq? ;
|
||||
|
||||
[ f ] [ \ predicate-instance? "compiled-uses" word-prop keys \ blah swap memq? ] unit-test
|
||||
|
||||
FORGET: blah
|
||||
[ 0 ] [ 0 abs ] unit-test
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.algebra kernel namespaces make words
|
||||
sequences quotations arrays kernel.private assocs combinators ;
|
||||
|
@ -7,21 +7,6 @@ IN: classes.predicate
|
|||
PREDICATE: predicate-class < class
|
||||
"metaclass" word-prop predicate-class eq? ;
|
||||
|
||||
DEFER: predicate-instance? ( object class -- ? )
|
||||
|
||||
: update-predicate-instance ( -- )
|
||||
\ predicate-instance? bootstrap-word
|
||||
classes [ predicate-class? ] filter [
|
||||
[ literalize ]
|
||||
[
|
||||
[ superclass 1array [ declare ] curry ]
|
||||
[ "predicate-definition" word-prop ]
|
||||
bi compose
|
||||
]
|
||||
bi
|
||||
] { } map>assoc [ case ] curry
|
||||
define ;
|
||||
|
||||
: predicate-quot ( class -- quot )
|
||||
[
|
||||
\ dup ,
|
||||
|
@ -38,19 +23,17 @@ DEFER: predicate-instance? ( object class -- ? )
|
|||
[ dup predicate-quot define-predicate ]
|
||||
[ update-classes ]
|
||||
bi
|
||||
]
|
||||
3tri
|
||||
update-predicate-instance ;
|
||||
] 3tri ;
|
||||
|
||||
M: predicate-class reset-class
|
||||
[ call-next-method ] [ { "predicate-definition" } reset-props ] bi
|
||||
update-predicate-instance ;
|
||||
[ call-next-method ] [ { "predicate-definition" } reset-props ] bi ;
|
||||
|
||||
M: predicate-class rank-class drop 1 ;
|
||||
|
||||
M: predicate-class instance?
|
||||
2dup superclass instance?
|
||||
[ predicate-instance? ] [ 2drop f ] if ;
|
||||
2dup superclass instance? [
|
||||
"predicate-definition" word-prop call( object -- ? )
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
M: predicate-class (flatten-class)
|
||||
superclass (flatten-class) ;
|
||||
|
|
|
@ -30,7 +30,7 @@ ERROR: duplicate-slot-names names ;
|
|||
|
||||
ERROR: invalid-slot-name name ;
|
||||
|
||||
: parse-long-slot-name ( -- )
|
||||
: parse-long-slot-name ( -- spec )
|
||||
[ scan , \ } parse-until % ] { } make ;
|
||||
|
||||
: parse-slot-name ( string/f -- ? )
|
||||
|
@ -64,7 +64,7 @@ ERROR: bad-literal-tuple ;
|
|||
|
||||
: parse-slot-value ( -- )
|
||||
scan scan-object 2array , scan {
|
||||
{ f [ unexpected-eof ] }
|
||||
{ f [ \ } unexpected-eof ] }
|
||||
{ "}" [ ] }
|
||||
[ bad-literal-tuple ]
|
||||
} case ;
|
||||
|
@ -72,13 +72,13 @@ ERROR: bad-literal-tuple ;
|
|||
: (parse-slot-values) ( -- )
|
||||
parse-slot-value
|
||||
scan {
|
||||
{ f [ unexpected-eof ] }
|
||||
{ f [ \ } unexpected-eof ] }
|
||||
{ "{" [ (parse-slot-values) ] }
|
||||
{ "}" [ ] }
|
||||
[ bad-literal-tuple ]
|
||||
} case ;
|
||||
|
||||
: parse-slot-values ( -- )
|
||||
: parse-slot-values ( -- values )
|
||||
[ (parse-slot-values) ] { } make ;
|
||||
|
||||
: boa>tuple ( class slots -- tuple )
|
||||
|
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
USING: arrays help.markup help.syntax strings sbufs vectors
|
||||
kernel quotations generic generic.standard classes
|
||||
math assocs sequences sequences.private ;
|
||||
math assocs sequences sequences.private combinators.private
|
||||
effects words ;
|
||||
IN: combinators
|
||||
|
||||
ARTICLE: "combinators-quot" "Quotation construction utilities"
|
||||
|
@ -9,6 +10,19 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
|
|||
{ $subsection case>quot }
|
||||
{ $subsection alist>quot } ;
|
||||
|
||||
ARTICLE: "call" "Calling code with known stack effects"
|
||||
"Arbitrary quotations and words can be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
|
||||
$nl
|
||||
"Quotations:"
|
||||
{ $subsection POSTPONE: call( }
|
||||
{ $subsection call-effect }
|
||||
"Words:"
|
||||
{ $subsection POSTPONE: execute( }
|
||||
{ $subsection execute-effect }
|
||||
"Unsafe calls:"
|
||||
{ $subsection call-effect-unsafe }
|
||||
{ $subsection execute-effect-unsafe } ;
|
||||
|
||||
ARTICLE: "combinators" "Additional combinators"
|
||||
"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
|
||||
$nl
|
||||
|
@ -27,11 +41,27 @@ $nl
|
|||
$nl
|
||||
"A combinator which can help with implementing methods on " { $link hashcode* } ":"
|
||||
{ $subsection recursive-hashcode }
|
||||
{ $subsection "call" }
|
||||
{ $subsection "combinators-quot" }
|
||||
{ $see-also "quotations" "dataflow" } ;
|
||||
|
||||
ABOUT: "combinators"
|
||||
|
||||
HELP: call-effect
|
||||
{ $values { "quot" quotation } { "effect" effect } }
|
||||
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
|
||||
|
||||
HELP: execute-effect
|
||||
{ $values { "word" word } { "effect" effect } }
|
||||
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
|
||||
|
||||
HELP: execute-effect-unsafe
|
||||
{ $values { "word" word } { "effect" effect } }
|
||||
{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
|
||||
{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ;
|
||||
|
||||
{ call-effect call-effect-unsafe execute-effect execute-effect-unsafe } related-words
|
||||
|
||||
HELP: cleave
|
||||
{ $values { "x" object } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } }
|
||||
{ $description "Applies each quotation to the object in turn." }
|
||||
|
|
|
@ -3,6 +3,38 @@ namespaces combinators words classes sequences accessors
|
|||
math.functions arrays ;
|
||||
IN: combinators.tests
|
||||
|
||||
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
|
||||
[ 1 2 [ + ] call( -- z ) ] must-fail
|
||||
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
|
||||
[ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
|
||||
[ [ + ] call( x y -- z ) ] must-infer
|
||||
|
||||
[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
|
||||
[ 1 2 \ + execute( -- z ) ] must-fail
|
||||
[ 1 2 \ + execute( x y -- z a ) ] must-fail
|
||||
[ \ + execute( x y -- z ) ] must-infer
|
||||
|
||||
: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
|
||||
|
||||
[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
|
||||
[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
|
||||
|
||||
: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
|
||||
|
||||
[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
|
||||
[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
|
||||
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
|
||||
[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
|
||||
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
|
||||
|
||||
: compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ;
|
||||
|
||||
[ t ] [ \ compile-call(-test-1 optimized>> ] unit-test
|
||||
[ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test
|
||||
[ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test
|
||||
[ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
|
||||
[ 4 ] [ 1 3 [ { + } [ ] like call ] compile-call(-test-1 ] unit-test
|
||||
|
||||
! Compiled
|
||||
: cond-test-1 ( obj -- str )
|
||||
{
|
||||
|
|
|
@ -1,10 +1,34 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! Copyright (C) 2006, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays sequences sequences.private math.private
|
||||
kernel kernel.private math assocs quotations vectors
|
||||
hashtables sorting words sets math.order make ;
|
||||
IN: combinators
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: call-effect-unsafe ( quot effect -- ) drop call ;
|
||||
|
||||
: execute-effect-unsafe ( word effect -- ) drop execute ;
|
||||
|
||||
M: object throw 5 getenv [ die ] or (( error -- * )) call-effect-unsafe ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: wrong-values effect ;
|
||||
|
||||
! We can't USE: effects here so we forward reference slots instead
|
||||
SLOT: in
|
||||
SLOT: out
|
||||
|
||||
: call-effect ( quot effect -- )
|
||||
[ [ datastack ] dip dip ] dip
|
||||
[ in>> length ] [ out>> length ] [ ] tri [ check-datastack ] dip
|
||||
[ wrong-values ] curry unless ;
|
||||
|
||||
: execute-effect ( word effect -- )
|
||||
[ [ execute ] curry ] dip call-effect ;
|
||||
|
||||
! cleave
|
||||
: cleave ( x seq -- )
|
||||
[ call ] with each ;
|
||||
|
|
|
@ -83,7 +83,6 @@ $nl
|
|||
{ $subsection with-return }
|
||||
"Reflecting the datastack:"
|
||||
{ $subsection with-datastack }
|
||||
{ $subsection assert-depth }
|
||||
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
|
||||
{ $subsection "continuations.private" } ;
|
||||
|
||||
|
@ -217,10 +216,6 @@ HELP: with-datastack
|
|||
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
|
||||
} ;
|
||||
|
||||
HELP: assert-depth
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Runs a quotation. Throws an error if the quotation attempts to take input values from the stack, or leave outputs on the stack." } ;
|
||||
|
||||
HELP: attempt-all
|
||||
{ $values
|
||||
{ "seq" sequence } { "quot" quotation }
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! Copyright (C) 2003, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays vectors kernel kernel.private sequences
|
||||
namespaces make math splitting sorting quotations assocs
|
||||
combinators accessors ;
|
||||
combinators combinators.private accessors ;
|
||||
IN: continuations
|
||||
|
||||
SYMBOL: error
|
||||
|
@ -73,7 +73,7 @@ C: <continuation> continuation
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: (continue) ( continuation -- )
|
||||
: (continue) ( continuation -- * )
|
||||
>continuation<
|
||||
set-catchstack
|
||||
set-namestack
|
||||
|
@ -81,19 +81,18 @@ C: <continuation> continuation
|
|||
[ set-datastack ] dip
|
||||
set-callstack ;
|
||||
|
||||
: (continue-with) ( obj continuation -- )
|
||||
swap 4 setenv
|
||||
>continuation<
|
||||
set-catchstack
|
||||
set-namestack
|
||||
set-retainstack
|
||||
[ set-datastack drop 4 getenv f 4 setenv f ] dip
|
||||
set-callstack ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: continue-with ( obj continuation -- * )
|
||||
[ (continue-with) ] 2 (throw) ;
|
||||
[
|
||||
swap 4 setenv
|
||||
>continuation<
|
||||
set-catchstack
|
||||
set-namestack
|
||||
set-retainstack
|
||||
[ set-datastack drop 4 getenv f 4 setenv f ] dip
|
||||
set-callstack
|
||||
] (( obj continuation -- * )) call-effect-unsafe ;
|
||||
|
||||
: continue ( continuation -- * )
|
||||
f swap continue-with ;
|
||||
|
@ -111,12 +110,9 @@ SYMBOL: return-continuation
|
|||
[
|
||||
[ [ { } like set-datastack ] dip call datastack ] dip
|
||||
continue-with
|
||||
] 3 (throw)
|
||||
] (( stack quot continuation -- * )) call-effect-unsafe
|
||||
] callcc1 2nip ;
|
||||
|
||||
: assert-depth ( quot -- )
|
||||
{ } swap with-datastack { } assert= ; inline
|
||||
|
||||
GENERIC: compute-restarts ( error -- seq )
|
||||
|
||||
<PRIVATE
|
||||
|
@ -133,7 +129,7 @@ SYMBOL: thread-error-hook
|
|||
dup save-error
|
||||
catchstack* empty? [
|
||||
thread-error-hook get-global
|
||||
[ 1 (throw) ] [ die ] if*
|
||||
[ (( error -- * )) call-effect-unsafe ] [ die ] if*
|
||||
] when
|
||||
c> continue-with ;
|
||||
|
||||
|
|
|
@ -63,3 +63,6 @@ M: effect clone
|
|||
|
||||
: shuffle ( stack shuffle -- newstack )
|
||||
shuffle-mapping swap nths ;
|
||||
|
||||
: add-effect-input ( effect -- effect' )
|
||||
[ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lexer sets sequences kernel splitting effects
|
||||
combinators arrays parser ;
|
||||
|
@ -26,3 +26,6 @@ ERROR: bad-effect ;
|
|||
: parse-effect ( end -- effect )
|
||||
parse-effect-tokens { "--" } split1 dup
|
||||
[ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
|
||||
|
||||
: parse-call( ( accum word -- accum )
|
||||
[ ")" parse-effect parsed ] dip parsed ;
|
|
@ -18,6 +18,6 @@ SYMBOL: current-method
|
|||
: with-method-definition ( method quot -- )
|
||||
over current-method set call current-method off ; inline
|
||||
|
||||
: (M:) ( method def -- )
|
||||
: (M:) ( -- method def )
|
||||
CREATE-METHOD [ parse-definition ] with-method-definition ;
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations continuations.private kernel
|
||||
kernel.private sequences assocs namespaces namespaces.private ;
|
||||
|
@ -9,10 +9,10 @@ SYMBOL: init-hooks
|
|||
init-hooks global [ drop V{ } clone ] cache drop
|
||||
|
||||
: do-init-hooks ( -- )
|
||||
init-hooks get [ nip call ] assoc-each ;
|
||||
init-hooks get [ nip call( -- ) ] assoc-each ;
|
||||
|
||||
: add-init-hook ( quot name -- )
|
||||
dup init-hooks get at [ over call ] unless
|
||||
dup init-hooks get at [ over call( -- ) ] unless
|
||||
init-hooks get set-at ;
|
||||
|
||||
: boot ( -- ) init-namespaces init-catchstack init-error-handler ;
|
||||
|
|
|
@ -39,7 +39,7 @@ M: object normalize-directory normalize-path ;
|
|||
|
||||
: set-io-backend ( io-backend -- )
|
||||
io-backend set-global init-io init-stdio
|
||||
"io.files" init-hooks get at call ;
|
||||
"io.files" init-hooks get at call( -- ) ;
|
||||
|
||||
! Note that we have 'alien' in our using list so that the alien
|
||||
! init hook runs before this one.
|
||||
|
|
|
@ -22,6 +22,8 @@ DEFER: 3dip
|
|||
! Combinators
|
||||
GENERIC: call ( callable -- )
|
||||
|
||||
GENERIC: execute ( word -- )
|
||||
|
||||
DEFER: if
|
||||
|
||||
: ? ( ? true false -- true/false )
|
||||
|
@ -235,7 +237,7 @@ GENERIC: boa ( ... class -- tuple )
|
|||
|
||||
! Error handling -- defined early so that other files can
|
||||
! throw errors before continuations are loaded
|
||||
: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
|
||||
GENERIC: throw ( error -- * )
|
||||
|
||||
ERROR: assert got expect ;
|
||||
|
||||
|
|
|
@ -402,9 +402,7 @@ IN: parser.tests
|
|||
[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
|
||||
] times
|
||||
|
||||
[ "vocab:parser/test/assert-depth.factor" run-file ]
|
||||
[ got>> { 1 2 3 } sequence= ]
|
||||
must-fail-with
|
||||
[ "vocab:parser/test/assert-depth.factor" run-file ] must-fail
|
||||
|
||||
2 [
|
||||
[ ] [
|
||||
|
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays definitions generic assocs kernel math namespaces
|
||||
sequences strings vectors words words.symbol quotations io
|
||||
combinators sorting splitting math.parser effects continuations
|
||||
io.files vocabs io.encodings.utf8 source-files
|
||||
classes hashtables compiler.errors compiler.units accessors sets
|
||||
lexer vocabs.parser slots ;
|
||||
sequences strings vectors words words.symbol quotations io combinators
|
||||
sorting splitting math.parser effects continuations io.files vocabs
|
||||
io.encodings.utf8 source-files classes hashtables compiler.errors
|
||||
compiler.units accessors sets lexer vocabs.parser slots ;
|
||||
IN: parser
|
||||
|
||||
: location ( -- loc )
|
||||
|
@ -90,9 +89,9 @@ SYMBOL: auto-use?
|
|||
|
||||
ERROR: staging-violation word ;
|
||||
|
||||
: execute-parsing ( word -- )
|
||||
: execute-parsing ( accum word -- accum )
|
||||
dup changed-definitions get key? [ staging-violation ] when
|
||||
execute ;
|
||||
execute( accum -- accum ) ;
|
||||
|
||||
: scan-object ( -- object )
|
||||
scan-word dup parsing-word?
|
||||
|
@ -125,7 +124,7 @@ M: f parse-quotation \ ] parse-until >quotation ;
|
|||
[ f parse-until >quotation ] with-lexer ;
|
||||
|
||||
: parse-lines ( lines -- quot )
|
||||
lexer-factory get call (parse-lines) ;
|
||||
lexer-factory get call( lines -- lexer ) (parse-lines) ;
|
||||
|
||||
: parse-literal ( accum end quot -- accum )
|
||||
[ parse-until ] dip call parsed ; inline
|
||||
|
@ -214,7 +213,7 @@ print-use-hook [ [ ] ] initialize
|
|||
[
|
||||
V{ } clone amended-use set
|
||||
parse-lines
|
||||
amended-use get empty? [ print-use-hook get call ] unless
|
||||
amended-use get empty? [ print-use-hook get call( -- ) ] unless
|
||||
] with-file-vocabs ;
|
||||
|
||||
: parsing-file ( file -- )
|
||||
|
@ -288,7 +287,7 @@ print-use-hook [ [ ] ] initialize
|
|||
] recover ;
|
||||
|
||||
: run-file ( file -- )
|
||||
[ parse-file call ] curry assert-depth ;
|
||||
parse-file call( -- ) ;
|
||||
|
||||
: ?run-file ( path -- )
|
||||
dup exists? [ run-file ] [ drop ] if ;
|
||||
|
|
|
@ -29,7 +29,7 @@ name>char-hook [
|
|||
: unicode-escape ( str -- ch str' )
|
||||
"{" ?head-slice [
|
||||
CHAR: } over index cut-slice
|
||||
[ >string name>char-hook get call ] dip
|
||||
[ >string name>char-hook get call( name -- char ) ] dip
|
||||
rest-slice
|
||||
] [
|
||||
6 cut-slice [ hex> ] dip
|
||||
|
@ -45,10 +45,10 @@ name>char-hook [
|
|||
: (parse-string) ( str -- m )
|
||||
dup [ "\"\\" member? ] find dup [
|
||||
[ cut-slice [ % ] dip rest-slice ] dip
|
||||
dup CHAR: " = [
|
||||
drop from>>
|
||||
CHAR: " = [
|
||||
from>>
|
||||
] [
|
||||
drop next-escape [ , ] dip (parse-string)
|
||||
next-escape [ , ] dip (parse-string)
|
||||
] if
|
||||
] [
|
||||
"Unterminated string" throw
|
||||
|
@ -59,8 +59,8 @@ name>char-hook [
|
|||
[ swap tail-slice (parse-string) ] "" make swap
|
||||
] change-lexer-column ;
|
||||
|
||||
: (unescape-string) ( str -- str' )
|
||||
dup [ CHAR: \\ = ] find [
|
||||
: (unescape-string) ( str -- )
|
||||
CHAR: \\ over index dup [
|
||||
cut-slice [ % ] dip rest-slice
|
||||
next-escape [ , ] dip
|
||||
(unescape-string)
|
||||
|
|
|
@ -770,3 +770,13 @@ HELP: call-next-method
|
|||
{ POSTPONE: call-next-method (call-next-method) next-method } related-words
|
||||
|
||||
{ POSTPONE: << POSTPONE: >> } related-words
|
||||
|
||||
HELP: call(
|
||||
{ $syntax "call( stack -- effect )" }
|
||||
{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
|
||||
|
||||
HELP: execute(
|
||||
{ $syntax "execute( stack -- effect )" }
|
||||
{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
|
||||
|
||||
{ POSTPONE: call( POSTPONE: execute( } related-words
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue