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

db4
Daniel Ehrenberg 2009-03-18 18:12:18 -05:00
commit 4aec9d2c46
129 changed files with 655 additions and 575 deletions

View File

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

View File

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

View File

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

View File

@ -1,2 +0,0 @@
Daniel Ehrenberg
Slava Pestov

View File

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

View File

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

View File

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

View File

@ -1 +0,0 @@
Calling arbitrary quotations and executing arbitrary words with a static stack effect

View File

@ -1 +0,0 @@
extensions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -0,0 +1 @@
Slava Pestov

View File

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

View File

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

View File

@ -0,0 +1 @@
Slava Pestov

View File

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

View File

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

View File

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

View File

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

View File

@ -1 +1,2 @@
Slava Pestov
Daniel Ehrenberg

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -23,7 +23,7 @@ SYMBOL: this-test
[ this-test get failure ] recover
] [
call
] if ;
] if ; inline
: unit-test ( output input -- )
[ 2array ] 2keep '[

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -78,6 +78,8 @@ IN: bootstrap.syntax
"call-next-method"
"initial:"
"read-only"
"call("
"execute("
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol

View File

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

View File

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

View File

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

View File

@ -1 +1,2 @@
Slava Pestov
Daniel Ehrenberg

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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