.#*
*.swo
checksums.txt
+*.so
+a.out
"} cond >>"
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
+
+ARTICLE: "loading-libs" "Loading native libraries"
+"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
+{ $subsection add-library }
+"Once a library has been defined, you can try loading it to see if the path name is correct:"
+{ $subsection load-library }
+"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals ;
+parser sequences splitting words fry locals lexer namespaces ;
IN: alien.parser
: parse-arglist ( parameters return -- types effect )
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
-:: define-function ( return library function parameters -- )
+:: make-function ( return library function parameters -- word quot effect )
function create-in dup reset-generic
return library function
- parameters return parse-arglist [ function-quot ] dip
- define-declared ;
+ parameters return parse-arglist [ function-quot ] dip ;
+
+: (FUNCTION:) ( -- word quot effect )
+ scan "c-library" get scan ";" parse-tokens
+ [ "()" subseq? not ] filter
+ make-function ;
+
+: define-function ( return library function parameters -- )
+ make-function define-declared ;
SYNTAX: LIBRARY: scan "c-library" set ;
SYNTAX: FUNCTION:
- scan "c-library" get scan ";" parse-tokens
- [ "()" subseq? not ] filter
- define-function ;
+ (FUNCTION:) define-declared ;
SYNTAX: TYPEDEF:
scan scan typedef ;
(command-line) parse-command-line
load-vocab-roots
run-user-init
- "e" get [ eval ] when*
+ "e" get [ eval( -- ) ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
kernel.private math memory continuations kernel io.files
io.pathnames io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings
-definitions assocs compiler.errors compiler.units math.parser
+definitions assocs compiler.units math.parser
generic sets command-line ;
IN: bootstrap.stage2
"none" require
] if
- [
- load-components
+ load-components
- millis over - core-bootstrap-time set-global
+ millis over - core-bootstrap-time set-global
- run-bootstrap-init
- ] with-compiler-errors
- :errors
+ run-bootstrap-init
f error set-global
f error-continuation set-global
"bootstrap.image"
"tools.annotations"
"tools.crossref"
+ "tools.errors"
"tools.deploy"
"tools.disassembler"
"tools.memory"
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex sets libc alien.libraries
continuations.private fry cpu.architecture
+source-files.errors
compiler.errors
compiler.alien
compiler.cfg
M: no-such-library summary
drop "Library not found" ;
-M: no-such-library compiler-error-type
- drop +linkage+ ;
+M: no-such-library error-type drop +linkage-error+ ;
: no-such-library ( name -- )
\ no-such-library boa
M: no-such-symbol summary
drop "Symbol not found" ;
-M: no-such-symbol compiler-error-type
- drop +linkage+ ;
+M: no-such-symbol error-type drop +linkage-error+ ;
: no-such-symbol ( name -- )
\ no-such-symbol boa
-USING: help.markup help.syntax words io parser
-assocs words.private sequences compiler.units quotations ;
+USING: assocs compiler.cfg.builder compiler.cfg.optimizer
+compiler.errors compiler.tree.builder compiler.tree.optimizer
+compiler.units help.markup help.syntax io parser quotations
+sequences words words.private ;
IN: compiler
HELP: enable-compiler
{ $subsection compile-call }
"Higher-level words can be found in " { $link "compilation-units" } "." ;
+ARTICLE: "compiler-impl" "Compiler implementation"
+"The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop."
+$nl
+"Words are added to the " { $link compile-queue } " variable as needed and compiled."
+{ $subsection compile-queue }
+"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
+$nl
+"The " { $link (compile) } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
+{ $list
+ { "The " { $link frontend } " word calls " { $link build-tree-from-word } ". If this fails, the error is passed to " { $link fail } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
+ { "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
+ { "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
+ { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link maybe-compile } "." }
+}
+"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
+$nl
+"Calling " { $link modify-code-heap } " is handled not by the " { $vocab-link "compiler" } " vocabulary, but rather " { $vocab-link "compiler.units" } ". The optimizing compiler merely provides an implementation of the " { $link recompile } " generic word." ;
+
ARTICLE: "compiler" "Optimizing compiler"
"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
$nl
"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
{ $subsection "compiler-errors" }
{ $subsection "hints" }
-{ $subsection "compiler-usage" } ;
+{ $subsection "compiler-usage" }
+{ $subsection "compiler-impl" } ;
ABOUT: "compiler"
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io stack-checker
+combinators deques search-deques macros io source-files.errors stack-checker
stack-checker.state stack-checker.inlining combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
f swap compiler-error ;
: ignore-error? ( word error -- ? )
- [ [ inline? ] [ macro? ] bi or ]
- [ compiler-error-type +warning+ eq? ] bi* and ;
-
-: fail ( word error -- * )
- [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
[
- drop
- [ compiled-unxref ]
- [ f swap compiled get set-at ]
- [ +unoptimized+ save-compiled-status ]
- tri
- ] 2bi
+ {
+ [ inline? ]
+ [ macro? ]
+ [ "transform-quot" word-prop ]
+ [ "no-compile" word-prop ]
+ [ "special" word-prop ]
+ } 1||
+ ] [ error-type +compiler-warning+ eq? ] bi* and ;
+
+: (fail) ( word -- * )
+ [ compiled-unxref ]
+ [ f swap compiled get set-at ]
+ [ +unoptimized+ save-compiled-status ]
+ tri
return ;
+: fail ( word error -- * )
+ [ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ;
+
: frontend ( word -- nodes )
- [ build-tree-from-word ] [ fail ] recover optimize-tree ;
+ dup contains-breakpoints? [ (fail) ] [
+ [ build-tree-from-word ] [ fail ] recover optimize-tree
+ ] if ;
! Only switch this off for debugging.
SYMBOL: compile-dependencies?
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
+\ compile-call t "no-compile" set-word-prop
+
SINGLETON: optimizing-compiler
M: optimizing-compiler recompile ( words -- alist )
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: compiler.errors
+USING: help.markup help.syntax vocabs.loader words io
+quotations words.symbol ;
+
+ABOUT: "compiler-errors"
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors source-files.errors kernel namespaces assocs ;
+IN: compiler.errors
+
+TUPLE: compiler-error < source-file-error ;
+
+M: compiler-error error-type error>> error-type ;
+
+SYMBOL: compiler-errors
+
+compiler-errors [ H{ } clone ] initialize
+
+SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ;
+
+: errors-of-type ( type -- assoc )
+ compiler-errors get-global
+ swap [ [ nip error-type ] dip eq? ] curry
+ assoc-filter ;
+
+T{ error-type
+ { type +compiler-error+ }
+ { word ":errors" }
+ { plural "compiler errors" }
+ { icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" }
+ { quot [ +compiler-error+ errors-of-type values ] }
+ { forget-quot [ compiler-errors get delete-at ] }
+} define-error-type
+
+T{ error-type
+ { type +compiler-warning+ }
+ { word ":warnings" }
+ { plural "compiler warnings" }
+ { icon "vocab:ui/tools/error-list/icons/compiler-warning.tiff" }
+ { quot [ +compiler-warning+ errors-of-type values ] }
+ { forget-quot [ compiler-errors get delete-at ] }
+} define-error-type
+
+T{ error-type
+ { type +linkage-error+ }
+ { word ":linkage" }
+ { plural "linkage errors" }
+ { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
+ { quot [ +linkage-error+ errors-of-type values ] }
+ { forget-quot [ compiler-errors get delete-at ] }
+ { fatal? f }
+} define-error-type
+
+: <compiler-error> ( error word -- compiler-error )
+ \ compiler-error <definition-error> ;
+
+: compiler-error ( error word -- )
+ compiler-errors get-global pick
+ [ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
--- /dev/null
+Compiler warning and error reporting
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USING: math arrays ;
IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ t ] [
[ 6 ] [ method-redefine-test-1 ] unit-test
-[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
[ 6 ] [ method-redefine-test-2 ] unit-test
-[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test
[ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test
-[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
+[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there optimized>> ] unit-test
-[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
+[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ;
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
-[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
+[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad optimized>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
-[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
+[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
TUPLE: jeah ;
-[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
+[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test
[ f ] [ T{ jeah } h ] unit-test
DEFER: redefine2-test
-[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
+[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
-[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
-[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ;
: my-inline ( a -- b ) my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
IN: compiler.tests.redefine5
TUPLE: my-tuple ;
M: my-tuple my-generic drop 0 ;
- "> eval
+ "> eval( -- )
] unit-test
[ 0 ] [
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 1 ] [
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USE: math
IN: compiler.tests.redefine7
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USE: math
IN: compiler.tests.redefine8
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
- "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
+ "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
] unit-test
] times
: check-cannot-infer ( word -- )
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
+TUPLE: do-not-compile word ;
+
: check-no-compile ( word -- )
- dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
+ dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
: build-tree-from-word ( word -- nodes )
[
} cleave
] maybe-cannot-infer
] with-tree-builder ;
+
+: contains-breakpoints? ( word -- ? )
+ def>> [ word? ] filter [ "break?" word-prop ] any? ;
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] if ; inline recursive
-: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline
+: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
[ f ] [
[ { bignum } declare annotate-entry-test-2 ]
] unit-test
[ t ] [
- [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+ [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )
[ t ] [
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
-] unit-test
\ No newline at end of file
+] unit-test
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
-: foo ( -- ) swap ; inline recursive
+: foo ( quot: ( -- ) -- ) call ; inline recursive
: recursive-inputs ( nodes -- n )
[ #recursive? ] find nip child>> first in-d>> length ;
-[ 0 2 ] [
- [ foo ] build-tree
+[ 1 3 ] [
+ [ [ swap ] foo ] build-tree
[ recursive-inputs ]
[ analyze-recursive normalize recursive-inputs ] bi
] unit-test
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb
-: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
-: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
+: aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
+: bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive
[ ] [ [ bbb ] test-normalization ] unit-test
-: ccc ( -- ) ccc drop 1 ; inline recursive
+: ccc ( obj -- 1 ) ccc drop 1 ; inline recursive
[ ] [ [ ccc ] test-normalization ] unit-test
DEFER: eee
-: ddd ( -- ) eee ; inline recursive
-: eee ( -- ) swap ddd ; inline recursive
+: ddd ( a b -- a b ) eee ; inline recursive
+: eee ( a b -- a b ) swap ddd ; inline recursive
[ ] [ [ eee ] test-normalization ] unit-test
] sum-outputs ;
: should-inline? ( #call word -- ? )
- dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
+ {
+ { [ dup contains-breakpoints? ] [ 2drop f ] }
+ { [ dup "inline" word-prop ] [ 2drop t ] }
+ [ inlining-rank 5 >= ]
+ } cond ;
SYMBOL: history
: (littledan-3-test) ( x -- )
length 1+ f <array> (littledan-3-test) ; inline recursive
-: littledan-3-test ( x -- )
+: littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
-[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
\ No newline at end of file
+[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
\ (each-integer) label-is-loop?
] unit-test
-: loop-test-2 ( a -- )
+: loop-test-2 ( a b -- a' )
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
[ t ] [
concurrency.count-downs concurrency.promises locals kernel\r
threads ;\r
\r
-:: exchanger-test ( -- )\r
+:: exchanger-test ( -- string )\r
[let |\r
ex [ <exchanger> ]\r
c [ 2 <count-down> ]\r
\r
[ f ] [ flag-test-1 ] unit-test\r
\r
-:: flag-test-2 ( -- )\r
+:: flag-test-2 ( -- ? )\r
[let | f [ <flag> ] |\r
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
f lower-flag\r
HELP: promise\r
{ $class-description "The class of write-once promises." } ;\r
\r
+HELP: <promise>\r
+{ $values { "promise" promise } }\r
+{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;\r
+\r
HELP: promise-fulfilled?\r
{ $values { "promise" promise } { "?" "a boolean" } }\r
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;\r
4 ds-reg 0 LWZ\r
5 ds-reg -4 LWZU\r
5 0 4 CMP\r
- 2 swap execute ! magic number\r
+ 2 swap execute( offset -- ) ! magic number\r
\ f tag-number 3 LI\r
3 ds-reg 0 STW ;\r
\r
: jit-math ( insn -- )\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZU\r
- [ 5 3 4 ] dip execute\r
+ [ 5 3 4 ] dip execute( dst src1 src2 -- )\r
5 ds-reg 0 STW ;\r
\r
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive\r
! compare with second value
ds-reg [] temp0 CMP
! move t if true
- [ temp1 temp3 ] dip execute
+ [ temp1 temp3 ] dip execute( dst src -- )
! store
ds-reg [] temp1 MOV ;
! pop stack
ds-reg bootstrap-cell SUB
! compute result
- [ ds-reg [] temp0 ] dip execute ;
+ [ ds-reg [] temp0 ] dip execute( dst src -- ) ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
combinators generic.math classes.builtin classes compiler.units
generic.standard vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
-classes.tuple.parser effects.parser lexer compiler.errors
-generic.parser strings.parser vocabs.loader vocabs.parser ;
+classes.tuple.parser effects.parser lexer
+generic.parser strings.parser vocabs.loader vocabs.parser see
+source-files.errors ;
IN: debugger
GENERIC: error. ( error -- )
M: assert summary drop "Assertion failed" ;
-M: assert error.
- "Assertion failed" print
+M: assert-sequence summary drop "Assertion failed" ;
+
+M: assert-sequence error.
standard-table-style [
- 15 length-limit set
- 5 line-limit set
- [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
- [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
- ] tabular-output nl ;
+ [ "=== Expected:" print expected>> stack. ]
+ [ "=== Got:" print got>> stack. ] bi
+ ] tabular-output ;
M: immutable summary drop "Sequence is immutable" ;
M: invalid-slot-name summary
drop "Invalid slot name" ;
-: file. ( file -- ) path>> <pathname> . ;
-
-M: source-file-error error.
- [ file>> file. ] [ error>> error. ] bi ;
-
-M: source-file-error summary
- error>> summary ;
-
-M: source-file-error compute-restarts
- error>> compute-restarts ;
-
-M: source-file-error error-help
- error>> error-help ;
-
M: not-in-a-method-error summary
drop "call-next-method can only be called in a method definition" ;
M: lexer-error error-help
error>> error-help ;
-M: object compiler-error. ( error word -- )
- nl
- "While compiling " write pprint ": " print
- nl
- print-error ;
-
M: bad-effect summary
drop "Bad stack effect declaration" ;
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
-[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
+[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test
[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
-[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
[ f ] [ hey \ two method ] unit-test
[ f ] [ hey \ four method ] unit-test
-[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ 0 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test
[ 0 ] [ 1 <hey> four ] unit-test
-[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test
+[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ -1 ] [ 1 <hey> two ] unit-test
[ -1 ] [ 1 <hey> three ] unit-test
[ -1 ] [ 1 <hey> four ] unit-test
-[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
+[ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
[ f ] [ hey \ one method ] unit-test
TUPLE: slot-protocol-test-1 a b ;
seq-delegate
sequence-protocol \ protocol-consult word-prop
key?
-] unit-test
\ No newline at end of file
+] unit-test
-USING: help.markup help.syntax parser source-files vocabs.loader ;
+USING: help.markup help.syntax parser source-files
+source-files.errors vocabs.loader ;
IN: editors
ARTICLE: "editor" "Editor integration"
ABOUT: "editor"
+HELP: edit-hook
+{ $var-description "A quotation with stack effect " { $snippet "( file line -- )" } ". If not set, the " { $link edit } " word throws a condition with restarts for loading one of the sub-vocabularies of the " { $vocab-link "editors" } " vocabulary." } ;
+
HELP: edit
{ $values { "defspec" "a definition specifier" } }
{ $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." }
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer kernel namespaces sequences definitions
-io.files io.backend io.pathnames io summary continuations
-tools.crossref tools.vocabs prettyprint source-files assocs
+USING: parser lexer kernel namespaces sequences definitions io.files
+io.backend io.pathnames io summary continuations tools.crossref
+tools.vocabs prettyprint source-files source-files.errors assocs
vocabs vocabs.loader splitting accessors debugger prettyprint
help.topics ;
IN: editors
[ error>> error-line ] [ line>> ] bi or ;
M: source-file-error error-file
- [ error>> error-file ] [ file>> path>> ] bi or ;
+ [ error>> error-file ] [ file>> ] bi or ;
M: source-file-error error-line
error>> error-line ;
: :edit ( -- )
error get (:edit) ;
+: edit-error ( error -- )
+ [ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
+
: edit-each ( seq -- )
[
[ "Editing " write . ]
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: editors io.launcher kernel make math.parser namespaces
+sequences ;
+IN: editors.gedit
+
+: gedit-path ( -- path )
+ \ gedit-path get-global [
+ "gedit"
+ ] unless* ;
+
+: gedit ( file line -- )
+ [
+ gedit-path , number>string "+" prepend , ,
+ ] { } make run-detached drop ;
+
+[ gedit ] edit-hook set-global
--- /dev/null
+gedit integration
--- /dev/null
+unportable
IN: eval
-USING: help.markup help.syntax strings io ;
+USING: help.markup help.syntax strings io effects ;
HELP: eval
-{ $values { "str" string } }
-{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
+{ $values { "str" string } { "effect" effect } }
+{ $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." }
+{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
+
+HELP: eval(
+{ $syntax "eval( inputs -- outputs )" }
+{ $description "Parses Factor source code from the string at the top of the stack, and calls the resulting quotation, which must have the given stack effect." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
HELP: eval>string
{ $values { "str" string } { "output" string } }
-{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
+{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } ;
ARTICLE: "eval" "Evaluating strings at runtime"
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
-{ $subsection eval }
+{ $subsection POSTPONE: eval( }
{ $subsection eval>string } ;
ABOUT: "eval"
IN: eval.tests
USING: eval tools.test ;
+[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
+[ "USE: math 2 2 +" eval( -- ) ] must-fail
[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: splitting parser compiler.units kernel namespaces
-debugger io.streams.string fry ;
+debugger io.streams.string fry combinators effects.parser ;
IN: eval
: parse-string ( str -- quot )
[ string-lines parse-lines ] with-compilation-unit ;
-: (eval) ( str -- )
- parse-string call ;
+: (eval) ( str effect -- )
+ [ parse-string ] dip call-effect ; inline
-: eval ( str -- )
- [ (eval) ] with-file-vocabs ;
+: eval ( str effect -- )
+ [ (eval) ] with-file-vocabs ; inline
+
+SYNTAX: eval( \ eval parse-call( ;
: (eval>string) ( str -- output )
[
"quiet" on
parser-notes off
- '[ _ (eval) ] try
+ '[ _ (( -- )) (eval) ] try
] with-string-writer ;
: eval>string ( str -- output )
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
-[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ]
+[ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
"x" [ 1+ ] schange\r
"x" sget number>string "text/html" <content> ;\r
\r
-: url-responder-mock-test ( -- )\r
+: url-responder-mock-test ( -- string )\r
[\r
<request>\r
"GET" >>method\r
[ write-response-body drop ] with-string-writer\r
] with-destructors ;\r
\r
-: sessions-mock-test ( -- )\r
+: sessions-mock-test ( -- string )\r
[\r
<request>\r
"GET" >>method\r
\r
HELP: n*quot\r
{ $values\r
- { "n" integer } { "seq" sequence }\r
- { "seq'" sequence }\r
+ { "n" integer } { "quot" quotation }\r
+ { "quot'" quotation }\r
}\r
{ $examples\r
{ $example "USING: generalizations prettyprint math ;"\r
<<
-: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
+: n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
: repeat ( n obj quot -- ) swapd times ; inline
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
-: nappend ( n -- seq ) narray concat ; inline
\ No newline at end of file
+: nappend ( n -- seq ) narray concat ; inline
[ t ] [ 1 2 { 1 2 } 2= ] unit-test
[ f ] [ 1 3 { 1 2 } 2= ] unit-test
-: sample-hash ( -- )
+: sample-hash ( -- hash )
5 <hash2>
- dup 2 3 "foo" roll set-hash2
- dup 4 2 "bar" roll set-hash2
- dup 4 7 "other" roll set-hash2 ;
+ [ [ 2 3 "foo" ] dip set-hash2 ] keep
+ [ [ 4 2 "bar" ] dip set-hash2 ] keep
+ [ [ 4 7 "other" ] dip set-hash2 ] keep ;
[ "foo" ] [ 2 3 sample-hash hash2 ] unit-test
[ "bar" ] [ 4 2 sample-hash hash2 ] unit-test
-USING: kernel sequences arrays math vectors ;
+! Copyright (C) 2007 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences arrays math vectors locals ;
IN: hash2
! Little ad-hoc datastructure used to map two numbers
: assoc2 ( a b alist -- value )
(assoc2) dup [ third ] when ; inline
-: set-assoc2 ( value a b alist -- alist )
- [ rot 3array ] dip ?push ; inline
+:: set-assoc2 ( value a b alist -- alist )
+ { a b value } alist ?push ; inline
: hash2@ ( a b hash2 -- a b bucket hash2 )
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
: hash2 ( a b hash2 -- value/f )
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
-: set-hash2 ( a b value hash2 -- )
- [ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
+:: set-hash2 ( a b value hash2 -- )
+ value a b hash2 hash2@ [ set-assoc2 ] change-nth ;
: alist>hash2 ( alist size -- hash2 )
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline
: sort-entries ( entries -- entries' )
[ [ key>> ] compare ] sort ;
-: delete-test ( n -- ? )
+: delete-test ( n -- obj1 obj2 )
[
random-alist
<min-heap> [ heap-push-all ] keep
"shuffle-words"
"words"
"generic"
- "tools"
+ "handbook-tools-reference"
} ;
ARTICLE: "cookbook-combinators" "Control flow cookbook"
io.streams.string continuations debugger compiler.units eval ;
[ ] [
- "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
+ "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
] unit-test
[ $subsection ] [
] unit-test
[ ] [
- "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
+ "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- )
] unit-test
[ ] [
"hello" "help.definitions.tests" lookup "help" word-prop
] unit-test
- [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test
+ [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval( -- ) ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
io.streams.byte-array classes.builtin parser lexer
classes.predicate classes.union classes.intersection
classes.singleton classes.tuple help.vocabs math.parser
-accessors definitions ;
+accessors definitions sets ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
{ $subsection "io.ports" }
{ $see-also "destructors" } ;
-ARTICLE: "tools" "Developer tools"
-{ $subsection "tools.vocabs" }
-"Exploratory tools:"
-{ $subsection "see" }
-{ $subsection "editor" }
-{ $subsection "listener" }
-{ $subsection "tools.crossref" }
-{ $subsection "inspector" }
-{ $subsection "tools.completion" }
-{ $subsection "summary" }
-"Debugging tools:"
-{ $subsection "tools.annotations" }
-{ $subsection "tools.test" }
-{ $subsection "tools.threads" }
-"Performance tools:"
-{ $subsection "tools.memory" }
-{ $subsection "profiling" }
-{ $subsection "timing" }
-{ $subsection "tools.disassembler" }
-"Deployment tools:"
-{ $subsection "tools.deploy" }
-{ $see-also "ui-tools" } ;
-
ARTICLE: "article-index" "Article index"
{ $index [ articles get keys ] } ;
USING: help.cookbook help.tutorial ;
-ARTICLE: "handbook-language-reference" "Language reference"
-"Fundamentals:"
+ARTICLE: "handbook-language-reference" "The language"
+{ $heading "Fundamentals" }
{ $subsection "conventions" }
{ $subsection "syntax" }
{ $subsection "effects" }
-"Data types:"
+{ $subsection "evaluator" }
+{ $heading "Data types" }
{ $subsection "booleans" }
{ $subsection "numbers" }
{ $subsection "collections" }
-"Evaluation semantics:"
-{ $subsection "evaluator" }
+{ $heading "Evaluation" }
{ $subsection "words" }
{ $subsection "shuffle-words" }
{ $subsection "combinators" }
{ $subsection "errors" }
{ $subsection "continuations" }
-"Named values:"
+{ $heading "Named values" }
{ $subsection "locals" }
{ $subsection "namespaces" }
{ $subsection "namespaces-global" }
{ $subsection "values" }
-"Abstractions:"
+{ $heading "Abstractions" }
{ $subsection "objects" }
{ $subsection "destructors" }
{ $subsection "macros" }
{ $subsection "fry" }
-"Program organization:"
+{ $heading "Program organization" }
{ $subsection "vocabs.loader" }
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
-ARTICLE: "handbook-environment-reference" "Environment reference"
-"Parse time and compile time:"
+ARTICLE: "handbook-system-reference" "The implementation"
+{ $heading "Parse time and compile time" }
{ $subsection "parser" }
{ $subsection "definitions" }
{ $subsection "vocabularies" }
{ $subsection "source-files" }
{ $subsection "compiler" }
-"Tools:"
-{ $subsection "prettyprint" }
-{ $subsection "tools" }
-{ $subsection "help" }
-{ $subsection "inference" }
+{ $heading "Virtual machine" }
{ $subsection "images" }
-"VM:"
{ $subsection "cli" }
{ $subsection "rc-files" }
{ $subsection "init" }
{ $subsection "system" }
{ $subsection "layouts" } ;
-ARTICLE: "handbook-library-reference" "Library reference"
-"This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "."
-{ $index [ "handbook" orphan-articles remove ] } ;
+ARTICLE: "handbook-tools-reference" "Developer tools"
+"The below tools are text-based. " { $link "ui-tools" } " are documented separately."
+{ $heading "Workflow" }
+{ $subsection "listener" }
+{ $subsection "editor" }
+{ $subsection "tools.vocabs" }
+{ $subsection "tools.test" }
+{ $subsection "help" }
+{ $heading "Debugging" }
+{ $subsection "prettyprint" }
+{ $subsection "inspector" }
+{ $subsection "tools.annotations" }
+{ $subsection "inference" }
+{ $heading "Browsing" }
+{ $subsection "see" }
+{ $subsection "tools.crossref" }
+{ $heading "Performance" }
+{ $subsection "timing" }
+{ $subsection "profiling" }
+{ $subsection "tools.memory" }
+{ $subsection "tools.threads" }
+{ $subsection "tools.disassembler" }
+{ $heading "Deployment" }
+{ $subsection "tools.deploy" } ;
+
+ARTICLE: "handbook-library-reference" "Libraries"
+"This index lists articles from loaded vocabularies which are not subsections of any other article. To explore more vocabularies, see " { $link "vocab-index" } "."
+{ $index [ orphan-articles { "help.home" "handbook" } diff ] } ;
ARTICLE: "handbook" "Factor handbook"
"Learn the language:"
{ $subsection "first-program" }
"Reference material:"
{ $subsection "handbook-language-reference" }
-{ $subsection "handbook-environment-reference" }
{ $subsection "io" }
{ $subsection "ui" }
+{ $subsection "handbook-system-reference" }
+{ $subsection "handbook-tools-reference" }
{ $subsection "ui-tools" }
-{ $subsection "unicode" }
{ $subsection "alien" }
{ $subsection "handbook-library-reference" }
"Explore loaded libraries:"
{ $link "handbook" }
{ $link "vocab-index" }
{ $link "ui-tools" }
+ { $link "ui-listener" }
}
{ $heading "Recently visited" }
{ $table
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes combinators
+combinators.short-circuit definitions effects eval fry grouping
+help help.markup help.topics io.streams.string kernel macros
+namespaces sequences sequences.deep sets sorting splitting
+strings unicode.categories values vocabs vocabs.loader words
+words.symbol summary debugger io ;
+IN: help.lint.checks
+
+ERROR: simple-lint-error message ;
+
+M: simple-lint-error summary message>> ;
+
+M: simple-lint-error error. summary print ;
+
+SYMBOL: vocabs-quot
+SYMBOL: all-vocabs
+SYMBOL: vocab-articles
+
+: check-example ( element -- )
+ '[
+ _ rest [
+ but-last "\n" join
+ [ (eval>string) ] call( code -- output )
+ "\n" ?tail drop
+ ] keep
+ peek assert=
+ ] vocabs-quot get call( quot -- ) ;
+
+: check-examples ( element -- )
+ \ $example swap elements [ check-example ] each ;
+
+: extract-values ( element -- seq )
+ \ $values swap elements dup empty? [
+ first rest [ first ] map prune natural-sort
+ ] unless ;
+
+: effect-values ( word -- seq )
+ stack-effect
+ [ in>> ] [ out>> ] bi append
+ [ dup pair? [ first ] when effect>string ] map
+ prune natural-sort ;
+
+: contains-funky-elements? ( element -- ? )
+ {
+ $shuffle
+ $values-x/y
+ $predicate
+ $class-description
+ $error-description
+ } swap '[ _ elements empty? not ] any? ;
+
+: don't-check-word? ( word -- ? )
+ {
+ [ macro? ]
+ [ symbol? ]
+ [ value-word? ]
+ [ parsing-word? ]
+ [ "declared-effect" word-prop not ]
+ } 1|| ;
+
+: check-values ( word element -- )
+ {
+ [
+ [ don't-check-word? ]
+ [ contains-funky-elements? ]
+ bi* or
+ ] [
+ [ effect-values ]
+ [ extract-values ]
+ bi* sequence=
+ ]
+ } 2|| [ "$values don't match stack effect" simple-lint-error ] unless ;
+
+: check-nulls ( element -- )
+ \ $values swap elements
+ null swap deep-member?
+ [ "$values should not contain null" simple-lint-error ] when ;
+
+: check-see-also ( element -- )
+ \ $see-also swap elements [
+ rest dup prune [ length ] bi@ assert=
+ ] each ;
+
+: vocab-exists? ( name -- ? )
+ [ vocab ] [ all-vocabs get member? ] bi or ;
+
+: check-modules ( element -- )
+ \ $vocab-link swap elements [
+ second
+ vocab-exists? [
+ "$vocab-link to non-existent vocabulary"
+ simple-lint-error
+ ] unless
+ ] each ;
+
+: check-rendering ( element -- )
+ [ print-content ] with-string-writer drop ;
+
+: check-strings ( str -- )
+ [
+ "\n\t" intersects? [
+ "Paragraph text should not contain \\n or \\t"
+ simple-lint-error
+ ] when
+ ] [
+ " " swap subseq? [
+ "Paragraph text should not contain double spaces"
+ simple-lint-error
+ ] when
+ ] bi ;
+
+: check-whitespace ( str1 str2 -- )
+ [ " " tail? ] [ " " head? ] bi* or
+ [ "Missing whitespace between strings" simple-lint-error ] unless ;
+
+: check-bogus-nl ( element -- )
+ { { $nl } { { $nl } } } [ head? ] with any? [
+ "Simple element should not begin with a paragraph break"
+ simple-lint-error
+ ] when ;
+
+: check-class-description ( word element -- )
+ [ class? not ]
+ [ { $class-description } swap elements empty? not ] bi* and
+ [ "A word that is not a class has a $class-description" simple-lint-error ] when ;
+
+: check-article-title ( article -- )
+ article-title first LETTER?
+ [ "Article title must begin with a capital letter" simple-lint-error ] unless ;
+
+: check-elements ( element -- )
+ {
+ [ check-bogus-nl ]
+ [ [ string? ] filter [ check-strings ] each ]
+ [ [ simple-element? ] filter [ check-elements ] each ]
+ [ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
+ } cleave ;
+
+: check-descriptions ( element -- )
+ { $description $class-description $var-description }
+ swap '[
+ _ elements [
+ rest { { } { "" } } member?
+ [ "Empty description" throw ] when
+ ] each
+ ] each ;
+
+: check-markup ( element -- )
+ {
+ [ check-elements ]
+ [ check-rendering ]
+ [ check-examples ]
+ [ check-modules ]
+ [ check-descriptions ]
+ } cleave ;
+
+: files>vocabs ( -- assoc )
+ vocabs
+ [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
+ [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
+ bi assoc-union ;
+
+: group-articles ( -- assoc )
+ articles get keys
+ files>vocabs
+ H{ } clone [
+ '[
+ dup >link where dup
+ [ first _ at _ push-at ] [ 2drop ] if
+ ] each
+ ] keep ;
+
+: all-word-help ( words -- seq )
+ [ word-help ] filter ;
"To run help lint, use one of the following two words:"
{ $subsection help-lint }
{ $subsection help-lint-all }
+"Once a help lint run completes, failures can be listed:"
+{ $subsection :lint-failures }
+"Help lint failures are also shown in the " { $link "ui.tools.error-list" } "."
+$nl
"Help lint performs the following checks:"
{ $list
"ensures examples run and produce stated output"
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors sequences parser kernel help help.markup
-help.topics words strings classes tools.vocabs namespaces make
-io io.streams.string prettyprint definitions arrays vectors
-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 ;
+USING: assocs continuations fry help help.lint.checks
+help.topics io kernel namespaces parser sequences
+source-files.errors tools.vocabs vocabs words classes
+locals tools.errors ;
+FROM: help.lint.checks => all-vocabs ;
IN: help.lint
-SYMBOL: vocabs-quot
-
-: check-example ( element -- )
- '[
- _ rest [
- but-last "\n" join
- [ (eval>string) ] call( code -- output )
- "\n" ?tail drop
- ] keep
- peek assert=
- ] vocabs-quot get call( quot -- ) ;
-
-: check-examples ( element -- )
- \ $example swap elements [ check-example ] each ;
-
-: extract-values ( element -- seq )
- \ $values swap elements dup empty? [
- first rest [ first ] map prune natural-sort
- ] unless ;
-
-: effect-values ( word -- seq )
- stack-effect
- [ in>> ] [ out>> ] bi append
- [ dup pair? [ first ] when effect>string ] map
- prune natural-sort ;
-
-: contains-funky-elements? ( element -- ? )
- {
- $shuffle
- $values-x/y
- $predicate
- $class-description
- $error-description
- } swap '[ _ elements empty? not ] any? ;
-
-: don't-check-word? ( word -- ? )
- {
- [ macro? ]
- [ symbol? ]
- [ value-word? ]
- [ parsing-word? ]
- [ "declared-effect" word-prop not ]
- } 1|| ;
-
-: check-values ( word element -- )
- {
- [
- [ don't-check-word? ]
- [ contains-funky-elements? ]
- bi* or
- ] [
- [ effect-values ]
- [ extract-values ]
- bi* sequence=
- ]
- } 2|| [ "$values don't match stack effect" throw ] unless ;
-
-: check-nulls ( element -- )
- \ $values swap elements
- null swap deep-member?
- [ "$values should not contain null" throw ] when ;
-
-: check-see-also ( element -- )
- \ $see-also swap elements [
- rest dup prune [ length ] bi@ assert=
- ] each ;
-
-: vocab-exists? ( name -- ? )
- [ vocab ] [ "all-vocabs" get member? ] bi or ;
-
-: check-modules ( element -- )
- \ $vocab-link swap elements [
- second
- vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
- ] each ;
-
-: check-rendering ( element -- )
- [ print-content ] with-string-writer drop ;
-
-: check-strings ( str -- )
- [
- "\n\t" intersects?
- [ "Paragraph text should not contain \\n or \\t" throw ] when
- ] [
- " " swap subseq?
- [ "Paragraph text should not contain double spaces" throw ] when
- ] bi ;
-
-: check-whitespace ( str1 str2 -- )
- [ " " tail? ] [ " " head? ] bi* or
- [ "Missing whitespace between strings" throw ] unless ;
-
-: check-bogus-nl ( element -- )
- { { $nl } { { $nl } } } [ head? ] with any?
- [ "Simple element should not begin with a paragraph break" throw ] when ;
-
-: check-elements ( element -- )
- {
- [ check-bogus-nl ]
- [ [ string? ] filter [ check-strings ] each ]
- [ [ simple-element? ] filter [ check-elements ] each ]
- [ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
- } cleave ;
-
-: check-descriptions ( element -- )
- { $description $class-description $var-description }
- swap '[
- _ elements [
- rest { { } { "" } } member?
- [ "Empty description" throw ] when
- ] each
- ] each ;
-
-: check-markup ( element -- )
- {
- [ check-elements ]
- [ check-rendering ]
- [ check-examples ]
- [ check-modules ]
- [ check-descriptions ]
- } cleave ;
-
-: check-class-description ( word element -- )
- [ class? not ]
- [ { $class-description } swap elements empty? not ] bi* and
- [ "A word that is not a class has a $class-description" throw ] when ;
-
-: all-word-help ( words -- seq )
- [ word-help ] filter ;
-
-TUPLE: help-error error topic ;
-
-C: <help-error> help-error
-
-M: help-error error.
- [ "In " write topic>> pprint nl ]
- [ error>> error. ]
- bi ;
-
-: check-something ( obj quot -- )
- flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
+SYMBOL: lint-failures
+
+lint-failures [ H{ } clone ] initialize
+
+TUPLE: help-lint-error < source-file-error ;
+
+SYMBOL: +help-lint-failure+
+
+T{ error-type
+ { type +help-lint-failure+ }
+ { word ":lint-failures" }
+ { plural "help lint failures" }
+ { icon "vocab:ui/tools/error-list/icons/help-lint-error.tiff" }
+ { quot [ lint-failures get values ] }
+ { forget-quot [ lint-failures get delete-at ] }
+} define-error-type
+
+M: help-lint-error error-type drop +help-lint-failure+ ;
+
+<PRIVATE
+
+: <help-lint-error> ( error topic -- help-lint-error )
+ \ help-lint-error <definition-error> ;
+
+PRIVATE>
+
+: help-lint-error ( error topic -- )
+ lint-failures get pick
+ [ [ [ <help-lint-error> ] keep ] dip set-at ] [ delete-at drop ] if
+ notify-error-observers ;
+
+<PRIVATE
+
+:: check-something ( topic quot -- )
+ [ quot call( -- ) f ] [ ] recover
+ topic help-lint-error ; inline
: check-word ( word -- )
[ with-file-vocabs ] vocabs-quot set
dup word-help [
- dup '[
+ [ >link ] keep '[
_ dup word-help
[ check-values ]
[ check-class-description ]
: check-words ( words -- ) [ check-word ] each ;
-: check-article-title ( article -- )
- article-title first LETTER?
- [ "Article title must begin with a capital letter" throw ] unless ;
-
: check-article ( article -- )
[ with-interactive-vocabs ] vocabs-quot set
- dup '[
+ >link dup '[
_
[ check-article-title ]
[ article-content check-markup ] bi
] check-something ;
-: files>vocabs ( -- assoc )
- vocabs
- [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
- [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
- bi assoc-union ;
-
-: group-articles ( -- assoc )
- articles get keys
- files>vocabs
- H{ } clone [
- '[
- dup >link where dup
- [ first _ at _ push-at ] [ 2drop ] if
- ] each
- ] keep ;
-
: check-about ( vocab -- )
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
-: check-vocab ( vocab -- seq )
+: check-vocab ( vocab -- )
"Checking " write dup write "..." print
- [
- [ check-about ]
- [ words [ check-word ] each ]
- [ "vocab-articles" get at [ check-article ] each ]
- tri
- ] { } make ;
+ [ vocab check-about ]
+ [ words [ check-word ] each ]
+ [ vocab-articles get at [ check-article ] each ]
+ tri ;
-: run-help-lint ( prefix -- alist )
+PRIVATE>
+
+: help-lint ( prefix -- )
[
- all-vocabs-seq [ vocab-name ] map "all-vocabs" set
- group-articles "vocab-articles" set
+ all-vocabs-seq [ vocab-name ] map all-vocabs set
+ group-articles vocab-articles set
child-vocabs
- [ dup check-vocab ] { } map>assoc
- [ nip empty? not ] assoc-filter
+ [ check-vocab ] each
] with-scope ;
-: typos. ( assoc -- )
- [
- "==== ALL CHECKS PASSED" print
- ] [
- [
- swap vocab-heading.
- [ print-error nl ] each
- ] assoc-each
- ] if-empty ;
-
-: help-lint ( prefix -- ) run-help-lint typos. ;
-
: help-lint-all ( -- ) "" help-lint ;
+: :lint-failures ( -- ) lint-failures get errors. ;
+
: unlinked-words ( words -- seq )
all-word-help [ article-parent not ] filter ;
all-words
[ word-help not ] filter
[ article-parent ] filter
- [ "predicating" word-prop not ] filter ;
+ [ predicate? not ] filter ;
MAIN: help-lint
[
[ "foobar" ] [
- "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval
+ "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval( -- )
"help.syntax.tests" vocab vocab-help
] unit-test
[ { "foobar" } ] [
- "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval
+ "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval( -- )
"help.syntax.tests" vocab vocab-help
] unit-test
} "\n" join
[
"testfile" source-file file set
- eval
+ eval( -- )
] with-scope
] unit-test
{ $code "." }
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
$nl
-"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
+"Create a test harness file using the scaffold tool:"
+{ $code "\"palindrome\" scaffold-tests" }
+"Now, open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
$nl
-"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
+"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link POSTPONE: unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
$nl
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code
: http-put ( post-data url -- response data )
<put-request> http-request ;
+: <delete-request> ( url -- request )
+ "DELETE" <client-request> ;
+
+: http-delete ( url -- response data )
+ <delete-request> http-request ;
+
USING: vocabs vocabs.loader ;
"debugger" vocab [ "http.client.debugger" require ] when
--- /dev/null
+IN: io.crlf.tests
+USING: io.crlf tools.test io.streams.string io ;
+
+[ "Hello, world." ] [ "Hello, world." [ read-crlf ] with-string-reader ] unit-test
+[ "Hello, world." ] [ "Hello, world.\r\n" [ read-crlf ] with-string-reader ] unit-test
+[ "Hello, world.\r" [ read-crlf ] with-string-reader ] must-fail
+[ f ] [ "" [ read-crlf ] with-string-reader ] unit-test
+[ "" ] [ "\r\n" [ read-crlf ] with-string-reader ] unit-test
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel ;
+USING: io kernel sequences ;
IN: io.crlf
: crlf ( -- )
: read-crlf ( -- seq )
"\r" read-until
- [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
+ [ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;
{ "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" }
{ "stream" "a bidirectional stream" } }
-{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
+{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream with the given encoding." } ;
+
+HELP: <process-reader>
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "stream" "an input stream" } }
+{ $description "Launches a process and redirects its output via a pipe which may be read as a stream with the given encoding." } ;
+
+HELP: <process-writer>
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "stream" "an output stream" }
+}
+{ $description "Launches a process and redirects its input via a pipe which may be written to as a stream with the given encoding." } ;
+
+HELP: with-process-stream
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+}
+{ $description "Launches a process and redirects its input and output via a pair of pipes. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to these pipes." } ;
+
+HELP: with-process-reader
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+}
+{ $description "Launches a process and redirects its output via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
+
+HELP: with-process-writer
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+}
+{ $description "Launches a process and redirects its input via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" object } }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-reader> }
{ $subsection <process-writer> }
-{ $subsection <process-stream> } ;
+{ $subsection <process-stream> }
+"Combinators built on top of the above:"
+{ $subsection with-process-reader }
+{ $subsection with-process-writer }
+{ $subsection with-process-stream } ;
ARTICLE: "io.launcher.examples" "Launcher examples"
"Starting a command and waiting for it to finish:"
[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
-[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
-[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
-[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
-[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
-[ "'abc def' \"hey" tokenize-command ] must-fail
-[ "'abc def" tokenize-command ] must-fail
-[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
+[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test
+[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test
+[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test
+[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test
+[ "\"abc def\" \"hey" tokenize-command ] must-fail
+[ "\"abc def" tokenize-command ] must-fail
+[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
[
V{
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: peg peg.parsers kernel sequences strings words ;
+USING: peg peg.ebnf arrays sequences strings kernel ;
IN: io.launcher.unix.parser
! Our command line parser. Supported syntax:
! foo bar baz -- simple tokens
! foo\ bar -- escaping the space
-! 'foo bar' -- quotation
! "foo bar" -- quotation
-: 'escaped-char' ( -- parser )
- "\\" token any-char 2seq [ second ] action ;
-
-: 'quoted-char' ( delimiter -- parser' )
- 'escaped-char'
- swap [ member? not ] curry satisfy
- 2choice ; inline
-
-: 'quoted' ( delimiter -- parser )
- dup 'quoted-char' repeat0 swap dup surrounded-by ;
-
-: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
-
-: 'argument' ( -- parser )
- "\"" 'quoted'
- "'" 'quoted'
- 'unquoted' 3choice
- [ >string ] action ;
-
-PEG: tokenize-command ( command -- ast/f )
- 'argument' " " token repeat1 list-of
- " " token repeat0 tuck pack
- just ;
+EBNF: tokenize-command
+space = " "
+escaped-char = "\" .:ch => [[ ch ]]
+quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
+unquoted = (escaped-char | [^ "])+
+argument = (quoted | unquoted) => [[ >string ]]
+command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
+;EBNF
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
os-envs =
] unit-test
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
os-envs =
] unit-test
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
"A" swap at
] unit-test
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
] unit-test
] with-destructors ;
: <client> ( remote encoding -- stream local )
- [ (client) -rot ] dip <encoder-duplex> swap ;
+ [ (client) ] dip swap [ <encoder-duplex> ] dip ;
SYMBOL: local-address
{ $description "Creates a new " { $link input } "." } ;
HELP: standard-table-style
-{ $values { "style" hashtable } }
+{ $values { "value" hashtable } }
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
ARTICLE: "io.streams.plain" "Plain writer streams"
SYMBOL: table-gap
SYMBOL: table-border
-: standard-table-style ( -- style )
+CONSTANT: standard-table-style
H{
{ table-gap { 5 5 } }
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
- } ;
+ }
! Input history
TUPLE: input string ;
-USING: help.markup help.syntax kernel io system prettyprint ;
+USING: help.markup help.syntax kernel io system prettyprint continuations ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
{ $subsection "listener-watch" }
-"You can start a nested listener or exit a listener using the following words:"
+"To start a nested listener:"
{ $subsection listener }
-{ $subsection bye }
-"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
+"To exit the listener, invoke the " { $link return } " word."
+$nl
+"Multi-line quotations can be read independently of the rest of the listener:"
{ $subsection read-quot } ;
ABOUT: "listener"
-<PRIVATE
-
-HELP: quit-flag
-{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
-
-PRIVATE>
-
HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
-HELP: listen
-{ $description "Prompts for an expression on " { $link input-stream } " and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
-{ $errors "If the expression input by the user throws an error, the error is printed to " { $link output-stream } " and the word returns normally." } ;
-
HELP: listener
{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
-
-HELP: bye
-{ $description "Exits the current listener." }
-{ $notes "This word is for interactive use only. To exit the Factor runtime, use " { $link exit } "." } ;
"\\ + 1 2 3 4" parse-interactive
"cont" get continue-with
] ignore-errors
- "USE: debugger :1" eval
+ "USE: debugger :1" eval( -- quot )
] callcc1
] unit-test
] with-file-vocabs
[
[ ] [
- "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
+ "IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive
drop
] unit-test
] with-file-vocabs
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors prettyprint fry
-sets vocabs.parser ;
+sets vocabs.parser source-files.errors locals ;
IN: listener
GENERIC: stream-read-quot ( stream -- quot/f )
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
-<PRIVATE
-
-SYMBOL: quit-flag
-
-PRIVATE>
-
-: bye ( -- ) quit-flag on ;
-
SYMBOL: visible-vars
-: show-var ( var -- ) visible-vars [ swap suffix ] change ;
+: show-var ( var -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
10 max-stack-items set-global
+SYMBOL: error-summary-hook
+
<PRIVATE
: title. ( string -- )
] dip
] when stack. ;
-: stacks. ( -- )
+: datastack. ( datastack -- )
display-stacks? get [
- datastack [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
- ] when ;
+ [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
+ ] [ drop ] if ;
: prompt. ( -- )
- "( " in get auto-use? get [ " - auto" append ] when " )" 3append
+ in get auto-use? get [ " - auto" append ] when "( " " )" surround
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
-: listen ( -- )
- visible-vars. stacks. prompt.
- [ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
- [ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
+[ error-summary ] error-summary-hook set-global
+
+: call-error-summary-hook ( -- )
+ error-summary-hook get call( -- ) ;
+
+:: (listener) ( datastack -- )
+ call-error-summary-hook
+ visible-vars.
+ datastack datastack.
+ prompt.
+
+ [
+ read-quot [
+ '[ datastack _ with-datastack ]
+ [ call-error-hook datastack ]
+ recover
+ ] [ return ] if*
+ ] [
+ dup lexer-error?
+ [ call-error-hook datastack ]
+ [ rethrow ]
+ if
+ ] recover
-: until-quit ( -- )
- quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
+ (listener) ;
PRIVATE>
: listener ( -- )
- [ until-quit ] with-interactive-vocabs ;
+ [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
MAIN: listener
: deep-sequence>cons ( sequence -- cons )
[ <reversed> ] keep nil
- [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
+ [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
+ with reduce ;
<PRIVATE
:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )
CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
-[ ] [ new-definition eval ] unit-test
+[ ] [ new-definition eval( -- ) ] unit-test
[ t ] [
[ \ a-word-with-locals see ] with-string-writer
[
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
- eval call
+ eval( -- ) call
] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
[ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases
-[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
-[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail
+[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
-[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail
+[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
-[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail
+[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
-[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail
+[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
-[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
+[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
-[ "USE: locals [| | { :> a } ]" eval ] must-fail
+[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
-[ "USE: locals 3 :> a" eval ] must-fail
+[ "USE: locals 3 :> a" eval( -- ) ] must-fail
[ 3 ] [ 3 [| | :> a a ] call ] unit-test
:: ed's-test-case ( a -- b )
{ [ a ed's-bug ] } && ;
-[ t ] [ \ ed's-test-case optimized>> ] unit-test
\ No newline at end of file
+[ t ] [ \ ed's-test-case optimized>> ] unit-test
[ t ] [ \ see-test macro? ] unit-test
[ t ] [
- "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
+ "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- )
[ \ see-test see ] with-string-writer =
] unit-test
[ f ] [ \ see-test macro? ] unit-test
-[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test
+[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
} cond ;
: match-replace ( object pattern1 pattern2 -- result )
- -rot
- match [ "Pattern does not match" throw ] unless*
+ [ match [ "Pattern does not match" throw ] unless* ] dip swap
[ replace-patterns ] bind ;
: ?1-tail ( seq -- tail/f )
0 pick interval-contains? over first \ recip eq? and [
2drop t
] [
- [ [ random-element ] dip first execute ] 2keep
- second execute interval-contains?
+ [ [ random-element ] dip first execute( a -- b ) ] 2keep
+ second execute( a -- b ) interval-contains?
] if ;
-[ t ] [ 80000 [ drop unary-test ] all? ] unit-test
+[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
: random-binary-op ( -- pair )
{
0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t
] [
- [ [ [ random-element ] bi@ ] dip first execute ] 3keep
- second execute interval-contains?
+ [ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep
+ second execute( a b -- c ) interval-contains?
] if ;
-[ t ] [ 80000 [ drop binary-test ] all? ] unit-test
+[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
: random-comparison ( -- pair )
{
[ [ [ random-element ] bi@ ] dip first execute ] 3keep
second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
-[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
+[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
! Test that commutative interval ops really are
-: random-interval-or-empty ( -- )
+: random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ;
: random-commutative-op ( -- op )
} random ;
[ t ] [
- 80000 [
+ 80000 iota [
drop
random-interval-or-empty random-interval-or-empty
random-commutative-op
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: math.matrices.elimination.tests
+USING: kernel math.matrices math.matrices.elimination
+tools.test sequences ;
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 1 1 0 0 }
+ { 1 0 1 0 }
+ { 1 0 0 1 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 1 1 0 0 }
+ { 1 0 1 0 }
+ { 1 1 0 1 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 1 1 0 0 }
+ { 1 1 0 1 }
+ { 1 0 1 0 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 0 0 }
+ { 0 0 0 0 }
+ }
+] [
+ {
+ { 0 1 0 0 }
+ { 1 0 0 0 }
+ { 1 0 0 0 }
+ { 1 0 0 0 }
+ } [
+ [ 1 ] [ 0 0 pivot-row ] unit-test
+ 1 0 do-row
+ ] with-matrix
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 0 0 }
+ { 0 0 0 0 }
+ }
+] [
+ {
+ { 0 1 0 0 }
+ { 1 0 0 0 }
+ { 1 0 0 0 }
+ { 1 0 0 0 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 0 1 }
+ { 0 0 0 0 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 1 0 0 1 }
+ { 1 0 0 1 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 1 }
+ { 0 1 0 1 }
+ { 0 0 0 -1 }
+ { 0 0 0 0 }
+ }
+] [
+ {
+ { 0 1 0 1 }
+ { 1 0 0 1 }
+ { 1 0 0 0 }
+ { 1 1 0 1 }
+ } echelon
+] unit-test
+
+[
+ 2
+] [
+ {
+ { 0 0 }
+ { 0 0 }
+ } nullspace length
+] unit-test
+
+[
+ 1 3
+] [
+ {
+ { 0 1 0 1 }
+ { 1 0 0 1 }
+ { 1 0 0 0 }
+ { 1 1 0 1 }
+ } null/rank
+] unit-test
+
+[
+ 1 3
+] [
+ {
+ { 0 0 0 0 0 1 0 1 }
+ { 0 0 0 0 1 0 0 1 }
+ { 0 0 0 0 1 0 0 0 }
+ { 0 0 0 0 1 1 0 1 }
+ } null/rank
+] unit-test
+
+[ { { 1 0 -1 } { 0 1 2 } } ]
+[ { { 1 2 3 } { 4 5 6 } } solution ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.vectors math.matrices namespaces
+sequences ;
+IN: math.matrices.elimination
+
+SYMBOL: matrix
+
+: with-matrix ( matrix quot -- )
+ [ swap matrix set call matrix get ] with-scope ; inline
+
+: nth-row ( row# -- seq ) matrix get nth ;
+
+: change-row ( row# quot: ( seq -- seq ) -- )
+ matrix get swap change-nth ; inline
+
+: exchange-rows ( row# row# -- ) matrix get exchange ;
+
+: rows ( -- n ) matrix get length ;
+
+: cols ( -- n ) 0 nth-row length ;
+
+: skip ( i seq quot -- n )
+ over [ find-from drop ] dip length or ; inline
+
+: first-col ( row# -- n )
+ #! First non-zero column
+ 0 swap nth-row [ zero? not ] skip ;
+
+: clear-scale ( col# pivot-row i-row -- n )
+ [ over ] dip nth dup zero? [
+ 3drop 0
+ ] [
+ [ nth dup zero? ] dip swap [
+ 2drop 0
+ ] [
+ swap / neg
+ ] if
+ ] if ;
+
+: (clear-col) ( col# pivot-row i -- )
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
+
+: rows-from ( row# -- slice )
+ rows dup <slice> ;
+
+: clear-col ( col# row# rows -- )
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
+
+: do-row ( exchange-with row# -- )
+ [ exchange-rows ] keep
+ [ first-col ] keep
+ dup 1+ rows-from clear-col ;
+
+: find-row ( row# quot -- i elt )
+ [ rows-from ] dip find ; inline
+
+: pivot-row ( col# row# -- n )
+ [ dupd nth-row nth zero? not ] find-row 2nip ;
+
+: (echelon) ( col# row# -- )
+ over cols < over rows < and [
+ 2dup pivot-row [ over do-row 1+ ] when*
+ [ 1+ ] dip (echelon)
+ ] [
+ 2drop
+ ] if ;
+
+: echelon ( matrix -- matrix' )
+ [ 0 0 (echelon) ] with-matrix ;
+
+: nonzero-rows ( matrix -- matrix' )
+ [ [ zero? ] all? not ] filter ;
+
+: null/rank ( matrix -- null rank )
+ echelon dup length swap nonzero-rows length [ - ] keep ;
+
+: leading ( seq -- n elt ) [ zero? not ] find ;
+
+: reduced ( matrix' -- matrix'' )
+ [
+ rows <reversed> [
+ dup nth-row leading drop
+ dup [ swap dup clear-col ] [ 2drop ] if
+ ] each
+ ] with-matrix ;
+
+: basis-vector ( row col# -- )
+ [ clone ] dip
+ [ swap nth neg recip ] 2keep
+ [ 0 spin set-nth ] 2keep
+ [ n*v ] dip
+ matrix get set-nth ;
+
+: nullspace ( matrix -- seq )
+ echelon reduced dup empty? [
+ dup first length identity-matrix [
+ [
+ dup leading drop
+ dup [ basis-vector ] [ 2drop ] if
+ ] each
+ ] with-matrix flip nonzero-rows
+ ] unless ;
+
+: 1-pivots ( matrix -- matrix )
+ [ dup leading nip [ recip v*n ] when* ] map ;
+
+: solution ( matrix -- matrix )
+ echelon nonzero-rows reduced 1-pivots ;
+
+: inverse ( matrix -- matrix ) ! Assumes an invertible matrix
+ dup length
+ [ identity-matrix [ append ] 2map solution ] keep
+ [ tail ] curry map ;
--- /dev/null
+Solving systems of linear equations
--- /dev/null
+IN: math.matrices.tests
+USING: math.matrices math.vectors tools.test math ;
+
+[
+ { { 0 } { 0 } { 0 } }
+] [
+ 3 1 zero-matrix
+] unit-test
+
+[
+ { { 1 0 0 }
+ { 0 1 0 }
+ { 0 0 1 } }
+] [
+ 3 identity-matrix
+] unit-test
+
+[
+ { { 1 0 4 }
+ { 0 7 0 }
+ { 6 0 3 } }
+] [
+ { { 1 0 0 }
+ { 0 2 0 }
+ { 0 0 3 } }
+
+ { { 0 0 4 }
+ { 0 5 0 }
+ { 6 0 0 } }
+
+ m+
+] unit-test
+
+[
+ { { 1 0 4 }
+ { 0 7 0 }
+ { 6 0 3 } }
+] [
+ { { 1 0 0 }
+ { 0 2 0 }
+ { 0 0 3 } }
+
+ { { 0 0 -4 }
+ { 0 -5 0 }
+ { -6 0 0 } }
+
+ m-
+] unit-test
+
+[
+ { 10 20 30 }
+] [
+ 10 { 1 2 3 } n*v
+] unit-test
+
+[
+ { 3 4 }
+] [
+ { { 1 0 }
+ { 0 1 } }
+
+ { 3 4 }
+
+ m.v
+] unit-test
+
+[
+ { 4 3 }
+] [
+ { { 0 1 }
+ { 1 0 } }
+
+ { 3 4 }
+
+ m.v
+] unit-test
+
+[
+ { { 6 } }
+] [
+ { { 3 } } { { 2 } } m.
+] unit-test
+
+[
+ { { 11 } }
+] [
+ { { 1 3 } } { { 5 } { 2 } } m.
+] unit-test
+
+[
+ { { 28 } }
+] [
+ { { 2 4 6 } }
+
+ { { 1 }
+ { 2 }
+ { 3 } }
+
+ m.
+] unit-test
+
+[ { 0 0 -1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test
+[ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test
+[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
+
+[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
+
+[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
+[ { 1 2 } { "a" "b" } cross-zip ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.order math.vectors sequences ;
+IN: math.matrices
+
+! Matrices
+: zero-matrix ( m n -- matrix )
+ [ nip 0 <array> ] curry map ;
+
+: identity-matrix ( n -- matrix )
+ #! Make a nxn identity matrix.
+ dup [ [ = 1 0 ? ] with map ] curry map ;
+
+! Matrix operations
+: mneg ( m -- m ) [ vneg ] map ;
+
+: n*m ( n m -- m ) [ n*v ] with map ;
+: m*n ( m n -- m ) [ v*n ] curry map ;
+: n/m ( n m -- m ) [ n/v ] with map ;
+: m/n ( m n -- m ) [ v/n ] curry map ;
+
+: m+ ( m m -- m ) [ v+ ] 2map ;
+: m- ( m m -- m ) [ v- ] 2map ;
+: m* ( m m -- m ) [ v* ] 2map ;
+: m/ ( m m -- m ) [ v/ ] 2map ;
+
+: v.m ( v m -- v ) flip [ v. ] with map ;
+: m.v ( m v -- v ) [ v. ] curry map ;
+: m. ( m m -- m ) flip [ swap m.v ] curry map ;
+
+: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
+: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
+: mnorm ( m -- n ) dup mmax abs m/n ;
+
+<PRIVATE
+
+: x ( seq -- elt ) first ; inline
+: y ( seq -- elt ) second ; inline
+: z ( seq -- elt ) third ; inline
+
+: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
+: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
+: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
+
+PRIVATE>
+
+: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
+
+: proj ( v u -- w )
+ [ [ v. ] [ norm-sq ] bi / ] keep n*v ;
+
+: (gram-schmidt) ( v seq -- newseq )
+ [ dupd proj v- ] each ;
+
+: gram-schmidt ( seq -- orthogonal )
+ V{ } clone [ over (gram-schmidt) over push ] reduce ;
+
+: norm-gram-schmidt ( seq -- orthonormal )
+ gram-schmidt [ normalize ] map ;
+
+: cross-zip ( seq1 seq2 -- seq1xseq2 )
+ [ [ 2array ] with map ] curry map ;
\ No newline at end of file
--- /dev/null
+Matrix arithmetic
[ 89 ] [ 10 fib ] unit-test
-[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail
+[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
MEMO: see-test ( a -- b ) reverse ;
[ [ \ see-test see ] with-string-writer ]
unit-test
-[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test
+[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test
[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test
: invalidate-memoized ( inputs... word -- )
[ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
+
+\ invalidate-memoized t "no-compile" set-word-prop
\ No newline at end of file
[ no-content-disposition ]
} case ;
-: assert-sequence= ( a b -- )
- 2dup sequence= [ 2drop ] [ assert ] if ;
-
: read-assert-sequence= ( sequence -- )
[ length read ] keep assert-sequence= ;
! Test reshaping with a mirror
1 2 3 color boa <mirror> "mirror" set
-[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test
+[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test
[ 1 ] [ "red" "mirror" get at ] unit-test
--- /dev/null
+Slava Pestov
\ No newline at end of file
{ $examples
"A model which adds the values of two existing models:"
{ $example
- "USING: models models.arrows.smart accessors math prettyprint ;"
+ "USING: models models.arrow.smart accessors kernel math prettyprint ;"
"1 <model> 2 <model> [ + ] <smart-arrow>"
"[ activate-model ] [ value>> ] bi ."
"3"
}
} ;
-ARTICLE: "models.arrows.smart" "Smart arrow models"
-"The " { $vocab-link "models.arrows.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "."
+ARTICLE: "models.arrow.smart" "Smart arrow models"
+"The " { $vocab-link "models.arrow.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "."
{ $subsection <smart-arrow> } ;
-ABOUT: "models.arrows.smart"
\ No newline at end of file
+ABOUT: "models.arrow.smart"
\ No newline at end of file
--- /dev/null
+IN: models.arrows.smart.tests
+USING: models.arrow.smart tools.test accessors models math kernel ;
+
+[ 7 ] [ 3 <model> 4 <model> [ + ] <smart-arrow> [ activate-model ] [ value>> ] bi ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: models.arrow models.product stack-checker accessors fry
+generalizations macros kernel ;
+IN: models.arrow.smart
+
+MACRO: <smart-arrow> ( quot -- quot' )
+ [ infer in>> dup ] keep
+ '[ _ narray <product> [ _ firstn @ ] <arrow> ] ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
-sequences unicode.case ;
+USING: fry kernel models.arrow.smart sequences unicode.case ;
IN: models.search
: <search> ( values search quot -- model )
- [ 2array <product> ] dip
- '[ first2 _ curry filter ] <arrow> ;
+ '[ _ curry filter ] <smart-arrow> ; inline
: <string-search> ( values search quot -- model )
- '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ;
+ '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ; inline
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
-sequences sorting ;
+USING: sorting models.arrow.smart fry ;
IN: models.sort
: <sort> ( values sort -- model )
- 2array <product> [ first2 sort ] <arrow> ;
\ No newline at end of file
+ [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] <smart-arrow> ; inline
\ No newline at end of file
: adjust-texture-dim ( dim -- dim' )
non-power-of-2-textures? get [
- [ next-power-of-2 ] map
+ [ dup 1 = [ next-power-of-2 ] unless ] map
] unless ;
: (tex-image) ( image bitmap -- )
[ display-list>> [ delete-dlist ] when* ] bi ;
M: single-texture draw-scaled-texture
- dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
+ 2dup dim>> = [ nip draw-texture ] [
+ dup texture>> [ draw-textured-rect ] [ 2drop ] if
+ ] if ;
TUPLE: multi-texture grid display-list loc disposed ;
f multi-texture boa
] with-destructors ;
+M: multi-texture draw-scaled-texture nip draw-texture ;
+
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
CONSTANT: max-texture-size { 512 512 }
"ad" parser4
] unit-test
-{ t } [
- "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t
+{ } [
+ "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" eval( -- )
] unit-test
[
- "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
+ "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval( -- ) drop
] must-fail
{ t } [
"\\" [EBNF foo="\\" EBNF]
] unit-test
-[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail
+[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail
[ <" USE: peg.ebnf [EBNF
lol = a
lol = b
- EBNF] "> eval
+ EBNF] "> eval( -- )
] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with
[ back>> ] [ front>> ] bi deque boa ;
: flipped ( deque quot -- newdeque )
- [ flip ] dip call flip ;
+ [ flip ] dip call flip ; inline
PRIVATE>
: deque-empty? ( deque -- ? )
: random-string ( -- str )
1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
-: random-assocs ( -- hash phash )
+: random-assocs ( n -- hash phash )
[ random-string ] replicate
[ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
[ PH{ } clone swap [ spin new-at ] each-index ]
: ok? ( assoc1 assoc2 -- ? )
[ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ;
-: test-persistent-hashtables-1 ( n -- )
+: test-persistent-hashtables-1 ( n -- ? )
random-assocs ok? ;
[ t ] [ 10 test-persistent-hashtables-1 ] unit-test
[ t ] [ 10000 test-persistent-hashtables-1 ] unit-test
[ t ] [ 50000 test-persistent-hashtables-1 ] unit-test
-: test-persistent-hashtables-2 ( n -- )
+: test-persistent-hashtables-2 ( n -- ? )
random-assocs
dup keys [
[ nip over delete-at ] [ swap pluck-at nip ] 3bi
kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
-continuations generic compiler.units tools.walker eval
-accessors make vocabs.parser see ;
+continuations generic compiler.units tools.continuations
+tools.continuations.private eval accessors make vocabs.parser see ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test
-: check-see ( expect name -- )
+: check-see ( expect name -- ? )
[
use [ clone ] change
GENERIC: method-layout ( a -- b )
M: complex method-layout
+ drop
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
;
[
{
- "USING: math prettyprint.tests ;"
+ "USING: kernel math prettyprint.tests ;"
"M: complex method-layout"
+ " drop"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
" ;"
""
"string-layout-test" string-layout check-see
] unit-test
-: narrow-test ( -- str )
+: narrow-test ( -- array )
{
"USING: arrays combinators continuations kernel sequences ;"
"IN: prettyprint.tests"
- ": narrow-layout ( obj -- )"
+ ": narrow-layout ( obj1 obj2 -- obj3 )"
" {"
" { [ dup continuation? ] [ append ] }"
" { [ dup not ] [ drop reverse ] }"
- " { [ dup pair? ] [ delete ] }"
+ " { [ dup pair? ] [ [ delete ] keep ] }"
" } cond ;"
} ;
"narrow-layout" narrow-test check-see
] unit-test
-: another-narrow-test ( -- str )
+: another-narrow-test ( -- array )
{
"IN: prettyprint.tests"
": another-narrow-layout ( -- obj )"
! Regression
[ t ] [
"IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
- dup eval
+ dup eval( -- )
"generic-decl-test" "prettyprint.tests" lookup
[ see ] with-string-writer =
] unit-test
-[ [ + ] ] [
- [ \ + (step-into-execute) ] (remove-breakpoints)
-] unit-test
-
-[ [ (step-into-execute) ] ] [
- [ (step-into-execute) ] (remove-breakpoints)
-] unit-test
+[ [ + ] ] [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test
+[ [ (step-into-execute) ] ] [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
+
[ [ 2 2 + . ] ] [
[ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test
100 [ 100 random ] replicate ;
: test-rng ( seed quot -- )
- [ <mersenne-twister> ] dip with-random ;
+ [ <mersenne-twister> ] dip with-random ; inline
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
Slava Pestov
+Alex Chapman
-! Copyright (C) 2007 Slava Pestov
+! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
+USING: boxes help.markup help.syntax kernel math namespaces ;
IN: refs
-ARTICLE: "refs" "References to assoc entries"
-"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary."
+ARTICLE: "refs" "References"
+"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "."
{ $subsection get-ref }
{ $subsection set-ref }
+{ $subsection set-ref* }
{ $subsection delete-ref }
-"References to keys:"
+"References to objects:"
+{ $subsection obj-ref }
+{ $subsection <obj-ref> }
+"References to assoc keys:"
{ $subsection key-ref }
{ $subsection <key-ref> }
-"References to values:"
+"References to assoc values:"
{ $subsection value-ref }
{ $subsection <value-ref> }
+"References to variables:"
+{ $subsection var-ref }
+{ $subsection <var-ref> }
+{ $subsection global-var-ref }
+{ $subsection <global-var-ref> }
+"References to tuple slots:"
+{ $subsection slot-ref }
+{ $subsection <slot-ref> }
+"Using boxes as references:"
+{ $subsection "box-refs" }
"References are used by the UI inspector." ;
ABOUT: "refs"
+ARTICLE: "refs-protocol" "Reference Protocol"
+"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
+{ $subsection get-ref }
+{ $subsection set-ref }
+"References may also implement:"
+{ $subsection delete-ref } ;
+
+ARTICLE: "box-refs" "Using Boxes as References"
+"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
+
HELP: ref
-{ $class-description "A class whose instances identify a key or value location in an associative structure. Instances of this clas are never used directly; only instances of " { $link key-ref } " and " { $link value-ref } " should be created." } ;
+{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
HELP: delete-ref
{ $values { "ref" ref } }
-{ $description "Deletes the association entry pointed at by this reference." } ;
+{ $description "Deletes the value pointed to by this reference. In most references this simply sets the value to f, but in some cases it is more destructive, such as in " { $link value-ref } " and " { $link key-ref } ", where it actually deletes the entry from the underlying assoc." } ;
HELP: get-ref
{ $values { "ref" ref } { "obj" object } }
-{ $description "Outputs the key or the value pointed at by this reference." } ;
+{ $description "Outputs the value pointed at by this reference." } ;
HELP: set-ref
{ $values { "obj" object } { "ref" ref } }
-{ $description "Stores a new key or value at by this reference." } ;
+{ $description "Stores a new value at this reference." } ;
+
+HELP: obj-ref
+{ $class-description "Instances of this class contain a value which can be changed using the " { $link "refs-protocol" } ". New object references are created by calling " { $link <obj-ref> } "." } ;
+
+HELP: <obj-ref>
+{ $values { "obj" object } { "obj-ref" obj-ref } }
+{ $description "Creates a reference which contains the value it references." } ;
+HELP: var-ref
+{ $class-description "Instances of this class reference a variable as defined by the " { $vocab-link "namespaces" } " vocabulary. New variable references are created by calling " { $link <var-ref> } "." } ;
+
+HELP: <var-ref>
+{ $values { "var" object } { "var-ref" var-ref } }
+{ $description "Creates a reference to the given variable. Note that this reference behaves just like any variable when it comes to dynamic scope. For example, if you use " { $link set-ref } " in an inner scope and then leave that scope, then calling " { $link get-ref } " may not return the expected value. If this is not what you want, try using an " { $link obj-ref } " instead." } ;
+
+HELP: global-var-ref
+{ $class-description "Instances of this class reference a global variable. New global references are created by calling " { $link <global-var-ref> } "." } ;
+
+HELP: <global-var-ref>
+{ $values { "var" object } { "global-var-ref" global-var-ref } }
+{ $description "Creates a reference to a global variable." } ;
+
+HELP: slot-ref
+{ $class-description "Instances of this class identify a particular slot of a particular instance of a tuple. New slot references are created by calling " { $link <slot-ref> } "." } ;
+
+HELP: <slot-ref>
+{ $values { "tuple" tuple } { "slot" integer } { "slot-ref" slot-ref } }
+{ $description "Creates a reference to the value in a particular slot of the given tuple. The slot must be given as an integer, where the first user-defined slot is number 2. This is mostly just a proof of concept until we have a way of generating this slot number from a slot name." } ;
+
HELP: key-ref
{ $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
{ $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
-{ get-ref set-ref delete-ref } related-words
+{ get-ref set-ref delete-ref set-ref* } related-words
+
+{ <obj-ref> <var-ref> <global-var-ref> <slot-ref> <key-ref> <value-ref> } related-words
-{ <key-ref> <value-ref> } related-words
+HELP: set-ref*
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ;
+
+HELP: ref-on
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to t." } ;
+
+HELP: ref-off
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to f." } ;
+
+HELP: ref-inc
+{ $values { "ref" ref } }
+{ $description "Increment the value of the ref by 1." } ;
+
+HELP: ref-dec
+{ $values { "ref" ref } }
+{ $description "Decrement the value of the ref by 1." } ;
+
+HELP: take
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Retrieve the value of the ref and then delete it, returning the value." } ;
+
+{ ref-on ref-off ref-inc ref-dec take } related-words
+{ take delete-ref } related-words
+{ on ref-on } related-words
+{ off ref-off } related-words
+{ inc ref-inc } related-words
+{ dec ref-dec } related-words
-USING: refs tools.test kernel ;
+USING: boxes kernel namespaces refs tools.test ;
+IN: refs.tests
+! assoc-refs
[ 3 ] [
H{ { "a" 3 } } "a" <value-ref> get-ref
] unit-test
set-ref
] keep
] unit-test
+
+SYMBOLS: lion giraffe elephant rabbit ;
+
+! obj-refs
+[ rabbit ] [ rabbit <obj-ref> get-ref ] unit-test
+[ rabbit ] [ f <obj-ref> rabbit set-ref* get-ref ] unit-test
+[ rabbit ] [ rabbit <obj-ref> take ] unit-test
+[ rabbit f ] [ rabbit <obj-ref> [ take ] keep get-ref ] unit-test
+[ lion ] [ rabbit <obj-ref> dup [ drop lion ] change-ref get-ref ] unit-test
+
+! var-refs
+[ giraffe ] [ [ giraffe rabbit set rabbit <var-ref> get-ref ] with-scope ] unit-test
+
+[ rabbit ]
+[
+ [
+ lion rabbit set [
+ rabbit rabbit set rabbit <var-ref> get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <var-ref>
+ [
+ lion rabbit set [
+ rabbit rabbit set get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <var-ref>
+ [
+ elephant rabbit set [
+ rabbit rabbit set
+ ] with-scope
+ get-ref
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <var-ref>
+ [
+ elephant set-ref* [
+ rabbit set-ref* get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <var-ref>
+ [
+ elephant set-ref* [
+ rabbit set-ref*
+ ] with-scope
+ get-ref
+ ] with-scope
+] unit-test
+
+! Top Hats
+[ lion ] [ lion rabbit set-global rabbit <global-var-ref> get-ref ] unit-test
+[ giraffe ] [ rabbit <global-var-ref> giraffe set-ref* get-ref ] unit-test
+
+! Tuple refs
+TUPLE: foo bar ;
+C: <foo> foo
+
+: test-tuple ( -- tuple )
+ rabbit <foo> ;
+
+: test-slot-ref ( -- slot-ref )
+ test-tuple 2 <slot-ref> ; ! hack!
+
+[ rabbit ] [ test-slot-ref get-ref ] unit-test
+[ lion ] [ test-slot-ref lion set-ref* get-ref ] unit-test
+
+! Boxes as refs
+[ rabbit ] [ <box> rabbit set-ref* get-ref ] unit-test
+[ <box> rabbit set-ref* lion set-ref* ] must-fail
+[ <box> get-ref ] must-fail
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2008 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.tuple kernel assocs accessors ;
+USING: kernel assocs accessors boxes math namespaces ;
IN: refs
-TUPLE: ref assoc key ;
+MIXIN: ref
-: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
-
-: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
GENERIC: set-ref ( obj ref -- )
+GENERIC: delete-ref ( ref -- )
+
+! works like >>slot words
+: set-ref* ( ref obj -- ref ) over set-ref ;
+
+! very similar to change, on, off, +@, inc, and dec from namespaces
+: change-ref ( ref quot -- )
+ [ [ get-ref ] keep ] dip dip set-ref ; inline
+: ref-on ( ref -- ) t swap set-ref ;
+: ref-off ( ref -- ) f swap set-ref ;
+: ref-+@ ( n ref -- ) [ 0 or + ] change-ref ;
+: ref-inc ( ref -- ) 1 swap ref-+@ ;
+: ref-dec ( ref -- ) -1 swap ref-+@ ;
+
+: take ( ref -- obj )
+ dup get-ref swap delete-ref ;
+
+! delete-ref defaults to setting ref to f
+M: ref delete-ref ref-off ;
+
+TUPLE: obj-ref obj ;
+C: <obj-ref> obj-ref
+M: obj-ref get-ref obj>> ;
+M: obj-ref set-ref (>>obj) ;
+INSTANCE: obj-ref ref
+
+TUPLE: var-ref var ;
+C: <var-ref> var-ref
+M: var-ref get-ref var>> get ;
+M: var-ref set-ref var>> set ;
+INSTANCE: var-ref ref
+
+TUPLE: global-var-ref var ;
+C: <global-var-ref> global-var-ref
+M: global-var-ref get-ref var>> get-global ;
+M: global-var-ref set-ref var>> set-global ;
+INSTANCE: global-var-ref ref
+
+USE: slots.private
+TUPLE: slot-ref tuple slot ;
+C: <slot-ref> slot-ref
+: >slot-ref< ( slot-ref -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
+M: slot-ref get-ref >slot-ref< slot ;
+M: slot-ref set-ref >slot-ref< set-slot ;
+INSTANCE: slot-ref ref
+
+M: box get-ref box> ;
+M: box set-ref >box ;
+M: box delete-ref box> drop ;
+INSTANCE: box ref
+
+TUPLE: assoc-ref assoc key ;
+
+: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
+
+M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ;
-TUPLE: key-ref < ref ;
+TUPLE: key-ref < assoc-ref ;
C: <key-ref> key-ref
M: key-ref get-ref key>> ;
-M: key-ref set-ref >ref< rename-at ;
+M: key-ref set-ref >assoc-ref< rename-at ;
+INSTANCE: key-ref ref
-TUPLE: value-ref < ref ;
+TUPLE: value-ref < assoc-ref ;
C: <value-ref> value-ref
-M: value-ref get-ref >ref< at ;
-M: value-ref set-ref >ref< set-at ;
+M: value-ref get-ref >assoc-ref< at ;
+M: value-ref set-ref >assoc-ref< set-at ;
+INSTANCE: value-ref ref
: regexp-parses ( string -- )
[ [ ] ] dip '[ _ parse-regexp drop ] unit-test ;
-: regexp-fails ( string -- )
+: regexp-fails ( string -- regexp )
'[ _ parse-regexp ] must-fail ;
{
! Comment inside a regular expression
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
-[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval( -- ) ] unit-test
-[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval( -- ) ] unit-test
-[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval( -- ) ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
Elie Chaftari
Dirk Vleugels
Slava Pestov
+Doug Coleman
+Daniel Ehrenberg
: process ( -- )
read-crlf {
+ { [ dup not ] [ f ] }
{
[ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
[ "220 and..?\r\n" write flush t ]
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel quotations help.syntax help.markup
-io.sockets strings calendar ;
+io.sockets strings calendar io.encodings.utf8 ;
IN: smtp
HELP: smtp-domain
{ { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." }
{ { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." }
{ { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." }
- { { $slot "subject" } " The subject of the e-mail. A string." }
+ { { $slot "subject" } "The subject of the e-mail. A string." }
+ { { $slot "content-type" } { "The MIME type of the body. A string, default is " { $snippet "text/plain" } "." } }
+ { { $slot "encoding" } { "An encoding to send the body as. Default is " { $link utf8 } "." } }
{ { $slot "body" } " The body of the e-mail. A string." }
}
"The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional."
[ { "hello" "." "world" } validate-message ] must-fail
[ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
- "hello\nworld" [ send-body ] with-string-writer
+ T{ email { body "hello\nworld" } } [ send-body ] with-string-writer
] unit-test
[ { "500 syntax error" } <response> check-response ]
[
{
{ "Content-Transfer-Encoding" "base64" }
- { "Content-Type" "Text/plain; charset=utf-8" }
+ { "Content-Type" "text/plain; charset=UTF-8" }
{ "From" "Doug <erg@factorcode.org>" }
{ "MIME-Version" "1.0" }
{ "Subject" "Factor rules" }
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
-! Slava Pestov, Doug Coleman.
+! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays namespaces make io io.encodings.string
-io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
-io.encodings.ascii kernel logging sequences combinators
-splitting assocs strings math.order math.parser random system
-calendar summary calendar.format accessors sets hashtables
-base64 debugger classes prettyprint io.crlf ;
+USING: arrays namespaces make io io.encodings.string io.encodings.utf8
+io.encodings.iana io.timeouts io.sockets io.sockets.secure
+io.encodings.ascii kernel logging sequences combinators splitting
+assocs strings math.order math.parser random system calendar summary
+calendar.format accessors sets hashtables base64 debugger classes
+prettyprint io.crlf words ;
IN: smtp
SYMBOL: smtp-domain
{ cc array }
{ bcc array }
{ subject string }
+ { content-type string initial: "text/plain" }
+ { encoding word initial: utf8 }
{ body string } ;
: <email> ( -- email ) email new ; inline
"." over member?
[ message-contains-dot ] when ;
-: send-body ( body -- )
- utf8 encode
+: send-body ( email -- )
+ [ body>> ] [ encoding>> ] bi encode
>base64-lines write crlf
"." command ;
: encode-header ( string -- string' )
dup aux>> [
- "=?utf-8?B?"
- swap utf8 encode >base64
- "?=" 3append
+ utf8 encode >base64
+ "=?utf-8?B?" "?=" surround
] when ;
ERROR: invalid-header-string string ;
! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ;
-: utf8-mime-header ( -- alist )
- {
- { "MIME-Version" "1.0" }
- { "Content-Transfer-Encoding" "base64" }
- { "Content-Type" "Text/plain; charset=utf-8" }
- } ;
+: email-content-type ( email -- content-type )
+ [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
-: email>headers ( email -- hashtable )
+: email>headers ( email -- assoc )
[
+ now timestamp>rfc822 "Date" set
+ message-id "Message-Id" set
+ "1.0" "MIME-Version" set
+ "base64" "Content-Transfer-Encoding" set
{
[ from>> "From" set ]
[ to>> ", " join "To" set ]
[ cc>> ", " join [ "Cc" set ] unless-empty ]
[ subject>> "Subject" set ]
+ [ email-content-type "Content-Type" set ]
} cleave
- now timestamp>rfc822 "Date" set
- message-id "Message-Id" set
- ] { } make-assoc utf8-mime-header append ;
+ ] { } make-assoc ;
: (send-email) ( headers email -- )
[
data get-ok
swap write-headers
crlf
- body>> send-body get-ok
+ send-body get-ok
quit get-ok
] with-smtp-connection ;
HELP: compare-slots
{ $values
- { "sort-specs" "a sequence of accessors ending with a comparator" }
- { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
+ { "obj1" object }
+ { "obj2" object }
+ { "sort-specs" "a sequence of accessors ending with a comparator" }
+ { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
}
{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
-HELP: sort-by-slots
+HELP: sort-by
{ $values
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
- { "sortedseq" sequence }
+ { "seq'" sequence }
}
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
{ $examples
- "Sort by slot c, then b descending:"
+ "Sort by slot a, then b descending:"
{ $example
"USING: accessors math.order prettyprint sorting.slots ;"
"IN: scratchpad"
" T{ sort-me f 2 3 } T{ sort-me f 3 2 }"
" T{ sort-me f 4 3 } T{ sort-me f 2 1 }"
"}"
- "{ { a>> <=> } { b>> >=< } } sort-by-slots ."
+ "{ { a>> <=> } { b>> >=< } } sort-by ."
"{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}"
}
} ;
-HELP: split-by-slots
-{ $values
- { "accessor-seqs" "a sequence of sequences of tuple accessors" }
- { "quot" quotation }
-}
-{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
-
-HELP: sort-by
-{ $values
- { "seq" sequence } { "sort-seq" "a sequence of comparators" }
- { "sortedseq" sequence }
-}
-{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
-
ARTICLE: "sorting.slots" "Sorting by slots"
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
"Comparing two objects by a sequence of slots:"
{ $subsection compare-slots }
"Sorting a sequence of tuples by a slot/comparator pairs:"
-{ $subsection sort-by-slots }
-"Sorting a sequence by a sequence of comparators:"
-{ $subsection sort-by } ;
+{ $subsection sort-by }
+{ $subsection sort-keys-by }
+{ $subsection sort-values-by } ;
ABOUT: "sorting.slots"
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
- } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+ } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by
] unit-test
[
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
- } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots
+ } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by
] unit-test
-[
- {
- {
- T{ sort-test { a 1 } { b 1 } { c 10 } }
- T{ sort-test { a 1 } { b 1 } { c 11 } }
- }
- { T{ sort-test { a 1 } { b 3 } { c 9 } } }
- {
- T{ sort-test { a 2 } { b 5 } { c 3 } }
- T{ sort-test { a 2 } { b 5 } { c 2 } }
- }
- }
-] [
- {
- T{ sort-test f 1 3 9 }
- T{ sort-test f 1 1 10 }
- T{ sort-test f 1 1 11 }
- T{ sort-test f 2 5 3 }
- T{ sort-test f 2 5 2 }
- }
- { { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep
- [ but-last-slice ] map split-by-slots [ >array ] map
-] unit-test
-
-: split-test ( seq -- seq' )
- { { a>> } { b>> } } split-by-slots ;
-
-[ split-test ] must-infer
-
[ { } ]
-[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
+[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test
[ { } ]
-[ { } { } sort-by-slots ] unit-test
+[ { } { } sort-by ] unit-test
[
{
T{ sort-test f 6 f f T{ tuple2 f 3 } }
T{ sort-test f 5 f f T{ tuple2 f 3 } }
T{ sort-test f 6 f f T{ tuple2 f 2 } }
- } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots
-] unit-test
-
-[
- {
- {
- T{ sort-test
- { a 6 }
- { tuple2 T{ tuple2 { d 1 } } }
- }
- }
- {
- T{ sort-test
- { a 6 }
- { tuple2 T{ tuple2 { d 2 } } }
- }
- }
- {
- T{ sort-test
- { a 5 }
- { tuple2 T{ tuple2 { d 3 } } }
- }
- }
- {
- T{ sort-test
- { a 6 }
- { tuple2 T{ tuple2 { d 3 } } }
- }
- T{ sort-test
- { a 6 }
- { tuple2 T{ tuple2 { d 3 } } }
- }
- }
- {
- T{ sort-test
- { a 5 }
- { tuple2 T{ tuple2 { d 4 } } }
- }
- }
- }
-] [
- {
- T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
- T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
- T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
- T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
- T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
- T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
- } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
+ } { { tuple2>> d>> <=> } { a>> <=> } } sort-by
] unit-test
{ { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
{ length-test<=> <=> } sort-by
] unit-test
+
+[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ]
+[
+ { { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
+ { length-test<=> <=> } sort-keys-by
+] unit-test
+
+[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ]
+[
+ { { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
+ { length-test<=> <=> } sort-values-by
+] unit-test
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit fry kernel macros math.order
-sequences words sorting sequences.deep assocs splitting.monotonic
-math ;
+USING: arrays fry kernel math.order sequences sorting ;
IN: sorting.slots
-<PRIVATE
+: execute-comparator ( obj1 obj2 word -- <=>/f )
+ execute( obj1 obj2 -- <=> ) dup +eq+ eq? [ drop f ] when ;
-: short-circuit-comparator ( obj1 obj2 word -- comparator/? )
- execute dup +eq+ eq? [ drop f ] when ; inline
+: execute-accessor ( obj1 obj2 word -- obj1' obj2' )
+ '[ _ execute( tuple -- value ) ] bi@ ;
-: slot-comparator ( seq -- quot )
- [
- but-last-slice
- [ '[ [ _ execute ] bi@ ] ] map concat
- ] [
- peek
- '[ @ _ short-circuit-comparator ]
- ] bi ;
-
-PRIVATE>
-
-MACRO: compare-slots ( sort-specs -- <=> )
+: compare-slots ( obj1 obj2 sort-specs -- <=> )
#! sort-spec: { accessors comparator }
- [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
-
-MACRO: sort-by-slots ( sort-specs -- quot )
- '[ [ _ compare-slots ] sort ] ;
-
-MACRO: compare-seq ( seq -- quot )
- [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
+ [
+ dup array? [
+ unclip-last-slice
+ [ [ execute-accessor ] each ] dip
+ ] when execute-comparator
+ ] with with map-find drop +eq+ or ;
-MACRO: sort-by ( sort-seq -- quot )
- '[ [ _ compare-seq ] sort ] ;
+: sort-by-with ( seq sort-specs quot -- seq' )
+ swap '[ _ bi@ _ compare-slots ] sort ; inline
-MACRO: sort-keys-by ( sort-seq -- quot )
- '[ [ first ] bi@ _ compare-seq ] sort ;
+: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ;
-MACRO: sort-values-by ( sort-seq -- quot )
- '[ [ second ] bi@ _ compare-seq ] sort ;
+: sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ;
-MACRO: split-by-slots ( accessor-seqs -- quot )
- [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
- '[ [ _ 2&& ] slice monotonic-slice ] ;
+: sort-values-by ( seq sort-seq -- seq' ) [ second ] sort-by-with ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic sequences io words arrays summary effects
continuations assocs accessors namespaces compiler.errors
-stack-checker.values stack-checker.recursive-state ;
+stack-checker.values stack-checker.recursive-state
+source-files.errors compiler.errors ;
IN: stack-checker.errors
: pretty-word ( word -- word' )
TUPLE: inference-error error type word ;
-M: inference-error compiler-error-type type>> ;
+M: inference-error error-type type>> ;
: (inference-error) ( ... class type -- * )
[ boa ] dip
\ inference-error boa rethrow ; inline
: inference-error ( ... class -- * )
- +error+ (inference-error) ; inline
+ +compiler-error+ (inference-error) ; inline
: inference-warning ( ... class -- * )
- +warning+ (inference-error) ; inline
+ +compiler-warning+ (inference-error) ; inline
TUPLE: literal-expected what ;
: unknown-primitive-error ( -- * )
\ unknown-primitive-error inference-warning ;
+
+TUPLE: transform-expansion-error word error ;
+
+: transform-expansion-error ( word error -- * )
+ \ transform-expansion-error inference-error ;
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel prettyprint io debugger
-sequences assocs stack-checker.errors summary effects ;
+sequences assocs stack-checker.errors summary effects make ;
IN: stack-checker.errors.prettyprint
+M: inference-error summary error>> summary ;
+
M: inference-error error-help error>> error-help ;
M: inference-error error.
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
-M: literal-expected error.
- "Got a computed value where a " write what>> write " was expected" print ;
+M: literal-expected summary
+ [ "Got a computed value where a " % what>> % " was expected" % ] "" make ;
+
+M: literal-expected error. summary print ;
+
+M: unbalanced-branches-error summary
+ drop "Unbalanced branches" ;
M: unbalanced-branches-error error.
- "Unbalanced branches:" print
+ dup summary print
[ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
drop
"Quotation pops retain stack elements which it did not push" ;
-M: missing-effect error.
- "The word " write
- word>> pprint
- " must declare a stack effect" print ;
+M: missing-effect summary
+ [
+ "The word " %
+ word>> name>> %
+ " must declare a stack effect" %
+ ] "" make ;
-M: effect-error error.
- "Stack effects of the word " write
- [ word>> pprint " do not match." print ]
- [ "Inferred: " write inferred>> . ]
- [ "Declared: " write declared>> . ] tri ;
+M: effect-error summary
+ [
+ "Stack effect declaration of the word " %
+ word>> name>> % " is wrong" %
+ ] "" make ;
M: recursive-quotation-error error.
"The quotation " write
" calls itself." print
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
-M: undeclared-recursion-error error.
- "The inline recursive word " write
- word>> pprint
- " must be declared recursive" print ;
+M: undeclared-recursion-error summary
+ drop
+ "Inline recursive words must be declared recursive" ;
-M: diverging-recursion-error error.
- "The recursive word " write
- word>> pprint
- " digs arbitrarily deep into the stack" print ;
+M: diverging-recursion-error summary
+ [
+ "The recursive word " %
+ word>> name>> %
+ " digs arbitrarily deep into the stack" %
+ ] "" make ;
-M: unbalanced-recursion-error error.
- "The recursive word " write
- word>> pprint
- " leaves with the stack having the wrong height" print ;
+M: unbalanced-recursion-error summary
+ [
+ "The recursive word " %
+ word>> name>> %
+ " leaves with the stack having the wrong height" %
+ ] "" make ;
-M: inconsistent-recursive-call-error error.
- "The recursive word " write
- word>> pprint
- " calls itself with a different set of quotation parameters than were input" print ;
+M: inconsistent-recursive-call-error summary
+ [
+ "The recursive word " %
+ word>> name>> %
+ " calls itself with a different set of quotation parameters than were input" %
+ ] "" make ;
-M: unknown-primitive-error error.
+M: unknown-primitive-error summary
drop
- "Cannot determine stack effect statically" print ;
+ "Cannot determine stack effect statically" ;
+
+M: transform-expansion-error summary
+ drop
+ "Compiler transform threw an error" ;
+
+M: transform-expansion-error error.
+ [ summary print ]
+ [ "Word: " write word>> . nl ]
+ [ error>> error. ] tri ;
\ No newline at end of file
alien-callback
} [ t "special" set-word-prop ] each
-{ call execute dispatch load-locals get-local drop-locals }
-[ t "no-compile" set-word-prop ] each
+\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
dup called-dependency depends-on
{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
+[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval( -- ) ] unit-test
[ 3 ] [ inference-invalidation-c ] unit-test
\ inference-invalidation-d must-infer
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
+[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval( -- ) ] unit-test
[ [ inference-invalidation-d ] infer ] must-fail
[ forget-test ] must-infer
[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
-[ forget-test ] must-infer
\ No newline at end of file
+[ forget-test ] must-infer
IN: stack-checker.transforms.tests
USING: sequences stack-checker.transforms tools.test math kernel
-quotations stack-checker accessors combinators words arrays
+quotations stack-checker stack-checker.errors accessors combinators words arrays
classes classes.tuple ;
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
: member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ;
[ f ] [ 1.0 member?-test ] unit-test
-[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test
\ No newline at end of file
+[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test
+
+! Macro expansion should throw its own type of error
+: bad-macro ( -- ) ;
+
+\ bad-macro [ "OOPS" throw ] 0 define-transform
+
+[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with
\ No newline at end of file
[ dup infer-word apply-word/effect ]
} cond ;
+: call-transformer ( word stack quot -- newquot )
+ '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
+ [ transform-expansion-error ]
+ recover ;
+
:: ((apply-transform)) ( word quot values stack rstate -- )
rstate recursive-state
- [ stack quot with-datastack first ] with-variable
+ [ word stack quot call-transformer ] with-variable
[
word inlined-dependency depends-on
values [ length meta-d shorten-by ] [ #drop, ] bi
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
-:: spawn-namespace-test ( -- )
+:: spawn-namespace-test ( -- ? )
[let | p [ <promise> ] g [ gensym ] |
[
g "x" set
[ 4 ] [ 3 some-generic ] unit-test
-[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test
+[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test
[ 2 ] [ 3 some-generic ] unit-test
\ another-generic watch
-[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval ] unit-test
+[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval( -- ) ] unit-test
[ ] [ \ another-generic reset ] unit-test
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
definitions compiler.units namespaces assocs tools.walker
-tools.time generic inspector fry ;
+tools.time generic inspector fry tools.continuations ;
IN: tools.annotations
GENERIC: reset ( word -- )
USING: accessors kernel arrays sequences math namespaces
strings io fry vectors words assocs combinators sorting
unicode.case unicode.categories math.order vocabs
-tools.vocabs unicode.data ;
+tools.vocabs unicode.data locals ;
IN: tools.completion
-: (fuzzy) ( accum ch i full -- accum i ? )
- index-from
- [
- [ swap push ] 2keep 1+ t
+:: (fuzzy) ( accum i full ch -- accum i full ? )
+ ch i full index-from [
+ :> i i accum push
+ accum i 1+ full t
] [
- drop f -1 f
+ f -1 full f
] if* ;
: fuzzy ( full short -- indices )
- dup length <vector> -rot 0 -rot
- [ -rot [ (fuzzy) ] keep swap ] all? 3drop ;
+ dup [ length <vector> 0 ] curry 2dip
+ [ (fuzzy) ] all? 3drop ;
: (runs) ( runs n seq -- runs n )
[
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: threads kernel namespaces continuations combinators
+sequences math namespaces.private continuations.private
+concurrency.messaging quotations kernel.private words
+sequences.private assocs models models.arrow arrays accessors
+generic generic.standard definitions make sbufs ;
+IN: tools.continuations
+
+<PRIVATE
+
+: after-break ( object -- )
+ {
+ { [ dup continuation? ] [ (continue) ] }
+ { [ dup not ] [ "Single stepping abandoned" rethrow ] }
+ } cond ;
+
+PRIVATE>
+
+SYMBOL: break-hook
+
+: break ( -- )
+ continuation callstack >>call
+ break-hook get call( continuation -- continuation' )
+ after-break ;
+
+\ break t "break?" set-word-prop
+
+GENERIC: add-breakpoint ( quot -- quot' )
+
+<PRIVATE
+
+M: callable add-breakpoint
+ dup [ break ] head? [ \ break prefix ] unless ;
+
+M: array add-breakpoint
+ [ add-breakpoint ] map ;
+
+M: object add-breakpoint ;
+
+: (step-into-quot) ( quot -- ) add-breakpoint call ;
+
+: (step-into-dip) ( quot -- ) add-breakpoint dip ;
+
+: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
+
+: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
+
+: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
+
+: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
+
+: (step-into-execute) ( word -- )
+ {
+ { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
+ { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup uses \ suspend swap member? ] [ execute break ] }
+ { [ dup primitive? ] [ execute break ] }
+ [ def>> (step-into-quot) ]
+ } cond ;
+
+\ (step-into-execute) t "step-into?" set-word-prop
+
+: (step-into-continuation) ( -- )
+ continuation callstack >>call break ;
+
+: (step-into-call-next-method) ( method -- )
+ next-method-quot (step-into-quot) ;
+
+<< {
+ (step-into-quot)
+ (step-into-dip)
+ (step-into-2dip)
+ (step-into-3dip)
+ (step-into-if)
+ (step-into-dispatch)
+ (step-into-execute)
+ (step-into-continuation)
+ (step-into-call-next-method)
+} [ t "no-compile" set-word-prop ] each >>
+
+: change-frame ( continuation quot -- continuation' )
+ #! Applies quot to innermost call frame of the
+ #! continuation.
+ [ clone ] dip [
+ [ clone ] dip
+ [
+ [
+ [ innermost-frame-scan 1+ ]
+ [ innermost-frame-quot ] bi
+ ] dip call
+ ]
+ [ drop set-innermost-frame-quot ]
+ [ drop ]
+ 2tri
+ ] curry change-call ; inline
+
+PRIVATE>
+
+: continuation-step ( continuation -- continuation' )
+ [
+ 2dup length = [ nip [ break ] append ] [
+ 2dup nth \ break = [ nip ] [
+ swap 1+ cut [ break ] glue
+ ] if
+ ] if
+ ] change-frame ;
+
+: continuation-step-out ( continuation -- continuation' )
+ [ nip \ break suffix ] change-frame ;
+
+
+{
+ { call [ (step-into-quot) ] }
+ { dip [ (step-into-dip) ] }
+ { 2dip [ (step-into-2dip) ] }
+ { 3dip [ (step-into-3dip) ] }
+ { execute [ (step-into-execute) ] }
+ { if [ (step-into-if) ] }
+ { dispatch [ (step-into-dispatch) ] }
+ { continuation [ (step-into-continuation) ] }
+ { (call-next-method) [ (step-into-call-next-method) ] }
+} [ "step-into" set-word-prop ] assoc-each
+
+! Never step into these words
+: don't-step-into ( word -- )
+ dup [ execute break ] curry "step-into" set-word-prop ;
+
+{
+ >n ndrop >c c>
+ continue continue-with
+ stop suspend (spawn)
+} [ don't-step-into ] each
+
+\ break [ break ] "step-into" set-word-prop
+
+: continuation-step-into ( continuation -- continuation' )
+ [
+ swap cut [
+ swap %
+ [ \ break , ] [
+ unclip {
+ { [ dup \ break eq? ] [ , ] }
+ { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+ { [ dup array? ] [ add-breakpoint , \ break , ] }
+ { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+ [ , \ break , ]
+ } cond %
+ ] if-empty
+ ] [ ] make
+ ] change-frame ;
+
+: continuation-current ( continuation -- obj )
+ call>>
+ [ innermost-frame-scan 1+ ]
+ [ innermost-frame-quot ] bi ?nth ;
: finish-deploy ( final-image -- )
"Finishing up" show
- [ { } set-datastack ] dip
- { } set-retainstack
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
- [ save-image-and-exit ] call-clear ;
+ save-image-and-exit ;
SYMBOL: deploy-vocab
[:c]
[print-error]
'[
- [ _ execute ] [
- _ execute nl
- _ execute
+ [ _ execute( obj -- ) ] [
+ _ execute( obj -- ) nl
+ _ execute( obj -- )
] recover
] %
] if
: deploy-error-handler ( quot -- )
[
strip-debugger?
- [ error-continuation get call>> callstack>array die ]
+ [ error-continuation get call>> callstack>array die 1 exit ]
! Don't reference these words literally, if we're stripping the
! debugger out we don't want to load the prettyprinter at all
- [ [:c] execute nl [print-error] execute flush ] if
+ [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
1 exit
] recover ; inline
USING: eval ;
IN: tools.deploy.test.11
-: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval ;
+: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval( -- ) ;
MAIN: foo
\ No newline at end of file
M: integer my-generic sq ;
-M: fixnum my-generic call-next-method my-var get call ;
+M: fixnum my-generic call-next-method my-var get call( a -- b ) ;
: test-7 ( -- )
[ 1 + ] my-var set-global
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: tools.errors
+USING: help.markup help.syntax source-files.errors words io
+compiler.errors ;
+
+ARTICLE: "compiler-errors" "Compiler warnings and errors"
+"After loading a vocabulary, you might see messages like:"
+{ $code
+ ":errors - print 2 compiler errors"
+ ":warnings - print 50 compiler warnings"
+}
+"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "."
+$nl
+"Words to view warnings and errors:"
+{ $subsection :warnings }
+{ $subsection :errors }
+{ $subsection :linkage }
+"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ;
+
+HELP: compiler-error
+{ $values { "error" "an error" } { "word" word } }
+{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ;
+
+HELP: :errors
+{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
+
+HELP: :warnings
+{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
+
+HELP: :linkage
+{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
+
+{ :errors :warnings :linkage } related-words
+
+HELP: errors.
+{ $values { "errors" "a sequence of " { $link source-file-error } " instances" } }
+{ $description "Prints a list of errors, grouped by source file." } ;
+
+ARTICLE: "tools.errors" "Batch error reporting"
+"Some tools, such as the " { $link "compiler" } ", " { $link "tools.test" } " and " { $link "help.lint" } " need to report multiple errors at a time. Each error is associated with a source file, line number, and optionally, a definition. " { $link "errors" } " cannot be used for this purpose, so the " { $vocab-link "source-files.errors" } " vocabulary provides an alternative mechanism. Note that the words in this vocabulary are used for implementation only; to actually list errors, consult the documentation for the relevant tools."
+$nl
+"Source file errors inherit from a class:"
+{ $subsection source-file-error }
+"Printing an error summary:"
+{ $subsection error-summary }
+"Printing a list of errors:"
+{ $subsection errors. }
+"Batch errors are reported in the " { $link "ui.tools.error-list" } "." ;
+
+ABOUT: "tools.errors"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs debugger io kernel sequences source-files.errors
+summary accessors continuations make math.parser io.styles namespaces
+compiler.errors ;
+IN: tools.errors
+
+#! Tools for source-files.errors. Used by tools.tests and others
+#! for error reporting
+
+M: source-file-error compute-restarts
+ error>> compute-restarts ;
+
+M: source-file-error error-help
+ error>> error-help ;
+
+M: source-file-error summary
+ [
+ [ file>> [ % ": " % ] [ "<Listener input>" % ] if* ]
+ [ line#>> [ # ] when* ] bi
+ ] "" make
+ ;
+
+M: source-file-error error.
+ [ summary print nl ] [ error>> error. ] bi ;
+
+: errors. ( errors -- )
+ group-by-source-file sort-errors
+ [
+ [ nl "==== " write print nl ]
+ [ [ nl ] [ error. ] interleave ]
+ bi*
+ ] assoc-each ;
+
+: compiler-errors. ( type -- )
+ errors-of-type values errors. ;
+
+: :errors ( -- ) +compiler-error+ compiler-errors. ;
+
+: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
+
+: :linkage ( -- ) +linkage-error+ compiler-errors. ;
\ No newline at end of file
: list-files-slow ( listing-tool -- array )
[ path>> ] [ sort>> ] [ specs>> ] tri '[
[ dup name>> file-info file-listing boa ] map
- _ [ sort-by-slots ] when*
+ _ [ sort-by ] when*
[ _ [ file-spec>string ] with map ] map
] with-directory-entries ; inline
IN: tools.profiler
: profile ( quot -- )
- [ t profiling call ] [ f profiling ] [ ] cleanup ;
+ [ t profiling call ] [ f profiling ] [ ] cleanup ; inline
: filter-counts ( alist -- alist' )
[ second 0 > ] filter ;
vocabs.loader io combinators calendar accessors math.parser
io.streams.string ui.tools.operations quotations strings arrays
prettyprint words vocabs sorting sets classes math alien urls
-splitting ascii combinators.short-circuit alarms words.symbol ;
+splitting ascii combinators.short-circuit alarms words.symbol
+system ;
IN: tools.scaffold
SYMBOL: developer-name
: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
+: ensure-vocab-exists ( string -- string )
+ dup vocabs member? [ no-vocab ] unless ;
+
: check-vocab-name ( string -- string )
[ ]
[ contains-dot? [ vocab-name-contains-dot ] when ]
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
: scaffold-help ( vocab -- )
+ ensure-vocab-exists
[
dup "-docs.factor" vocab/suffix>path scaffolding? [
set-scaffold-docs-file
PRIVATE>
: scaffold-tests ( vocab -- )
+ ensure-vocab-exists
dup "-tests.factor" vocab/suffix>path
scaffolding? [
set-scaffold-tests-file
[ home ] dip append-path
[ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
-: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ;
+: scaffold-factor-boot-rc ( -- )
+ os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ;
-: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ;
+: scaffold-factor-rc ( -- )
+ os windows? "factor-rc" ".factor-rc" ? scaffold-rc ;
: scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
ARTICLE: "tools.test.write" "Writing unit tests"
"Assert that a quotation outputs a specific set of values:"
-{ $subsection unit-test }
+{ $subsection POSTPONE: unit-test }
"Assert that a quotation throws an error:"
-{ $subsection must-fail }
-{ $subsection must-fail-with }
+{ $subsection POSTPONE: must-fail }
+{ $subsection POSTPONE: must-fail-with }
"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):"
-{ $subsection must-infer }
-{ $subsection must-infer-as } ;
+{ $subsection POSTPONE: must-infer }
+{ $subsection POSTPONE: must-infer-as }
+"All of the above are used like ordinary words but are actually parsing words. This ensures that parse-time state, namely the line number, can be associated with the test in question, and reported in test failures." ;
ARTICLE: "tools.test.run" "Running unit tests"
"The following words run test harness files; any test failures are collected and printed at the end:"
{ $subsection test }
-{ $subsection test-all } ;
-
-ARTICLE: "tools.test.failure" "Handling test failures"
-"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "."
-$nl
-"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:"
-{ $list
- { { $snippet "error" } " - the error thrown by the unit test" }
- { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" }
- { { $snippet "continuation" } " - the traceback at the point of the error" }
-}
-"The following words run test harness files and output failures:"
-{ $subsection run-tests }
-{ $subsection run-all-tests }
+{ $subsection test-all }
"The following word prints failures:"
-{ $subsection test-failures. } ;
+{ $subsection :test-failures }
+"Test failures are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "."
+$nl
+"Unit test failures are instances of a class, and are stored in a global variable:"
+{ $subsection test-failure }
+{ $subsection test-failures } ;
ARTICLE: "tools.test" "Unit testing"
"A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract."
$nl
"If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested."
{ $subsection "tools.test.write" }
-{ $subsection "tools.test.run" }
-{ $subsection "tools.test.failure" } ;
+{ $subsection "tools.test.run" } ;
ABOUT: "tools.test"
HELP: unit-test
+{ $syntax "[ output ] [ input ] unit-test" }
{ $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } }
{ $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ;
{ $values { "prefix" "a vocabulary name" } }
{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ;
-HELP: run-tests
-{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
-{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
-
HELP: test-all
{ $description "Runs unit tests for all loaded vocabularies." } ;
-HELP: run-all-tests
-{ $values { "failures" "an association list of unit test failures" } }
-{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
-
-HELP: test-failures.
-{ $values { "assoc" "an association list of unit test failures" } }
-{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ;
+HELP: :test-failures
+{ $description "Prints all pending unit test failures." } ;
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces arrays prettyprint sequences kernel
-vectors quotations words parser assocs combinators continuations
-debugger io io.styles io.files vocabs vocabs.loader source-files
-compiler.units summary stack-checker effects tools.vocabs fry ;
+USING: accessors arrays assocs combinators compiler.units
+continuations debugger effects fry generalizations io io.files
+io.styles kernel lexer locals macros math.parser namespaces
+parser prettyprint quotations sequences source-files splitting
+stack-checker summary unicode.case vectors vocabs vocabs.loader words
+tools.vocabs tools.errors source-files.errors io.streams.string make
+compiler.errors ;
IN: tools.test
-SYMBOL: failures
+TUPLE: test-failure < source-file-error continuation ;
-: <failure> ( error what -- triple )
- error-continuation get 3array ;
+SYMBOL: +test-failure+
-: failure ( error what -- )
+M: test-failure error-type drop +test-failure+ ;
+
+SYMBOL: test-failures
+
+test-failures [ V{ } clone ] initialize
+
+T{ error-type
+ { type +test-failure+ }
+ { word ":test-failures" }
+ { plural "unit test failures" }
+ { icon "vocab:ui/tools/error-list/icons/unit-test-error.tiff" }
+ { quot [ test-failures get ] }
+} define-error-type
+
+<PRIVATE
+
+: <test-failure> ( error experiment file line# -- triple )
+ test-failure new
+ swap >>line#
+ swap >>file
+ swap >>asset
+ swap >>error
+ error-continuation get >>continuation ;
+
+: failure ( error experiment file line# -- )
"--> test failed!" print
- <failure> failures get push ;
+ <test-failure> test-failures get push
+ notify-error-observers ;
-SYMBOL: this-test
+SYMBOL: file
-: (unit-test) ( what quot -- )
- swap dup . flush this-test set
- failures get [
- [ this-test get failure ] recover
- ] [
- call
- ] if ; inline
+: file-failure ( error -- )
+ f file get f failure ;
-: unit-test ( output input -- )
- [ 2array ] 2keep '[
- _ { } _ with-datastack swap >array assert=
- ] (unit-test) ;
+:: (unit-test) ( output input -- error ? )
+ [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline
: short-effect ( effect -- pair )
[ in>> length ] [ out>> length ] bi 2array ;
-: must-infer-as ( effect quot -- )
- [ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
+:: (must-infer-as) ( effect quot -- error ? )
+ [ quot infer short-effect effect assert= f f ] [ t ] recover ; inline
+
+:: (must-infer) ( word/quot -- error ? )
+ word/quot dup word? [ '[ _ execute ] ] when :> quot
+ [ quot infer drop f f ] [ t ] recover ; inline
+
+TUPLE: did-not-fail ;
+CONSTANT: did-not-fail T{ did-not-fail }
+
+M: did-not-fail summary drop "Did not fail" ;
+
+:: (must-fail-with) ( quot pred -- error ? )
+ [ quot call did-not-fail t ]
+ [ dup pred call [ drop f f ] [ t ] if ] recover ; inline
+
+:: (must-fail) ( quot -- error ? )
+ [ quot call did-not-fail t ] [ drop f f ] recover ; inline
-: must-infer ( word/quot -- )
- dup word? [ 1quotation ] when
- '[ _ infer drop ] [ ] swap unit-test ;
+: experiment-title ( word -- string )
+ "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;
-: must-fail-with ( quot pred -- )
- [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
+MACRO: <experiment> ( word -- )
+ [ stack-effect in>> length dup ]
+ [ name>> experiment-title ] bi
+ '[ _ ndup _ narray _ prefix ] ;
-: must-fail ( quot -- )
- [ drop t ] must-fail-with ;
+: experiment. ( seq -- )
+ [ first write ": " write ] [ rest . ] bi ;
-: (run-test) ( vocab -- )
+:: experiment ( word: ( -- error ? ) line# -- )
+ word <experiment> :> e
+ e experiment.
+ word execute [
+ file get [
+ e file get line# failure
+ ] [ rethrow ] if
+ ] [ drop ] if ; inline
+
+: parse-test ( accum word -- accum )
+ literalize parsed
+ lexer get line>> parsed
+ \ experiment parsed ; inline
+
+<<
+
+SYNTAX: TEST:
+ scan
+ [ create-in ]
+ [ "(" ")" surround search '[ _ parse-test ] ] bi
+ define-syntax ;
+
+>>
+
+: run-test-file ( path -- )
+ dup file [
+ test-failures get file get +test-failure+ delete-file-errors
+ '[ _ run-file ] [ file-failure ] recover
+ ] with-variable ;
+
+: run-vocab-tests ( vocab -- )
dup vocab source-loaded?>> [
- vocab-tests [ run-file ] each
+ vocab-tests [ run-test-file ] each
] [ drop ] if ;
-: run-test ( vocab -- failures )
- V{ } clone [
- failures [
- [ (run-test) ] [ swap failure ] recover
- ] with-variable
- ] keep ;
-
-: failure. ( triple -- )
- dup second .
- dup first print-error
- "Traceback" swap third write-object ;
-
-: test-failures. ( assoc -- )
- [
- nl
- [
- "==== ALL TESTS PASSED" print
- ] [
- "==== FAILING TESTS:" print
- [
- swap vocab-heading.
- [ failure. nl ] each
- ] assoc-each
- ] if-empty
- ] [
- "==== NOTHING TO TEST" print
- ] if* ;
-
-: run-tests ( prefix -- failures )
- child-vocabs [ f ] [
- [ dup run-test ] { } map>assoc
- [ second empty? not ] filter
- ] if-empty ;
+: traceback-button. ( failure -- )
+ "[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
-: test ( prefix -- )
- run-tests test-failures. ;
+PRIVATE>
+
+TEST: unit-test
+TEST: must-infer-as
+TEST: must-infer
+TEST: must-fail-with
+TEST: must-fail
+
+M: test-failure error. ( error -- )
+ {
+ [ summary print nl ]
+ [ asset>> [ experiment. nl ] when* ]
+ [ error>> error. ]
+ [ traceback-button. ]
+ } cleave ;
-: run-all-tests ( -- failures )
- "" run-tests ;
+: :test-failures ( -- ) test-failures get errors. ;
+
+: test ( prefix -- )
+ child-vocabs [ run-vocab-tests ] each ;
-: test-all ( -- )
- run-all-tests test-failures. ;
+: test-all ( -- ) "" test ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: tools.trace.tests
+USING: tools.trace tools.test sequences ;
+
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.promises models tools.continuations kernel
+sequences concurrency.messaging locals continuations threads
+namespaces namespaces.private make assocs accessors io strings
+prettyprint math math.parser words effects summary io.styles classes
+generic.math combinators.short-circuit ;
+IN: tools.trace
+
+: callstack-depth ( callstack -- n )
+ callstack>array length 2/ ;
+
+SYMBOL: end
+
+SYMBOL: exclude-vocabs
+SYMBOL: include-vocabs
+
+exclude-vocabs { "math" "accessors" } swap set-global
+
+: include? ( vocab -- ? )
+ include-vocabs get dup [ member? ] [ 2drop t ] if ;
+
+: exclude? ( vocab -- ? )
+ exclude-vocabs get dup [ member? ] [ 2drop f ] if ;
+
+: into? ( obj -- ? )
+ {
+ [ word? ]
+ [ predicate? not ]
+ [ math-generic? not ]
+ [
+ {
+ [ inline? ]
+ [
+ {
+ [ vocabulary>> include? ]
+ [ vocabulary>> exclude? not ]
+ } 1&&
+ ]
+ } 1||
+ ]
+ } 1&& ;
+
+TUPLE: trace-step word inputs ;
+
+M: trace-step summary
+ [
+ [ "Word: " % word>> name>> % ]
+ [ " -- inputs: " % inputs>> unparse-short % ] bi
+ ] "" make ;
+
+: <trace-step> ( continuation word -- trace-step )
+ [ nip ] [ [ data>> ] [ stack-effect in>> length ] bi* short tail* ] 2bi
+ \ trace-step boa ;
+
+: print-step ( continuation -- )
+ dup continuation-current dup word? [
+ [ nip name>> ] [ <trace-step> ] 2bi write-object nl
+ ] [
+ nip short.
+ ] if ;
+
+: print-depth ( continuation -- )
+ call>> callstack-depth
+ [ CHAR: \s <string> write ]
+ [ number>string write ": " write ] bi ;
+
+: trace-step ( continuation -- continuation' )
+ dup continuation-current end eq? [
+ [ print-depth ]
+ [ print-step ]
+ [
+ dup continuation-current into?
+ [ continuation-step-into ] [ continuation-step ] if
+ ] tri
+ ] unless ;
+
+: trace ( quot -- data )
+ [ [ trace-step ] break-hook ] dip
+ [ break ] [ end drop ] surround
+ with-variable ;
+
+<< \ trace t "no-compile" set-word-prop >>
\ No newline at end of file
recover\r
] each\r
failures get\r
- ] with-compiler-errors ;\r
+ ] with-scope ;\r
\r
: source-modified? ( path -- ? )\r
dup source-files get at [\r
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: concurrency.promises models tools.walker kernel
-sequences concurrency.messaging locals continuations
-threads namespaces namespaces.private assocs accessors ;
+USING: concurrency.promises models tools.walker tools.continuations
+kernel sequences concurrency.messaging locals continuations threads
+namespaces namespaces.private assocs accessors ;
IN: tools.walker.debug
:: test-walker ( quot -- data )
USING: tools.walker io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
continuations math.parser threads arrays tools.walker.debug
-generic.standard sequences.private kernel.private ;
+generic.standard sequences.private kernel.private
+tools.continuations accessors words ;
IN: tools.walker.tests
[ { } ] [
[ { } ] [
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
] unit-test
+
+: breakpoint-test ( -- x ) break 1 2 + ;
+
+\ breakpoint-test don't-step-into
+
+[ f ] [ \ breakpoint-test optimized>> ] unit-test
+
+[ { 3 } ] [ [ breakpoint-test ] test-walker ] unit-test
+
+GENERIC: method-breakpoint-test ( x -- y )
+
+TUPLE: method-breakpoint-tuple ;
+
+M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
+
+\ method-breakpoint-test don't-step-into
+
+[ { 3 } ]
+[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
\ No newline at end of file
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors
-generic generic.standard definitions make sbufs ;
+generic generic.standard definitions make sbufs
+tools.continuations parser ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
2dup start-walker-thread
] if* ;
-: show-walker ( -- thread )
- get-walker-thread
- [ show-walker-hook get call ] keep ;
-
-: after-break ( object -- )
- {
- { [ dup continuation? ] [ (continue) ] }
- { [ dup quotation? ] [ call ] }
- { [ dup not ] [ "Single stepping abandoned" rethrow ] }
- } cond ;
-
-: break ( -- )
- continuation callstack >>call
- show-walker send-synchronous
- after-break ;
-
-\ break t "break?" set-word-prop
-
: walk ( quot -- quot' )
\ break prefix [ break rethrow ] recover ;
-GENERIC: add-breakpoint ( quot -- quot' )
-
-M: callable add-breakpoint
- dup [ break ] head? [ \ break prefix ] unless ;
-
-M: array add-breakpoint
- [ add-breakpoint ] map ;
-
-M: object add-breakpoint ;
-
-: (step-into-quot) ( quot -- ) add-breakpoint call ;
-
-: (step-into-dip) ( quot -- ) add-breakpoint dip ;
-
-: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
-
-: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
-
-: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
-
-: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
-
-: (step-into-execute) ( word -- )
- {
- { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
- { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
- { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
- { [ dup uses \ suspend swap member? ] [ execute break ] }
- { [ dup primitive? ] [ execute break ] }
- [ def>> (step-into-quot) ]
- } cond ;
+<< \ walk t "no-compile" set-word-prop >>
-\ (step-into-execute) t "step-into?" set-word-prop
-
-: (step-into-continuation) ( -- )
- continuation callstack >>call break ;
-
-: (step-into-call-next-method) ( method -- )
- next-method-quot (step-into-quot) ;
+break-hook [
+ [
+ get-walker-thread
+ [ show-walker-hook get call ] keep
+ send-synchronous
+ ]
+] initialize
! Messages sent to walker thread
SYMBOL: step
SYMBOL: +suspended+
SYMBOL: +stopped+
-: change-frame ( continuation quot -- continuation' )
- #! Applies quot to innermost call frame of the
- #! continuation.
- [ clone ] dip [
- [ clone ] dip
- [
- [
- [ innermost-frame-scan 1+ ]
- [ innermost-frame-quot ] bi
- ] dip call
- ]
- [ drop set-innermost-frame-quot ]
- [ drop ]
- 2tri
- ] curry change-call ; inline
-
-: step-msg ( continuation -- continuation' ) USE: io
- [
- 2dup length = [ nip [ break ] append ] [
- 2dup nth \ break = [ nip ] [
- swap 1+ cut [ break ] glue
- ] if
- ] if
- ] change-frame ;
-
-: step-out-msg ( continuation -- continuation' )
- [ nip \ break suffix ] change-frame ;
-
-{
- { call [ (step-into-quot) ] }
- { dip [ (step-into-dip) ] }
- { 2dip [ (step-into-2dip) ] }
- { 3dip [ (step-into-3dip) ] }
- { execute [ (step-into-execute) ] }
- { if [ (step-into-if) ] }
- { dispatch [ (step-into-dispatch) ] }
- { continuation [ (step-into-continuation) ] }
- { (call-next-method) [ (step-into-call-next-method) ] }
-} [ "step-into" set-word-prop ] assoc-each
-
-! Never step into these words
-{
- >n ndrop >c c>
- continue continue-with
- stop suspend (spawn)
-} [
- dup [ execute break ] curry
- "step-into" set-word-prop
-] each
-
-\ break [ break ] "step-into" set-word-prop
-
-: step-into-msg ( continuation -- continuation' )
- [
- swap cut [
- swap %
- [ \ break , ] [
- unclip {
- { [ dup \ break eq? ] [ , ] }
- { [ dup quotation? ] [ add-breakpoint , \ break , ] }
- { [ dup array? ] [ add-breakpoint , \ break , ] }
- { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
- [ , \ break , ]
- } cond %
- ] if-empty
- ] [ ] make
- ] change-frame ;
-
: status ( -- symbol )
walker-status tget value>> ;
{ f [ +stopped+ set-status f ] }
[
[ walker-continuation tget set-model ]
- [ step-into-msg ] bi
+ [ continuation-step-into ] bi
]
} case
] handle-synchronous
] while ;
-: step-back-msg ( continuation -- continuation' )
+: continuation-step-back ( continuation -- continuation' )
walker-history tget
[ pop* ]
[ [ nip pop ] unless-empty ] bi ;
{
! These are sent by the walker tool. We reply
! and keep cycling.
- { step [ step-msg keep-running ] }
- { step-out [ step-out-msg keep-running ] }
- { step-into [ step-into-msg keep-running ] }
+ { step [ continuation-step keep-running ] }
+ { step-out [ continuation-step-out keep-running ] }
+ { step-into [ continuation-step-into keep-running ] }
{ step-all [ keep-running ] }
{ step-into-all [ step-into-all-loop ] }
{ abandon [ drop f keep-running ] }
! Pass quotation to debugged thread
{ call-in [ keep-running ] }
! Pass previous continuation to debugged thread
- { step-back [ step-back-msg ] }
+ { step-back [ continuation-step-back ] }
} case f
] handle-synchronous
] while ;
-
+
: walker-loop ( -- )
+running+ set-status
[ status +stopped+ eq? ] [
! For convenience
IN: syntax
-: B ( -- ) break ;
+SYNTAX: B \ break parsed ;
! Service support; evaluate Factor code from other apps
:: do-service ( pboard error quot -- )
pboard error ?pasteboard-string
- dup [ quot call ] when
+ dup [ quot call( string -- result/f ) ] when
[ pboard set-pasteboard-string ] when* ;
CLASS: {
USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
ui.gadgets.private ui.gestures ui.backend ui.clipboards
ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
-namespaces opengl sequences strings x11.xlib x11.events x11.xim
-x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
-io.encodings.ascii io.encodings.utf8 combinators command-line
-math.vectors classes.tuple opengl.gl threads math.rectangles
-environment ascii ;
+namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
+x11.glx x11.clipboard x11.constants x11.windows x11.io
+io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
+command-line math.vectors classes.tuple opengl.gl threads
+math.rectangles environment ascii ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
QueuedAfterFlush events-queued 0 > [
next-event dup
None XFilterEvent 0 = [ drop wait-event ] unless
- ] [ ui-wait wait-event ] if ;
+ ] [ wait-for-display wait-event ] if ;
M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel locals math math.order math.vectors
+USING: arrays kernel locals math math.functions math.order math.vectors
sequences ui.gadgets accessors combinators ;
IN: ui.baseline-alignment
[ dup [ 2dup - ] [ f ] if ] dip
gadget-metrics boa ; inline
+: ?supremum ( seq -- n/f )
+ sift [ f ] [ supremum ] if-empty ;
+
: max-ascent ( seq -- n )
- 0 [ ascent>> [ max ] when* ] reduce ; inline
+ [ ascent>> ] map ?supremum ;
: max-cap-height ( seq -- n )
- 0 [ cap-height>> [ max ] when* ] reduce ; inline
+ [ cap-height>> ] map ?supremum ;
: max-descent ( seq -- n )
- 0 [ descent>> [ max ] when* ] reduce ; inline
+ [ descent>> ] map ?supremum ;
: max-text-height ( seq -- y )
- 0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ;
+ [ ascent>> ] filter [ height>> ] map ?supremum ;
: max-graphics-height ( seq -- y )
- 0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ;
-
-: (align-baselines) ( y max leading -- y' ) [ swap - ] dip + ;
+ [ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;
:: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
- cap-height 2 / :> mid-line
- graphics-height 2 /
- [ ascent mid-line - max mid-line + >integer ]
- [ descent mid-line + max mid-line - >integer ] bi ;
+ ascent [
+ cap-height 2 / :> mid-line
+ graphics-height 2 /
+ [ ascent mid-line - max mid-line + floor >integer ]
+ [ descent mid-line + max mid-line - ceiling >integer ] bi
+ ] [ f f ] if ;
+
+: (measure-metrics) ( children sizes -- graphics-height ascent descent cap-height )
+ [ <gadget-metrics> ] 2map
+ {
+ [ max-graphics-height ]
+ [ max-ascent ]
+ [ max-descent ]
+ [ max-cap-height ]
+ } cleave ;
PRIVATE>
:: align-baselines ( gadgets -- ys )
gadgets [ dup pref-dim <gadget-metrics> ] map
- dup max-ascent :> max-ascent
- dup max-cap-height :> max-cap-height
+ dup max-ascent 0 or :> max-ascent
+ dup max-cap-height 0 or :> max-cap-height
dup max-graphics-height :> max-graphics-height
max-cap-height max-graphics-height + 2 /i :> critical-line
[
dup ascent>>
- [ ascent>> max-ascent text-leading ]
- [ height>> max-graphics-height graphics-leading ] if
- (align-baselines)
+ [ ascent>> max-ascent swap - text-leading ]
+ [ height>> max-graphics-height swap - 2/ graphics-leading ] if +
] map ;
: measure-metrics ( children sizes -- ascent descent )
- [ <gadget-metrics> ] 2map
- {
- [ max-graphics-height ]
- [ max-ascent ]
- [ max-descent ]
- [ max-cap-height ]
- } cleave
- combine-metrics ;
+ (measure-metrics) combine-metrics ;
: measure-height ( children sizes -- height )
- measure-metrics + ;
\ No newline at end of file
+ (measure-metrics) dup [ combine-metrics + ] [ 3drop ] if ;
\ No newline at end of file
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry ;
+concurrency.flags math.order math.rectangles fry locals ;
IN: ui.gadgets
! Values for orientation slot
: ((fast-children-on)) ( gadget dim axis -- <=> )
[ swap loc>> v- ] dip v. 0 <=> ;
-: (fast-children-on) ( dim axis children -- i )
- -rot '[ _ _ ((fast-children-on)) ] search drop ;
+:: (fast-children-on) ( dim axis children -- i )
+ children [ dim axis ((fast-children-on)) ] search drop ;
PRIVATE>
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ui.images ui.pens
-ui.pens.image ui.gadgets ;
+ui.pens.image ui.gadgets ui.gadgets.labels ;
IN: ui.gadgets.icons
TUPLE: icon < gadget ;
: <icon> ( image-name -- icon )
icon new swap <image-pen> t >>fill? >>interior ;
-M: icon pref-dim* dup interior>> pen-pref-dim ;
\ No newline at end of file
+M: icon pref-dim* dup interior>> pen-pref-dim ;
+
+M: image-name >label <icon> ;
\ No newline at end of file
[ ] [ "g" get prefer ] unit-test
-[ ] [ "g" get layout ] unit-test
\ No newline at end of file
+[ ] [ "g" get layout ] unit-test
+
+! Baseline alignment without any text gadgets should behave like align=1/2
+<shelf> +baseline+ >>align
+ <gadget> { 30 30 } >>dim add-gadget
+ <gadget> { 30 20 } >>dim add-gadget
+"g" set
+
+[ { 60 30 } ] [ "g" get pref-dim ] unit-test
+
+[ ] [ "g" get prefer ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 30 5 } } ]
+[ "g" get children>> [ loc>> ] map ] unit-test
+
+<shelf> +baseline+ >>align
+<gadget> { 30 30 } >>dim add-gadget
+10 10 { 10 10 } <baseline-gadget> add-gadget
+"g" set
+
+[ ] [ "g" get prefer ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 30 10 } } ]
+[ "g" get children>> [ loc>> ] map ] unit-test
+
+<shelf> +baseline+ >>align
+<shelf> <gadget> { 30 30 } >>dim add-gadget add-gadget
+10 10 { 10 10 } <baseline-gadget> add-gadget
+"g" set
+
+[ ] [ "g" get prefer ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 30 10 } } ]
+[ "g" get children>> [ loc>> ] map ] unit-test
+
+<shelf> +baseline+ >>align
+<gadget> { 24 24 } >>dim add-gadget
+12 9 { 15 15 } <baseline-gadget> add-gadget
+"g" set
+
+[ { 39 24 } ] [ "g" get pref-dim ] unit-test
\ No newline at end of file
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences ui.gadgets ui.baseline-alignment kernel math
-math.functions math.vectors math.order math.rectangles namespaces
-accessors fry combinators arrays ;
+USING: sequences ui.gadgets ui.baseline-alignment
+ui.baseline-alignment.private kernel math math.functions math.vectors
+math.order math.rectangles namespaces accessors fry combinators arrays ;
IN: ui.gadgets.packs
TUPLE: pack < gadget
children>> dup pref-dims measure-metrics drop ;
: pack-cap-height ( pack -- n )
- children>> [ cap-height ] map sift
- [ f ] [ supremum ] if-empty ;
+ children>> [ cap-height ] map ?supremum ;
PRIVATE>
kernel sequences io io.styles io.streams.string tools.test
prettyprint definitions help help.syntax help.markup
help.stylesheet splitting ui.gadgets.debug models math summary
-inspector accessors help.topics see ;
+inspector accessors help.topics see fry ;
IN: ui.gadgets.panes.tests
: #children ( -- n ) "pane" get children>> length ;
[ t ] [ #children "num-children" get = ] unit-test
: test-gadget-text ( quot -- ? )
- dup make-pane gadget-text dup print "======" print
- swap with-string-writer dup print = ;
+ '[ _ call( -- ) ]
+ [ make-pane gadget-text dup print "======" print ]
+ [ with-string-writer dup print ] bi = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
[ { 0 0 } ] [ "a" get loc>> ] unit-test
-[ { 45 15 } ] [ "b" get loc>> ] unit-test
+[ { 45 7 } ] [ "b" get loc>> ] unit-test
[ { 0 30 } ] [ "c" get loc>> ] unit-test
TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- )
- [ [ dup hook>> call ] [ object>> ] bi ] dip
+ [ [ dup hook>> call( presentation -- ) ] [ object>> ] bi ] dip
invoke-command ;
: invoke-primary ( presentation -- )
dup field>> { 2 2 } <filled-border> f track-add
values search 500 milliseconds <delay> quot <string-search>
renderer <table> f >>takes-focus? >>table
- dup table>> <scroller> 1 track-add ;
+ dup table>> <scroller> 1 track-add ; inline
M: search-table model-changed
nip field>> clear-search-field ;
} define-command
: close ( slot-editor -- )
- dup close-hook>> call ;
+ dup close-hook>> call( slot-editor -- ) ;
\ close H{
{ +description+ "Close the slot editor without saving changes." }
} define-command
: close-and-update ( slot-editor -- )
- [ update-hook>> call ] [ close ] bi ;
+ [ update-hook>> call( -- ) ] [ close ] bi ;
: slot-editor-value ( slot-editor -- object )
text>> control-value parse-fresh first ;
{ +description+ "Parse the object being edited, and store the result back into the edited slot." }
} define-command
-: eval-1 ( string -- object )
- 1array [ eval ] with-datastack first ;
-
: com-eval ( slot-editor -- )
- [ [ text>> editor-string eval-1 ] [ ref>> ] bi set-ref ]
+ [ [ text>> editor-string eval( -- result ) ] [ ref>> ] bi set-ref ]
[ close-and-update ]
bi ;
GENERIC: cell-width ( font cell -- x )
GENERIC: cell-height ( font cell -- y )
+GENERIC: cell-padding ( cell -- y )
GENERIC: draw-cell ( font cell -- )
M: string cell-width text-width ;
M: string cell-height text-height ceiling ;
+M: string cell-padding drop 0 ;
M: string draw-cell draw-text ;
+CONSTANT: image-padding 2
+
M: image-name cell-width nip image-dim first ;
M: image-name cell-height nip image-dim second ;
+M: image-name cell-padding drop image-padding ;
M: image-name draw-cell nip draw-image ;
: table-rows ( table -- rows )
if ;
: row-column-widths ( table row -- widths )
- [ font>> ] dip [ cell-width ] with map ;
+ [ font>> ] dip [ [ cell-width ] [ cell-padding ] bi + ] with map ;
: compute-total-width ( gap widths -- total )
swap [ column-offsets drop ] keep - ;
'[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
] bi ;
-: column-loc ( font column width align -- loc )
- [ [ cell-width ] dip swap - ] dip
- * >integer 0 2array ;
+:: column-loc ( font column width align -- loc )
+ font column cell-width width swap - align * column cell-padding 2 / 1 align - * +
+ font column cell-height \ line-height get swap - 2 /
+ [ >integer ] bi@ 2array ;
: translate-column ( width gap -- )
+ 0 2array gl-translate ;
M: table draw-gadget*
dup control-value empty? [ drop ] [
- {
- [ draw-selected-row ]
- [ draw-lines ]
- [ draw-column-lines ]
- [ draw-focused-row ]
- [ draw-moused-row ]
- } cleave
+ dup line-height \ line-height [
+ {
+ [ draw-selected-row ]
+ [ draw-lines ]
+ [ draw-column-lines ]
+ [ draw-focused-row ]
+ [ draw-moused-row ]
+ } cleave
+ ] with-variable
] if ;
M: table line-height ( table -- y )
[ font>> ] [ renderer>> prototype-row ] bi
- [ cell-height ] with [ max ] map-reduce ;
+ [ [ cell-height ] [ cell-padding ] bi + ] with
+ [ max ] map-reduce ;
M: table pref-dim*
[ compute-column-widths drop ] keep
column-title-background <solid> >>interior ;
: draw-column-titles ( table -- )
- {
- [ renderer>> column-titles ]
- [ column-widths>> ]
- [ table-column-alignment ]
- [ font>> column-title-font ]
- [ gap>> ]
- } cleave
- draw-columns ;
+ dup font>> font-metrics height>> \ line-height [
+ {
+ [ renderer>> column-titles ]
+ [ column-widths>> ]
+ [ table-column-alignment ]
+ [ font>> column-title-font ]
+ [ gap>> ]
+ } cleave
+ draw-columns
+ ] with-variable ;
M: column-headers draw-gadget*
table>> draw-column-titles ;
IN: ui.operations
: $operations ( element -- )
- >quotation call
+ >quotation call( -- obj )
f operations>commands
command-map. ;
HELP: line-metrics
{ $values { "font" font } { "string" string } { "metrics" line-metrics } }
-{ $contract "Outputs a " { $link line-metrics } " object with text measurements." } ;
+{ $contract "Outputs a " { $link metrics } " object with text measurements." } ;
ARTICLE: "text-rendering" "Rendering text"
"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11."
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger help help.topics help.crossref help.home kernel models
+USING: debugger classes help help.topics help.crossref help.home kernel models
compiler.units assocs words vocabs accessors fry arrays
combinators.short-circuit namespaces sequences models help.apropos
combinators ui ui.commands ui.gadgets ui.gadgets.panes
: browser-window ( -- )
"help.home" (browser-window) ;
+: error-help-window ( error -- )
+ [ error-help ]
+ [ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ;
+
\ browser-window H{ { +nullary+ t } } define-command
: com-browse ( link -- )
: show-links-popup ( browser-gadget quot title -- )
[ dup model>> ] 2dip <links-popup>
- [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ;
+ [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ; inline
: com-show-outgoing-links ( browser-gadget -- )
[ uses ] "Outgoing links" show-links-popup ;
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
-ui.tools.inspector ;
+ui.tools.inspector ui.tools.browser ;
IN: ui.tools.debugger
TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
: com-traceback ( debugger -- ) continuation>> traceback-window ;
-: com-help ( debugger -- ) error>> (:help) ;
-
-\ com-help H{ { +listener+ t } } define-command
+: com-help ( debugger -- ) error>> error-help-window ;
: com-edit ( debugger -- ) error>> (:edit) ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: ui.tools.error-list
+USING: help.markup help.syntax ui.tools.common ui.commands ;
+
+ARTICLE: "ui.tools.error-list" "UI error list tool"
+"The error list tool displays messages generated by tools which process source files and definitions. To display the error list, press " { $command tool "common" show-error-list } " in any UI tool window."
+$nl
+"The " { $vocab-link "source-files.errors" } " vocabulary contains backend code used by this tool."
+{ $heading "Message icons" }
+{ $table
+ { "Icon" "Message type" "Reference" }
+ { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } }
+ { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } }
+ { { $image "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } "Compiler warning" { $link "compiler-errors" } }
+ { { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } }
+ { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
+ { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } }
+ { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } }
+} ;
+
+ABOUT: "ui.tools.error-list"
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sequences sorting assocs colors.constants fry
+combinators combinators.smart combinators.short-circuit editors make
+memoize compiler.units fonts kernel io.pathnames prettyprint
+source-files.errors math.parser init math.order models models.arrow
+models.arrow.smart models.search models.mapping models.delay debugger namespaces
+summary locals ui ui.commands ui.gadgets ui.gadgets.panes
+ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures
+ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
+ui.tools.inspector ui.gadgets.status-bar ui.operations
+ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
+ui.gadgets.labels ui.baseline-alignment ui.images
+compiler.errors calendar ;
+IN: ui.tools.error-list
+
+CONSTANT: source-file-icon
+ T{ image-name f "vocab:ui/tools/error-list/icons/source-file.tiff" }
+
+MEMO: error-icon ( type -- image-name )
+ error-icon-path <image-name> ;
+
+: <checkboxes> ( alist -- gadget )
+ [ <shelf> { 15 0 } >>gap ] dip
+ [ swap <checkbox> add-gadget ] assoc-each ;
+
+: <error-toggle> ( -- model gadget )
+ #! Linkage errors are not shown by default.
+ error-types get [ fatal?>> <model> ] assoc-map
+ [ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
+ [ <mapping> ] bi ;
+
+TUPLE: error-list-gadget < tool
+visible-errors source-file error
+error-toggle source-file-table error-table error-display ;
+
+SINGLETON: source-file-renderer
+
+M: source-file-renderer row-columns
+ drop first2 [
+ [ source-file-icon ]
+ [ "<Listener input>" or ]
+ [ length number>string ] tri*
+ ] output>array ;
+
+M: source-file-renderer prototype-row
+ drop source-file-icon "" "" 3array ;
+
+M: source-file-renderer row-value
+ drop dup [ first [ <pathname> ] [ f ] if* ] when ;
+
+M: source-file-renderer column-titles
+ drop { "" "File" "Errors" } ;
+
+M: source-file-renderer column-alignment drop { 0 0 1 } ;
+
+M: source-file-renderer filled-column drop 1 ;
+
+: <source-file-model> ( model -- model' )
+ [ group-by-source-file >alist sort-keys ] <arrow> ;
+
+:: <source-file-table> ( error-list -- table )
+ error-list model>> <source-file-model>
+ source-file-renderer
+ <table>
+ [ invoke-primary-operation ] >>action
+ COLOR: dark-gray >>column-line-color
+ 6 >>gap
+ 5 >>min-rows
+ 5 >>max-rows
+ 60 >>min-cols
+ 60 >>max-cols
+ t >>selection-required?
+ error-list source-file>> >>selected-value ;
+
+SINGLETON: error-renderer
+
+M: error-renderer row-columns
+ drop [
+ {
+ [ error-type error-icon ]
+ [ line#>> [ number>string ] [ "" ] if* ]
+ [ asset>> [ unparse-short ] [ "" ] if* ]
+ [ error>> summary ]
+ } cleave
+ ] output>array ;
+
+M: error-renderer prototype-row
+ drop [ +compiler-error+ error-icon "" "" "" ] output>array ;
+
+M: error-renderer row-value
+ drop ;
+
+M: error-renderer column-titles
+ drop { "" "Line" "Asset" "Error" } ;
+
+M: error-renderer column-alignment drop { 0 1 0 0 } ;
+
+: sort-errors ( seq -- seq' )
+ [ [ [ asset>> unparse-short ] [ line#>> ] bi 2array ] keep ] { } map>assoc
+ sort-keys values ;
+
+: file-matches? ( error pathname/f -- ? )
+ [ file>> ] [ dup [ string>> ] when ] bi* = ;
+
+: <error-table-model> ( error-list -- model )
+ [ model>> ] [ source-file>> ] bi
+ [ file-matches? ] <search>
+ [ sort-errors ] <arrow> ;
+
+:: <error-table> ( error-list -- table )
+ error-list <error-table-model>
+ error-renderer
+ <table>
+ [ invoke-primary-operation ] >>action
+ COLOR: dark-gray >>column-line-color
+ 6 >>gap
+ 5 >>min-rows
+ 5 >>max-rows
+ 60 >>min-cols
+ 60 >>max-cols
+ t >>selection-required?
+ error-list error>> >>selected-value ;
+
+TUPLE: error-display < track ;
+
+: <error-display> ( error-list -- gadget )
+ vertical error-display new-track
+ add-toolbar
+ swap error>> >>model
+ dup model>> [ [ print-error ] when* ] <pane-control> <scroller> 1 track-add ;
+
+: com-inspect ( error-display -- )
+ model>> value>> [ inspector ] when* ;
+
+: com-help ( error-display -- )
+ model>> value>> [ error>> error-help-window ] when* ;
+
+: com-edit ( error-display -- )
+ model>> value>> [ edit-error ] when* ;
+
+error-display "toolbar" f {
+ { f com-inspect }
+ { f com-help }
+ { f com-edit }
+} define-command-map
+
+: <error-list-toolbar> ( error-list -- toolbar )
+ [ <toolbar> ] [ error-toggle>> "Show errors:" label-on-left add-gadget ] bi ;
+
+: <error-model> ( visible-errors model -- model' )
+ [ swap '[ error-type _ at ] filter ] <smart-arrow> ;
+
+:: <error-list-gadget> ( model -- gadget )
+ vertical error-list-gadget new-track
+ <error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
+ dup visible-errors>> model <error-model> >>model
+ f <model> >>source-file
+ f <model> >>error
+ dup <source-file-table> >>source-file-table
+ dup <error-table> >>error-table
+ dup <error-display> >>error-display
+ :> error-list
+ error-list vertical <track>
+ { 5 5 } >>gap
+ error-list <error-list-toolbar> f track-add
+ error-list source-file-table>> <scroller> "Source files" <labeled-gadget> 1/4 track-add
+ error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/2 track-add
+ error-list error-display>> "Details" <labeled-gadget> 1/4 track-add
+ { 5 5 } <filled-border> 1 track-add ;
+
+M: error-list-gadget focusable-child*
+ source-file-table>> ;
+
+: error-list-help ( -- ) "ui.tools.error-list" com-browse ;
+
+\ error-list-help H{ { +nullary+ t } } define-command
+
+error-list-gadget "toolbar" f {
+ { T{ key-down f f "F1" } error-list-help }
+} define-command-map
+
+SYMBOL: error-list-model
+
+error-list-model [ f <model> ] initialize
+
+SINGLETON: updater
+
+M: updater errors-changed
+ drop f error-list-model get-global set-model ;
+
+[ updater add-error-observer ] "ui.tools.error-list" add-init-hook
+
+: <error-list-model> ( -- model )
+ error-list-model get-global
+ 1/2 seconds <delay> [ drop all-errors ] <arrow> ;
+
+: error-list-window ( -- )
+ <error-list-model> <error-list-gadget> "Errors" open-status-window ;
+
+: show-error-list ( -- )
+ [ error-list-gadget? ] find-window
+ [ raise-window ] [ error-list-window ] if* ;
+
+\ show-error-list H{ { +nullary+ t } } define-command
USING: help.markup help.syntax ui.commands ui.gadgets.slots
-ui.gadgets.editors ;
+ui.gadgets.editors kernel ;
IN: ui.tools.inspector
ARTICLE: "ui-inspector-edit" "Editing slot values in the inspector"
"The UI inspector is an instance of " { $link inspector-gadget } "."
{ $subsection "ui-inspector-edit" } ;
+HELP: inspector
+{ $values { "obj" object } }
+{ $description "Opens a new inspector window displaying the slots of " { $snippet "obj" } "." } ;
+
ABOUT: "ui-inspector"
\ No newline at end of file
{ $command-map interactor "quotation" }
{ $heading "Editing commands" }
"The text editing commands are standard; see " { $link "gadgets-editors-commands" } "."
+$nl
+"The listener displays a summary with any outstanding error conditions before every prompt. See " { $link "ui.tools.error-list" } " for details."
{ $heading "Implementation" }
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs calendar combinators locals
-colors.constants combinators.short-circuit compiler.units
-help.tips concurrency.flags concurrency.mailboxes continuations
-destructors documents documents.elements fry hashtables help
-help.markup io io.styles kernel lexer listener math models
+source-files.errors colors.constants combinators.short-circuit
+compiler.units help.tips concurrency.flags concurrency.mailboxes
+continuations destructors documents documents.elements fry hashtables
+help help.markup io io.styles kernel lexer listener math models sets
models.delay models.arrow namespaces parser prettyprint quotations
sequences strings threads tools.vocabs vocabs vocabs.loader
vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
ui.tools.listener.completion ui.tools.listener.popups
-ui.tools.listener.history ;
+ui.tools.listener.history ui.tools.error-list ;
+FROM: source-files.errors => all-errors ;
IN: ui.tools.listener
! If waiting is t, we're waiting for user input, and invoking
{ T{ key-down f { C+ } "r" } history-completion-popup }
} define-command-map
+: ui-error-summary ( -- )
+ error-counts keys [
+ [ icon>> 1array \ $image prefix " " 2array ] { } map-as
+ { "Press " { $command tool "common" show-error-list } " to view errors." }
+ append print-element nl
+ ] unless-empty ;
+
: listener-thread ( listener -- )
dup listener-streams [
[ com-browse ] help-hook set
'[ [ _ input>> ] 2dip debugger-popup ] error-hook set
+ [ ui-error-summary ] error-summary-hook set
tip-of-the-day. nl
listener
] with-streams* ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations definitions generic help.topics threads
-stack-checker summary io.pathnames io.styles kernel namespaces
-parser prettyprint quotations tools.crossref tools.annotations
-editors tools.profiler tools.test tools.time tools.walker vocabs
-vocabs.loader words sequences tools.vocabs classes
-compiler.units accessors vocabs.parser macros.expander ui
-ui.tools.browser ui.tools.listener ui.tools.listener.completion
-ui.tools.profiler ui.tools.inspector ui.tools.traceback
-ui.commands ui.gadgets.editors ui.gestures ui.operations
-ui.tools.deploy models help.tips ;
+stack-checker summary io.pathnames io.styles kernel namespaces parser
+prettyprint quotations tools.crossref tools.annotations editors
+tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader
+words sequences tools.vocabs classes compiler.errors compiler.units
+accessors vocabs.parser macros.expander ui ui.tools.browser
+ui.tools.listener ui.tools.listener.completion ui.tools.profiler
+ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors
+ui.gestures ui.operations ui.tools.deploy models help.tips
+source-files.errors ;
IN: ui.tools.operations
! Objects
{ +listener+ t }
} define-operation
+! Source file error
+[ source-file-error? ] \ edit-error H{
+ { +primary+ t }
+ { +secondary+ t }
+ { +listener+ t }
+} define-operation
+
+: com-reload ( error -- )
+ file>> run-file ;
+
+[ compiler-error? ] \ com-reload H{
+ { +listener+ t }
+} define-operation
+
+! Definitions
: com-forget ( defspec -- )
[ forget ] with-compilation-unit ;
"These commands operate on the entire contents of the input area."
[ ]
[ quot-action ]
-define-operation-map
+define-operation-map
\ No newline at end of file
--- /dev/null
+USING: ui.tools.profiler tools.test ;
+
+\ profiler-window must-infer
ui.tools.browser ui.tools.common ui.baseline-alignment
ui.operations ui.images ;
FROM: models.arrow => <arrow> ;
+FROM: models.arrow.smart => <smart-arrow> ;
FROM: models.product => <product> ;
IN: ui.tools.profiler
: <methods-model> ( profiler -- model )
[
[ method-counters <model> ] dip
- [ generic>> ] [ class>> ] bi 3array <product>
- [ first3 '[ _ _ method-matches? ] filter ] <arrow>
+ [ generic>> ] [ class>> ] bi
+ [ '[ _ _ method-matches? ] filter ] <smart-arrow>
] keep <profiler-model> ;
: sort-by-name ( obj1 obj2 -- <=> )
: profiler-window ( -- )
<profiler-gadget> "Profiling results" open-status-window ;
-: com-profile ( quot -- ) profile profiler-window ;
+: com-profile ( quot -- ) profile profiler-window ; inline
MAIN: profiler-window
{ $subsection "ui-listener" }
{ $subsection "ui-browser" }
{ $subsection "ui-inspector" }
+{ $subsection "ui.tools.error-list" }
{ $subsection "ui.tools.profiler" }
{ $subsection "ui-walker" }
{ $subsection "ui.tools.deploy" }
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: memory system kernel tools.vocabs ui.tools.operations
-ui.tools.listener ui.tools.browser ui.tools.common
+ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
ui.tools.walker ui.commands ui.gestures ui ui.private ;
IN: ui.tools
{ T{ key-down f { A+ } "w" } close-window }
{ T{ key-down f { A+ } "q" } com-exit }
{ T{ key-down f f "F2" } refresh-all }
+ { T{ key-down f f "F3" } show-error-list }
} define-command-map
\ No newline at end of file
IN: ui.tools.walker\r
USING: help.markup help.syntax ui.commands ui.operations\r
-ui.render tools.walker sequences ;\r
+ui.render tools.walker sequences tools.continuations ;\r
\r
ARTICLE: "ui-walker-step" "Stepping through code"\r
"If the current position points to a word, the various stepping commands behave as follows:"\r
HELP: url-encode
{ $values { "str" string } { "encoded" string } }
-{ $description "URL-encodes a string." } ;
+{ $description "URL-encodes a string, excluding certain characters, such as \"/\"." } ;
+
+HELP: url-encode-full
+{ $values { "str" string } { "encoded" string } }
+{ $description "URL-encodes a string, including all reserved characters, such as \"/\"." } ;
HELP: url-quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
[ "/_-.:" member? ]
} 1|| ; foldable
+! see http://tools.ietf.org/html/rfc3986#section-2.2
+: gen-delim? ( ch -- ? )
+ ":/?#[]@" member? ; foldable
+
+: sub-delim? ( ch -- ? )
+ "!$&'()*+,;=" member? ; foldable
+
+: reserved? ( ch -- ? )
+ [ gen-delim? ] [ sub-delim? ] bi or ; foldable
+
+! see http://tools.ietf.org/html/rfc3986#section-2.3
+: unreserved? ( ch -- ? )
+ {
+ [ letter? ]
+ [ LETTER? ]
+ [ digit? ]
+ [ "-._~" member? ]
+ } 1|| ; foldable
+
<PRIVATE
: push-utf8 ( ch -- )
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
+: url-encode-full ( str -- encoded )
+ [
+ [ dup unreserved? [ , ] [ push-utf8 ] if ] each
+ ] "" make ;
+
<PRIVATE
: url-decode-hex ( index str -- )
USING: alien.syntax kernel math windows.types math.bitwise ;
IN: windows.advapi32
+
LIBRARY: advapi32
CONSTANT: PROV_RSA_FULL 1
TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
+C-STRUCT: SECURITY_DESCRIPTOR
+ { "UCHAR" "Revision" }
+ { "UCHAR" "Sbz1" }
+ { "WORD" "Control" }
+ { "PVOID" "Owner" }
+ { "PVOID" "Group" }
+ { "PACL" "Sacl" }
+ { "PACL" "Dacl" } ;
+
+TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR
+
+CONSTANT: SE_OWNER_DEFAULTED 1
+CONSTANT: SE_GROUP_DEFAULTED 2
+CONSTANT: SE_DACL_PRESENT 4
+CONSTANT: SE_DACL_DEFAULTED 8
+CONSTANT: SE_SACL_PRESENT 16
+CONSTANT: SE_SACL_DEFAULTED 32
+CONSTANT: SE_DACL_AUTO_INHERIT_REQ 256
+CONSTANT: SE_SACL_AUTO_INHERIT_REQ 512
+CONSTANT: SE_DACL_AUTO_INHERITED 1024
+CONSTANT: SE_SACL_AUTO_INHERITED 2048
+CONSTANT: SE_DACL_PROTECTED 4096
+CONSTANT: SE_SACL_PROTECTED 8192
+CONSTANT: SE_SELF_RELATIVE 32768
+
+TYPEDEF: DWORD SECURITY_DESCRIPTOR_CONTROL
+TYPEDEF: SECURITY_DESCRIPTOR_CONTROL* PSECURITY_DESCRIPTOR_CONTROL
+
! typedef enum _TOKEN_INFORMATION_CLASS {
CONSTANT: TokenUser 1
CONSTANT: TokenSandBoxInert 15
! } TOKEN_INFORMATION_CLASS;
+TYPEDEF: DWORD ACCESS_MODE
+C-ENUM:
+ NOT_USED_ACCESS
+ GRANT_ACCESS
+ SET_ACCESS
+ DENY_ACCESS
+ REVOKE_ACCESS
+ SET_AUDIT_SUCCESS
+ SET_AUDIT_FAILURE ;
+
+TYPEDEF: DWORD MULTIPLE_TRUSTEE_OPERATION
+C-ENUM:
+ NO_MULTIPLE_TRUSTEE
+ TRUSTEE_IS_IMPERSONATE ;
+
+TYPEDEF: DWORD TRUSTEE_FORM
+C-ENUM:
+ TRUSTEE_IS_SID
+ TRUSTEE_IS_NAME
+ TRUSTEE_BAD_FORM
+ TRUSTEE_IS_OBJECTS_AND_SID
+ TRUSTEE_IS_OBJECTS_AND_NAME ;
+
+TYPEDEF: DWORD TRUSTEE_TYPE
+C-ENUM:
+ TRUSTEE_IS_UNKNOWN
+ TRUSTEE_IS_USER
+ TRUSTEE_IS_GROUP
+ TRUSTEE_IS_DOMAIN
+ TRUSTEE_IS_ALIAS
+ TRUSTEE_IS_WELL_KNOWN_GROUP
+ TRUSTEE_IS_DELETED
+ TRUSTEE_IS_INVALID
+ TRUSTEE_IS_COMPUTER ;
+
+TYPEDEF: DWORD SE_OBJECT_TYPE
+C-ENUM:
+ SE_UNKNOWN_OBJECT_TYPE
+ SE_FILE_OBJECT
+ SE_SERVICE
+ SE_PRINTER
+ SE_REGISTRY_KEY
+ SE_LMSHARE
+ SE_KERNEL_OBJECT
+ SE_WINDOW_OBJECT
+ SE_DS_OBJECT
+ SE_DS_OBJECT_ALL
+ SE_PROVIDER_DEFINED_OBJECT
+ SE_WMIGUID_OBJECT
+ SE_REGISTRY_WOW64_32KEY ;
+
+TYPEDEF: TRUSTEE* PTRUSTEE
+
+C-STRUCT: TRUSTEE
+ { "PTRUSTEE" "pMultipleTrustee" }
+ { "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" }
+ { "TRUSTEE_FORM" "TrusteeForm" }
+ { "TRUSTEE_TYPE" "TrusteeType" }
+ { "LPTSTR" "ptstrName" } ;
+
+C-STRUCT: EXPLICIT_ACCESS
+ { "DWORD" "grfAccessPermissions" }
+ { "ACCESS_MODE" "grfAccessMode" }
+ { "DWORD" "grfInheritance" }
+ { "TRUSTEE" "Trustee" } ;
+
+C-STRUCT: SID_IDENTIFIER_AUTHORITY
+ { { "BYTE" 6 } "Value" } ;
+
+TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY
+
+CONSTANT: SECURITY_NULL_SID_AUTHORITY 0
+CONSTANT: SECURITY_WORLD_SID_AUTHORITY 1
+CONSTANT: SECURITY_LOCAL_SID_AUTHORITY 2
+CONSTANT: SECURITY_CREATOR_SID_AUTHORITY 3
+CONSTANT: SECURITY_NON_UNIQUE_AUTHORITY 4
+CONSTANT: SECURITY_NT_AUTHORITY 5
+CONSTANT: SECURITY_RESOURCE_MANAGER_AUTHORITY 6
+
+CONSTANT: SECURITY_NULL_RID 0
+CONSTANT: SECURITY_WORLD_RID 0
+CONSTANT: SECURITY_LOCAL_RID 0
+CONSTANT: SECURITY_CREATOR_OWNER_RID 0
+CONSTANT: SECURITY_CREATOR_GROUP_RID 1
+CONSTANT: SECURITY_CREATOR_OWNER_SERVER_RID 2
+CONSTANT: SECURITY_CREATOR_GROUP_SERVER_RID 3
+CONSTANT: SECURITY_DIALUP_RID 1
+CONSTANT: SECURITY_NETWORK_RID 2
+CONSTANT: SECURITY_BATCH_RID 3
+CONSTANT: SECURITY_INTERACTIVE_RID 4
+CONSTANT: SECURITY_SERVICE_RID 6
+CONSTANT: SECURITY_ANONYMOUS_LOGON_RID 7
+CONSTANT: SECURITY_PROXY_RID 8
+CONSTANT: SECURITY_SERVER_LOGON_RID 9
+CONSTANT: SECURITY_PRINCIPAL_SELF_RID 10
+CONSTANT: SECURITY_AUTHENTICATED_USER_RID 11
+CONSTANT: SECURITY_LOGON_IDS_RID 5
+CONSTANT: SECURITY_LOGON_IDS_RID_COUNT 3
+CONSTANT: SECURITY_LOCAL_SYSTEM_RID 18
+CONSTANT: SECURITY_NT_NON_UNIQUE 21
+CONSTANT: SECURITY_BUILTIN_DOMAIN_RID 32
+CONSTANT: DOMAIN_USER_RID_ADMIN 500
+CONSTANT: DOMAIN_USER_RID_GUEST 501
+CONSTANT: DOMAIN_GROUP_RID_ADMINS 512
+CONSTANT: DOMAIN_GROUP_RID_USERS 513
+CONSTANT: DOMAIN_GROUP_RID_GUESTS 514
+CONSTANT: DOMAIN_ALIAS_RID_ADMINS 544
+CONSTANT: DOMAIN_ALIAS_RID_USERS 545
+CONSTANT: DOMAIN_ALIAS_RID_GUESTS 546
+CONSTANT: DOMAIN_ALIAS_RID_POWER_USERS 547
+CONSTANT: DOMAIN_ALIAS_RID_ACCOUNT_OPS 548
+CONSTANT: DOMAIN_ALIAS_RID_SYSTEM_OPS 549
+CONSTANT: DOMAIN_ALIAS_RID_PRINT_OPS 550
+CONSTANT: DOMAIN_ALIAS_RID_BACKUP_OPS 551
+CONSTANT: DOMAIN_ALIAS_RID_REPLICATOR 552
+CONSTANT: SE_GROUP_MANDATORY 1
+CONSTANT: SE_GROUP_ENABLED_BY_DEFAULT 2
+CONSTANT: SE_GROUP_ENABLED 4
+CONSTANT: SE_GROUP_OWNER 8
+CONSTANT: SE_GROUP_LOGON_ID -1073741824
+
+! SID is a variable length structure
+TYPEDEF: void* PSID
+
+TYPEDEF: EXPLICIT_ACCESS* PEXPLICIT_ACCESS
+
+TYPEDEF: DWORD SECURITY_INFORMATION
+TYPEDEF: SECURITY_INFORMATION* PSECURITY_INFORMATION
+
+CONSTANT: OWNER_SECURITY_INFORMATION 1
+CONSTANT: GROUP_SECURITY_INFORMATION 2
+CONSTANT: DACL_SECURITY_INFORMATION 4
+CONSTANT: SACL_SECURITY_INFORMATION 8
+
CONSTANT: DELETE HEX: 00010000
CONSTANT: READ_CONTROL HEX: 00020000
CONSTANT: WRITE_DAC HEX: 00040000
TOKEN_ADJUST_DEFAULT
} flags ; foldable
+CONSTANT: HKEY_CLASSES_ROOT 1
+CONSTANT: HKEY_CURRENT_CONFIG 2
+CONSTANT: HKEY_CURRENT_USER 3
+CONSTANT: HKEY_LOCAL_MACHINE 4
+CONSTANT: HKEY_USERS 5
+
+CONSTANT: KEY_ALL_ACCESS HEX: 0001
+CONSTANT: KEY_CREATE_LINK HEX: 0002
+CONSTANT: KEY_CREATE_SUB_KEY HEX: 0004
+CONSTANT: KEY_ENUMERATE_SUB_KEYS HEX: 0008
+CONSTANT: KEY_EXECUTE HEX: 0010
+CONSTANT: KEY_NOTIFY HEX: 0020
+CONSTANT: KEY_QUERY_VALUE HEX: 0040
+CONSTANT: KEY_READ HEX: 0080
+CONSTANT: KEY_SET_VALUE HEX: 0100
+CONSTANT: KEY_WOW64_64KEY HEX: 0200
+CONSTANT: KEY_WOW64_32KEY HEX: 0400
+CONSTANT: KEY_WRITE HEX: 0800
+
+CONSTANT: REG_BINARY 1
+CONSTANT: REG_DWORD 2
+CONSTANT: REG_EXPAND_SZ 3
+CONSTANT: REG_MULTI_SZ 4
+CONSTANT: REG_QWORD 5
+CONSTANT: REG_SZ 6
+
+TYPEDEF: DWORD REGSAM
+
! : I_ScGetCurrentGroupStateW ;
! : A_SHAFinal ;
PTOKEN_PRIVILEGES PreviousState,
PDWORD ReturnLength ) ;
-! : AllocateAndInitializeSid ;
+FUNCTION: BOOL AllocateAndInitializeSid (
+ PSID_IDENTIFIER_AUTHORITY pIdentifierAuthority,
+ BYTE nSubAuthorityCount,
+ DWORD dwSubAuthority0,
+ DWORD dwSubAuthority1,
+ DWORD dwSubAuthority2,
+ DWORD dwSubAuthority3,
+ DWORD dwSubAuthority4,
+ DWORD dwSubAuthority5,
+ DWORD dwSubAuthority6,
+ DWORD dwSubAuthority7,
+ PSID* pSid ) ;
+
! : AllocateLocallyUniqueId ;
! : AreAllAccessesGranted ;
! : AreAnyAccessesGranted ;
! : GetExplicitEntriesFromAclA ;
! : GetExplicitEntriesFromAclW ;
! : GetFileSecurityA ;
-! : GetFileSecurityW ;
+FUNCTION: BOOL GetFileSecurityW ( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded ) ;
+ALIAS: GetFileSecurity GetFileSecurityW
! : GetInformationCodeAuthzLevelW ;
! : GetInformationCodeAuthzPolicyW ;
! : GetInheritanceSourceA ;
! : GetMultipleTrusteeW ;
! : GetNamedSecurityInfoA ;
! : GetNamedSecurityInfoExA ;
-! : GetNamedSecurityInfoExW ;
-! : GetNamedSecurityInfoW ;
+! FUNCTION: DWORD GetNamedSecurityInfoExW
+FUNCTION: DWORD GetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID* ppsidOwner, PSID* ppsidGroup, PACL* ppDacl, PACL* ppSacl, PSECURITY_DESCRIPTOR* ppSecurityDescriptor ) ;
+ALIAS: GetNamedSecurityInfo GetNamedSecurityInfoW
! : GetNumberOfEventLogRecords ;
! : GetOldestEventLogRecord ;
! : GetOverlappedAccessResults ;
! : GetPrivateObjectSecurity ;
-! : GetSecurityDescriptorControl ;
-! : GetSecurityDescriptorDacl ;
-! : GetSecurityDescriptorGroup ;
-! : GetSecurityDescriptorLength ;
-! : GetSecurityDescriptorOwner ;
-! : GetSecurityDescriptorRMControl ;
-! : GetSecurityDescriptorSacl ;
+FUNCTION: BOOL GetSecurityDescriptorControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSECURITY_DESCRIPTOR_CONTROL pControl, LPDWORD lpdwRevision ) ;
+FUNCTION: BOOL GetSecurityDescriptorDacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbDaclPresent, PACL* pDacl, LPBOOL lpDaclDefaulted ) ;
+FUNCTION: BOOL GetSecurityDescriptorGroup ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pGroup, LPBOOL lpGroupDefaulted ) ;
+FUNCTION: BOOL GetSecurityDescriptorLength ( PSECURITY_DESCRIPTOR pSecurityDescriptor ) ;
+FUNCTION: BOOL GetSecurityDescriptorOwner ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pOwner, LPBOOL lpOwnerDefaulted ) ;
+FUNCTION: BOOL GetSecurityDescriptorRMControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PUCHAR RMControl ) ;
+FUNCTION: BOOL GetSecurityDescriptorSacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbSaclPresent, PACL* pSacl, LPBOOL lpSaclDefaulted ) ;
! : GetSecurityInfo ;
! : GetSecurityInfoExA ;
! : GetSecurityInfoExW ;
! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ;
FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
-! : InitializeSecurityDescriptor ;
+FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ;
! : InitializeSid ;
! : InitiateSystemShutdownA ;
! : InitiateSystemShutdownExA ;
! : RegConnectRegistryW ;
! : RegCreateKeyA ;
! : RegCreateKeyExA ;
-! : RegCreateKeyExW ;
-! : RegCreateKeyW ;
+FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ;
+! : RegCreateKeyW
! : RegDeleteKeyA ;
! : RegDeleteKeyW ;
! : RegDeleteValueA ;
! : RegLoadKeyA ;
! : RegLoadKeyW ;
! : RegNotifyChangeKeyValue ;
-! : RegOpenCurrentUser ;
+FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ;
! : RegOpenKeyA ;
! : RegOpenKeyExA ;
! : RegOpenKeyExW ;
! : RegQueryMultipleValuesW ;
! : RegQueryValueA ;
! : RegQueryValueExA ;
-! : RegQueryValueExW ;
+FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ;
! : RegQueryValueW ;
! : RegReplaceKeyA ;
! : RegReplaceKeyW ;
! : SetEntriesInAccessListA ;
! : SetEntriesInAccessListW ;
! : SetEntriesInAclA ;
-! : SetEntriesInAclW ;
+FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ;
+ALIAS: SetEntriesInAcl SetEntriesInAclW
! : SetEntriesInAuditListA ;
! : SetEntriesInAuditListW ;
! : SetFileSecurityA ;
! : SetNamedSecurityInfoA ;
! : SetNamedSecurityInfoExA ;
! : SetNamedSecurityInfoExW ;
-! : SetNamedSecurityInfoW ;
+FUNCTION: DWORD SetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID psidOwner, PSID psidGroup, PACL pDacl, PACL pSacl ) ;
+ALIAS: SetNamedSecurityInfo SetNamedSecurityInfoW
! : SetPrivateObjectSecurity ;
! : SetPrivateObjectSecurityEx ;
! : SetSecurityDescriptorControl ;
--- /dev/null
+IN: windows.dinput.constants.tests
+USING: tools.test windows.dinput.constants.private ;
+
+[ ] [ define-constants ] unit-test
+[ ] [ free-dinput-constants ] unit-test
\ No newline at end of file
: (flag) ( thing -- integer )
{
- { [ dup word? ] [ execute ] }
- { [ dup callable? ] [ call ] }
+ { [ dup word? ] [ execute( -- value ) ] }
+ { [ dup callable? ] [ call( -- value ) ] }
[ ]
} cond ;
-: (flags) ( array -- )
+: (flags) ( array -- n )
0 [ (flag) bitor ] reduce ;
: (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien )
] ;
: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
- [ {
- [ set-DIDATAFORMAT-rgodf ]
- [ set-DIDATAFORMAT-dwNumObjs ]
- [ set-DIDATAFORMAT-dwDataSize ]
- [ set-DIDATAFORMAT-dwFlags ]
- [ set-DIDATAFORMAT-dwObjSize ]
- [ set-DIDATAFORMAT-dwSize ]
- } cleave ] keep ;
+ [
+ {
+ [ set-DIDATAFORMAT-rgodf ]
+ [ set-DIDATAFORMAT-dwNumObjs ]
+ [ set-DIDATAFORMAT-dwDataSize ]
+ [ set-DIDATAFORMAT-dwFlags ]
+ [ set-DIDATAFORMAT-dwObjSize ]
+ [ set-DIDATAFORMAT-dwSize ]
+ } cleave
+ ] keep ;
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip
"DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
: (malloc-guid-symbol) ( symbol guid -- )
- global swap '[ [
- _ execute [ byte-length malloc ] [ over byte-array>memory ] bi
- ] unless* ] change-at ;
+ '[
+ _ execute( -- value )
+ [ byte-length malloc ] [ over byte-array>memory ] bi
+ ] initialize ;
: define-guid-constants ( -- )
{
} [ first2 (malloc-guid-symbol) ] each ;
: define-joystick-format-constant ( -- )
- c_dfDIJoystick2 global [ [
+ c_dfDIJoystick2 [
DIDF_ABSAXIS
"DIJOYSTATE2" heap-size
"DIJOYSTATE2" {
{ GUID_Slider_malloced "rglFSlider" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE }
{ GUID_Slider_malloced "rglFSlider" 1 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE }
} <DIDATAFORMAT>
- ] unless* ] change-at ;
+ ] initialize ;
: define-mouse-format-constant ( -- )
- c_dfDIMouse2 global [ [
+ c_dfDIMouse2 [
DIDF_RELAXIS
"DIMOUSESTATE2" heap-size
"DIMOUSESTATE2" {
{ GUID_Button_malloced "rgbButtons" 6 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 }
{ GUID_Button_malloced "rgbButtons" 7 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 }
} <DIDATAFORMAT>
- ] unless* ] change-at ;
+ ] initialize ;
! Not a standard DirectInput format. Included for cross-platform niceness.
! This format returns the keyboard keys in USB HID order rather than Windows
! order
: define-hid-keyboard-format-constant ( -- )
- c_dfDIKeyboard_HID global [ [
+ c_dfDIKeyboard_HID [
DIDF_RELAXIS
256
f {
{ GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 }
{ GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 }
} <DIDATAFORMAT>
- ] unless* ] change-at ;
+ ] initialize ;
: define-keyboard-format-constant ( -- )
- c_dfDIKeyboard global [ [
+ c_dfDIKeyboard [
DIDF_RELAXIS
256
f {
{ GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 254 DIDFT_MAKEINSTANCE ] } 0 }
{ GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 255 DIDFT_MAKEINSTANCE ] } 0 }
} <DIDATAFORMAT>
- ] unless* ] change-at ;
+ ] initialize ;
: define-format-constants ( -- )
define-joystick-format-constant
define-format-constants ;
[ define-constants ] "windows.dinput.constants" add-init-hook
-define-constants
+
+: uninitialize ( variable quot -- )
+ [ global ] dip '[ _ when* f ] change-at ; inline
: free-dinput-constants ( -- )
{
GUID_Slider_malloced GUID_Button_malloced GUID_Key_malloced GUID_POV_malloced GUID_Unknown_malloced
GUID_SysMouse_malloced GUID_SysKeyboard_malloced GUID_Joystick_malloced GUID_SysMouseEm_malloced
GUID_SysMouseEm2_malloced GUID_SysKeyboardEm_malloced GUID_SysKeyboardEm2_malloced
- } [ global [ [ free ] when* f ] change-at ] each
+ } [ [ free ] uninitialize ] each
+
{
c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2
- } [ global [ [ DIDATAFORMAT-rgodf free ] when* f ] change-at ] each ;
+ } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ;
PRIVATE>
FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
ALIAS: ExtTextOut ExtTextOutW
! FUNCTION: FillPath
-FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
! FUNCTION: FillRgn
! FUNCTION: FixBrushOrgEx
! FUNCTION: FlattenPath
! FUNCTION: LoadLibraryW
! FUNCTION: LoadModule
! FUNCTION: LoadResource
-! FUNCTION: LocalAlloc
+FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ;
! FUNCTION: LocalCompact
! FUNCTION: LocalFileTimeToFileTime
! FUNCTION: LocalFlags
! FUNCTION: EqualRect
! FUNCTION: ExcludeUpdateRgn
! FUNCTION: ExitWindowsEx
-! FUNCTION: FillRect
+FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ;
FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ;
! FUNCTION: FindWindowExW
--- /dev/null
+unportable
+bindings
--- /dev/null
+Eduardo Cavazos
+Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
kernel math namespaces sequences io.encodings.string
-io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants
+io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants
specialized-arrays.int accessors ;
IN: x11.clipboard
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays hashtables io kernel math
math.order namespaces prettyprint sequences strings combinators
-x11.xlib ;
+x11 x11.xlib ;
IN: x11.events
GENERIC: expose-event ( event window -- )
! See http://factorcode.org/license.txt for BSD license.
!
! based on glx.h from xfree86, and some of glxtokens.h
-USING: alien alien.c-types alien.syntax x11.xlib namespaces make
-kernel sequences parser words specialized-arrays.int accessors ;
+USING: alien alien.c-types alien.syntax x11 x11.xlib x11.syntax
+namespaces make kernel sequences parser words specialized-arrays.int
+accessors ;
IN: x11.glx
LIBRARY: glx
TYPEDEF: void* GLXContext ! typedef struct __GLXcontextRec *GLXContext;
TYPEDEF: void* GLXFBConfig ! typedef struct __GLXFBConfigRec *GLXFBConfig;
-FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ;
-FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ;
-FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ;
-FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ;
-FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ;
-FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ;
-FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ;
-FUNCTION: GLXContext glXGetCurrentContext ( ) ;
-FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ;
-FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ;
-FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ;
-FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ;
-FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ;
-FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ;
-FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ;
-FUNCTION: void glXWaitGL ( ) ;
-FUNCTION: void glXWaitX ( ) ;
-FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ;
-FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ;
-FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ;
+X-FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ;
+X-FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ;
+X-FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ;
+X-FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ;
+X-FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ;
+X-FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ;
+X-FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ;
+X-FUNCTION: GLXContext glXGetCurrentContext ( ) ;
+X-FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ;
+X-FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ;
+X-FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ;
+X-FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ;
+X-FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ;
+X-FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ;
+X-FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ;
+X-FUNCTION: void glXWaitGL ( ) ;
+X-FUNCTION: void glXWaitX ( ) ;
+X-FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ;
+X-FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ;
+X-FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ;
! New for GLX 1.3
-FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ;
-FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ;
-FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ;
-FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ;
-FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ;
-FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ;
-FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ;
-FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ;
-FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ;
-FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ;
-FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ;
-FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ;
-FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ;
-FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ;
-FUNCTION: Display* glXGetCurrentDisplay ( ) ;
-FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ;
-FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ;
-FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ;
+X-FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ;
+X-FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ;
+X-FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ;
+X-FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ;
+X-FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ;
+X-FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ;
+X-FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ;
+X-FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ;
+X-FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ;
+X-FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ;
+X-FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ;
+X-FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ;
+X-FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ;
+X-FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ;
+X-FUNCTION: Display* glXGetCurrentDisplay ( ) ;
+X-FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ;
+X-FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ;
+X-FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ;
! GLX 1.4 and later
-FUNCTION: void* glXGetProcAddress ( char* procname ) ;
+X-FUNCTION: void* glXGetProcAddress ( char* procname ) ;
! GLX_ARB_get_proc_address extension
-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
+X-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
! GLX Events
! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks)
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend calendar threads kernel ;
+IN: x11.io
+
+HOOK: init-x-io io-backend ( -- )
+
+M: object init-x-io ;
+
+HOOK: wait-for-display io-backend ( -- )
+
+M: object wait-for-display 10 milliseconds sleep ;
+
+HOOK: awaken-event-loop io-backend ( -- )
+
+M: object awaken-event-loop ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend.unix io.backend.unix.multiplexers
+namespaces system x11 x11.xlib x11.io
+accessors threads sequences kernel ;
+IN: x11.io.unix
+
+SYMBOL: dpy-fd
+
+M: unix init-x-io dpy get XConnectionNumber <fd> dpy-fd set-global ;
+
+M: unix wait-for-display dpy-fd get +input+ wait-for-fd ;
+
+M: unix awaken-event-loop
+ dpy-fd get [ fd>> mx get remove-input-callbacks [ resume ] each ] when* ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax alien.parser words x11.io sequences kernel ;
+IN: x11.syntax
+
+SYNTAX: X-FUNCTION:
+ (FUNCTION:)
+ [ \ awaken-event-loop suffix ] dip
+ define-declared ;
\ No newline at end of file
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types hashtables kernel math math.vectors
-math.bitwise namespaces sequences x11.xlib x11.constants x11.glx
+math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx
arrays fry ;
IN: x11.windows
: window-attributes ( visinfo -- attributes )
"XSetWindowAttributes" <c-object>
+ 0 over set-XSetWindowAttributes-background_pixel
+ 0 over set-XSetWindowAttributes-border_pixel
[ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
event-mask over set-XSetWindowAttributes-event_mask ;
--- /dev/null
+! Copyright (C) 2005, 2009 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.strings continuations io
+io.encodings.ascii kernel namespaces x11.xlib x11.io
+vocabs vocabs.loader ;
+IN: x11
+
+SYMBOL: dpy
+SYMBOL: scr
+SYMBOL: root
+
+: init-locale ( -- )
+ LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
+ XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
+
+: flush-dpy ( -- ) dpy get XFlush drop ;
+
+: x-atom ( string -- atom ) [ dpy get ] dip 0 XInternAtom ;
+
+: check-display ( alien -- alien' )
+ [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ;
+
+: init-x ( display-string -- )
+ init-locale
+ dup [ ascii string>alien ] when
+ XOpenDisplay check-display dpy set-global
+ dpy get XDefaultScreen scr set-global
+ dpy get scr get XRootWindow root set-global
+ init-x-io ;
+
+: close-x ( -- ) dpy get XCloseDisplay drop ;
+
+: with-x ( display-string quot -- )
+ [ init-x ] dip [ close-x ] [ ] cleanup ; inline
+
+"io.backend.unix" vocab [ "x11.io.unix" require ] when
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays byte-arrays
hashtables io io.encodings.string kernel math namespaces
-sequences strings continuations x11.xlib specialized-arrays.uint
+sequences strings continuations x11 x11.xlib specialized-arrays.uint
accessors io.encodings.utf16n ;
IN: x11.xim
xim get-global XCloseIM drop f xim set-global ;
: with-xim ( quot -- )
- [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ;
+ [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ; inline
: create-xic ( window classname -- xic )
[
USING: kernel arrays alien alien.c-types alien.strings
alien.syntax math math.bitwise words sequences namespaces
-continuations io io.encodings.ascii ;
+continuations io io.encodings.ascii x11.syntax ;
IN: x11.xlib
LIBRARY: xlib
{ "void*" "free_funcs" }
{ "int" "fd" } ;
-FUNCTION: Display* XOpenDisplay ( void* display_name ) ;
+X-FUNCTION: Display* XOpenDisplay ( void* display_name ) ;
! 2.2 Obtaining Information about the Display, Image Formats, or Screens
-FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ;
-FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ;
-FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ;
-FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ;
-FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ;
-FUNCTION: int XDefaultScreen ( Display* display ) ;
-FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ;
-FUNCTION: Window XDefaultRootWindow ( Display* display ) ;
-FUNCTION: int XProtocolVersion ( Display* display ) ;
-FUNCTION: int XProtocolRevision ( Display* display ) ;
-FUNCTION: int XQLength ( Display* display ) ;
-FUNCTION: int XScreenCount ( Display* display ) ;
-FUNCTION: int XConnectionNumber ( Display* display ) ;
+X-FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ;
+X-FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ;
+X-FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ;
+X-FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ;
+X-FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ;
+X-FUNCTION: int XDefaultScreen ( Display* display ) ;
+X-FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ;
+X-FUNCTION: Window XDefaultRootWindow ( Display* display ) ;
+X-FUNCTION: int XProtocolVersion ( Display* display ) ;
+X-FUNCTION: int XProtocolRevision ( Display* display ) ;
+X-FUNCTION: int XQLength ( Display* display ) ;
+X-FUNCTION: int XScreenCount ( Display* display ) ;
+X-FUNCTION: int XConnectionNumber ( Display* display ) ;
! 2.5 Closing the Display
-FUNCTION: int XCloseDisplay ( Display* display ) ;
+X-FUNCTION: int XCloseDisplay ( Display* display ) ;
!
! 3 - Window Functions
! 3.3 - Creating Windows
-FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ;
-FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ;
-FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ;
-FUNCTION: Status XMapWindow ( Display* display, Window window ) ;
-FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ;
-FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ;
-FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ;
+X-FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ;
+X-FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ;
+X-FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XMapWindow ( Display* display, Window window ) ;
+X-FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ;
+X-FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ;
! 3.5 Mapping Windows
-FUNCTION: int XMapRaised ( Display* display, Window w ) ;
+X-FUNCTION: int XMapRaised ( Display* display, Window w ) ;
! 3.7 - Configuring Windows
{ "Window" "sibling" }
{ "int" "stack_mode" } ;
-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ;
-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ;
-FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ;
-FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ;
+X-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ;
+X-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ;
+X-FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ;
+X-FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ;
! 3.8 Changing Window Stacking Order
-FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ;
-FUNCTION: Status XLowerWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XLowerWindow ( Display* display, Window w ) ;
! 3.9 - Changing Window Attributes
-FUNCTION: Status XChangeWindowAttributes (
+X-FUNCTION: Status XChangeWindowAttributes (
Display* display, Window w, ulong valuemask, XSetWindowAttributes* attr ) ;
-FUNCTION: Status XSetWindowBackground (
+X-FUNCTION: Status XSetWindowBackground (
Display* display, Window w, ulong background_pixel ) ;
-FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ;
-FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ;
+X-FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ;
+X-FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 4 - Window Information Functions
! 4.1 - Obtaining Window Information
-FUNCTION: Status XQueryTree (
+X-FUNCTION: Status XQueryTree (
Display* display,
Window w,
Window* root_return,
{ "Bool" "override_redirect" }
{ "Screen*" "screen" } ;
-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ;
+X-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ;
CONSTANT: IsUnmapped 0
CONSTANT: IsUnviewable 1
CONSTANT: IsViewable 2
-FUNCTION: Status XGetGeometry (
+X-FUNCTION: Status XGetGeometry (
Display* display,
Drawable d,
Window* root_return,
! 4.2 - Translating Screen Coordinates
-FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ;
+X-FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ;
! 4.3 - Properties and Atoms
-FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ;
+X-FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ;
-FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ;
+X-FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ;
! 4.4 - Obtaining and Changing Window Properties
-FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ;
+X-FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ;
-FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ;
+X-FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ;
! 4.5 Selections
-FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ;
+X-FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ;
-FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ;
+X-FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ;
-FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ;
+X-FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 5.1 - Creating and Freeing Pixmaps
-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
+X-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
+X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
{ "char" "flags" }
{ "char" "pad" } ;
-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ;
-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ;
-FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ;
+X-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ;
+X-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ;
+X-FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ;
! 6.4 Creating, Copying, and Destroying Colormaps
-FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ;
+X-FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 7 - Graphics Context Functions
{ "int" "dash_offset" }
{ "char" "dashes" } ;
-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ;
-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ;
-FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ;
-FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ;
-FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ;
-FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ;
-FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ;
+X-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ;
+X-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ;
+X-FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ;
+X-FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ;
+X-FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ;
+X-FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ;
+X-FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ;
-FUNCTION: GContext XGContextFromGC ( GC gc ) ;
+X-FUNCTION: GContext XGContextFromGC ( GC gc ) ;
-FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ;
+X-FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 8 - Graphics Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-FUNCTION: Status XClearWindow ( Display* display, Window w ) ;
-FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ;
-FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ;
-FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
+X-FUNCTION: Status XClearWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ;
+X-FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ;
+X-FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
+X-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
! 8.5 - Font Metrics
{ "short" "descent" }
{ "ushort" "attributes" } ;
-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
+X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
+X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
+X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
C-STRUCT: XFontStruct
{ "XExtData*" "ext_data" }
{ "int" "ascent" }
{ "int" "descent" } ;
-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
+X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
! 8.6 - Drawing Text
-FUNCTION: Status XDrawString (
+X-FUNCTION: Status XDrawString (
Display* display,
Drawable d,
GC gc,
{ "XPointer" "obdata" }
{ "XImage-funcs" "f" } ;
-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
+X-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
: XImage-size ( ximage -- size )
[ XImage-height ] [ XImage-bytes_per_line ] bi * ;
! 9 - Window and Session Manager Functions
!
-FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ;
-FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ;
-FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ;
-FUNCTION: Status XGrabServer ( Display* display ) ;
-FUNCTION: Status XUngrabServer ( Display* display ) ;
-FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
+X-FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ;
+X-FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ;
+X-FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ;
+X-FUNCTION: Status XGrabServer ( Display* display ) ;
+X-FUNCTION: Status XUngrabServer ( Display* display ) ;
+X-FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 10 - Events
! 11 - Event Handling Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ;
-FUNCTION: Status XFlush ( Display* display ) ;
-FUNCTION: Status XSync ( Display* display, int discard ) ;
-FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ;
-FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ;
+X-FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ;
+X-FUNCTION: Status XFlush ( Display* display ) ;
+X-FUNCTION: Status XSync ( Display* display, int discard ) ;
+X-FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ;
+X-FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ;
! 11.3 - Event Queue Management
CONSTANT: QueuedAfterReading 1
CONSTANT: QueuedAfterFlush 2
-FUNCTION: int XEventsQueued ( Display* display, int mode ) ;
-FUNCTION: int XPending ( Display* display ) ;
+X-FUNCTION: int XEventsQueued ( Display* display, int mode ) ;
+X-FUNCTION: int XPending ( Display* display ) ;
! 11.6 - Sending Events to Other Applications
-FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ;
+X-FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ;
! 11.8 - Handling Protocol Errors
-FUNCTION: int XSetErrorHandler ( void* handler ) ;
+X-FUNCTION: int XSetErrorHandler ( void* handler ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 12 - Input Device Functions
CONSTANT: None 0
-FUNCTION: int XGrabPointer (
+X-FUNCTION: int XGrabPointer (
Display* display,
Window grab_window,
Bool owner_events,
Cursor cursor,
Time time ) ;
-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ;
-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ;
-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ;
-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ;
+X-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ;
+X-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ;
+X-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ;
+X-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ;
-FUNCTION: Status XGetInputFocus ( Display* display,
+X-FUNCTION: Status XGetInputFocus ( Display* display,
Window* focus_return,
int* revert_to_return ) ;
-FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ;
+X-FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 14 - Inter-Client Communication Functions
! 14.1 Client to Window Manager Communication
-FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ;
-FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ;
+X-FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ;
+X-FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ;
! 14.1.1. Manipulating Top-Level Windows
-FUNCTION: Status XIconifyWindow (
+X-FUNCTION: Status XIconifyWindow (
Display* display, Window w, int screen_number ) ;
-FUNCTION: Status XWithdrawWindow (
+X-FUNCTION: Status XWithdrawWindow (
Display* display, Window w, int screen_number ) ;
! 14.1.6 - Setting and Reading the WM_HINTS Property
! 14.1.10. Setting and Reading the WM_PROTOCOLS Property
-FUNCTION: Status XSetWMProtocols (
+X-FUNCTION: Status XSetWMProtocols (
Display* display, Window w, Atom* protocols, int count ) ;
-FUNCTION: Status XGetWMProtocols (
+X-FUNCTION: Status XGetWMProtocols (
Display* display,
Window w,
Atom** protocols_return,
! 16.1 Keyboard Utility Functions
-FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ;
+X-FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ;
-FUNCTION: int XLookupString (
+X-FUNCTION: int XLookupString (
XKeyEvent* event_struct,
void* buffer_return,
int bytes_buffer,
! Appendix D - Compatibility Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-FUNCTION: Status XSetStandardProperties (
+X-FUNCTION: Status XSetStandardProperties (
Display* display,
Window w,
char* window_name,
! The rest of the stuff is not from the book.
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-FUNCTION: void XFree ( void* data ) ;
-FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ;
-FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ;
-FUNCTION: int XBell ( Display* display, int percent ) ;
+X-FUNCTION: void XFree ( void* data ) ;
+X-FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ;
+X-FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ;
+X-FUNCTION: int XBell ( Display* display, int percent ) ;
! !!! INPUT METHODS
CONSTANT: XLookupKeySym 3
CONSTANT: XLookupBoth 4
-FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ;
+X-FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ;
-FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ;
+X-FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ;
-FUNCTION: Status XCloseIM ( XIM im ) ;
+X-FUNCTION: Status XCloseIM ( XIM im ) ;
-FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ;
+X-FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ;
-FUNCTION: void XDestroyIC ( XIC ic ) ;
+X-FUNCTION: void XDestroyIC ( XIC ic ) ;
-FUNCTION: void XSetICFocus ( XIC ic ) ;
+X-FUNCTION: void XSetICFocus ( XIC ic ) ;
-FUNCTION: void XUnsetICFocus ( XIC ic ) ;
+X-FUNCTION: void XUnsetICFocus ( XIC ic ) ;
-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
+X-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
-FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
+X-FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
! !!! category of setlocale
CONSTANT: LC_ALL 0
CONSTANT: LC_NUMERIC 4
CONSTANT: LC_TIME 5
-FUNCTION: char* setlocale ( int category, char* name ) ;
+X-FUNCTION: char* setlocale ( int category, char* name ) ;
-FUNCTION: Bool XSupportsLocale ( ) ;
+X-FUNCTION: Bool XSupportsLocale ( ) ;
-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ;
-
-SYMBOL: dpy
-SYMBOL: scr
-SYMBOL: root
-
-: init-locale ( -- )
- LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
- XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
-
-: flush-dpy ( -- ) dpy get XFlush drop ;
-
-: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ;
-
-: check-display ( alien -- alien' )
- [
- "Cannot connect to X server - check $DISPLAY" throw
- ] unless* ;
-
-: initialize-x ( display-string -- )
- init-locale
- dup [ ascii string>alien ] when
- XOpenDisplay check-display dpy set-global
- dpy get XDefaultScreen scr set-global
- dpy get scr get XRootWindow root set-global ;
-
-: close-x ( -- ) dpy get XCloseDisplay drop ;
-
-: with-x ( display-string quot -- )
- [ initialize-x ] dip [ close-x ] [ ] cleanup ;
+X-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ;
}
check_X11_libraries() {
- check_library_exists GLU
check_library_exists GL
check_library_exists X11
check_library_exists pango-1.0
}
install_build_system_apt() {
- sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
+ sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make
check_ret sudo
}
{ $subsection set-alien-float }
{ $subsection set-alien-double } ;
-ARTICLE: "loading-libs" "Loading native libraries"
-"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
-{ $subsection add-library }
-"Once a library has been defined, you can try loading it to see if the path name is correct:"
-{ $subsection load-library } ;
-
ARTICLE: "alien-invoke" "Calling C from Factor"
"The easiest way to call into a C library is to define bindings using a pair of parsing words:"
{ $subsection POSTPONE: LIBRARY: }
] unit-test
! Minor leak
-[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test
+[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval( -- ) ] unit-test
[ ] [ f \ word set-global ] unit-test
-[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test
-[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test
+[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tests FORGET: forget-me" eval( -- ) ] unit-test
[ 0 ] [
[ word? ] instances
[ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count
[ t ] [ mx1 integer class<= ] unit-test
[ t ] [ mx1 number class<= ] unit-test
-"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval
+"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- )
[ t ] [ array mx1 class<= ] unit-test
[ f ] [ mx1 number class<= ] unit-test
[ ] [ "IN: classes.mixin.tests.a" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
-[ { string } ] [ move-instance-declaration-mixin members ] unit-test
\ No newline at end of file
+[ { string } ] [ move-instance-declaration-mixin members ] unit-test
DEFER: foo
-[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
+[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval( -- ) ]
[ error>> invalid-slot-name? ]
must-fail-with
-[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ]
+[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval( -- ) ]
[ error>> invalid-slot-name? ]
must-fail-with
-[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ]
+[ "IN: classes.tuple.parser.tests TUPLE: foo" eval( -- ) ]
[ error>> unexpected-eof? ]
must-fail-with
2 [
- [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
+ [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval( -- ) ]
[ error>> no-initial-value? ]
must-fail-with
] times
2 [
- [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
+ [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval( -- ) ]
[ error>> bad-initial-value? ]
must-fail-with
[ f ] [ \ foo tuple-class? ] unit-test
] times
-[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ]
+[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval( -- ) ]
[ error>> duplicate-slot-names? ]
must-fail-with
" f"
" 3"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
"T{ parsing-corner-case"
" { x 3 }"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
"T{ parsing-corner-case {"
" x 3 }"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
{
"USE: classes.tuple.parser.tests T{ parsing-corner-case"
" { x 3 }"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
[
{
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
-"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval
+"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- )
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
[ ] [ 100 200 <point> "p" set ] unit-test
! Use eval to sequence parsing explicitly
-[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
[ 100 ] [ "p" get x>> ] unit-test
[ 200 ] [ "p" get y>> ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test
[ 2 ] [ "p" get tuple-size ] unit-test
[ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ]
-[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word name>> ] unit-test
+[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval( -- ) word name>> ] unit-test
TUPLE: size-test a b c d ;
TUPLE: yo-momma ;
-[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval( -- ) ] unit-test
[ f ] [ \ <yo-momma> generic? ] unit-test
: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
-[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval( -- ) ] unit-test
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
] unit-test
[
- "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
+ "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval( -- )
] must-fail
! Dynamically changing inheritance hierarchy
TUPLE: electronic-device ;
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test
[ f ] [ electronic-device laptop class<= ] unit-test
[ t ] [ server electronic-device class<= ] unit-test
[ f ] [ "server" get laptop? ] unit-test
[ t ] [ "server" get server? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval( -- ) ] unit-test
[ f ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
[ ] [ "laptop" get 220 >>voltage drop ] unit-test
[ ] [ "server" get 110 >>voltage drop ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
[ 110 ] [ "server" get voltage>> ] unit-test
! Reshaping superclass and subclass simultaneously
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
test-a/b
-[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test
test-a/b
-[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test
test-a/b
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test
! Constructors must be recompiled when changing superclass
TUPLE: constructor-update-1 xxx ;
{ 3 1 } [ <constructor-update-2> ] must-infer-as
-[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
{ 5 1 } [ <constructor-update-2> ] must-infer-as
TUPLE: redefinition-problem-2 ;
-"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval
+"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval( -- )
[ t ] [ 3 redefinition-problem'? ] unit-test
] with-compilation-unit
] unit-test
-[ "USE: words T{ word }" eval ]
+[ "USE: words T{ word }" eval( -- ) ]
[ error>> T{ no-method f word new } = ]
must-fail-with
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
-: accessor-exists? ( class name -- ? )
+: accessor-exists? ( name -- ? )
[ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
">>" append "accessors" lookup method >boolean ;
[ f ] [
t parser-notes? [
[
- "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
+ "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval( -- )
] with-string-writer empty?
] with-variable
] unit-test
! Missing error check
-[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail
! Class forget messyness
TUPLE: subclass-forget-test ;
TUPLE: subclass-forget-test-2 < subclass-forget-test ;
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
-[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval( -- ) ] unit-test
[ { subclass-forget-test-2 } ]
[ subclass-forget-test-2 class-usages ]
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail
-[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail
+[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval( -- ) ] must-fail
! More
DEFER: subclass-reset-test
[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval( -- ) ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval( -- ) ] unit-test
[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval( -- ) ] unit-test
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
T{ reshape-test f "hi" } "tuple" set
-[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
[ f ] [ \ reshape-test \ (>>x) method ] unit-test
[ "hi" ] [ "tuple" get x>> ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test
[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
[ f ] [ \ error-class-test "inline" word-prop ] unit-test
-[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ]
+[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ]
[ error>> error>> redefine-error? ] must-fail-with
DEFER: error-y
[ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
-[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test
[ f ] [ \ error-y tuple-class? ] unit-test
[ t ] [ \ error-y generic? ] unit-test
-[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test
[ t ] [ \ error-y tuple-class? ] unit-test
] unit-test
[ ] [
- "IN: sequences TUPLE: reversed { seq read-only } ;" eval
+ "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- )
] unit-test
TUPLE: bogus-hashcode-1 x ;
DEFER: redefine-tuple-twice
-[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
-[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice deferred? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
-[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
\ No newline at end of file
+[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
[ t ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
-"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
+"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval( -- )
[ t ] [ bignum union-1 class<= ] unit-test
[ f ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
-"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval
+"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval( -- )
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ quotation redefine-bug-2 class<= ] unit-test
-[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
+[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval( -- ) ] unit-test
[ t ] [ bignum redefine-bug-1 class<= ] unit-test
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
-: test-case-8 ( n -- )
+: test-case-8 ( n -- string )
{
{ 1 [ "foo" ] }
} case ;
] [ callable? ] if
] find nip ;
+\ case-find t "no-compile" set-word-prop
+
: case ( obj assoc -- )
case-find {
{ [ dup array? ] [ nip second call ] }
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: compiler.errors
-USING: help.markup help.syntax vocabs.loader words io
-quotations words.symbol ;
-
-ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"After loading a vocabulary, you might see messages like:"
-{ $code
- ":errors - print 2 compiler errors."
- ":warnings - print 50 compiler warnings."
-}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
-$nl
-"The precise warning and error conditions are documented in " { $link "inference-errors" } "."
-$nl
-"Words to view warnings and errors:"
-{ $subsection :errors }
-{ $subsection :warnings }
-{ $subsection :linkage }
-"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
-{ $subsection with-compiler-errors } ;
-
-HELP: compiler-errors
-{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ;
-
-ABOUT: "compiler-errors"
-
-HELP: compiler-error
-{ $values { "error" "an error" } { "word" word } }
-{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
-
-HELP: compiler-error.
-{ $values { "error" "an error" } { "word" word } }
-{ $description "Prints a compiler error to " { $link output-stream } "." } ;
-
-HELP: compiler-errors.
-{ $values { "type" symbol } }
-{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
-HELP: :errors
-{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :warnings
-{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :linkage
-{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
-
-{ :errors :warnings } related-words
-
-HELP: with-compiler-errors
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
-{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make assocs io sequences
-sorting continuations math math.parser ;
-IN: compiler.errors
-
-SYMBOL: +error+
-SYMBOL: +warning+
-SYMBOL: +linkage+
-
-GENERIC: compiler-error-type ( error -- ? )
-
-M: object compiler-error-type drop +error+ ;
-
-GENERIC# compiler-error. 1 ( error word -- )
-
-SYMBOL: compiler-errors
-
-SYMBOL: with-compiler-errors?
-
-: errors-of-type ( type -- assoc )
- compiler-errors get-global
- swap [ [ nip compiler-error-type ] dip eq? ] curry
- assoc-filter ;
-
-: compiler-errors. ( type -- )
- errors-of-type >alist sort-keys
- [ swap compiler-error. ] assoc-each ;
-
-: (compiler-report) ( what type word -- )
- over errors-of-type assoc-empty? [ 3drop ] [
- [
- ":" %
- %
- " - print " %
- errors-of-type assoc-size #
- " " %
- %
- "." %
- ] "" make print
- ] if ;
-
-: compiler-report ( -- )
- "semantic errors" +error+ "errors" (compiler-report)
- "semantic warnings" +warning+ "warnings" (compiler-report)
- "linkage errors" +linkage+ "linkage" (compiler-report) ;
-
-: :errors ( -- ) +error+ compiler-errors. ;
-
-: :warnings ( -- ) +warning+ compiler-errors. ;
-
-: :linkage ( -- ) +linkage+ compiler-errors. ;
-
-: compiler-error ( error word -- )
- with-compiler-errors? get [
- compiler-errors get pick
- [ set-at ] [ delete-at drop ] if
- ] [ 2drop ] if ;
-
-: with-compiler-errors ( quot -- )
- with-compiler-errors? get "quiet" get or [ call ] [
- [
- with-compiler-errors? on
- V{ } clone compiler-errors set-global
- [ compiler-report ] [ ] cleanup
- ] with-scope
- ] if ; inline
+++ /dev/null
-Compiler warning and error reporting
-IN: compiler.units.tests
USING: definitions compiler.units tools.test arrays sequences words kernel
-accessors namespaces fry ;
+accessors namespaces fry eval ;
+IN: compiler.units.tests
[ [ [ ] define-temp ] with-compilation-unit ] must-infer
[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
"a" get [ "B" ] define
] with-compilation-unit
"b" get execute
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Notify observers even if compilation unit did nothing
+SINGLETON: observer
+
+observer add-definition-observer
+
+SYMBOL: counter
+
+0 counter set-global
+
+M: observer definitions-changed 2drop global [ counter inc ] bind ;
+
+[ ] with-compilation-unit
+
+[ 1 ] [ counter get-global ] unit-test
+
+observer remove-definition-observer
+
+! Notify observers with nested compilation units
+observer add-definition-observer
+
+0 counter set-global
+
+DEFER: nesting-test
+
+[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test
+
+observer remove-definition-observer
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math math.order classes classes.algebra classes.tuple
-classes.tuple.private generic ;
+classes.tuple.private generic source-files.errors ;
IN: compiler.units
SYMBOL: old-definitions
definition-observers get push ;
: remove-definition-observer ( obj -- )
- definition-observers get delete ;
+ definition-observers get delq ;
: notify-definition-observers ( assoc -- )
definition-observers get
changed-generics get compiled-generic-usages
append assoc-combine keys ;
-: unxref-forgotten-definitions ( -- )
- forgotten-definitions get
- keys [ word? ] filter
- [ delete-compiled-xref ] each ;
+: process-forgotten-definitions ( -- )
+ forgotten-definitions get keys
+ [ [ word? ] filter [ delete-compiled-xref ] each ]
+ [ [ delete-definition-errors ] each ]
+ bi ;
: finish-compilation-unit ( -- )
remake-generics
to-recompile recompile
update-tuples
- unxref-forgotten-definitions
- modify-code-heap ;
+ process-forgotten-definitions
+ modify-code-heap
+ updated-definitions notify-definition-observers
+ notify-error-observers ;
: with-nested-compilation-unit ( quot -- )
[
H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
- [
- finish-compilation-unit
- updated-definitions
- notify-definition-observers
- ] [ ] cleanup
+ [ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
{ $heading "Anti-pattern #4: Logging and rethrowing" }
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
-ARTICLE: "errors" "Error handling"
+ARTICLE: "errors" "Exception handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl
"Two words raise an error in the innermost error handler for the current dynamic extent:"
kernel.private accessors eval ;
IN: continuations.tests
-: (callcc1-test) ( -- )
+: (callcc1-test) ( n obj -- n' obj )
[ 1- dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ;
! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail
-: don't-compile-me ( -- ) { } [ ] each ;
+: don't-compile-me ( n -- ) { } [ ] each ;
: foo ( -- ) callstack "c" set 3 don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
namespaces make math splitting sorting quotations assocs
-combinators combinators.private accessors ;
+combinators combinators.private accessors words ;
IN: continuations
SYMBOL: error
<PRIVATE
: (continue) ( continuation -- * )
- >continuation<
- set-catchstack
- set-namestack
- set-retainstack
- [ set-datastack ] dip
- set-callstack ;
+ [
+ >continuation<
+ set-catchstack
+ set-namestack
+ set-retainstack
+ [ set-datastack ] dip
+ set-callstack
+ ] (( continuation -- * )) call-effect-unsafe ;
PRIVATE>
[ 2 ] [ 1.0 union-containment ] unit-test
! Testing recovery from bad method definitions
-"IN: generic.tests GENERIC: unhappy ( x -- x )" eval
+"IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- )
[
- "IN: generic.tests M: dictionary unhappy ;" eval
+ "IN: generic.tests M: dictionary unhappy ;" eval( -- )
] must-fail
-[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
+[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test
GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ;
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
-[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
+[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval( -- ) ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
[ t ] [ "m" get \ a-word usage memq? ] unit-test
-[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test
+[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "m" get \ a-word usage memq? ] unit-test
M: boii jeah ;
GENERIC: jeah* ( a -- b )
M: boii jeah* jeah ;
- "> eval
+ "> eval( -- )
<"
IN: compiler.tests
FORGET: boii
- "> eval
+ "> eval( -- )
<"
IN: compiler.tests
TUPLE: boii ;
M: boii jeah ;
- "> eval
+ "> eval( -- )
] unit-test
! call-next-method cache test
GENERIC: c-n-m-cache ( a -- b )
! Force it to be unoptimized
-M: fixnum c-n-m-cache { } [ ] like call call-next-method ;
+M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ;
M: integer c-n-m-cache 1 + ;
M: number c-n-m-cache ;
[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
-[ { string } ] [ \ move-method-generic order ] unit-test
\ No newline at end of file
+[ { string } ] [ \ move-method-generic order ] unit-test
GENERIC: effective-method ( generic -- method )
+\ effective-method t "no-compile" set-word-prop
+
: next-method-class ( class generic -- class/f )
order [ class<= ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ;
effect boa
] [ 2drop f ] if ;
+M: engine-word where "tuple-dispatch-generic" word-prop where ;
+
M: engine-word crossref? "forgotten" word-prop not ;
M: engine-word irrelevant? drop t ;
GENERIC: perimiter ( shape -- n )
-: rectangle-perimiter ( n -- n ) + 2 * ;
+: rectangle-perimiter ( l w -- n ) + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
[ ] [ :c ] unit-test
-: (overflow-d-alt) ( -- ) 3 ;
+: (overflow-d-alt) ( -- n ) 3 ;
: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
! Regression
: (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap
- < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline
+ < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
: loop ( obj obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
[ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
-[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
\ No newline at end of file
+[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
[ [ ] instances ] must-infer
! Code GC wasn't kicking in when needed
-: leak-step ( -- ) 800000 f <array> 1quotation call drop ;
+: leak-step ( -- ) 800000 f <array> 1quotation call( -- obj ) drop ;
: leak-loop ( -- ) 100 [ leak-step ] times ;
sequences strings io.files io.pathnames definitions
continuations sorting classes.tuple compiler.units debugger
vocabs vocabs.loader accessors eval combinators lexer
-vocabs.parser words.symbol multiline ;
+vocabs.parser words.symbol multiline source-files.errors ;
IN: parser.tests
\ run-file must-infer
[
[ 1 [ 2 [ 3 ] 4 ] 5 ]
- [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
+ [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ]
unit-test
[ t t f f ]
- [ "t t f f" eval ]
+ [ "t t f f" eval( -- ? ? ? ? ) ]
unit-test
[ "hello world" ]
- [ "\"hello world\"" eval ]
+ [ "\"hello world\"" eval( -- string ) ]
unit-test
[ "\n\r\t\\" ]
- [ "\"\\n\\r\\t\\\\\"" eval ]
+ [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ]
unit-test
[ "hello world" ]
[
"IN: parser.tests : hello ( -- str ) \"hello world\" ;"
- eval "USE: parser.tests hello" eval
+ eval( -- ) "USE: parser.tests hello" eval( -- string )
] unit-test
[ ]
- [ "! This is a comment, people." eval ]
+ [ "! This is a comment, people." eval( -- ) ]
unit-test
! Test escapes
[ " " ]
- [ "\"\\u000020\"" eval ]
+ [ "\"\\u000020\"" eval( -- string ) ]
unit-test
[ "'" ]
- [ "\"\\u000027\"" eval ]
+ [ "\"\\u000027\"" eval( -- string ) ]
unit-test
! Test EOL comments in multiline strings.
- [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test
+ [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test
[ word ] [ \ f class ] unit-test
[ \ baz "declared-effect" word-prop terminated?>> ]
unit-test
- [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test
+ [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test
[ t ] [
"effect-parsing-test" "parser.tests" lookup
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
! Funny bug
- [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test
+ [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test
- [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail
+ [ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail
! These should throw errors
- [ "HEX: zzz" eval ] must-fail
- [ "OCT: 999" eval ] must-fail
- [ "BIN: --0" eval ] must-fail
+ [ "HEX: zzz" eval( -- obj ) ] must-fail
+ [ "OCT: 999" eval( -- obj ) ] must-fail
+ [ "BIN: --0" eval( -- obj ) ] must-fail
! Another funny bug
[ t ] [
] unit-test
DEFER: foo
- "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval
+ "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- )
- [ ] [ "USE: parser.tests foo" eval ] unit-test
+ [ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test
- "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval
+ "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- )
[ t ] [
- "USE: parser.tests \\ foo" eval
+ "USE: parser.tests \\ foo" eval( -- word )
"foo" "parser.tests" lookup eq?
] unit-test
] unit-test
[ ] [
- "IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- ) <bogus-error> ;"
+ "IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- error ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop
] unit-test
[ ] [
- "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- ) <bogus-error> ;"
+ "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- error ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop
] unit-test
] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [
- "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
+ "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- )
] unit-test
[
- "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
+ "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- )
] must-fail
] with-file-vocabs
[ ] [
- "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
+ "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval( -- )
] unit-test
[ t ] [
] unit-test
[
- "USE: this-better-not-exist" eval
+ "USE: this-better-not-exist" eval( -- )
] must-fail
-[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
+[ ": foo ;" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with
-[ 92 ] [ "CHAR: \\" eval ] unit-test
-[ 92 ] [ "CHAR: \\\\" eval ] unit-test
+[ 92 ] [ "CHAR: \\" eval( -- n ) ] unit-test
+[ 92 ] [ "CHAR: \\\\" eval( -- n ) ] unit-test
[ ] [
{
"IN: parser.tests"
- "USING: math arrays ;"
- "GENERIC: change-combination ( a -- b )"
- "M: integer change-combination 1 ;"
- "M: array change-combination 2 ;"
+ "USING: math arrays kernel ;"
+ "GENERIC: change-combination ( obj a -- b )"
+ "M: integer change-combination 2drop 1 ;"
+ "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test
[ ] [
{
"IN: parser.tests"
- "USING: math arrays ;"
- "GENERIC# change-combination 1 ( a -- b )"
- "M: integer change-combination 1 ;"
- "M: array change-combination 2 ;"
+ "USING: math arrays kernel ;"
+ "GENERIC# change-combination 1 ( obj a -- b )"
+ "M: integer change-combination 2drop 1 ;"
+ "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test
] unit-test
[ [ ] ] [
- "IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
+ "IN: parser.tests : staging-problem-test-1 ( -- a ) 1 ; : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream
] unit-test
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ [ ] ] [
- "IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
+ "IN: parser.tests << : staging-problem-test-1 ( -- a ) 1 ; >> : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream
] unit-test
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
-[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
+[ "DEFER: blahy" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with
[
- "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval
+ "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval( -- )
] [
error>> staging-violation?
] must-fail-with
! Bogus error message
DEFER: blahy
-[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ]
+[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval( -- ) ]
[ error>> error>> def>> \ blahy eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
-[ "CHAR: \\u9999999999999" eval ] must-fail
+[ "CHAR: \\u9999999999999" eval( -- n ) ] must-fail
SYMBOLS: a b c ;
DEFER: blah
-[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test
-[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
+[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval( -- ) ] unit-test
+[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval( -- ) ] unit-test
[ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test
DEFER: blah1
-[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ]
+[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval( -- ) ]
[ error>> error>> def>> \ blah1 eq? ]
must-fail-with
[ 3 ] [ x ] unit-test
[ 4 ] [ y ] unit-test
-[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
+[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval( -- ) ]
[ error>> no-word-error? ] must-fail-with
-[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
+[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval( -- ) ]
[ error>> no-word-error? ] must-fail-with
! Two similar bugs
! 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 effects.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.units accessors sets lexer vocabs.parser
+effects.parser slots ;
IN: parser
: location ( -- loc )
"math.order"
"memory"
"namespaces"
+ "parser"
"prettyprint"
"see"
"sequences"
"tools.annotations"
"tools.crossref"
"tools.disassembler"
+ "tools.errors"
"tools.memory"
"tools.profiler"
"tools.test"
: parse-file ( file -- quot )
[
- [
- [ parsing-file ] keep
- [ utf8 <file-reader> ] keep
- parse-stream
- ] with-compiler-errors
+ [ parsing-file ] keep
+ [ utf8 <file-reader> ] keep
+ parse-stream
] [
over parse-file-restarts rethrow-restarts
drop parse-file
"Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:"
{ $subsection wrapper }
{ $subsection literalize }
+"Wrapper literal syntax is documented in " { $link "syntax-words" } "."
{ $see-also "combinators" } ;
ABOUT: "quotations"
2dup [ length ] bi@ =
[ mismatch not ] [ 2drop f ] if ; inline
+ERROR: assert-sequence got expected ;
+
+: assert-sequence= ( a b -- )
+ 2dup sequence= [ 2drop ] [ assert-sequence ] if ;
+
: sequence-hashcode-step ( oldhash newpart -- newhash )
>fixnum swap [
[ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
! See if declarations are cleared on redefinition
-[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test
+[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test
[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
-[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test
+[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
[ make-slot ] map ;
: finalize-slots ( specs base -- specs )
- over length [ + ] with map [ >>offset ] 2map ;
+ over length iota [ + ] with map [ >>offset ] 2map ;
: slot-named ( name specs -- spec/f )
[ name>> = ] with find nip ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: assocs compiler.errors compiler.units definitions
+namespaces source-files.errors tools.test words ;
+IN: source-files.errors.tests
+
+DEFER: forget-test
+
+[ ] [ [ \ forget-test [ 1 ] (( -- )) define-declared ] with-compilation-unit ] unit-test
+[ t ] [ \ forget-test compiler-errors get key? ] unit-test
+[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
+[ f ] [ \ forget-test compiler-errors get key? ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math.order sorting sequences definitions
+namespaces arrays splitting io math.parser math init ;
+IN: source-files.errors
+
+TUPLE: source-file-error error asset file line# ;
+
+: sort-errors ( errors -- alist )
+ [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+
+: group-by-source-file ( errors -- assoc )
+ H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
+
+TUPLE: error-type type word plural icon quot forget-quot { fatal? initial: t } ;
+
+GENERIC: error-type ( error -- type )
+
+: <definition-error> ( error definition class -- source-file-error )
+ new
+ swap
+ [ >>asset ]
+ [ where [ first2 [ >>file ] [ >>line# ] bi* ] when* ] bi
+ swap >>error ; inline
+
+SYMBOL: error-types
+
+error-types [ V{ } clone ] initialize
+
+: define-error-type ( error-type -- )
+ dup type>> error-types get set-at ;
+
+: error-icon-path ( type -- icon )
+ error-types get at icon>> ;
+
+: error-counts ( -- alist )
+ error-types get
+ [ nip dup quot>> call( -- seq ) length ] assoc-map
+ [ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ;
+
+: error-summary ( -- )
+ error-counts [
+ over
+ [ word>> write ]
+ [ " - show " write number>string write bl ]
+ [ plural>> print ] tri*
+ ] assoc-each ;
+
+: all-errors ( -- errors )
+ error-types get values
+ [ quot>> call( -- seq ) ] map
+ concat ;
+
+GENERIC: errors-changed ( observer -- )
+
+SYMBOL: error-observers
+
+[ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook
+
+: add-error-observer ( observer -- ) error-observers get push ;
+
+: remove-error-observer ( observer -- ) error-observers get delq ;
+
+: notify-error-observers ( -- ) error-observers get [ errors-changed ] each ;
+
+: delete-file-errors ( seq file type -- )
+ [
+ [ swap file>> = ] [ swap error-type = ]
+ bi-curry* bi and not
+ ] 2curry filter-here
+ notify-error-observers ;
+
+: delete-definition-errors ( definition -- )
+ error-types get [
+ second forget-quot>> dup
+ [ call( definition -- ) ] [ 2drop ] if
+ ] with each ;
\ No newline at end of file
sequences strings vectors words quotations io io.files
io.pathnames combinators sorting splitting math.parser effects
continuations checksums checksums.crc32 vocabs hashtables graphs
-compiler.units io.encodings.utf8 accessors ;
+compiler.units io.encodings.utf8 accessors source-files.errors ;
IN: source-files
SYMBOL: source-files
[
source-file
[ unxref-source ]
- [ definitions>> [ keys forget-all ] each ]
- bi
+ [ definitions>> [ keys forget-all ] each ] bi
]
[ source-files get delete-at ]
bi ;
SYMBOL: file
-TUPLE: source-file-error error file ;
-
-: <source-file-error> ( msg -- error )
+: wrap-source-file-error ( error -- * )
+ file get rollback-source-file
\ source-file-error new
- file get >>file
- swap >>error ;
+ f >>line#
+ file get path>> >>file
+ swap >>error rethrow ;
: with-source-file ( name quot -- )
#! Should be called from inside with-compilation-unit.
[
- swap source-file
- dup file set
- definitions>> old-definitions set
[
- file get rollback-source-file
- <source-file-error> rethrow
- ] recover
+ source-file
+ [ file set ]
+ [ definitions>> old-definitions set ] bi
+ ] dip
+ [ wrap-source-file-error ] recover
] with-scope ; inline
forget-junk
[ { } ] [
- "IN: xabbabbja" eval "xabbabbja" vocab-files
+ "IN: xabbabbja" eval( -- ) "xabbabbja" vocab-files
] unit-test
[ "xabbabbja" forget-vocab ] with-compilation-unit
USING: namespaces make sequences io io.files io.pathnames kernel
assocs words vocabs definitions parser continuations hashtables
sorting source-files arrays combinators strings system
-math.parser compiler.errors splitting init accessors sets ;
+math.parser splitting init accessors sets ;
IN: vocabs.loader
SYMBOL: vocab-roots
PRIVATE>
: require ( vocab -- )
- [ load-vocab drop ] with-compiler-errors ;
+ load-vocab drop ;
: reload ( name -- )
dup vocab
- [ [ [ load-source ] [ load-docs ] bi ] with-compiler-errors ]
+ [ [ load-source ] [ load-docs ] bi ]
[ require ]
?if ;
[
dup vocab-name blacklist get at* [ rethrow ] [
drop dup find-vocab-root
- [ [ (load-vocab) ] with-compiler-errors ]
- [ dup vocab [ ] [ no-vocab ] ?if ]
- if
+ [ (load-vocab) ] [ dup vocab [ ] [ no-vocab ] ?if ] if
] if
] load-vocab-hook set-global
IN: words.alias.tests
ALIAS: foo +
-[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
-[ (( -- value )) ] [ \ foo stack-effect ] unit-test
\ No newline at end of file
+[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval( -- ) ] unit-test
+[ (( -- value )) ] [ \ foo stack-effect ] unit-test
--- /dev/null
+USING: help.markup help.syntax words.constant ;
+IN: words.constant
+
+ARTICLE: "words.constant" "Constants"
+"There is a syntax for defining words which push literals on the stack."
+$nl
+"Define a new word that pushes a literal on the stack:"
+{ $subsection POSTPONE: CONSTANT: }
+"Define an constant at run-time:"
+{ $subsection define-constant } ;
+
+ABOUT: "words.constant"
{ $subsection define }
{ $subsection define-declared }
{ $subsection define-inline }
-"Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "."
+"Word definitions must declare their stack effect. See " { $link "effect-declaration" } "."
$nl
"All other types of word definitions, such as " { $link "words.symbol" } " and " { $link "generic" } ", are just special cases of the above." ;
{ $subsection "colon-definition" }
{ $subsection "words.symbol" }
{ $subsection "words.alias" }
+{ $subsection "words.constant" }
{ $subsection "primitives" }
{ $subsection "deferred" }
{ $subsection "declarations" }
[ 4 ] [
[
- "poo" "words.tests" create [ 2 2 + ] define
+ "poo" "words.tests" create [ 2 2 + ] (( -- n )) define-declared
] with-compilation-unit
"poo" "words.tests" lookup execute
] unit-test
! See if redefining a generic as a colon def clears some
! word props.
GENERIC: testing ( a -- b )
-"IN: words.tests : testing ( -- ) ;" eval
+"IN: words.tests : testing ( -- ) ;" eval( -- )
[ f ] [ \ testing generic? ] unit-test
[
\ calls-a-gensym
gensym dup "x" set 1quotation
- define
+ (( x -- x )) define-declared
] with-compilation-unit
] unit-test
[ ] [ "no-loc" "words.tests" create drop ] unit-test
[ f ] [ "no-loc" "words.tests" lookup where ] unit-test
-[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test
-[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test
[ "test-last" ] [ word name>> ] unit-test
! regression
[ forget ] with-compilation-unit
] when*
-[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval ]
+[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval( -- ) ]
[ error>> undefined? ] must-fail-with
[ ] [
- "IN: words.tests GENERIC: symbol-generic ( -- )" eval
+ "IN: words.tests GENERIC: symbol-generic ( -- )" eval( -- )
] unit-test
[ ] [
- "IN: words.tests SYMBOL: symbol-generic" eval
+ "IN: words.tests SYMBOL: symbol-generic" eval( -- )
] unit-test
[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
! Regressions
-[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval( -- ) ] unit-test
[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
-[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
-[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval( -- ) ] unit-test
[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
-[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ { } ]
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
! namespace utilities\r
- \r
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;\r
\r
: closed-quot ( quot -- quot )\r
namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;\r
3 model-projection <model> view4> (>>model) ;\r
\r
: camera-action ( quot -- quot ) \r
- [ drop [ ] observer3d> \r
+ '[ drop _ observer3d> \r
with-self update-observer-projections ] \r
- make* closed-quot ;\r
+ closed-quot ;\r
\r
: win3D ( text gadget -- ) \r
"navigateur 4D : " rot append open-window ;\r
\r
: add-keyboard-delegate ( obj -- obj )\r
<handler>\r
-{\r
+H{\r
{ T{ key-down f f "LEFT" } \r
[ [ rotation-step turn-left ] camera-action ] }\r
{ T{ key-down f f "RIGHT" } \r
{ T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }\r
{ T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }\r
\r
- } [ make* ] map >hashtable >>table\r
+ } >>table\r
; \r
\r
! --------------------------------------------\r
: init-filelist-model ( file-chooser -- file-chooser )\r
dup list-of-files <model> >>model ; \r
\r
-: (fc-go) ( file-chooser quot -- )\r
+: (fc-go) ( file-chooser button quot -- )\r
[ [ file-chooser? ] find-parent dup path>> ] dip\r
call\r
normalize-path swap set-model\r
update-filelist-model\r
- drop ;\r
+ drop ; inline\r
\r
-: fc-go-parent ( file-chooser -- )\r
+: fc-go-parent ( file-chooser button -- )\r
[ dup value>> parent-directory ] (fc-go) ;\r
\r
-: fc-go-home ( file-chooser -- )\r
+: fc-go-home ( file-chooser button -- )\r
[ home ] (fc-go) ;\r
\r
: fc-change-directory ( file-chooser file -- )\r
;\r
\r
: fc-load-file ( file-chooser file -- )\r
- dupd [ selected-file>> ] [ name>> ] bi* swap set-model \r
- [ path>> value>> ] \r
- [ selected-file>> value>> append ] \r
- [ hook>> ] tri\r
- call\r
+ over [ name>> ] [ selected-file>> ] bi* set-model \r
+ [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi\r
+ call( path -- )\r
; inline\r
\r
! : fc-ok-action ( file-chooser -- quot )\r
+++ /dev/null
-IN: advice
-USING: help.markup help.syntax tools.annotations words coroutines ;
-
-HELP: make-advised
-{ $values { "word" "a word to annotate in preparation of advising" } }
-{ $description "Prepares a word for being advised. This is done by: "
- { $list
- { "Annotating it to call the appropriate words before, around, and after the original body " }
- { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
- { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
- }
-}
-{ $see-also advised? annotate } ;
-
-HELP: advised?
-{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
-{ $description "Determines whether or not the given word has any advice on it." } ;
-
-HELP: ad-do-it
-{ $values { "input" "an object" } { "result" "an object" } }
-{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
-{ $see-also coyield } ;
-
-ARTICLE: "advice" "Advice"
-"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
-
-ABOUT: "advice"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences io io.streams.string math tools.test advice math.parser
-parser namespaces multiline eval words assocs ;
-IN: advice.tests
-
-[
- [ ad-do-it ] must-fail
-
- : foo ( -- str ) "foo" ;
- \ foo make-advised
-
- { "bar" "foo" } [
- [ "bar" ] "barify" \ foo advise-before
- foo
- ] unit-test
-
- { "bar" "foo" "baz" } [
- [ "baz" ] "bazify" \ foo advise-after
- foo
- ] unit-test
-
- { "foo" "baz" } [
- "barify" \ foo before remove-advice
- foo
- ] unit-test
-
- : bar ( a -- b ) 1+ ;
- \ bar make-advised
-
- { 11 } [
- [ 2 * ] "double" \ bar advise-before
- 5 bar
- ] unit-test
-
- { 11/3 } [
- [ 3 / ] "third" \ bar advise-after
- 5 bar
- ] unit-test
-
- { -2 } [
- [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
- 5 bar
- ] unit-test
-
- : add ( a b -- c ) + ;
- \ add make-advised
-
- { 10 } [
- [ [ 2 * ] bi@ ] "double-args" \ add advise-before
- 2 3 add
- ] unit-test
-
- { 21 } [
- [ 3 * ad-do-it 1- ] "around1" \ add advise-around
- 2 3 add
- ] unit-test
-
-! { 9 } [
-! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
-! 2 3 add
-! ] unit-test
-
-! { { "around1" "around2" } } [
-! \ add around word-prop keys
-! ] unit-test
-
- { 5 f } [
- \ add unadvise
- 2 3 add \ add advised?
- ] unit-test
-
-! : quux ( a b -- c ) * ;
-
-! { f t 3+3/4 } [
-! <" USING: advice kernel math ;
-! IN: advice.tests
-! \ quux advised?
-! ADVISE: quux halve before [ 2 / ] bi@ ;
-! \ quux advised?
-! 3 5 quux"> eval
-! ] unit-test
-
-! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
-! <" USING: advice kernel math math.parser io io.streams.string ;
-! IN: advice.tests
-! ADVISE: quux log around
-! 2dup [ number>string write " " write ] bi@
-! ad-do-it
-! dup number>string write ;
-! [ 3 5 quux ] with-string-writer"> eval
-! ] unit-test
-
-] with-scope
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences fry words assocs linked-assocs tools.annotations
-coroutines lexer parser quotations arrays namespaces continuations ;
-IN: advice
-
-SYMBOLS: before after around advised in-advice? ;
-
-: advised? ( word -- ? )
- advised word-prop ;
-
-DEFER: make-advised
-
-<PRIVATE
-: init-around-co ( quot -- coroutine )
- \ coreset suffix cocreate ;
-PRIVATE>
-
-: advise ( quot name word loc -- )
- dup around eq? [ [ init-around-co ] 3dip ] when
- over advised? [ over make-advised ] unless
- word-prop set-at ;
-
-: advise-before ( quot name word -- ) before advise ;
-
-: advise-after ( quot name word -- ) after advise ;
-
-: advise-around ( quot name word -- ) around advise ;
-
-: get-advice ( word type -- seq )
- word-prop values ;
-
-: call-before ( word -- )
- before get-advice [ call ] each ;
-
-: call-after ( word -- )
- after get-advice [ call ] each ;
-
-: call-around ( main word -- )
- t in-advice? [
- around get-advice tuck
- [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
- ] with-variable ;
-
-: remove-advice ( name word loc -- )
- word-prop delete-at ;
-
-: ad-do-it ( input -- result )
- in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
-
-: make-advised ( word -- )
- [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
- [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
- [ t advised set-word-prop ] tri ;
-
-: unadvise ( word -- )
- [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
-
-SYNTAX: ADVISE: ! word adname location => word adname quot loc
- scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
-
-SYNTAX: UNADVISE:
- scan-word parsed \ unadvise parsed ;
\ No newline at end of file
+++ /dev/null
-James Cash
+++ /dev/null
-Implmentation of advice/aspects
+++ /dev/null
-extensions
: process-day ( account date -- )
2dup accumulate-interest ?pay-interest ;
-: each-day ( quot start end -- )
+: each-day ( quot: ( -- ) start end -- )
2dup before? [
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [
: process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+
- [ dupd process-day ] spin each-day ; inline
+ [ dupd process-day ] spin each-day ;
: inserting-transactions ( account transactions -- account )
[ [ date>> process-to-date ] keep >>transaction ] each ;
: base64-benchmark ( -- )
65535 [ 255 bitand ] "" map-as
- 100 [ >base64 base64> ] times
+ 20 [ >base64 base64> ] times
drop ;
MAIN: base64-benchmark
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger math ;
+continuations debugger math namespaces ;
IN: benchmark
-: run-benchmark ( vocab -- result )
+<PRIVATE
+
+SYMBOL: timings
+SYMBOL: errors
+
+PRIVATE>
+
+: run-benchmark ( vocab -- )
[ "=== " write vocab-name print flush ] [
- [ [ require ] [ [ run ] benchmark ] bi ] curry
- [ error. f ] recover
+ [ [ require ] [ [ run ] benchmark ] [ ] tri timings ]
+ [ swap errors ]
+ recover get set-at
] bi ;
-: run-benchmarks ( -- assoc )
- "benchmark" all-child-vocabs-seq
- [ dup run-benchmark ] { } map>assoc ;
+: run-benchmarks ( -- timings errors )
+ [
+ V{ } clone timings set
+ V{ } clone errors set
+ "benchmark" all-child-vocabs-seq
+ [ run-benchmark ] each
+ timings get
+ errors get
+ ] with-scope ;
-: benchmarks. ( assoc -- )
+: timings. ( assocs -- )
standard-table-style [
[
[ "Benchmark" write ] with-cell
[
[
[ [ 1array $vocab-link ] with-cell ]
- [ [ 1000000 /f pprint-cell ] [ [ "failed" write ] with-cell ] if* ] bi*
+ [ 1000000 /f pprint-cell ]
+ bi*
] with-row
] assoc-each
] tabular-output nl ;
+: benchmark-errors. ( errors -- )
+ [
+ [ "=== " write vocab-name print ]
+ [ error. ]
+ bi*
+ ] assoc-each ;
+
: benchmarks ( -- )
- run-benchmarks benchmarks. ;
+ run-benchmarks [ timings. ] [ benchmark-errors. ] bi* ;
MAIN: benchmarks
1 [a,b] [ number>string all-unique? ] count ; inline
: beust ( -- )
- 10000000 count-numbers
+ 2000000 count-numbers
number>string " unique numbers." append print ;
MAIN: beust
:: beust ( -- )
[let | i! [ 0 ] |
- 10000000000 [ i 1+ i! ] count-numbers
+ 5000000000 [ i 1+ i! ] count-numbers
i number>string " unique numbers." append print
] ;
] alien-callback\r
"int" { "int" } "cdecl" alien-indirect ;\r
\r
-: fib-main ( -- ) 34 fib drop ;\r
+: fib-main ( -- ) 32 fib drop ;\r
\r
MAIN: fib-main\r
-USING: checksums checksums.md5 io.files kernel ;
+USING: checksums checksums.md5 sequences byte-arrays kernel ;
IN: benchmark.md5
: md5-file ( -- )
- "vocab:mime/multipart/multipart-tests.factor" md5 checksum-file drop ;
+ 2000000 iota >byte-array md5 checksum-bytes drop ;
MAIN: md5-file
] with-file-writer ;
: random-main ( -- )
- 1000000 write-random-numbers ;
+ 300000 write-random-numbers ;
MAIN: random-main
-USING: checksums checksums.sha1 io.files kernel ;
+USING: checksums checksums.sha1 sequences byte-arrays kernel ;
IN: benchmark.sha1
: sha1-file ( -- )
- "vocab:mime/multipart/multipart-tests.factor" sha1 checksum-file drop ;
+ 2000000 iota >byte-array sha1 checksum-bytes drop ;
MAIN: sha1-file
ascii [ 0 sum-file-loop ] with-file-reader . ;
: sum-file-main ( -- )
- random-numbers-path sum-file ;
+ 5 [ random-numbers-path sum-file ] times ;
MAIN: sum-file-main
: coresume ( v co -- result )
[
>>exitcc
- resumecc>> call
+ resumecc>> call( -- )
#! At this point, the coroutine quotation must have terminated
- #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen.
+ #! normally (without calling coyield, coreset, or coterminate).
+ #! This shouldn't happen.
f over
] callcc1 2nip ;
: coreset ( v -- )
current-coro get dup
originalcc>> >>resumecc
- exitcc>> continue-with ;
\ No newline at end of file
+ exitcc>> continue-with ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs couchdb kernel namespaces sequences strings tools.test ;
+IN: couchdb.tests
+
+! You must have a CouchDB server (currently only the version from svn will
+! work) running on localhost and listening on the default port for these tests
+! to work.
+
+<default-server> "factor-test" <db> [
+ [ ] [ couch get create-db ] unit-test
+ [ couch get create-db ] must-fail
+ [ ] [ couch get delete-db ] unit-test
+ [ couch get delete-db ] must-fail
+ [ ] [ couch get ensure-db ] unit-test
+ [ ] [ couch get ensure-db ] unit-test
+ [ 0 ] [ couch get db-info "doc_count" swap at ] unit-test
+ [ ] [ couch get compact-db ] unit-test
+ [ t ] [ couch get server>> next-uuid string? ] unit-test
+ [ ] [ H{
+ { "Subject" "I like Planktion" }
+ { "Tags" { "plankton" "baseball" "decisions" } }
+ { "Body"
+ "I decided today that I don't like baseball. I like plankton." }
+ { "Author" "Rusty" }
+ { "PostedDate" "2006-08-15T17:30:12Z-04:00" }
+ } save-doc ] unit-test
+ [ t ] [ couch get all-docs "rows" swap at first "id" swap at dup "id" set string? ] unit-test
+ [ t ] [ "id" get dup load-doc id> = ] unit-test
+ [ ] [ "id" get load-doc save-doc ] unit-test
+ [ "Rusty" ] [ "id" get load-doc "Author" swap at ] unit-test
+ [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test
+ [ "Alex" ] [ "id" get load-doc "Author" swap at ] unit-test
+ [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" swap at ] unit-test
+ [ ] [ H{
+ { "_id" "_design/posts" }
+ { "language" "javascript" }
+ { "views" H{
+ { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } }
+ }
+ }
+ } save-doc ] unit-test
+ [ t ] [ "id" get load-doc delete-doc string? ] unit-test
+ [ "id" get load-doc ] must-fail
+ [ ] [ couch get delete-db ] unit-test
+] with-couch
--- /dev/null
+! Copyright (C) 2008, 2009 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs continuations debugger hashtables http
+http.client io io.encodings.string io.encodings.utf8 json.reader
+json.writer kernel make math math.parser namespaces sequences strings
+urls urls.encoding vectors ;
+IN: couchdb
+
+! NOTE: This code only works with the latest couchdb (0.9.*), because old
+! versions didn't provide the /_uuids feature which this code relies on when
+! creating new documents.
+
+SYMBOL: couch
+: with-couch ( db quot -- )
+ couch swap with-variable ; inline
+
+! errors
+TUPLE: couchdb-error { data assoc } ;
+C: <couchdb-error> couchdb-error
+
+M: couchdb-error error. ( error -- )
+ "CouchDB Error: " write data>>
+ "error" over at [ print ] when*
+ "reason" swap at [ print ] when* ;
+
+PREDICATE: file-exists-error < couchdb-error
+ data>> "error" swap at "file_exists" = ;
+
+! http tools
+: couch-http-request ( request -- data )
+ [ http-request ] [
+ dup download-failed? [
+ response>> body>> json> <couchdb-error> throw
+ ] [
+ rethrow
+ ] if
+ ] recover nip ;
+
+: couch-request ( request -- assoc )
+ couch-http-request json> ;
+
+: couch-get ( url -- assoc )
+ <get-request> couch-request ;
+
+: couch-put ( post-data url -- assoc )
+ <put-request> couch-request ;
+
+: couch-post ( post-data url -- assoc )
+ <post-request> couch-request ;
+
+: couch-delete ( url -- assoc )
+ <delete-request> couch-request ;
+
+: response-ok ( assoc -- assoc )
+ "ok" over delete-at* and t assert= ;
+
+: response-ok* ( assoc -- )
+ response-ok drop ;
+
+! server
+TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
+
+: default-couch-host ( -- host ) "localhost" ; inline
+: default-couch-port ( -- port ) 5984 ; inline
+: default-uuids-to-cache ( -- n ) 100 ; inline
+
+: <server> ( host port -- server )
+ V{ } clone default-uuids-to-cache server boa ;
+
+: <default-server> ( -- server )
+ default-couch-host default-couch-port <server> ;
+
+: (server-url) ( server -- )
+ "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
+
+: server-url ( server -- url )
+ [ (server-url) ] "" make ;
+
+: all-dbs ( server -- dbs )
+ server-url "_all_dbs" append couch-get ;
+
+: uuids-url ( server -- url )
+ [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
+
+: uuids-get ( server -- uuids )
+ uuids-url couch-get "uuids" swap at >vector ;
+
+: get-uuids ( server -- server )
+ dup uuids-get [ nip ] curry change-uuids ;
+
+: ensure-uuids ( server -- server )
+ dup uuids>> empty? [ get-uuids ] when ;
+
+: next-uuid ( server -- uuid )
+ ensure-uuids uuids>> pop ;
+
+! db
+TUPLE: db { server server } { name string } ;
+C: <db> db
+
+: (db-url) ( db -- )
+ [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
+
+: db-url ( db -- url )
+ [ (db-url) ] "" make ;
+
+: create-db ( db -- )
+ f swap db-url couch-put response-ok* ;
+
+: ensure-db ( db -- )
+ [ create-db ] [
+ dup file-exists-error? [ 2drop ] [ rethrow ] if
+ ] recover ;
+
+: delete-db ( db -- )
+ db-url couch-delete drop ;
+
+: db-info ( db -- info )
+ db-url couch-get ;
+
+: compact-db ( db -- )
+ f swap db-url "_compact" append couch-post response-ok* ;
+
+: all-docs ( db -- docs )
+ ! TODO: queries. Maybe pass in a hashtable with options
+ db-url "_all_docs" append couch-get ;
+
+: <json-post-data> ( assoc -- post-data )
+ >json utf8 encode "application/json" <post-data> swap >>data ;
+
+! documents
+: id> ( assoc -- id ) "_id" swap at ;
+: >id ( assoc id -- assoc ) "_id" pick set-at ;
+: rev> ( assoc -- rev ) "_rev" swap at ;
+: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
+: attachments> ( assoc -- attachments ) "_attachments" swap at ;
+: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
+
+: copy-key ( to from to-key from-key -- )
+ rot at spin set-at ;
+
+: copy-id ( to from -- )
+ "_id" "id" copy-key ;
+
+: copy-rev ( to from -- )
+ "_rev" "rev" copy-key ;
+
+: id-url ( id -- url )
+ couch get db-url swap url-encode-full append ;
+
+: doc-url ( assoc -- url )
+ id> id-url ;
+
+: temp-view ( view -- results )
+ <json-post-data> couch get db-url "_temp_view" append couch-post ;
+
+: temp-view-map ( map -- results )
+ "map" H{ } clone [ set-at ] keep temp-view ;
+
+: save-doc-as ( assoc id -- )
+ [ dup <json-post-data> ] dip id-url couch-put response-ok
+ [ copy-id ] [ copy-rev ] 2bi ;
+
+: save-new-doc ( assoc -- )
+ couch get server>> next-uuid save-doc-as ;
+
+: save-doc ( assoc -- )
+ dup id> [ save-doc-as ] [ save-new-doc ] if* ;
+
+: load-doc ( id -- assoc )
+ id-url couch-get ;
+
+: delete-doc ( assoc -- deletion-revision )
+ [
+ [ doc-url % ]
+ [ "?rev=" % "_rev" swap at % ] bi
+ ] "" make couch-delete response-ok "rev" swap at ;
+
+: remove-keys ( assoc keys -- )
+ swap [ delete-at ] curry each ;
+
+: remove-couch-info ( assoc -- )
+ { "_id" "_rev" "_attachments" } remove-keys ;
+
+! : construct-attachment ( content-type data -- assoc )
+! H{ } clone "name" pick set-at "content-type" pick set-at ;
+!
+! : add-attachment ( assoc name attachment -- )
+! pick attachments> [ H{ } clone ] unless*
+!
+! : attach ( assoc name content-type data -- )
+! construct-attachment H{ } clone
+
+! TODO:
+! - startkey, limit, descending, etc.
+! - loading specific revisions
+! - views
+! - attachments
+! - bulk insert/update
+! - ...?
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
+: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
t fuel-eval-res-flag set-global
: fuel-eval-restartable? ( -- ? )
- fuel-eval-res-flag get-global ; inline
+ fuel-eval-res-flag get-global ;
: fuel-push-status ( -- )
in get use get clone restarts get-global clone
fuel-status-stack get push ;
: fuel-pop-restarts ( restarts -- )
- fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline
+ fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ;
: fuel-pop-status ( -- )
fuel-status-stack get empty? [
[ restarts>> fuel-pop-restarts ] tri
] unless ;
-: fuel-forget-error ( -- ) f error set-global ; inline
-: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
-: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
+: fuel-forget-error ( -- ) f error set-global ;
+: fuel-forget-result ( -- ) f fuel-eval-result set-global ;
+: fuel-forget-output ( -- ) f fuel-eval-output set-global ;
: fuel-forget-status ( -- )
- fuel-forget-error fuel-forget-result fuel-forget-output ; inline
+ fuel-forget-error fuel-forget-result fuel-forget-output ;
: fuel-send-retort ( -- )
error get fuel-eval-result get-global fuel-eval-output get-global
3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
: (fuel-begin-eval) ( -- )
- fuel-push-status fuel-forget-status ; inline
+ fuel-push-status fuel-forget-status ;
: (fuel-end-eval) ( output -- )
- fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline
+ fuel-eval-output set-global fuel-send-retort fuel-pop-status ;
: (fuel-eval) ( lines -- )
- [ [ parse-lines ] with-compilation-unit call ] curry
- [ print-error ] recover ; inline
-
-: (fuel-eval-each) ( lines -- )
- [ 1vector (fuel-eval) ] each ; inline
+ [ [ parse-lines ] with-compilation-unit call( -- ) ] curry
+ [ print-error ] recover ;
: (fuel-eval-usings) ( usings -- )
- [ "USING: " prepend " ;" append ] map
- (fuel-eval-each) fuel-forget-error fuel-forget-output ;
+ [ "USE: " prepend ] map
+ (fuel-eval) fuel-forget-error fuel-forget-output ;
: (fuel-eval-in) ( in -- )
- [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
+ [ dup "IN: " prepend 1array (fuel-eval) in set ] when* ;
: (fuel-eval-in-context) ( lines in usings -- )
(fuel-begin-eval)
: fuel-vocab-summary ( name -- )
(fuel-vocab-summary) fuel-eval-set-result ;
-: fuel-index ( quot -- ) call format-index fuel-eval-set-result ;
+: fuel-index ( quot -- ) call( -- seq ) format-index fuel-eval-set-result ;
: fuel-get-vocabs/tag ( tag -- )
(fuel-get-vocabs/tag) fuel-eval-set-result ;
USING: accessors arrays classes.tuple combinators continuations io
kernel lexer math prettyprint quotations sequences source-files
-strings words ;
+source-files.errors strings words ;
IN: fuel.pprint
+++ /dev/null
-William Schlieper
+++ /dev/null
-! See http://factorcode.org/license.txt for BSD licence.
-USING: help.markup help.syntax ;
-
-IN: graph-theory
-
-ARTICLE: "graph-protocol" "Graph protocol"
-"All graphs must be instances of the graph mixin:"
-{ $subsection graph }
-"All graphs must implement a method on the following generic word:"
-{ $subsection vertices }
-"At least one of the following two generic words must have a method; the " { $link graph } " mixin has default definitions which are mutually recursive:"
-{ $subsection adjlist }
-{ $subsection adj? }
-"All mutable graphs must implement a method on the following generic word:"
-{ $subsection add-blank-vertex }
-"All mutable undirected graphs must implement a method on the following generic word:"
-{ $subsection add-edge }
-"Mutable directed graphs should not implement the above word, as it has a default definition defined in terms of the following generic word:"
-{ $subsection add-edge* }
-"The following two words have default definitions, but are available as generics to allow implementations to optimize them:"
-{ $subsection num-vertices }
-{ $subsection num-edges } ;
-
-HELP: graph
-{ $class-description "A mixin class whose instances are graphs. Custom implementations of the graph protocol should be declared as instances of this mixin for all graph functionality to work correctly:"
- { $code "INSTANCE: hex-board graph" }
-} ;
-
-{ vertices num-vertices num-edges } related-words
-
-HELP: vertices
-{ $values { "graph" graph } { "seq" "The vertices" } }
-{ $description "Returns the vertices of the graph." } ;
-
-HELP: num-vertices
-{ $values { "graph" graph } { "n" "The number of vertices" } }
-{ $description "Returns the number of vertices in the graph." } ;
-
-HELP: num-edges
-{ $values { "graph" "A graph" } { "n" "The number of edges" } }
-{ $description "Returns the number of edges in the graph." } ;
-
-{ adjlist adj? } related-words
-
-HELP: adjlist
-{ $values
- { "from" "The index of a vertex" }
- { "graph" "The graph to be examined" }
- { "seq" "The adjacency list" } }
-{ $description "Returns a sequence of vertices that this vertex links to" } ;
-
-HELP: adj?
-{ $values
- { "from" "The index of a vertex" }
- { "to" "The index of a vertex" }
- { "graph" "A graph" }
- { "?" "A boolean" } }
-{ $description "Returns a boolean describing whether there is an edge in the graph between from and to." } ;
-
-{ add-blank-vertex add-blank-vertices add-edge add-edge* } related-words
-
-HELP: add-blank-vertex
-{ $values
- { "index" "A vertex index" }
- { "graph" "A graph" } }
-{ $description "Adds a vertex to the graph." } ;
-
-HELP: add-blank-vertices
-{ $values
- { "seq" "A sequence of vertex indices" }
- { "graph" "A graph" } }
-{ $description "Adds vertices with indices in seq to the graph." } ;
-
-HELP: add-edge*
-{ $values
- { "from" "The index of a vertex" }
- { "to" "The index of another vertex" }
- { "graph" "A graph" } }
-{ $description "Adds a one-way edge to the graph, between " { $snippet "from" } " and " { $snippet "to" } "."
- $nl
- "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
-
-HELP: add-edge
-{ $values
- { "u" "The index of a vertex" }
- { "v" "The index of another vertex" }
- { "graph" "A graph" } }
-{ $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
- $nl
- "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;
-
-{ depth-first full-depth-first dag? topological-sort } related-words
-
-HELP: depth-first
-{ $values
- { "v" "The vertex to start the search at" }
- { "graph" "The graph to search" }
- { "pre" "A quotation of the form ( n -- )" }
- { "post" "A quotation of the form ( n -- )" }
- { "?list" "A list of booleans describing the vertices visited in the search" }
- { "?" "A boolean describing whether or not the end-search error was thrown" } }
-{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } " can be accessed in both quotations."
- $nl
- "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
- $nl
- "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
- $nl
- { $emphasis "?list" } " is a list of booleans, " { $link t } " for every vertex visted during the search, and " { $link f } " for every vertex not visited." } ;
-
-HELP: full-depth-first
-{ $values
- { "graph" "The graph to search" }
- { "pre" "A quotation of the form ( n -- )" }
- { "post" "A quotation of the form ( n -- )" }
- { "tail" "A quotation of the form ( -- )" }
- { "?" "A boolean describing whether or not the end-search error was thrown" } }
-{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } "can be accessed in both quotations."
- $nl
- "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
- $nl
- "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
- $nl
- "The " { $emphasis "tail" } " quotation is run after each time the depth-first search runs out of nodes. On an undirected graph this will be each connected subgroup but on a directed graph it can be more complex." } ;
-
-HELP: dag?
-{ $values
- { "graph" graph }
- { "?" "A boolean indicating if the graph is acyclic" } }
-{ $description "Using a depth-first search, determines if the specified directed graph is a directed acyclic graph. An undirected graph will produce a false result, as the algorithm does not eliminate cycles of length 2, which will include any edge that goes both ways." } ;
-
-HELP: topological-sort
-{ $values
- { "graph" graph }
- { "seq/f" "Either a sequence of values or f" } }
-{ $description "Using a depth-first search, topologically sorts the specified directed graph. Returns f if the graph contains any cycles, and a topologically sorted sequence otherwise." } ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators fry continuations sequences arrays vectors assocs hashtables heaps namespaces ;
-
-IN: graph-theory
-
-MIXIN: graph
-SYMBOL: visited?
-ERROR: end-search ;
-
-GENERIC: vertices ( graph -- seq ) flushable
-
-GENERIC: num-vertices ( graph -- n ) flushable
-
-GENERIC: num-edges ( graph -- n ) flushable
-
-GENERIC: adjlist ( from graph -- seq ) flushable
-
-GENERIC: adj? ( from to graph -- ? ) flushable
-
-GENERIC: add-blank-vertex ( index graph -- )
-
-GENERIC: delete-blank-vertex ( index graph -- )
-
-GENERIC: add-edge* ( from to graph -- )
-
-GENERIC: add-edge ( u v graph -- )
-
-GENERIC: delete-edge* ( from to graph -- )
-
-GENERIC: delete-edge ( u v graph -- )
-
-M: graph num-vertices
- vertices length ;
-
-M: graph num-edges
- [ vertices ] [ '[ _ adjlist length ] map sum ] bi ;
-
-M: graph adjlist
- [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
-
-M: graph adj?
- swapd adjlist index >boolean ;
-
-M: graph add-edge
- [ add-edge* ] [ swapd add-edge* ] 3bi ;
-
-M: graph delete-edge
- [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
-
-: add-blank-vertices ( seq graph -- )
- '[ _ add-blank-vertex ] each ;
-
-: delete-vertex ( index graph -- )
- [ adjlist ]
- [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
- [ delete-blank-vertex ] 2tri ;
-
-<PRIVATE
-
-: search-wrap ( quot graph -- ? )
- [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
- [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
-
-: (depth-first) ( v pre post -- )
- { [ 2drop visited? get t -rot set-at ]
- [ drop call ]
- [ [ graph get adjlist ] 2dip
- '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
- [ nip call ] } 3cleave ; inline
-
-PRIVATE>
-
-: depth-first ( v graph pre post -- ?list ? )
- '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
-
-: full-depth-first ( graph pre post tail -- ? )
- '[ [ visited? get [ nip not ] assoc-find ]
- [ drop _ _ (depth-first) @ ]
- while 2drop ] swap search-wrap ; inline
-
-: dag? ( graph -- ? )
- V{ } clone swap [ 2dup swap push dupd
- '[ _ swap graph get adj? not ] all?
- [ end-search ] unless ]
- [ drop dup pop* ] [ ] full-depth-first nip ;
-
-: topological-sort ( graph -- seq/f )
- dup dag?
- [ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
- [ drop f ] if ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: accessors kernel graph-theory ;
-
-IN: graph-theory.reversals
-
-TUPLE: reversal graph ;
-
-GENERIC: reverse-graph ( graph -- reversal )
-
-M: graph reverse-graph reversal boa ;
-
-M: reversal reverse-graph graph>> ;
-
-INSTANCE: reversal graph
-
-M: reversal vertices
- graph>> vertices ;
-
-M: reversal adj?
- swapd graph>> adj? ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: accessors kernel sequences arrays vectors sets assocs hashtables graph-theory namespaces fry ;
-
-IN: graph-theory.sparse
-
-TUPLE: sparse-graph alist ;
-
-: <sparse-graph> ( -- sparse-graph )
- H{ } clone sparse-graph boa ;
-
-: >sparse-graph ( graph -- sparse-graph )
- [ vertices ] keep
- '[ dup _ adjlist 2array ] map >hashtable sparse-graph boa ;
-
-INSTANCE: sparse-graph graph
-
-M: sparse-graph vertices
- alist>> keys ;
-
-M: sparse-graph adjlist
- alist>> at ;
-
-M: sparse-graph add-blank-vertex
- alist>> V{ } clone -rot set-at ;
-
-M: sparse-graph delete-blank-vertex
- alist>> delete-at ;
-
-M: sparse-graph add-edge*
- alist>> swapd at adjoin ;
-
-M: sparse-graph delete-edge*
- alist>> swapd at delete ;
+++ /dev/null
-Graph-theoretic algorithms
+++ /dev/null
-collections
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel namespaces
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
GENERIC: image. ( object -- )
-: default-image. ( path -- )
- <image-gadget> gadget. ;
+M: string image. ( image -- ) load-image image. ;
-M: string image. ( image -- ) load-image default-image. ;
+M: pathname image. ( image -- ) load-image image. ;
-M: pathname image. ( image -- ) load-image default-image. ;
-
-M: image image. ( image -- ) default-image. ;
+M: image image. ( image -- ) <image-gadget> gadget. ;
M: ast-op infix-codegen
[ left>> infix-codegen ] [ right>> infix-codegen ]
[ op>> select-op ] tri
- 2over [ number? ] both? [ call ] [
+ 2over [ number? ] both? [ call( a b -- c ) ] [
[ [ prepare-operand ] bi@ ] dip '[ @ @ @ ]
] if ;
{ command "NICK" }
{ parameters { } }
{ trailing "someuser2" }
- { sender "someuser" } } }
+ { sender "someuser" }
+ { nickname "someuser2" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
string>irc-message f >>timestamp ] unit-test
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Jamshred" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
+IN: jamshred.game
+
+TUPLE: jamshred sounds tunnel players running quit ;
+
+: <jamshred> ( -- jamshred )
+ <sounds> <random-tunnel> "Player 1" pick <player>
+ 2dup swap play-in-tunnel 1array f f jamshred boa ;
+
+: jamshred-player ( jamshred -- player )
+ ! TODO: support more than one player
+ players>> first ;
+
+: jamshred-update ( jamshred -- )
+ dup running>> [
+ jamshred-player update-player
+ ] [ drop ] if ;
+
+: toggle-running ( jamshred -- )
+ dup running>> [
+ f >>running drop
+ ] [
+ [ jamshred-player moved ]
+ [ t >>running drop ] bi
+ ] if ;
+
+: mouse-moved ( x-radians y-radians jamshred -- )
+ jamshred-player -rot turn-player ;
+
+: units-per-full-roll ( -- n ) 50 ;
+
+: jamshred-roll ( jamshred n -- )
+ [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
+
+: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
+
+: mouse-scroll-y ( jamshred y -- )
+ neg swap jamshred-player change-player-speed ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types jamshred.game jamshred.oint
+jamshred.player jamshred.tunnel kernel math math.constants
+math.functions math.vectors opengl opengl.gl opengl.glu
+opengl.demo-support sequences specialized-arrays.float ;
+IN: jamshred.gl
+
+: min-vertices ( -- n ) 6 ; inline
+: max-vertices ( -- n ) 32 ; inline
+
+: n-vertices ( -- n ) 32 ; inline
+
+! render enough of the tunnel that it looks continuous
+: n-segments-ahead ( -- n ) 60 ; inline
+: n-segments-behind ( -- n ) 40 ; inline
+
+: wall-drawing-offset ( -- n )
+ #! so that we can't see through the wall, we draw it a bit further away
+ 0.15 ;
+
+: wall-drawing-radius ( segment -- r )
+ radius>> wall-drawing-offset + ;
+
+: wall-up ( segment -- v )
+ [ wall-drawing-radius ] [ up>> ] bi n*v ;
+
+: wall-left ( segment -- v )
+ [ wall-drawing-radius ] [ left>> ] bi n*v ;
+
+: segment-vertex ( theta segment -- vertex )
+ [
+ [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
+ ] [
+ location>> v+
+ ] bi ;
+
+: segment-vertex-normal ( vertex segment -- normal )
+ location>> swap v- normalize ;
+
+: segment-vertex-and-normal ( segment theta -- vertex normal )
+ swap [ segment-vertex ] keep dupd segment-vertex-normal ;
+
+: equally-spaced-radians ( n -- seq )
+ #! return a sequence of n numbers between 0 and 2pi
+ dup [ / pi 2 * * ] curry map ;
+
+: draw-segment-vertex ( segment theta -- )
+ over color>> gl-color segment-vertex-and-normal
+ gl-normal gl-vertex ;
+
+: draw-vertex-pair ( theta next-segment segment -- )
+ rot tuck draw-segment-vertex draw-segment-vertex ;
+
+: draw-segment ( next-segment segment -- )
+ GL_QUAD_STRIP [
+ [ draw-vertex-pair ] 2curry
+ n-vertices equally-spaced-radians float-array{ 0.0 } append swap each
+ ] do-state ;
+
+: draw-segments ( segments -- )
+ 1 over length pick subseq swap [ draw-segment ] 2each ;
+
+: segments-to-render ( player -- segments )
+ dup nearest-segment>> number>> dup n-segments-behind -
+ swap n-segments-ahead + rot tunnel>> sub-tunnel ;
+
+: draw-tunnel ( player -- )
+ segments-to-render draw-segments ;
+
+: init-graphics ( -- )
+ GL_DEPTH_TEST glEnable
+ GL_SCISSOR_TEST glDisable
+ 1.0 glClearDepth
+ 0.0 0.0 0.0 0.0 glClearColor
+ GL_PROJECTION glMatrixMode glPushMatrix
+ GL_MODELVIEW glMatrixMode glPushMatrix
+ GL_LEQUAL glDepthFunc
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_FOG glEnable
+ GL_FOG_DENSITY 0.09 glFogf
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ GL_COLOR_MATERIAL glEnable
+ GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
+
+: cleanup-graphics ( -- )
+ GL_DEPTH_TEST glDisable
+ GL_SCISSOR_TEST glEnable
+ GL_MODELVIEW glMatrixMode glPopMatrix
+ GL_PROJECTION glMatrixMode glPopMatrix
+ GL_LIGHTING glDisable
+ GL_LIGHT0 glDisable
+ GL_FOG glDisable
+ GL_COLOR_MATERIAL glDisable ;
+
+: pre-draw ( width height -- )
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_PROJECTION glMatrixMode glLoadIdentity
+ dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
+ GL_MODELVIEW glMatrixMode glLoadIdentity ;
+
+: player-view ( player -- )
+ [ location>> ]
+ [ [ location>> ] [ forward>> ] bi v+ ]
+ [ up>> ] tri gl-look-at ;
+
+: draw-jamshred ( jamshred width height -- )
+ pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ;
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.rectangles math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
+IN: jamshred
+
+TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
+
+: <jamshred-gadget> ( jamshred -- gadget )
+ jamshred-gadget new swap >>jamshred ;
+
+: default-width ( -- x ) 800 ;
+: default-height ( -- y ) 600 ;
+
+M: jamshred-gadget pref-dim*
+ drop default-width default-height 2array ;
+
+M: jamshred-gadget draw-gadget* ( gadget -- )
+ [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ;
+
+: jamshred-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ [ jamshred>> jamshred-update ]
+ [ relayout-1 ]
+ [ 100 milliseconds sleep jamshred-loop ] tri
+ ] if ;
+
+: fullscreen ( gadget -- )
+ find-world t swap set-fullscreen* ;
+
+: no-fullscreen ( gadget -- )
+ find-world f swap set-fullscreen* ;
+
+: toggle-fullscreen ( world -- )
+ [ fullscreen? not ] keep set-fullscreen* ;
+
+M: jamshred-gadget graft* ( gadget -- )
+ [ find-gl-context init-graphics ]
+ [ [ jamshred-loop ] curry in-thread ] bi ;
+
+M: jamshred-gadget ungraft* ( gadget -- )
+ dup find-gl-context cleanup-graphics jamshred>> t swap (>>quit) ;
+
+: jamshred-restart ( jamshred-gadget -- )
+ <jamshred> >>jamshred drop ;
+
+: pix>radians ( n m -- theta )
+ / pi 4 * * ; ! 2 / / pi 2 * * ;
+
+: x>radians ( x gadget -- theta )
+ #! translate motion of x pixels to an angle
+ dim>> first pix>radians neg ;
+
+: y>radians ( y gadget -- theta )
+ #! translate motion of y pixels to an angle
+ dim>> second pix>radians ;
+
+: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
+ dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
+ rot jamshred>> mouse-moved ;
+
+: handle-mouse-motion ( jamshred-gadget -- )
+ hand-loc get [
+ over last-hand-loc>> [
+ v- (handle-mouse-motion)
+ ] [ 2drop ] if*
+ ] 2keep >>last-hand-loc drop ;
+
+: handle-mouse-scroll ( jamshred-gadget -- )
+ jamshred>> scroll-direction get
+ [ first mouse-scroll-x ]
+ [ second mouse-scroll-y ] 2bi ;
+
+: quit ( gadget -- )
+ [ no-fullscreen ] [ close-window ] bi ;
+
+jamshred-gadget H{
+ { T{ key-down f f "r" } [ jamshred-restart ] }
+ { T{ key-down f f " " } [ jamshred>> toggle-running ] }
+ { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
+ { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
+ { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
+ { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
+ { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
+ { T{ key-down f f "q" } [ quit ] }
+ { motion [ handle-mouse-motion ] }
+ { mouse-scroll [ handle-mouse-scroll ] }
+} set-gestures
+
+: jamshred-window ( -- )
+ [ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
+
+MAIN: jamshred-window
--- /dev/null
+USING: kernel logging ;
+IN: jamshred.log
+
+LOG: (jamshred-log) DEBUG
+
+: with-jamshred-log ( quot -- )
+ "jamshred" swap with-logging ; inline
+
+: jamshred-log ( message -- )
+ [ (jamshred-log) ] with-jamshred-log ; ! ugly...
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
+[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
+[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
+[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
+[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+IN: jamshred.oint
+
+! An oint is a point with three linearly independent unit vectors
+! given relative to that point. In jamshred a player's location and
+! direction are given by the player's oint. Similarly, a tunnel
+! segment's location and orientation are given by an oint.
+
+TUPLE: oint location forward up left ;
+C: <oint> oint
+
+: rotation-quaternion ( theta axis -- quaternion )
+ swap 2 / dup cos swap sin rot n*v first3 rect> [ rect> ] dip 2array ;
+
+: rotate-vector ( q qrecip v -- v )
+ v>q swap q* q* q>v ;
+
+: rotate-oint ( oint theta axis -- )
+ rotation-quaternion dup qrecip pick
+ [ forward>> rotate-vector >>forward ]
+ [ up>> rotate-vector >>up ]
+ [ left>> rotate-vector >>left ] 3tri drop ;
+
+: left-pivot ( oint theta -- )
+ over left>> rotate-oint ;
+
+: up-pivot ( oint theta -- )
+ over up>> rotate-oint ;
+
+: forward-pivot ( oint theta -- )
+ over forward>> rotate-oint ;
+
+: random-float+- ( n -- m )
+ #! find a random float between -n/2 and n/2
+ dup 10000 * >fixnum random 10000 / swap 2 / - ;
+
+: random-turn ( oint theta -- )
+ 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
+
+: location+ ( v oint -- )
+ [ location>> v+ ] [ (>>location) ] bi ;
+
+: go-forward ( distance oint -- )
+ [ forward>> n*v ] [ location+ ] bi ;
+
+: distance-vector ( oint oint -- vector )
+ [ location>> ] bi@ swap v- ;
+
+: distance ( oint oint -- distance )
+ distance-vector norm ;
+
+: scalar-projection ( v1 v2 -- n )
+ #! the scalar projection of v1 onto v2
+ tuck v. swap norm / ;
+
+: proj-perp ( u v -- w )
+ dupd proj v- ;
+
+: perpendicular-distance ( oint oint -- distance )
+ tuck distance-vector swap 2dup left>> scalar-projection abs
+ -rot up>> scalar-projection abs + ;
+
+:: reflect ( v n -- v' )
+ #! bounce v on a surface with normal n
+ v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+ over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+ [ location>> ] bi@ half-way ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors colors.constants combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle specialized-arrays.float strings system ;
+IN: jamshred.player
+
+TUPLE: player < oint
+ { name string }
+ { sounds sounds }
+ tunnel
+ nearest-segment
+ { last-move integer }
+ { speed float } ;
+
+! speeds are in GL units / second
+: default-speed ( -- speed ) 1.0 ;
+: max-speed ( -- speed ) 30.0 ;
+
+: <player> ( name sounds -- player )
+ [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
+ f f 0 default-speed player boa ;
+
+: turn-player ( player x-radians y-radians -- )
+ [ over ] dip left-pivot up-pivot ;
+
+: roll-player ( player z-radians -- )
+ forward-pivot ;
+
+: to-tunnel-start ( player -- )
+ [ tunnel>> first dup location>> ]
+ [ tuck (>>location) (>>nearest-segment) ] bi ;
+
+: play-in-tunnel ( player segments -- )
+ >>tunnel to-tunnel-start ;
+
+: update-nearest-segment ( player -- )
+ [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
+ [ (>>nearest-segment) ] tri ;
+
+: update-time ( player -- seconds-passed )
+ millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
+
+: moved ( player -- ) millis swap (>>last-move) ;
+
+: speed-range ( -- range )
+ max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+ [ + speed-range clamp-to-range ] change-speed drop ;
+
+: multiply-player-speed ( n player -- )
+ [ * speed-range clamp-to-range ] change-speed drop ;
+
+: distance-to-move ( seconds-passed player -- distance )
+ speed>> * ;
+
+: bounce ( d-left player -- d-left' player )
+ {
+ [ dup nearest-segment>> bounce-off-wall ]
+ [ sounds>> bang ]
+ [ 3/4 swap multiply-player-speed ]
+ [ ]
+ } cleave ;
+
+:: (distance) ( heading player -- current next location heading )
+ player nearest-segment>>
+ player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+ player location>> heading ;
+
+: distance-to-heading-segment ( heading player -- distance )
+ (distance) distance-to-next-segment ;
+
+: distance-to-heading-segment-area ( heading player -- distance )
+ (distance) distance-to-next-segment-area ;
+
+: distance-to-collision ( player -- distance )
+ dup nearest-segment>> (distance-to-collision) ;
+
+: almost-to-collision ( player -- distance )
+ distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
+
+: from ( player -- radius distance-from-centre )
+ [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+ distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+ fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
+ ] [
+ 2drop
+ ] if ;
+
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+ [let* | d-to-move [ d-left distance min ]
+ move-v [ d-to-move heading n*v ] |
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ] ;
+
+: distance-to-move-freely ( player -- distance )
+ [ almost-to-collision ]
+ [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
+
+: ?move-player-freely ( d-left player -- d-left' player )
+ over 0 > [
+ ! must make sure we are moving a significant distance, otherwise
+ ! we can recurse endlessly due to floating-point imprecision.
+ ! (at least I /think/ that's what causes it...)
+ dup distance-to-move-freely dup 0.1 > [
+ over forward>> move-player-on-heading ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: drag-heading ( player -- heading )
+ [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+ [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+ ?move-player-freely over 0 > [
+ ! bounce
+ drag-player
+ (move-player)
+ ] when ;
+
+: move-player ( player -- )
+ [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
+
+: update-player ( player -- )
+ [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.pathnames kernel openal sequences ;
+IN: jamshred.sound
+
+TUPLE: sounds bang ;
+
+: assign-sound ( source wav-path -- )
+ resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
+
+: <sounds> ( -- sounds )
+ init-openal 1 gen-sources first sounds boa
+ dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
+
+: bang ( sounds -- ) bang>> source-play check-error ;
--- /dev/null
+A simple 3d tunnel racing game
--- /dev/null
+applications
+games
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences specialized-arrays.float tools.test ;
+IN: jamshred.tunnel.tests
+
+[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
+ T{ segment f { 1 1 1 } f f f 1 }
+ T{ oint f { 0 0 0.25 } }
+ nearer-segment number>> ] unit-test
+
+[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+
+[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
+
+[ float-array{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
+
+: test-segment-oint ( -- oint )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
+
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
+
+: simplest-straight-ahead ( -- oint segment )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
+
+: simple-collision-up ( -- oint segment )
+ { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
+[ { 0.0 1.0 0.0 } ]
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ;
+IN: jamshred.tunnel
+
+: n-segments ( -- n ) 5000 ; inline
+
+TUPLE: segment < oint number color radius ;
+C: <segment> segment
+
+: segment-number++ ( segment -- )
+ [ number>> 1+ ] keep (>>number) ;
+
+: random-color ( -- color )
+ { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
+
+: tunnel-segment-distance ( -- n ) 0.4 ;
+: random-rotation-angle ( -- theta ) pi 20 / ;
+
+: random-segment ( previous-segment -- segment )
+ clone dup random-rotation-angle random-turn
+ tunnel-segment-distance over go-forward
+ random-color >>color dup segment-number++ ;
+
+: (random-segments) ( segments n -- segments )
+ dup 0 > [
+ [ dup peek random-segment over push ] dip 1- (random-segments)
+ ] [ drop ] if ;
+
+: default-segment-radius ( -- r ) 1 ;
+
+: initial-segment ( -- segment )
+ float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
+ 0 random-color default-segment-radius <segment> ;
+
+: random-segments ( n -- segments )
+ initial-segment 1vector swap (random-segments) ;
+
+: simple-segment ( n -- segment )
+ [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
+ random-color default-segment-radius <segment> ;
+
+: simple-segments ( n -- segments )
+ [ simple-segment ] map ;
+
+: <random-tunnel> ( -- segments )
+ n-segments random-segments ;
+
+: <straight-tunnel> ( -- segments )
+ n-segments simple-segments ;
+
+: sub-tunnel ( from to segments -- segments )
+ #! return segments between from and to, after clamping from and to to
+ #! valid values
+ [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
+
+: nearer-segment ( segment segment oint -- segment )
+ #! return whichever of the two segments is nearer to the oint
+ [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ;
+
+: (find-nearest-segment) ( nearest next oint -- nearest ? )
+ #! find the nearest of 'next' and 'nearest' to 'oint', and return
+ #! t if the nearest hasn't changed
+ pick [ nearer-segment dup ] dip = ;
+
+: find-nearest-segment ( oint segments -- segment )
+ dup first swap rest-slice rot [ (find-nearest-segment) ] curry
+ find 2drop ;
+
+: nearest-segment-forward ( segments oint start -- segment )
+ rot dup length swap <slice> find-nearest-segment ;
+
+: nearest-segment-backward ( segments oint start -- segment )
+ swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+
+: nearest-segment ( segments oint start-segment -- segment )
+ #! find the segment nearest to 'oint', and return it.
+ #! start looking at segment 'start-segment'
+ number>> over [
+ [ nearest-segment-forward ] 3keep nearest-segment-backward
+ ] dip nearer-segment ;
+
+: get-segment ( segments n -- segment )
+ over sequence-index-range clamp-to-range swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+ number>> 1+ get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+ number>> 1- get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+ #! the next segment on the given heading
+ over forward>> v. 0 <=> {
+ { +gt+ [ next-segment ] }
+ { +lt+ [ previous-segment ] }
+ { +eq+ [ nip ] } ! current segment
+ } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+ [let | cf [ current forward>> ] |
+ cf next location>> v. cf location v. - cf heading v. / ] ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ [let | cf [ current forward>> ]
+ h [ next current half-way-between-oints ] |
+ cf h v. cf location v. - cf heading v. / ] ;
+
+: vector-to-centre ( seg loc -- v )
+ over location>> swap v- swap forward>> proj-perp ;
+
+: distance-from-centre ( seg loc -- distance )
+ vector-to-centre norm ;
+
+: wall-normal ( seg oint -- n )
+ location>> vector-to-centre normalize ;
+
+: distant ( -- n ) 1000 ;
+
+: max-real ( a b -- c )
+ #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ dup real? [
+ over real? [ max ] [ nip ] if
+ ] [
+ drop dup real? [ drop distant ] unless
+ ] if ;
+
+:: collision-coefficient ( v w r -- c )
+ v norm 0 = [
+ distant
+ ] [
+ [let* | a [ v dup v. ]
+ b [ v w v. 2 * ]
+ c [ w dup v. r sq - ] |
+ c b a quadratic max-real ]
+ ] if ;
+
+: sideways-heading ( oint segment -- v )
+ [ forward>> ] bi@ proj-perp ;
+
+: sideways-relative-location ( oint segment -- loc )
+ [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
+
+: (distance-to-collision) ( oint segment -- distance )
+ [ sideways-heading ] [ sideways-relative-location ]
+ [ nip radius>> ] 2tri collision-coefficient ;
+
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
+
+: bounce-forward ( segment oint -- )
+ [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-left ( segment oint -- )
+ #! must be done after forward
+ [ forward>> vneg ] dip [ left>> swap reflect ]
+ [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
+
+: bounce-up ( segment oint -- )
+ #! must be done after forward and left!
+ nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
+
+: bounce-off-wall ( oint segment -- )
+ swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+
swap [
" " [ drop ] <border-button>
swap [ first >>loc ] [ second >>dim ] bi
- ] [ execute ] bi*
+ ] [ execute( -- value ) ] bi*
] dip set-nth ;
: add-keys-gadgets ( gadget -- gadget )
swap call [ at 0 or ] curry map ; inline
: op-matrix ( domain range quot -- matrix )
- rot [ [ 2dup ] dip (op-matrix) ] map 2nip ; inline
+ rot [ (op-matrix) ] with with map ; inline
: d-matrix ( domain range -- matrix )
[ (d) ] op-matrix ;
IN: lint.tests
! Don't write code like this
-: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when
+: lint1 ( obj -- ) [ "hi" print ] [ ] if ; ! when
[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
USING: mason.build tools.test sequences ;
IN: mason.build.tests
-
-{ create-build-dir enter-build-dir clone-builds-factor record-id }
-[ must-infer ] each
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar io.directories io.encodings.utf8
+USING: arrays kernel calendar io.directories io.encodings.utf8
io.files io.launcher mason.child mason.cleanup mason.common
-mason.help mason.release mason.report namespaces prettyprint ;
+mason.help mason.release mason.report mason.email mason.notify
+namespaces prettyprint ;
IN: mason.build
QUALIFIED: continuations
: enter-build-dir ( -- ) build-dir set-current-directory ;
: clone-builds-factor ( -- )
- "git" "clone" builds/factor 3array try-process ;
+ "git" "clone" builds/factor 3array try-output-process ;
-: record-id ( -- )
- "factor" [ git-id ] with-directory "git-id" to-file ;
+: begin-build ( -- )
+ "factor" [ git-id ] with-directory
+ [ "git-id" to-file ] [ notify-begin-build ] bi ;
: build ( -- )
create-build-dir
enter-build-dir
clone-builds-factor
[
- record-id
+ begin-build
build-child
- upload-help
- release
+ [ notify-report ]
+ [ status-clean eq? [ upload-help release ] when ] bi
] [ cleanup ] [ ] continuations:cleanup ;
MAIN: build
IN: mason.child.tests
-USING: mason.child mason.config tools.test namespaces ;
+USING: mason.child mason.config tools.test namespaces io kernel sequences ;
[ { "make" "winnt-x86-32" } ] [
[
boot-cmd
] with-scope
] unit-test
+
+[ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] must-infer
+
+[ 4 ] [ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] unit-test
+
+[ 3 ] [ [ "Hi" throw ] [ drop 3 ] [ 4 ] recover-else ] unit-test
+
+[ "A" ] [
+ {
+ { [ 3 throw ] [ { "X" "Y" "Z" "A" } nth ] }
+ [ "B" ]
+ } recover-cond
+] unit-test
+
+[ "B" ] [
+ {
+ { [ ] [ ] }
+ [ "B" ]
+ } recover-cond
+] unit-test
\ No newline at end of file
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators.short-circuit
+USING: accessors arrays calendar combinators.short-circuit fry
continuations debugger io.directories io.files io.launcher
io.pathnames io.encodings.ascii kernel make mason.common mason.config
-mason.platform mason.report mason.email namespaces sequences ;
+mason.platform mason.report mason.notify namespaces sequences
+quotations macros ;
IN: mason.child
: make-cmd ( -- args )
try-process
] with-directory ;
-: return-with ( obj -- * ) return-continuation get continue-with ;
+: recover-else ( try catch else -- )
+ [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline
-: build-clean? ( -- ? )
- {
- [ load-everything-vocabs-file eval-file empty? ]
- [ test-all-vocabs-file eval-file empty? ]
- [ help-lint-vocabs-file eval-file empty? ]
- [ compiler-errors-file eval-file empty? ]
- } 0&& ;
-
-: build-child ( -- )
- [
- return-continuation set
-
- copy-image
+MACRO: recover-cond ( alist -- )
+ dup { [ length 1 = ] [ first callable? ] } 1&&
+ [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ;
- [ make-vm ] [ compile-failed-report status-error return-with ] recover
- [ boot ] [ boot-failed-report status-error return-with ] recover
- [ test ] [ test-failed-report status-error return-with ] recover
-
- successful-report
-
- build-clean? status-clean status-dirty ? return-with
- ] callcc1
- status set
- email-report ;
\ No newline at end of file
+: build-child ( -- status )
+ copy-image
+ {
+ { [ notify-make-vm make-vm ] [ compile-failed ] }
+ { [ notify-boot boot ] [ boot-failed ] }
+ { [ notify-test test ] [ test-failed ] }
+ [ success ]
+ } recover-cond ;
\ No newline at end of file
mason.common mason.config mason.platform namespaces ;
IN: mason.cleanup
+: compress ( filename -- )
+ dup exists? [ "bzip2" swap 2array try-output-process ] [ drop ] if ;
+
: compress-image ( -- )
- "bzip2" boot-image-name 2array try-process ;
+ boot-image-name compress ;
: compress-test-log ( -- )
- "test-log" exists? [
- { "bzip2" "test-log" } try-process
- ] when ;
+ "test-log" compress ;
: cleanup ( -- )
builder-debug get [
math.functions make io io.files io.pathnames io.directories
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
-calendar.format arrays mason.config locals system ;
+calendar.format arrays mason.config locals system debugger ;
IN: mason.common
+ERROR: output-process-error output process ;
+
+M: output-process-error error.
+ [ "Process:" print process>> . nl ]
+ [ "Output:" print output>> print ]
+ bi ;
+
+: try-output-process ( command -- )
+ >process +stdout+ >>stderr utf8 <process-reader*>
+ [ contents ] [ dup wait-for-process ] bi*
+ 0 = [ 2drop ] [ output-process-error ] if ;
+
HOOK: really-delete-tree os ( path -- )
M: windows really-delete-tree
#! Workaround: Cygwin GIT creates read-only files for
#! some reason.
- [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ]
+ [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ]
[ delete-tree ]
bi ;
<process>
swap >>command
15 minutes >>timeout
- try-process ;
+ try-output-process ;
:: upload-safely ( local username host remote -- )
[let* | temp [ remote ".incomplete" append ]
: prepare-build-machine ( -- )
builds-dir get make-directories
builds-dir get
- [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
+ [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ]
with-directory ;
: git-id ( -- id )
CONSTANT: help-lint-vocabs-file "help-lint-vocabs"
CONSTANT: help-lint-errors-file "help-lint-errors"
+CONSTANT: compiler-errors-file "compiler-errors"
+CONSTANT: compiler-error-messages-file "compiler-error-messages"
+
CONSTANT: boot-time-file "boot-time"
CONSTANT: load-time-file "load-time"
-CONSTANT: compiler-errors-file "compiler-errors"
CONSTANT: test-time-file "test-time"
CONSTANT: help-lint-time-file "help-lint-time"
CONSTANT: benchmark-time-file "benchmark-time"
CONSTANT: html-help-time-file "html-help-time"
CONSTANT: benchmarks-file "benchmarks"
-
-SYMBOL: status
+CONSTANT: benchmark-error-messages-file "benchmark-error-messages"
+CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs"
SYMBOL: status-error ! didn't bootstrap, or crashed
SYMBOL: status-dirty ! bootstrapped but not all tests passed
home "builds" append-path builds-dir set-global
] unless
-! Who sends build reports.
+! Who sends build report e-mails.
SYMBOL: builder-from
-! Who receives build reports.
+! Who receives build report e-mails.
SYMBOL: builder-recipients
+! (Optional) twitter credentials for status updates.
+SYMBOL: builder-twitter-username
+
+SYMBOL: builder-twitter-password
+
! (Optional) CPU architecture to build for.
SYMBOL: target-cpu
! Keep test-log around?
SYMBOL: builder-debug
+! Host to send status notifications to.
+SYMBOL: status-host
+
+! Username to log in.
+SYMBOL: status-username
+
SYMBOL: upload-help?
! The below are only needed if upload-help is true.
[
"linux" target-os set
"x86.64" target-cpu set
- status-error status set
- subject prefix-subject
+ status-error subject prefix-subject
] with-scope
] unit-test
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces accessors combinators make smtp
-debugger prettyprint io io.streams.string io.encodings.utf8
-io.files io.sockets
+USING: kernel namespaces accessors combinators make smtp debugger
+prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets
mason.common mason.platform mason.config ;
IN: mason.email
: prefix-subject ( str -- str' )
[ "mason on " % platform % ": " % % ] "" make ;
-: email-status ( body subject -- )
+: email-status ( body content-type subject -- )
<email>
builder-from get >>from
builder-recipients get >>to
swap prefix-subject >>subject
+ swap >>content-type
swap >>body
send-email ;
-: subject ( -- str )
- status get {
+: subject ( status -- str )
+ {
{ status-clean [ "clean" ] }
{ status-dirty [ "dirty" ] }
{ status-error [ "error" ] }
} case ;
-: email-report ( -- )
- "report" utf8 file-contents subject email-status ;
+: email-report ( report status -- )
+ [ "text/html" ] dip subject email-status ;
: email-error ( error callstack -- )
[
"Fatal error on " write host-name print nl
[ error. ] [ callstack. ] bi*
- ] with-string-writer "fatal error"
+ ] with-string-writer "text/plain" "fatal error"
email-status ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.html io.directories io.files io.launcher
kernel make mason.common mason.config namespaces sequences ;
: make-help-archive ( -- )
"factor/temp" [
- { "tar" "cfz" "docs.tar.gz" "docs" } try-process
+ { "tar" "cfz" "docs.tar.gz" "docs" } try-output-process
] with-directory ;
: upload-help-archive ( -- )
help-directory get "/docs.tar.gz" append
upload-safely ;
-: (upload-help) ( -- )
+: upload-help ( -- )
upload-help? get [
make-help-archive
upload-help-archive
- ] when ;
-
-: upload-help ( -- )
- status get status-clean eq? [ (upload-help) ] when ;
+ ] when ;
\ No newline at end of file
IN: mason
: build-loop-error ( error -- )
- error-continuation get call>> email-error ;
+ [ "Build loop error:" print flush error. flush ]
+ [ error-continuation get call>> email-error ] bi ;
: build-loop-fatal ( error -- )
"FATAL BUILDER ERROR:" print
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors io io.sockets io.encodings.utf8 io.files
+io.launcher kernel make mason.config mason.common mason.email
+mason.twitter namespaces sequences ;
+IN: mason.notify
+
+: status-notify ( input-file args -- )
+ status-host get [
+ [
+ "ssh" , status-host get , "-l" , status-username get ,
+ "./mason-notify" ,
+ host-name ,
+ target-cpu get ,
+ target-os get ,
+ ] { } make prepend
+ <process>
+ swap >>command
+ swap [ +closed+ ] unless* >>stdin
+ try-output-process
+ ] [ 2drop ] if ;
+
+: notify-begin-build ( git-id -- )
+ [ "Starting build of GIT ID " write print flush ]
+ [ f swap "git-id" swap 2array status-notify ]
+ bi ;
+
+: notify-make-vm ( -- )
+ "Compiling VM" print flush
+ f { "make-vm" } status-notify ;
+
+: notify-boot ( -- )
+ "Bootstrapping" print flush
+ f { "boot" } status-notify ;
+
+: notify-test ( -- )
+ "Running tests" print flush
+ f { "test" } status-notify ;
+
+: notify-report ( status -- )
+ [ "Build finished with status: " write print flush ]
+ [
+ [ "report" utf8 file-contents ] dip email-report
+ "report" { "report" } status-notify
+ ] bi ;
+
+: notify-release ( archive-name -- )
+ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
\ No newline at end of file
: archive-name ( -- string ) base-name extension append ;
-: make-windows-archive ( -- )
- [ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ;
+: make-windows-archive ( archive-name -- )
+ [ "zip" , "-r" , , "factor" , ] { } make try-output-process ;
-: make-macosx-archive ( -- )
- { "mkdir" "dmg-root" } try-process
- { "cp" "-R" "factor" "dmg-root" } try-process
+: make-macosx-archive ( archive-name -- )
+ { "mkdir" "dmg-root" } try-output-process
+ { "cp" "-R" "factor" "dmg-root" } try-output-process
{ "hdiutil" "create"
"-srcfolder" "dmg-root"
"-fs" "HFS+"
"-volname" "factor" }
- archive-name suffix try-process
+ swap suffix try-output-process
"dmg-root" really-delete-tree ;
-: make-unix-archive ( -- )
- [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ;
+: make-unix-archive ( archive-name -- )
+ [ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ;
-: make-archive ( -- )
+: make-archive ( archive-name -- )
target-os get {
{ "winnt" [ make-windows-archive ] }
{ "macosx" [ make-macosx-archive ] }
: releases ( -- path )
builds-dir get "releases" append-path dup make-directories ;
-: save-archive ( -- )
- archive-name releases move-file-into ;
\ No newline at end of file
+: save-archive ( archive-name -- )
+ releases move-file-into ;
\ No newline at end of file
-! Copyright (C) 2008 Eduardo Cavazos.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel debugger namespaces sequences splitting
+USING: kernel debugger namespaces sequences splitting combinators
combinators io io.files io.launcher prettyprint bootstrap.image
mason.common mason.release.branch mason.release.tidy
-mason.release.archive mason.release.upload ;
+mason.release.archive mason.release.upload mason.notify ;
IN: mason.release
-: (release) ( -- )
+: release ( -- )
update-clean-branch
tidy
- make-archive
- upload
- save-archive ;
-
-: release ( -- ) status get status-clean eq? [ (release) ] when ;
\ No newline at end of file
+ archive-name {
+ [ make-archive ]
+ [ upload ]
+ [ save-archive ]
+ [ notify-release ]
+ } cleave ;
\ No newline at end of file
: remote-location ( -- dest )
upload-directory get "/" platform 3append ;
-: remote-archive-name ( -- dest )
- remote-location "/" archive-name 3append ;
+: remote-archive-name ( archive-name -- dest )
+ [ remote-location "/" ] dip 3append ;
-: upload ( -- )
+: upload ( archive-name -- )
upload-to-factorcode? get [
- archive-name
upload-username get
upload-host get
- remote-archive-name
+ pick remote-archive-name
upload-safely
- ] when ;
+ ] [ drop ] if ;
IN: mason.report.tests
USING: mason.report tools.test ;
+
+{ 0 0 } [ [ ] with-report ] must-infer-as
\ No newline at end of file
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces debugger fry io io.files io.sockets
-io.encodings.utf8 prettyprint benchmark mason.common
-mason.platform mason.config sequences ;
+USING: benchmark combinators.smart debugger fry io assocs
+io.encodings.utf8 io.files io.sockets io.streams.string kernel
+locals mason.common mason.config mason.platform math namespaces
+prettyprint sequences xml.syntax xml.writer combinators.short-circuit ;
IN: mason.report
-: time. ( file -- )
- [ write ": " write ] [ eval-file milli-seconds>time print ] bi ;
-
-: common-report ( -- )
- "Build machine: " write host-name print
- "CPU: " write target-cpu get print
- "OS: " write target-os get print
- "Build directory: " write build-dir print
- "git id: " write "git-id" eval-file print nl ;
+: common-report ( -- xml )
+ target-os get
+ target-cpu get
+ host-name
+ build-dir
+ "git-id" eval-file
+ [XML
+ <h1>Build report for <->/<-></h1>
+ <table>
+ <tr><td>Build machine:</td><td><-></td></tr>
+ <tr><td>Build directory:</td><td><-></td></tr>
+ <tr><td>GIT ID:</td><td><-></td></tr>
+ </table>
+ XML] ;
: with-report ( quot -- )
- [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; inline
+ [ "report" utf8 ] dip
+ '[
+ common-report
+ _ call( -- xml )
+ [XML <html><body><-><-></body></html> XML]
+ pprint-xml
+ ] with-file-writer ; inline
-: compile-failed-report ( error -- )
+:: failed-report ( error file what -- status )
[
- "VM compile failed:" print nl
- "compile-log" cat nl
- error.
- ] with-report ;
+ error [ error. ] with-string-writer :> error
+ file utf8 file-contents 400 short tail* :> output
+
+ [XML
+ <h2><-what-></h2>
+ Build output:
+ <pre><-output-></pre>
+ Launcher error:
+ <pre><-error-></pre>
+ XML]
+ ] with-report
+ status-error ;
-: boot-failed-report ( error -- )
- [
- "Bootstrap failed:" print nl
- "boot-log" 100 cat-n nl
- error.
- ] with-report ;
+: compile-failed ( error -- status )
+ "compile-log" "VM compilation failed" failed-report ;
+
+: boot-failed ( error -- status )
+ "boot-log" "Bootstrap failed" failed-report ;
+
+: test-failed ( error -- status )
+ "test-log" "Tests failed" failed-report ;
+
+: timings-table ( -- xml )
+ {
+ boot-time-file
+ load-time-file
+ test-time-file
+ help-lint-time-file
+ benchmark-time-file
+ html-help-time-file
+ } [
+ execute( -- string )
+ dup utf8 file-contents milli-seconds>time
+ [XML <tr><td><-></td><td><-></td></tr> XML]
+ ] map [XML <h2>Timings</h2> <table><-></table> XML] ;
+
+: error-dump ( heading vocabs-file messages-file -- xml )
+ [ eval-file ] dip over empty? [ 3drop f ] [
+ [ ]
+ [ [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ]
+ [ utf8 file-contents ]
+ tri*
+ [XML <h1><-></h1> <-> Details: <pre><-></pre> XML]
+ ] if ;
-: test-failed-report ( error -- )
+: benchmarks-table ( assoc -- xml )
[
- "Tests failed:" print nl
- "test-log" 100 cat-n nl
- error.
- ] with-report ;
+ 1000000 /f
+ [XML <tr><td><-></td><td><-></td></tr> XML]
+ ] { } assoc>map [XML <h2>Benchmarks</h2> <table><-></table> XML] ;
: successful-report ( -- )
[
- boot-time-file time.
- load-time-file time.
- test-time-file time.
- help-lint-time-file time.
- benchmark-time-file time.
- html-help-time-file time.
-
- nl
-
- load-everything-vocabs-file eval-file [
- "== Did not pass load-everything:" print .
- load-everything-errors-file cat
- ] unless-empty
-
- compiler-errors-file eval-file [
- "== Vocabularies with compiler errors:" print .
- ] unless-empty
-
- test-all-vocabs-file eval-file [
- "== Did not pass test-all:" print .
- test-all-errors-file cat
- ] unless-empty
-
- help-lint-vocabs-file eval-file [
- "== Did not pass help-lint:" print .
- help-lint-errors-file cat
- ] unless-empty
-
- "== Benchmarks:" print
- benchmarks-file eval-file benchmarks.
- ] with-report ;
\ No newline at end of file
+ [
+ timings-table
+
+ "Load failures"
+ load-everything-vocabs-file
+ load-everything-errors-file
+ error-dump
+
+ "Compiler warnings and errors"
+ compiler-errors-file
+ compiler-error-messages-file
+ error-dump
+
+ "Unit test failures"
+ test-all-vocabs-file
+ test-all-errors-file
+ error-dump
+
+ "Help lint failures"
+ help-lint-vocabs-file
+ help-lint-errors-file
+ error-dump
+
+ "Benchmark errors"
+ benchmark-error-vocabs-file
+ benchmark-error-messages-file
+ error-dump
+
+ "Benchmark timings"
+ benchmarks-file eval-file benchmarks-table
+ ] output>array
+ ] with-report ;
+
+: build-clean? ( -- ? )
+ {
+ [ load-everything-vocabs-file eval-file empty? ]
+ [ test-all-vocabs-file eval-file empty? ]
+ [ help-lint-vocabs-file eval-file empty? ]
+ [ compiler-errors-file eval-file empty? ]
+ [ benchmark-error-vocabs-file eval-file empty? ]
+ } 0&& ;
+
+: success ( -- status )
+ successful-report build-clean? status-clean status-dirty ? ;
\ No newline at end of file
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs benchmark bootstrap.stage2
-compiler.errors generic help.html help.lint io.directories
+USING: accessors assocs benchmark bootstrap.stage2 compiler.errors
+source-files.errors generic help.html help.lint io.directories
io.encodings.utf8 io.files kernel mason.common math namespaces
-prettyprint sequences sets sorting tools.test tools.time
-tools.vocabs words system io ;
+prettyprint sequences sets sorting tools.test tools.time tools.vocabs
+words system io tools.errors locals ;
IN: mason.test
: do-load ( -- )
M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
+:: do-step ( errors summary-file details-file -- )
+ errors
+ [ error-type +linkage-error+ eq? not ] filter
+ [ file>> ] map prune natural-sort summary-file to-file
+ errors details-file utf8 [ errors. ] with-file-writer ;
+
: do-compile-errors ( -- )
- compiler-errors-file utf8 [
- +error+ errors-of-type keys
- [ word-vocabulary ] map
- prune natural-sort .
- ] with-file-writer ;
+ compiler-errors get values
+ compiler-errors-file
+ compiler-error-messages-file
+ do-step ;
: do-tests ( -- )
- run-all-tests
- [ keys test-all-vocabs-file to-file ]
- [ test-all-errors-file utf8 [ test-failures. ] with-file-writer ]
- bi ;
+ test-all test-failures get
+ test-all-vocabs-file
+ test-all-errors-file
+ do-step ;
: do-help-lint ( -- )
- "" run-help-lint
- [ keys help-lint-vocabs-file to-file ]
- [ help-lint-errors-file utf8 [ typos. ] with-file-writer ]
- bi ;
+ help-lint-all lint-failures get values
+ help-lint-vocabs-file
+ help-lint-errors-file
+ do-step ;
: do-benchmarks ( -- )
- run-benchmarks benchmarks-file to-file ;
+ run-benchmarks
+ [ benchmarks-file to-file ] [
+ [ keys benchmark-error-vocabs-file to-file ]
+ [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi
+ ] bi* ;
: benchmark-ms ( quot -- ms )
benchmark 1000 /i ; inline
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: debugger fry kernel mason.config namespaces twitter ;
+IN: mason.twitter
+
+: mason-tweet ( message -- )
+ builder-twitter-username get builder-twitter-password get and
+ [
+ [
+ builder-twitter-username get twitter-username set
+ builder-twitter-password get twitter-password set
+ '[ _ tweet ] try
+ ] with-scope
+ ] [ drop ] if ;
\ No newline at end of file
[ dup zip ] dip binpack [ keys ] map ;
: binpack! ( items quot n -- bins )
- [ dupd map zip ] dip binpack [ keys ] map ;
+ [ dupd map zip ] dip binpack [ keys ] map ; inline
[ bi - ] 2curry ; inline
: eval ( x func -- pt )
- dupd call 2array ; inline
+ dupd call( x -- y ) 2array ; inline
: eval-inverse ( y func -- pt )
- dupd call swap 2array ; inline
+ dupd call( y -- x ) swap 2array ; inline
: eval3d ( x y func -- pt )
- [ 2dup ] dip call 3array ; inline
+ [ 2dup ] dip call( x y -- z ) 3array ; inline
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: math.matrices.elimination.tests
-USING: kernel math.matrices math.matrices.elimination
-tools.test sequences ;
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- }
-] [
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- }
-] [
- {
- { 1 0 0 0 }
- { 1 1 0 0 }
- { 1 0 1 0 }
- { 1 0 0 1 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- }
-] [
- {
- { 1 0 0 0 }
- { 1 1 0 0 }
- { 1 0 1 0 }
- { 1 1 0 1 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- }
-] [
- {
- { 1 0 0 0 }
- { 1 1 0 0 }
- { 1 1 0 1 }
- { 1 0 1 0 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 0 0 }
- { 0 0 0 0 }
- }
-] [
- {
- { 0 1 0 0 }
- { 1 0 0 0 }
- { 1 0 0 0 }
- { 1 0 0 0 }
- } [
- [ 1 ] [ 0 0 pivot-row ] unit-test
- 1 0 do-row
- ] with-matrix
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 0 0 }
- { 0 0 0 0 }
- }
-] [
- {
- { 0 1 0 0 }
- { 1 0 0 0 }
- { 1 0 0 0 }
- { 1 0 0 0 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 0 1 }
- { 0 0 0 0 }
- }
-] [
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 1 0 0 1 }
- { 1 0 0 1 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 1 }
- { 0 1 0 1 }
- { 0 0 0 -1 }
- { 0 0 0 0 }
- }
-] [
- {
- { 0 1 0 1 }
- { 1 0 0 1 }
- { 1 0 0 0 }
- { 1 1 0 1 }
- } echelon
-] unit-test
-
-[
- 2
-] [
- {
- { 0 0 }
- { 0 0 }
- } nullspace length
-] unit-test
-
-[
- 1 3
-] [
- {
- { 0 1 0 1 }
- { 1 0 0 1 }
- { 1 0 0 0 }
- { 1 1 0 1 }
- } null/rank
-] unit-test
-
-[
- 1 3
-] [
- {
- { 0 0 0 0 0 1 0 1 }
- { 0 0 0 0 1 0 0 1 }
- { 0 0 0 0 1 0 0 0 }
- { 0 0 0 0 1 1 0 1 }
- } null/rank
-] unit-test
-
-[ { { 1 0 -1 } { 0 1 2 } } ]
-[ { { 1 2 3 } { 4 5 6 } } solution ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.vectors math.matrices namespaces
-sequences ;
-IN: math.matrices.elimination
-
-SYMBOL: matrix
-
-: with-matrix ( matrix quot -- )
- [ swap matrix set call matrix get ] with-scope ; inline
-
-: nth-row ( row# -- seq ) matrix get nth ;
-
-: change-row ( row# quot: ( seq -- seq ) -- )
- matrix get swap change-nth ; inline
-
-: exchange-rows ( row# row# -- ) matrix get exchange ;
-
-: rows ( -- n ) matrix get length ;
-
-: cols ( -- n ) 0 nth-row length ;
-
-: skip ( i seq quot -- n )
- over [ find-from drop ] dip length or ; inline
-
-: first-col ( row# -- n )
- #! First non-zero column
- 0 swap nth-row [ zero? not ] skip ;
-
-: clear-scale ( col# pivot-row i-row -- n )
- [ over ] dip nth dup zero? [
- 3drop 0
- ] [
- [ nth dup zero? ] dip swap [
- 2drop 0
- ] [
- swap / neg
- ] if
- ] if ;
-
-: (clear-col) ( col# pivot-row i -- )
- [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
-
-: rows-from ( row# -- slice )
- rows dup <slice> ;
-
-: clear-col ( col# row# rows -- )
- [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
-
-: do-row ( exchange-with row# -- )
- [ exchange-rows ] keep
- [ first-col ] keep
- dup 1+ rows-from clear-col ;
-
-: find-row ( row# quot -- i elt )
- [ rows-from ] dip find ; inline
-
-: pivot-row ( col# row# -- n )
- [ dupd nth-row nth zero? not ] find-row 2nip ;
-
-: (echelon) ( col# row# -- )
- over cols < over rows < and [
- 2dup pivot-row [ over do-row 1+ ] when*
- [ 1+ ] dip (echelon)
- ] [
- 2drop
- ] if ;
-
-: echelon ( matrix -- matrix' )
- [ 0 0 (echelon) ] with-matrix ;
-
-: nonzero-rows ( matrix -- matrix' )
- [ [ zero? ] all? not ] filter ;
-
-: null/rank ( matrix -- null rank )
- echelon dup length swap nonzero-rows length [ - ] keep ;
-
-: leading ( seq -- n elt ) [ zero? not ] find ;
-
-: reduced ( matrix' -- matrix'' )
- [
- rows <reversed> [
- dup nth-row leading drop
- dup [ swap dup clear-col ] [ 2drop ] if
- ] each
- ] with-matrix ;
-
-: basis-vector ( row col# -- )
- [ clone ] dip
- [ swap nth neg recip ] 2keep
- [ 0 spin set-nth ] 2keep
- [ n*v ] dip
- matrix get set-nth ;
-
-: nullspace ( matrix -- seq )
- echelon reduced dup empty? [
- dup first length identity-matrix [
- [
- dup leading drop
- dup [ basis-vector ] [ 2drop ] if
- ] each
- ] with-matrix flip nonzero-rows
- ] unless ;
-
-: 1-pivots ( matrix -- matrix )
- [ dup leading nip [ recip v*n ] when* ] map ;
-
-: solution ( matrix -- matrix )
- echelon nonzero-rows reduced 1-pivots ;
-
-: inverse ( matrix -- matrix ) ! Assumes an invertible matrix
- dup length
- [ identity-matrix [ append ] 2map solution ] keep
- [ tail ] curry map ;
+++ /dev/null
-Solving systems of linear equations
+++ /dev/null
-IN: math.matrices.tests
-USING: math.matrices math.vectors tools.test math ;
-
-[
- { { 0 } { 0 } { 0 } }
-] [
- 3 1 zero-matrix
-] unit-test
-
-[
- { { 1 0 0 }
- { 0 1 0 }
- { 0 0 1 } }
-] [
- 3 identity-matrix
-] unit-test
-
-[
- { { 1 0 4 }
- { 0 7 0 }
- { 6 0 3 } }
-] [
- { { 1 0 0 }
- { 0 2 0 }
- { 0 0 3 } }
-
- { { 0 0 4 }
- { 0 5 0 }
- { 6 0 0 } }
-
- m+
-] unit-test
-
-[
- { { 1 0 4 }
- { 0 7 0 }
- { 6 0 3 } }
-] [
- { { 1 0 0 }
- { 0 2 0 }
- { 0 0 3 } }
-
- { { 0 0 -4 }
- { 0 -5 0 }
- { -6 0 0 } }
-
- m-
-] unit-test
-
-[
- { 10 20 30 }
-] [
- 10 { 1 2 3 } n*v
-] unit-test
-
-[
- { 3 4 }
-] [
- { { 1 0 }
- { 0 1 } }
-
- { 3 4 }
-
- m.v
-] unit-test
-
-[
- { 4 3 }
-] [
- { { 0 1 }
- { 1 0 } }
-
- { 3 4 }
-
- m.v
-] unit-test
-
-[
- { { 6 } }
-] [
- { { 3 } } { { 2 } } m.
-] unit-test
-
-[
- { { 11 } }
-] [
- { { 1 3 } } { { 5 } { 2 } } m.
-] unit-test
-
-[
- { { 28 } }
-] [
- { { 2 4 6 } }
-
- { { 1 }
- { 2 }
- { 3 } }
-
- m.
-] unit-test
-
-[ { 0 0 -1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test
-[ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test
-[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
-
-[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
-
-[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2005, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.vectors sequences ;
-IN: math.matrices
-
-! Matrices
-: zero-matrix ( m n -- matrix )
- [ nip 0 <array> ] curry map ;
-
-: identity-matrix ( n -- matrix )
- #! Make a nxn identity matrix.
- dup [ [ = 1 0 ? ] with map ] curry map ;
-
-! Matrix operations
-: mneg ( m -- m ) [ vneg ] map ;
-
-: n*m ( n m -- m ) [ n*v ] with map ;
-: m*n ( m n -- m ) [ v*n ] curry map ;
-: n/m ( n m -- m ) [ n/v ] with map ;
-: m/n ( m n -- m ) [ v/n ] curry map ;
-
-: m+ ( m m -- m ) [ v+ ] 2map ;
-: m- ( m m -- m ) [ v- ] 2map ;
-: m* ( m m -- m ) [ v* ] 2map ;
-: m/ ( m m -- m ) [ v/ ] 2map ;
-
-: v.m ( v m -- v ) flip [ v. ] with map ;
-: m.v ( m v -- v ) [ v. ] curry map ;
-: m. ( m m -- m ) flip [ swap m.v ] curry map ;
-
-: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
-: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
-: mnorm ( m -- n ) dup mmax abs m/n ;
-
-<PRIVATE
-
-: x ( seq -- elt ) first ; inline
-: y ( seq -- elt ) second ; inline
-: z ( seq -- elt ) third ; inline
-
-: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
-: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
-: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
-
-PRIVATE>
-
-: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
-
-: proj ( v u -- w )
- [ [ v. ] [ norm-sq ] bi / ] keep n*v ;
-
-: (gram-schmidt) ( v seq -- newseq )
- [ dupd proj v- ] each ;
-
-: gram-schmidt ( seq -- orthogonal )
- V{ } clone [ over (gram-schmidt) over push ] reduce ;
-
-: norm-gram-schmidt ( seq -- orthonormal )
- gram-schmidt [ normalize ] map ;
-
-: cross-zip ( seq1 seq2 -- seq1xseq2 )
- [ [ 2array ] with map ] curry map ;
\ No newline at end of file
+++ /dev/null
-Matrix arithmetic
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences namespaces make math math.ranges
-math.vectors vectors ;
+USING: kernel math math.ranges math.vectors namespaces
+sequences ;
IN: math.numerical-integration
SYMBOL: num-steps
length 2 / 2 - { 2 4 } <repetition> concat
{ 1 4 } { 1 } surround ;
-: integrate-simpson ( from to f -- x )
+: integrate-simpson ( from to quot -- x )
[ setup-simpson-range dup ] dip
map dup generate-simpson-weights
- v. swap [ third ] keep first - 6 / * ;
+ v. swap [ third ] keep first - 6 / * ; inline
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: morse
+
+HELP: ch>morse
+{ $values
+ { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
+{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
+
+HELP: morse>ch
+{ $values
+ { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
+{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
+
+HELP: >morse
+{ $values
+ { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } }
+{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." }
+{ $see-also morse> ch>morse } ;
+
+HELP: morse>
+{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } }
+{ $description "Translates morse code into ASCII text" }
+{ $see-also >morse morse>ch } ;
+
+HELP: play-as-morse*
+{ $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } }
+{ $description "Plays a string as morse code" } ;
+
+HELP: play-as-morse
+{ $values { "str" "A string of ascii characters which can be translated into morse code" } }
+{ $description "Plays a string as morse code" } ;
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays morse strings tools.test ;
+
+[ "" ] [ CHAR: \\ ch>morse ] unit-test
+[ "..." ] [ CHAR: s ch>morse ] unit-test
+[ CHAR: s ] [ "..." morse>ch ] unit-test
+[ f ] [ "..--..--.." morse>ch ] unit-test
+[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
+[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
+[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
+! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
+! [ ] [ "Factor rocks!" play-as-morse ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ascii assocs combinators hashtables kernel lists math
+namespaces make openal parser-combinators promises sequences
+strings synth synth.buffers unicode.case ;
+IN: morse
+
+<PRIVATE
+: morse-codes ( -- array )
+ {
+ { CHAR: a ".-" }
+ { CHAR: b "-..." }
+ { CHAR: c "-.-." }
+ { CHAR: d "-.." }
+ { CHAR: e "." }
+ { CHAR: f "..-." }
+ { CHAR: g "--." }
+ { CHAR: h "...." }
+ { CHAR: i ".." }
+ { CHAR: j ".---" }
+ { CHAR: k "-.-" }
+ { CHAR: l ".-.." }
+ { CHAR: m "--" }
+ { CHAR: n "-." }
+ { CHAR: o "---" }
+ { CHAR: p ".--." }
+ { CHAR: q "--.-" }
+ { CHAR: r ".-." }
+ { CHAR: s "..." }
+ { CHAR: t "-" }
+ { CHAR: u "..-" }
+ { CHAR: v "...-" }
+ { CHAR: w ".--" }
+ { CHAR: x "-..-" }
+ { CHAR: y "-.--" }
+ { CHAR: z "--.." }
+ { CHAR: 1 ".----" }
+ { CHAR: 2 "..---" }
+ { CHAR: 3 "...--" }
+ { CHAR: 4 "....-" }
+ { CHAR: 5 "....." }
+ { CHAR: 6 "-...." }
+ { CHAR: 7 "--..." }
+ { CHAR: 8 "---.." }
+ { CHAR: 9 "----." }
+ { CHAR: 0 "-----" }
+ { CHAR: . ".-.-.-" }
+ { CHAR: , "--..--" }
+ { CHAR: ? "..--.." }
+ { CHAR: ' ".----." }
+ { CHAR: ! "-.-.--" }
+ { CHAR: / "-..-." }
+ { CHAR: ( "-.--." }
+ { CHAR: ) "-.--.-" }
+ { CHAR: & ".-..." }
+ { CHAR: : "---..." }
+ { CHAR: ; "-.-.-." }
+ { CHAR: = "-...- " }
+ { CHAR: + ".-.-." }
+ { CHAR: - "-....-" }
+ { CHAR: _ "..--.-" }
+ { CHAR: " ".-..-." }
+ { CHAR: $ "...-..-" }
+ { CHAR: @ ".--.-." }
+ { CHAR: \s "/" }
+ } ;
+
+: ch>morse-assoc ( -- assoc )
+ morse-codes >hashtable ;
+
+: morse>ch-assoc ( -- assoc )
+ morse-codes [ reverse ] map >hashtable ;
+
+PRIVATE>
+
+: ch>morse ( ch -- str )
+ ch>lower ch>morse-assoc at* swap "" ? ;
+
+: morse>ch ( str -- ch )
+ morse>ch-assoc at* swap f ? ;
+
+: >morse ( str -- str )
+ [
+ [ CHAR: \s , ] [ ch>morse % ] interleave
+ ] "" make ;
+
+<PRIVATE
+
+: dot-char ( -- ch ) CHAR: . ;
+: dash-char ( -- ch ) CHAR: - ;
+: char-gap-char ( -- ch ) CHAR: \s ;
+: word-gap-char ( -- ch ) CHAR: / ;
+
+: =parser ( obj -- parser )
+ [ = ] curry satisfy ;
+
+LAZY: 'dot' ( -- parser )
+ dot-char =parser ;
+
+LAZY: 'dash' ( -- parser )
+ dash-char =parser ;
+
+LAZY: 'char-gap' ( -- parser )
+ char-gap-char =parser ;
+
+LAZY: 'word-gap' ( -- parser )
+ word-gap-char =parser ;
+
+LAZY: 'morse-char' ( -- parser )
+ 'dot' 'dash' <|> <+> ;
+
+LAZY: 'morse-word' ( -- parser )
+ 'morse-char' 'char-gap' list-of ;
+
+LAZY: 'morse-words' ( -- parser )
+ 'morse-word' 'word-gap' list-of ;
+
+PRIVATE>
+
+: morse> ( str -- str )
+ 'morse-words' parse car parsed>> [
+ [
+ >string morse>ch
+ ] map >string
+ ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
+
+<PRIVATE
+SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
+
+: queue ( symbol -- )
+ get source get swap queue-buffer ;
+
+: dot ( -- ) dot-buffer queue ;
+: dash ( -- ) dash-buffer queue ;
+: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
+: letter-gap ( -- ) letter-gap-buffer queue ;
+
+: beep-freq ( -- n ) 880 ;
+
+: <morse-buffer> ( -- buffer )
+ half-sample-freq <8bit-mono-buffer> ;
+
+: sine-buffer ( seconds -- id )
+ beep-freq swap <morse-buffer> >sine-wave-buffer
+ send-buffer id>> ;
+
+: silent-buffer ( seconds -- id )
+ <morse-buffer> >silent-buffer send-buffer id>> ;
+
+: make-buffers ( unit-length -- )
+ {
+ [ sine-buffer dot-buffer set ]
+ [ 3 * sine-buffer dash-buffer set ]
+ [ silent-buffer intra-char-gap-buffer set ]
+ [ 3 * silent-buffer letter-gap-buffer set ]
+ } cleave ;
+
+: playing-morse ( quot unit-length -- )
+ [
+ init-openal 1 gen-sources first source set make-buffers
+ call
+ source get source-play
+ ] with-scope ; inline
+
+: play-char ( ch -- )
+ [ intra-char-gap ] [
+ {
+ { dot-char [ dot ] }
+ { dash-char [ dash ] }
+ { word-gap-char [ intra-char-gap ] }
+ } case
+ ] interleave ;
+
+PRIVATE>
+
+: play-as-morse* ( str unit-length -- )
+ [
+ [ letter-gap ] [ ch>morse play-char ] interleave
+ ] swap playing-morse ; inline
+
+: play-as-morse ( str -- )
+ 0.05 play-as-morse* ; inline
--- /dev/null
+Converts between text and morse code, and plays morse code.
--- /dev/null
+Chris Double
--- /dev/null
+Chris Double
--- /dev/null
+USING: namespaces system ;
+IN: openal.backend
+
+HOOK: load-wav-file os ( filename -- format data size frequency )
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: calendar kernel openal sequences threads ;\r
+IN: openal.example\r
+\r
+: play-hello ( -- )\r
+ init-openal\r
+ 1 gen-sources\r
+ first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param\r
+ source-play\r
+ 1000 milliseconds sleep ;\r
+ \r
+: (play-file) ( source -- )\r
+ 100 milliseconds sleep\r
+ dup source-playing? [ (play-file) ] [ drop ] if ;\r
+\r
+: play-file ( filename -- )\r
+ init-openal\r
+ create-buffer-from-file \r
+ 1 gen-sources\r
+ first dup [ AL_BUFFER rot set-source-param ] dip\r
+ dup source-play\r
+ check-error\r
+ (play-file) ;\r
+\r
+: play-wav ( filename -- )\r
+ init-openal\r
+ create-buffer-from-wav \r
+ 1 gen-sources\r
+ first dup [ AL_BUFFER rot set-source-param ] dip\r
+ dup source-play\r
+ check-error\r
+ (play-file) ;\r
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel alien alien.syntax shuffle
+openal.backend namespaces system generalizations ;
+IN: openal.macosx
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
+
+M: macosx load-wav-file ( path -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ alutLoadWAVFile ] 4 nkeep
+ [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors arrays alien system combinators alien.syntax namespaces
+ alien.c-types sequences vocabs.loader shuffle
+ openal.backend specialized-arrays.uint alien.libraries generalizations ;
+IN: openal
+
+<< "alut" {
+ { [ os windows? ] [ "alut.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libalut.so" ] }
+ } cond "cdecl" add-library >>
+
+<< "openal" {
+ { [ os windows? ] [ "OpenAL32.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libopenal.so" ] }
+ } cond "cdecl" add-library >>
+
+LIBRARY: openal
+
+TYPEDEF: char ALboolean
+TYPEDEF: char ALchar
+TYPEDEF: char ALbyte
+TYPEDEF: uchar ALubyte
+TYPEDEF: short ALshort
+TYPEDEF: ushort ALushort
+TYPEDEF: int ALint
+TYPEDEF: uint ALuint
+TYPEDEF: int ALsizei
+TYPEDEF: int ALenum
+TYPEDEF: float ALfloat
+TYPEDEF: double ALdouble
+
+CONSTANT: AL_INVALID -1
+CONSTANT: AL_NONE 0
+CONSTANT: AL_FALSE 0
+CONSTANT: AL_TRUE 1
+CONSTANT: AL_SOURCE_RELATIVE HEX: 202
+CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001
+CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002
+CONSTANT: AL_PITCH HEX: 1003
+CONSTANT: AL_POSITION HEX: 1004
+CONSTANT: AL_DIRECTION HEX: 1005
+CONSTANT: AL_VELOCITY HEX: 1006
+CONSTANT: AL_LOOPING HEX: 1007
+CONSTANT: AL_BUFFER HEX: 1009
+CONSTANT: AL_GAIN HEX: 100A
+CONSTANT: AL_MIN_GAIN HEX: 100D
+CONSTANT: AL_MAX_GAIN HEX: 100E
+CONSTANT: AL_ORIENTATION HEX: 100F
+CONSTANT: AL_CHANNEL_MASK HEX: 3000
+CONSTANT: AL_SOURCE_STATE HEX: 1010
+CONSTANT: AL_INITIAL HEX: 1011
+CONSTANT: AL_PLAYING HEX: 1012
+CONSTANT: AL_PAUSED HEX: 1013
+CONSTANT: AL_STOPPED HEX: 1014
+CONSTANT: AL_BUFFERS_QUEUED HEX: 1015
+CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016
+CONSTANT: AL_SEC_OFFSET HEX: 1024
+CONSTANT: AL_SAMPLE_OFFSET HEX: 1025
+CONSTANT: AL_BYTE_OFFSET HEX: 1026
+CONSTANT: AL_SOURCE_TYPE HEX: 1027
+CONSTANT: AL_STATIC HEX: 1028
+CONSTANT: AL_STREAMING HEX: 1029
+CONSTANT: AL_UNDETERMINED HEX: 1030
+CONSTANT: AL_FORMAT_MONO8 HEX: 1100
+CONSTANT: AL_FORMAT_MONO16 HEX: 1101
+CONSTANT: AL_FORMAT_STEREO8 HEX: 1102
+CONSTANT: AL_FORMAT_STEREO16 HEX: 1103
+CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020
+CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021
+CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022
+CONSTANT: AL_MAX_DISTANCE HEX: 1023
+CONSTANT: AL_FREQUENCY HEX: 2001
+CONSTANT: AL_BITS HEX: 2002
+CONSTANT: AL_CHANNELS HEX: 2003
+CONSTANT: AL_SIZE HEX: 2004
+CONSTANT: AL_UNUSED HEX: 2010
+CONSTANT: AL_PENDING HEX: 2011
+CONSTANT: AL_PROCESSED HEX: 2012
+CONSTANT: AL_NO_ERROR AL_FALSE
+CONSTANT: AL_INVALID_NAME HEX: A001
+CONSTANT: AL_ILLEGAL_ENUM HEX: A002
+CONSTANT: AL_INVALID_ENUM HEX: A002
+CONSTANT: AL_INVALID_VALUE HEX: A003
+CONSTANT: AL_ILLEGAL_COMMAND HEX: A004
+CONSTANT: AL_INVALID_OPERATION HEX: A004
+CONSTANT: AL_OUT_OF_MEMORY HEX: A005
+CONSTANT: AL_VENDOR HEX: B001
+CONSTANT: AL_VERSION HEX: B002
+CONSTANT: AL_RENDERER HEX: B003
+CONSTANT: AL_EXTENSIONS HEX: B004
+CONSTANT: AL_DOPPLER_FACTOR HEX: C000
+CONSTANT: AL_DOPPLER_VELOCITY HEX: C001
+CONSTANT: AL_SPEED_OF_SOUND HEX: C003
+CONSTANT: AL_DISTANCE_MODEL HEX: D000
+CONSTANT: AL_INVERSE_DISTANCE HEX: D001
+CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002
+CONSTANT: AL_LINEAR_DISTANCE HEX: D003
+CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004
+CONSTANT: AL_EXPONENT_DISTANCE HEX: D005
+CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006
+
+FUNCTION: void alEnable ( ALenum capability ) ;
+FUNCTION: void alDisable ( ALenum capability ) ;
+FUNCTION: ALboolean alIsEnabled ( ALenum capability ) ;
+FUNCTION: ALchar* alGetString ( ALenum param ) ;
+FUNCTION: void alGetBooleanv ( ALenum param, ALboolean* data ) ;
+FUNCTION: void alGetIntegerv ( ALenum param, ALint* data ) ;
+FUNCTION: void alGetFloatv ( ALenum param, ALfloat* data ) ;
+FUNCTION: void alGetDoublev ( ALenum param, ALdouble* data ) ;
+FUNCTION: ALboolean alGetBoolean ( ALenum param ) ;
+FUNCTION: ALint alGetInteger ( ALenum param ) ;
+FUNCTION: ALfloat alGetFloat ( ALenum param ) ;
+FUNCTION: ALdouble alGetDouble ( ALenum param ) ;
+FUNCTION: ALenum alGetError ( ) ;
+FUNCTION: ALboolean alIsExtensionPresent ( ALchar* extname ) ;
+FUNCTION: void* alGetProcAddress ( ALchar* fname ) ;
+FUNCTION: ALenum alGetEnumValue ( ALchar* ename ) ;
+FUNCTION: void alListenerf ( ALenum param, ALfloat value ) ;
+FUNCTION: void alListener3f ( ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
+FUNCTION: void alListenerfv ( ALenum param, ALfloat* values ) ;
+FUNCTION: void alListeneri ( ALenum param, ALint value ) ;
+FUNCTION: void alListener3i ( ALenum param, ALint value1, ALint value2, ALint value3 ) ;
+FUNCTION: void alListeneriv ( ALenum param, ALint* values ) ;
+FUNCTION: void alGetListenerf ( ALenum param, ALfloat* value ) ;
+FUNCTION: void alGetListener3f ( ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3 ) ;
+FUNCTION: void alGetListenerfv ( ALenum param, ALfloat* values ) ;
+FUNCTION: void alGetListeneri ( ALenum param, ALint* value ) ;
+FUNCTION: void alGetListener3i ( ALenum param, ALint* value1, ALint* value2, ALint* value3 ) ;
+FUNCTION: void alGetListeneriv ( ALenum param, ALint* values ) ;
+FUNCTION: void alGenSources ( ALsizei n, ALuint* sources ) ;
+FUNCTION: void alDeleteSources ( ALsizei n, ALuint* sources ) ;
+FUNCTION: ALboolean alIsSource ( ALuint sid ) ;
+FUNCTION: void alSourcef ( ALuint sid, ALenum param, ALfloat value ) ;
+FUNCTION: void alSource3f ( ALuint sid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
+FUNCTION: void alSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alSourcei ( ALuint sid, ALenum param, ALint value ) ;
+FUNCTION: void alSource3i ( ALuint sid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
+FUNCTION: void alSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
+FUNCTION: void alGetSourcef ( ALuint sid, ALenum param, ALfloat* value ) ;
+FUNCTION: void alGetSource3f ( ALuint sid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
+FUNCTION: void alGetSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alGetSourcei ( ALuint sid, ALenum param, ALint* value ) ;
+FUNCTION: void alGetSource3i ( ALuint sid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
+FUNCTION: void alGetSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
+FUNCTION: void alSourcePlayv ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourceStopv ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourceRewindv ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourcePausev ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourcePlay ( ALuint sid ) ;
+FUNCTION: void alSourceStop ( ALuint sid ) ;
+FUNCTION: void alSourceRewind ( ALuint sid ) ;
+FUNCTION: void alSourcePause ( ALuint sid ) ;
+FUNCTION: void alSourceQueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
+FUNCTION: void alSourceUnqueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
+FUNCTION: void alGenBuffers ( ALsizei n, ALuint* buffers ) ;
+FUNCTION: void alDeleteBuffers ( ALsizei n, ALuint* buffers ) ;
+FUNCTION: ALboolean alIsBuffer ( ALuint bid ) ;
+FUNCTION: void alBufferData ( ALuint bid, ALenum format, void* data, ALsizei size, ALsizei freq ) ;
+FUNCTION: void alBufferf ( ALuint bid, ALenum param, ALfloat value ) ;
+FUNCTION: void alBuffer3f ( ALuint bid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
+FUNCTION: void alBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alBufferi ( ALuint bid, ALenum param, ALint value ) ;
+FUNCTION: void alBuffer3i ( ALuint bid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
+FUNCTION: void alBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
+FUNCTION: void alGetBufferf ( ALuint bid, ALenum param, ALfloat* value ) ;
+FUNCTION: void alGetBuffer3f ( ALuint bid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
+FUNCTION: void alGetBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alGetBufferi ( ALuint bid, ALenum param, ALint* value ) ;
+FUNCTION: void alGetBuffer3i ( ALuint bid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
+FUNCTION: void alGetBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
+FUNCTION: void alDopplerFactor ( ALfloat value ) ;
+FUNCTION: void alDopplerVelocity ( ALfloat value ) ;
+FUNCTION: void alSpeedOfSound ( ALfloat value ) ;
+FUNCTION: void alDistanceModel ( ALenum distanceModel ) ;
+
+LIBRARY: alut
+
+CONSTANT: ALUT_API_MAJOR_VERSION 1
+CONSTANT: ALUT_API_MINOR_VERSION 1
+CONSTANT: ALUT_ERROR_NO_ERROR 0
+CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
+CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
+CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
+CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
+CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
+CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
+CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
+CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
+CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
+CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
+CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
+CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
+CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
+CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
+CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
+CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
+CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
+CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
+CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
+CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
+CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
+CONSTANT: ALUT_LOADER_BUFFER HEX: 300
+CONSTANT: ALUT_LOADER_MEMORY HEX: 301
+
+FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
+FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
+FUNCTION: ALboolean alutExit ( ) ;
+FUNCTION: ALenum alutGetError ( ) ;
+FUNCTION: char* alutGetErrorString ( ALenum error ) ;
+FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
+FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
+FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
+FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
+FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
+FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
+FUNCTION: ALint alutGetMajorVersion ( ) ;
+FUNCTION: ALint alutGetMinorVersion ( ) ;
+FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
+
+FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
+
+SYMBOL: init
+
+: init-openal ( -- )
+ init get-global expired? [
+ f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
+ 1337 <alien> init set-global
+ ] when ;
+
+: exit-openal ( -- )
+ init get-global expired? [
+ alutExit 0 = [ "Could not close OpenAL" throw ] when
+ f init set-global
+ ] unless ;
+
+: gen-sources ( size -- seq )
+ dup <uint-array> [ alGenSources ] keep ;
+
+: gen-buffers ( size -- seq )
+ dup <uint-array> [ alGenBuffers ] keep ;
+
+: gen-buffer ( -- buffer ) 1 gen-buffers first ;
+
+: create-buffer-from-file ( filename -- buffer )
+ alutCreateBufferFromFile dup AL_NONE = [
+ "create-buffer-from-file failed" throw
+ ] when ;
+
+os macosx? "openal.macosx" "openal.other" ? require
+
+: create-buffer-from-wav ( filename -- buffer )
+ gen-buffer dup rot load-wav-file
+ [ alBufferData ] 4 nkeep alutUnloadWAV ;
+
+: queue-buffers ( source buffers -- )
+ [ length ] [ >uint-array ] bi alSourceQueueBuffers ;
+
+: queue-buffer ( source buffer -- )
+ 1array queue-buffers ;
+
+: set-source-param ( source param value -- )
+ alSourcei ;
+
+: get-source-param ( source param -- value )
+ 0 <uint> dup [ alGetSourcei ] dip *uint ;
+
+: set-buffer-param ( source param value -- )
+ alBufferi ;
+
+: get-buffer-param ( source param -- value )
+ 0 <uint> dup [ alGetBufferi ] dip *uint ;
+
+: source-play ( source -- ) alSourcePlay ;
+
+: source-stop ( source -- ) alSourceStop ;
+
+: check-error ( -- )
+ alGetError dup ALUT_ERROR_NO_ERROR = [
+ drop
+ ] [
+ alGetString throw
+ ] if ;
+
+: source-playing? ( source -- bool )
+ AL_SOURCE_STATE get-source-param AL_PLAYING = ;
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax combinators generalizations
+kernel openal.backend ;
+IN: openal.other
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
+
+M: object load-wav-file ( filename -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ 0 <char> alutLoadWAVFile ] 4 nkeep
+ { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
--- /dev/null
+OpenAL 3D audio library binding
--- /dev/null
+bindings
+audio
over empty? [
2drop nil
] [
- quot>> [ unclip-slice dup ] dip call
+ quot>> [ unclip-slice dup ] dip call( char -- ? )
[ swap <parse-results> ] [ 2drop nil ] if
] if ;
: range ( r from to -- n )
over - 1 + rot [
-rot [ over + pick call drop ] each 2drop f
- ] bshift 2nip ;
+ ] bshift 2nip ; inline
[ 55 ] [
0 sum set
USING: kernel continuations arrays sequences quotations ;
: breset ( quot -- )
- [ 1array swap keep first continue-with ] callcc1 nip ;
+ [ 1array swap keep first continue-with ] callcc1 nip ; inline
: (bshift) ( v r k -- obj )
[ dup first -rot ] dip
: parse* ( parser -- ast )
compile
- [ execute [ error-stack get first throw ] unless* ] with-global-lexer
+ [ execute( -- result ) [ error-stack get first throw ] unless* ] with-global-lexer
ast>> ;
: create-bnf ( name parser -- )
: euler011 ( -- answer )
[
{ [ horizontal ] [ vertical ] [ diagonal/ ] [ diagonal\ ] }
- [ call 4 max-product , ] each
+ [ call( -- matrix ) 4 max-product , ] each
] { } make supremum ;
! [ euler011 ] 100 ave-time
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
- } 15 [ 1+ cut swap ] map nip ;
+ } 15 iota [ 1+ cut swap ] map nip ;
PRIVATE>
<PRIVATE
: source-032 ( -- seq )
- 9 factorial [ 9 permutation [ 1+ ] map 10 digits>integer ] map ;
+ 9 factorial iota [
+ 9 permutation [ 1+ ] map 10 digits>integer
+ ] map ;
: 1and4 ( n -- ? )
number>string 1 cut-slice 4 cut-slice
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
- 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
+ 0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
m [| x |
x 1+ [| y |
- m x - [| z |
+ m x - iota [| z |
x z + table nth-unsafe
[ y z + 1+ swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
[ ]
if ;
-METHOD: expand { factor-expr } expr>> eval unparse ;
+METHOD: expand { factor-expr } expr>> eval>string ;
DEFER: expansion
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run-sword ( basic-expr -- )
- command>> expansion unclip "shell" lookup execute ;
+ command>> expansion unclip "shell" lookup execute( arguments -- ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+Alex Chapman
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged specialized-arrays.uchar specialized-arrays.short ;
+IN: synth.buffers
+
+TUPLE: buffer sample-freq 8bit? id ;
+
+: <buffer> ( sample-freq 8bit? -- buffer )
+ f buffer boa ;
+
+TUPLE: mono-buffer < buffer data ;
+
+: <mono-buffer> ( sample-freq 8bit? -- buffer )
+ f f mono-buffer boa ;
+
+: <8bit-mono-buffer> ( sample-freq -- buffer ) t <mono-buffer> ;
+: <16bit-mono-buffer> ( sample-freq -- buffer ) f <mono-buffer> ;
+
+TUPLE: stereo-buffer < buffer left-data right-data ;
+
+: <stereo-buffer> ( sample-freq 8bit? -- buffer )
+ f f f stereo-buffer boa ;
+
+: <8bit-stereo-buffer> ( sample-freq -- buffer ) t <stereo-buffer> ;
+: <16bit-stereo-buffer> ( sample-freq -- buffer ) f <stereo-buffer> ;
+
+PREDICATE: 8bit-buffer < buffer 8bit?>> ;
+PREDICATE: 16bit-buffer < buffer 8bit?>> not ;
+INTERSECTION: 8bit-mono-buffer 8bit-buffer mono-buffer ;
+INTERSECTION: 16bit-mono-buffer 16bit-buffer mono-buffer ;
+INTERSECTION: 8bit-stereo-buffer 8bit-buffer stereo-buffer ;
+INTERSECTION: 16bit-stereo-buffer 16bit-buffer stereo-buffer ;
+
+GENERIC: buffer-format ( buffer -- format )
+M: 8bit-mono-buffer buffer-format drop AL_FORMAT_MONO8 ;
+M: 16bit-mono-buffer buffer-format drop AL_FORMAT_MONO16 ;
+M: 8bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO8 ;
+M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ;
+
+: 8bit-buffer-data ( seq -- data size )
+ [ 128 * >integer 128 + ] uchar-array{ } map-as [ underlying>> ] [ length ] bi ;
+
+: 16bit-buffer-data ( seq -- data size )
+ [ 32768 * >integer ] short-array{ } map-as [ underlying>> ] [ byte-length ] bi ;
+
+: stereo-data ( stereo-buffer -- left right )
+ [ left-data>> ] [ right-data>> ] bi@ ;
+
+: interleaved-stereo-data ( stereo-buffer -- data )
+ stereo-data <2merged> ;
+
+GENERIC: buffer-data ( buffer -- data size )
+M: 8bit-mono-buffer buffer-data data>> 8bit-buffer-data ;
+M: 16bit-mono-buffer buffer-data data>> 16bit-buffer-data ;
+M: 8bit-stereo-buffer buffer-data
+ interleaved-stereo-data 8bit-buffer-data ;
+M: 16bit-stereo-buffer buffer-data
+ interleaved-stereo-data 16bit-buffer-data ;
+
+: telephone-sample-freq ( -- n ) 8000 ;
+: half-sample-freq ( -- n ) 22050 ;
+: cd-sample-freq ( -- n ) 44100 ;
+: digital-sample-freq ( -- n ) 48000 ;
+: professional-sample-freq ( -- n ) 88200 ;
+
+: send-buffer ( buffer -- buffer )
+ {
+ [ gen-buffer dup [ >>id ] dip ]
+ [ buffer-format ]
+ [ buffer-data ]
+ [ sample-freq>> alBufferData ]
+ } cleave ;
+
+: ?send-buffer ( buffer -- buffer )
+ dup id>> [ send-buffer ] unless ;
+
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel namespaces make openal sequences
+synth synth.buffers ;
+IN: synth.example
+
+: play-sine-wave ( freq seconds sample-freq -- )
+ init-openal
+ <16bit-mono-buffer> >sine-wave-buffer send-buffer id>>
+ 1 gen-sources first
+ [ AL_BUFFER rot set-source-param ] [ source-play ] bi
+ check-error ;
+
+: test-instrument1 ( -- harmonics )
+ [
+ 1 0.5 <harmonic> ,
+ 2 0.125 <harmonic> ,
+ 3 0.0625 <harmonic> ,
+ 4 0.03125 <harmonic> ,
+ ] { } make ;
+
+: test-instrument2 ( -- harmonics )
+ [
+ 1 0.25 <harmonic> ,
+ 2 0.25 <harmonic> ,
+ 3 0.25 <harmonic> ,
+ 4 0.25 <harmonic> ,
+ ] { } make ;
+
+: sine-instrument ( -- harmonics )
+ 1 1 <harmonic> 1array ;
+
+: test-note-buffer ( note -- )
+ init-openal
+ test-instrument2 swap cd-sample-freq <16bit-mono-buffer>
+ >note send-buffer id>>
+ 1 gen-sources first [ swap queue-buffer ] [ source-play ] bi
+ check-error ;
--- /dev/null
+Simple sound synthesis using OpenAL.
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
+IN: synth
+
+MEMO: single-sine-wave ( samples/wave -- seq )
+ pi 2 * over / [ * sin ] curry map ;
+
+: (sine-wave) ( samples/wave n-samples -- seq )
+ [ single-sine-wave ] dip <repeating> ;
+
+: sine-wave ( sample-freq freq seconds -- seq )
+ pick * >integer [ /i ] dip (sine-wave) ;
+
+: >sine-wave-buffer ( freq seconds buffer -- buffer )
+ [ sample-freq>> -rot sine-wave ] keep swap >>data ;
+
+: >silent-buffer ( seconds buffer -- buffer )
+ tuck sample-freq>> * >integer 0 <repetition> >>data ;
+
+TUPLE: harmonic n amplitude ;
+C: <harmonic> harmonic
+
+TUPLE: note hz secs ;
+C: <note> note
+
+: harmonic-freq ( note harmonic -- freq )
+ n>> swap hz>> * ;
+
+:: note-harmonic-data ( harmonic note buffer -- data )
+ buffer sample-freq>> note harmonic harmonic-freq note secs>> sine-wave
+ harmonic amplitude>> <scaled> ;
+
+: >note ( harmonics note buffer -- buffer )
+ dup -roll [ note-harmonic-data ] 2curry map <summed> >>data ;
+
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.files io.files.links io.directories
io.pathnames io.streams.string kernel math math.parser
continuations namespaces pack prettyprint sequences strings
system tools.hexdump io.encodings.binary summary accessors
-io.backend byte-arrays ;
+io.backend byte-arrays io.streams.byte-array splitting ;
IN: tar
CONSTANT: zero-checksum 256
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-ERROR: checksum-error ;
-SYMBOLS: base-dir filename ;
+ERROR: checksum-error ;
-: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
+: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
-: read-c-string* ( n -- str/f )
+: read-c-string ( n -- str/f )
read [ zero? ] trim-tail [ f ] when-empty ;
: read-tar-header ( -- obj )
\ tar-header new
- 100 read-c-string* >>name
- 8 read-c-string* tar-trim oct> >>mode
- 8 read-c-string* tar-trim oct> >>uid
- 8 read-c-string* tar-trim oct> >>gid
- 12 read-c-string* tar-trim oct> >>size
- 12 read-c-string* tar-trim oct> >>mtime
- 8 read-c-string* tar-trim oct> >>checksum
- read1 >>typeflag
- 100 read-c-string* >>linkname
- 6 read >>magic
- 2 read >>version
- 32 read-c-string* >>uname
- 32 read-c-string* >>gname
- 8 read tar-trim oct> >>devmajor
- 8 read tar-trim oct> >>devminor
- 155 read-c-string* >>prefix ;
-
-: header-checksum ( seq -- x )
- 148 cut-slice 8 tail-slice
- [ sum ] bi@ + 256 + ;
+ 100 read-c-string >>name
+ 8 read-c-string trim-string oct> >>mode
+ 8 read-c-string trim-string oct> >>uid
+ 8 read-c-string trim-string oct> >>gid
+ 12 read-c-string trim-string oct> >>size
+ 12 read-c-string trim-string oct> >>mtime
+ 8 read-c-string trim-string oct> >>checksum
+ read1 >>typeflag
+ 100 read-c-string >>linkname
+ 6 read >>magic
+ 2 read >>version
+ 32 read-c-string >>uname
+ 32 read-c-string >>gname
+ 8 read trim-string oct> >>devmajor
+ 8 read trim-string oct> >>devminor
+ 155 read-c-string >>prefix ;
+
+: checksum-header ( seq -- n )
+ 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
: read-data-blocks ( tar-header -- )
dup size>> 0 > [
] if ;
: parse-tar-header ( seq -- obj )
- [ header-checksum ] keep over zero-checksum = [
+ [ checksum-header ] keep over zero-checksum = [
2drop
\ tar-header new
0 >>size
0 >>checksum
] [
- [ read-tar-header ] with-string-reader
+ binary [ read-tar-header ] with-byte-reader
[ checksum>> = [ checksum-error ] unless ] keep
] if ;
ERROR: unknown-typeflag ch ;
-M: unknown-typeflag summary ( obj -- str )
- ch>> 1string "Unknown typeflag: " prepend ;
-: tar-prepend-path ( path -- newpath )
- base-dir get prepend-path ;
+M: unknown-typeflag summary ( obj -- str )
+ ch>> [ "Unknown typeflag: " ] dip prefix ;
: read/write-blocks ( tar-header path -- )
binary [ read-data-blocks ] with-file-writer ;
+: prepend-current-directory ( path -- path' )
+ current-directory get prepend-path ;
+
! Normal file
: typeflag-0 ( header -- )
- dup name>> tar-prepend-path read/write-blocks ;
+ dup name>> dup "global_pax_header" = [
+ drop [ read-data-blocks ] with-string-writer drop
+ ] [
+ prepend-current-directory read/write-blocks
+ ] if ;
! Hard link
: typeflag-1 ( header -- ) unknown-typeflag ;
! Directory
: typeflag-5 ( header -- )
- name>> tar-prepend-path make-directories ;
+ name>> prepend-current-directory make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
drop ;
! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] trim-tail filename set
- ! filename get tar-prepend-path make-directories ;
+ ! filename get prepend-current-directory make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
: typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- )
- block-size read dup length 512 = [
+ block-size read dup length block-size = [
parse-tar-header
dup typeflag>>
{
drop
] if ;
-: parse-tar ( path -- )
- normalize-path dup parent-directory base-dir [
+: untar ( path -- )
+ normalize-path [ ] [ parent-directory ] bi [
binary [ (parse-tar) ] with-file-reader
- ] with-variable ;
+ ] with-directory ;
: invoke-value-action ( list -- )
dup list-empty? [
- dup hook>> call
+ dup hook>> call( list -- )
] [
[ index>> ] keep nth-gadget invoke-secondary
] if ;
dup class
{
{ \ string [ ] }
- { \ quotation [ call ] }
- { \ word [ execute ] }
+ { \ quotation [ call( -- string ) ] }
+ { \ word [ execute( -- string ) ] }
{ \ fixnum [ number>string ] }
{ \ array [ to-strings concat ] }
}
: <counter-app> ( -- responder )
counter-app new-dispatcher
- [ 1+ ] <counter-action> "inc" add-responder
- [ 1- ] <counter-action> "dec" add-responder
+ [ 1 + ] <counter-action> "inc" add-responder
+ [ 1 - ] <counter-action> "dec" add-responder
<display-action> "" add-responder ;
! Deployment example
main-responder set-global
M: site-watcher-app init-user-profile
- drop B
- "username" value "email" value <account> insert-tuple ;
+ drop "username" value "email" value <account> insert-tuple ;
: init-db ( -- )
site-watcher-db [
{ site-watcher-app "spider-list" } >>template
[
! Silly query
- username B spidering-sites [ site>> ] map
+ username spidering-sites [ site>> ] map
"sites" set-value
] >>init
<protected>
swap [ * - ] keep 2array ;
: change-global ( variable quot -- )
- global swap change-at ;
+ global swap change-at ; inline
: (correct-for-timing-overhead) ( timingshash -- timingshash )
time-dummy-word [ subtract-overhead ] curry assoc-map ;
correct-for-timing-overhead
"total time:" write
] dip pprint nl
- print-word-timings nl ;
+ print-word-timings nl ; inline
: profile-vocab ( vocab quot -- )
"annotating vocab..." print flush
correct-for-timing-overhead
"total time:" write
] dip pprint
- print-word-timings ;
+ print-word-timings ; inline
--- /dev/null
+IN: advice
+USING: help.markup help.syntax tools.annotations words coroutines ;
+
+HELP: make-advised
+{ $values { "word" "a word to annotate in preparation of advising" } }
+{ $description "Prepares a word for being advised. This is done by: "
+ { $list
+ { "Annotating it to call the appropriate words before, around, and after the original body " }
+ { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
+ { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
+ }
+}
+{ $see-also advised? annotate } ;
+
+HELP: advised?
+{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
+{ $description "Determines whether or not the given word has any advice on it." } ;
+
+HELP: ad-do-it
+{ $values { "input" "an object" } { "result" "an object" } }
+{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
+{ $see-also coyield } ;
+
+ARTICLE: "advice" "Advice"
+"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
+
+ABOUT: "advice"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences io io.streams.string math tools.test advice math.parser
+parser namespaces multiline eval words assocs ;
+IN: advice.tests
+
+[
+ [ ad-do-it ] must-fail
+
+ : foo ( -- str ) "foo" ;
+ \ foo make-advised
+
+ { "bar" "foo" } [
+ [ "bar" ] "barify" \ foo advise-before
+ foo
+ ] unit-test
+
+ { "bar" "foo" "baz" } [
+ [ "baz" ] "bazify" \ foo advise-after
+ foo
+ ] unit-test
+
+ { "foo" "baz" } [
+ "barify" \ foo before remove-advice
+ foo
+ ] unit-test
+
+ : bar ( a -- b ) 1 + ;
+ \ bar make-advised
+
+ { 11 } [
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
+ ] unit-test
+
+ { 11/3 } [
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
+ ] unit-test
+
+ { -2 } [
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
+ ] unit-test
+
+ : add ( a b -- c ) + ;
+ \ add make-advised
+
+ { 10 } [
+ [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+ 2 3 add
+ ] unit-test
+
+ { 21 } [
+ [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+ 2 3 add
+ ] unit-test
+
+! { 9 } [
+! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+! 2 3 add
+! ] unit-test
+
+! { { "around1" "around2" } } [
+! \ add around word-prop keys
+! ] unit-test
+
+ { 5 f } [
+ \ add unadvise
+ 2 3 add \ add advised?
+ ] unit-test
+
+! : quux ( a b -- c ) * ;
+
+! { f t 3+3/4 } [
+! <" USING: advice kernel math ;
+! IN: advice.tests
+! \ quux advised?
+! ADVISE: quux halve before [ 2 / ] bi@ ;
+! \ quux advised?
+! 3 5 quux"> eval
+! ] unit-test
+
+! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+! <" USING: advice kernel math math.parser io io.streams.string ;
+! IN: advice.tests
+! ADVISE: quux log around
+! 2dup [ number>string write " " write ] bi@
+! ad-do-it
+! dup number>string write ;
+! [ 3 5 quux ] with-string-writer"> eval
+! ] unit-test
+
+] with-scope
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences fry words assocs linked-assocs tools.annotations
+coroutines lexer parser quotations arrays namespaces continuations
+summary ;
+IN: advice
+
+SYMBOLS: before after around advised in-advice? ;
+
+: advised? ( word -- ? )
+ advised word-prop ;
+
+DEFER: make-advised
+
+<PRIVATE
+: init-around-co ( quot -- coroutine )
+ \ coreset suffix cocreate ;
+PRIVATE>
+
+: advise ( quot name word loc -- )
+ dup around eq? [ [ init-around-co ] 3dip ] when
+ over advised? [ over make-advised ] unless
+ word-prop set-at ;
+
+: advise-before ( quot name word -- ) before advise ;
+
+: advise-after ( quot name word -- ) after advise ;
+
+: advise-around ( quot name word -- ) around advise ;
+
+: get-advice ( word type -- seq )
+ word-prop values ;
+
+: call-before ( word -- )
+ before get-advice [ call ] each ;
+
+: call-after ( word -- )
+ after get-advice [ call ] each ;
+
+: call-around ( main word -- )
+ t in-advice? [
+ around get-advice tuck
+ [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
+ ] with-variable ;
+
+: remove-advice ( name word loc -- )
+ word-prop delete-at ;
+
+ERROR: ad-do-it-error ;
+
+M: ad-do-it-error summary
+ drop "ad-do-it should only be called inside 'around' advice" ;
+
+: ad-do-it ( input -- result )
+ in-advice? get [ ad-do-it-error ] unless coyield ;
+
+: make-advised ( word -- )
+ [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
+ [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
+ [ t advised set-word-prop ] tri ;
+
+: unadvise ( word -- )
+ [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
+
+SYNTAX: ADVISE: ! word adname location => word adname quot loc
+ scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
+
+SYNTAX: UNADVISE:
+ scan-word parsed \ unadvise parsed ;
--- /dev/null
+James Cash
--- /dev/null
+Implmentation of advice/aspects
--- /dev/null
+extensions
--- /dev/null
+William Schlieper
--- /dev/null
+! See http://factorcode.org/license.txt for BSD licence.
+USING: help.markup help.syntax ;
+
+IN: graph-theory
+
+ARTICLE: "graph-protocol" "Graph protocol"
+"All graphs must be instances of the graph mixin:"
+{ $subsection graph }
+"All graphs must implement a method on the following generic word:"
+{ $subsection vertices }
+"At least one of the following two generic words must have a method; the " { $link graph } " mixin has default definitions which are mutually recursive:"
+{ $subsection adjlist }
+{ $subsection adj? }
+"All mutable graphs must implement a method on the following generic word:"
+{ $subsection add-blank-vertex }
+"All mutable undirected graphs must implement a method on the following generic word:"
+{ $subsection add-edge }
+"Mutable directed graphs should not implement the above word, as it has a default definition defined in terms of the following generic word:"
+{ $subsection add-edge* }
+"The following two words have default definitions, but are available as generics to allow implementations to optimize them:"
+{ $subsection num-vertices }
+{ $subsection num-edges } ;
+
+HELP: graph
+{ $class-description "A mixin class whose instances are graphs. Custom implementations of the graph protocol should be declared as instances of this mixin for all graph functionality to work correctly:"
+ { $code "INSTANCE: hex-board graph" }
+} ;
+
+{ vertices num-vertices num-edges } related-words
+
+HELP: vertices
+{ $values { "graph" graph } { "seq" "The vertices" } }
+{ $description "Returns the vertices of the graph." } ;
+
+HELP: num-vertices
+{ $values { "graph" graph } { "n" "The number of vertices" } }
+{ $description "Returns the number of vertices in the graph." } ;
+
+HELP: num-edges
+{ $values { "graph" "A graph" } { "n" "The number of edges" } }
+{ $description "Returns the number of edges in the graph." } ;
+
+{ adjlist adj? } related-words
+
+HELP: adjlist
+{ $values
+ { "from" "The index of a vertex" }
+ { "graph" "The graph to be examined" }
+ { "seq" "The adjacency list" } }
+{ $description "Returns a sequence of vertices that this vertex links to" } ;
+
+HELP: adj?
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of a vertex" }
+ { "graph" "A graph" }
+ { "?" "A boolean" } }
+{ $description "Returns a boolean describing whether there is an edge in the graph between from and to." } ;
+
+{ add-blank-vertex add-blank-vertices add-edge add-edge* } related-words
+
+HELP: add-blank-vertex
+{ $values
+ { "index" "A vertex index" }
+ { "graph" "A graph" } }
+{ $description "Adds a vertex to the graph." } ;
+
+HELP: add-blank-vertices
+{ $values
+ { "seq" "A sequence of vertex indices" }
+ { "graph" "A graph" } }
+{ $description "Adds vertices with indices in seq to the graph." } ;
+
+HELP: add-edge*
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a one-way edge to the graph, between " { $snippet "from" } " and " { $snippet "to" } "."
+ $nl
+ "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
+
+HELP: add-edge
+{ $values
+ { "u" "The index of a vertex" }
+ { "v" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
+ $nl
+ "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;
+
+{ depth-first full-depth-first dag? topological-sort } related-words
+
+HELP: depth-first
+{ $values
+ { "v" "The vertex to start the search at" }
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "?list" "A list of booleans describing the vertices visited in the search" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } " can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ { $emphasis "?list" } " is a list of booleans, " { $link t } " for every vertex visted during the search, and " { $link f } " for every vertex not visited." } ;
+
+HELP: full-depth-first
+{ $values
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "tail" "A quotation of the form ( -- )" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } "can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "tail" } " quotation is run after each time the depth-first search runs out of nodes. On an undirected graph this will be each connected subgroup but on a directed graph it can be more complex." } ;
+
+HELP: dag?
+{ $values
+ { "graph" graph }
+ { "?" "A boolean indicating if the graph is acyclic" } }
+{ $description "Using a depth-first search, determines if the specified directed graph is a directed acyclic graph. An undirected graph will produce a false result, as the algorithm does not eliminate cycles of length 2, which will include any edge that goes both ways." } ;
+
+HELP: topological-sort
+{ $values
+ { "graph" graph }
+ { "seq/f" "Either a sequence of values or f" } }
+{ $description "Using a depth-first search, topologically sorts the specified directed graph. Returns f if the graph contains any cycles, and a topologically sorted sequence otherwise." } ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel combinators fry continuations sequences arrays
+vectors assocs hashtables heaps namespaces ;
+IN: graph-theory
+
+MIXIN: graph
+SYMBOL: visited?
+ERROR: end-search ;
+
+GENERIC: vertices ( graph -- seq ) flushable
+
+GENERIC: num-vertices ( graph -- n ) flushable
+
+GENERIC: num-edges ( graph -- n ) flushable
+
+GENERIC: adjlist ( from graph -- seq ) flushable
+
+GENERIC: adj? ( from to graph -- ? ) flushable
+
+GENERIC: add-blank-vertex ( index graph -- )
+
+GENERIC: delete-blank-vertex ( index graph -- )
+
+GENERIC: add-edge* ( from to graph -- )
+
+GENERIC: add-edge ( u v graph -- )
+
+GENERIC: delete-edge* ( from to graph -- )
+
+GENERIC: delete-edge ( u v graph -- )
+
+M: graph num-vertices
+ vertices length ;
+
+M: graph num-edges
+ [ vertices ] [ '[ _ adjlist length ] sigma ] bi ;
+
+M: graph adjlist
+ [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
+
+M: graph adj?
+ swapd adjlist index >boolean ;
+
+M: graph add-edge
+ [ add-edge* ] [ swapd add-edge* ] 3bi ;
+
+M: graph delete-edge
+ [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
+
+: add-blank-vertices ( seq graph -- )
+ '[ _ add-blank-vertex ] each ;
+
+: delete-vertex ( index graph -- )
+ [ adjlist ]
+ [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
+ [ delete-blank-vertex ] 2tri ;
+
+<PRIVATE
+
+: search-wrap ( quot graph -- ? )
+ [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
+ [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
+
+: (depth-first) ( v pre post -- )
+ { [ 2drop visited? get t -rot set-at ]
+ [ drop call ]
+ [ [ graph get adjlist ] 2dip
+ '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
+ [ nip call ] } 3cleave ; inline
+
+PRIVATE>
+
+: depth-first ( v graph pre post -- ?list ? )
+ '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
+
+: full-depth-first ( graph pre post tail -- ? )
+ '[ [ visited? get [ nip not ] assoc-find ]
+ [ drop _ _ (depth-first) @ ]
+ while 2drop ] swap search-wrap ; inline
+
+: dag? ( graph -- ? )
+ V{ } clone swap [ 2dup swap push dupd
+ '[ _ swap graph get adj? not ] all?
+ [ end-search ] unless ]
+ [ drop dup pop* ] [ ] full-depth-first nip ;
+
+: topological-sort ( graph -- seq/f )
+ dup dag?
+ [ V{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
+ [ drop f ] if ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel graph-theory ;
+
+IN: graph-theory.reversals
+
+TUPLE: reversal graph ;
+
+GENERIC: reverse-graph ( graph -- reversal )
+
+M: graph reverse-graph reversal boa ;
+
+M: reversal reverse-graph graph>> ;
+
+INSTANCE: reversal graph
+
+M: reversal vertices
+ graph>> vertices ;
+
+M: reversal adj?
+ swapd graph>> adj? ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel sequences arrays vectors sets assocs hashtables graph-theory namespaces fry ;
+
+IN: graph-theory.sparse
+
+TUPLE: sparse-graph alist ;
+
+: <sparse-graph> ( -- sparse-graph )
+ H{ } clone sparse-graph boa ;
+
+: >sparse-graph ( graph -- sparse-graph )
+ [ vertices ] keep
+ '[ dup _ adjlist 2array ] map >hashtable sparse-graph boa ;
+
+INSTANCE: sparse-graph graph
+
+M: sparse-graph vertices
+ alist>> keys ;
+
+M: sparse-graph adjlist
+ alist>> at ;
+
+M: sparse-graph add-blank-vertex
+ alist>> V{ } clone -rot set-at ;
+
+M: sparse-graph delete-blank-vertex
+ alist>> delete-at ;
+
+M: sparse-graph add-edge*
+ alist>> swapd at adjoin ;
+
+M: sparse-graph delete-edge*
+ alist>> swapd at delete ;
--- /dev/null
+Graph-theoretic algorithms
--- /dev/null
+collections
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
-IN: morse
-
-HELP: ch>morse
-{ $values
- { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
-{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
-
-HELP: morse>ch
-{ $values
- { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
-{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
-
-HELP: >morse
-{ $values
- { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } }
-{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." }
-{ $see-also morse> ch>morse } ;
-
-HELP: morse>
-{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } }
-{ $description "Translates morse code into ASCII text" }
-{ $see-also >morse morse>ch } ;
-
-HELP: play-as-morse*
-{ $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } }
-{ $description "Plays a string as morse code" } ;
-
-HELP: play-as-morse
-{ $values { "str" "A string of ascii characters which can be translated into morse code" } }
-{ $description "Plays a string as morse code" } ;
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays morse strings tools.test ;
-
-[ "" ] [ CHAR: \\ ch>morse ] unit-test
-[ "..." ] [ CHAR: s ch>morse ] unit-test
-[ CHAR: s ] [ "..." morse>ch ] unit-test
-[ f ] [ "..--..--.." morse>ch ] unit-test
-[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
-[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
-[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
-! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
-! [ ] [ "Factor rocks!" play-as-morse ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lists math
-namespaces make openal parser-combinators promises sequences
-strings symbols synth synth.buffers unicode.case ;
-IN: morse
-
-<PRIVATE
-: morse-codes ( -- array )
- {
- { CHAR: a ".-" }
- { CHAR: b "-..." }
- { CHAR: c "-.-." }
- { CHAR: d "-.." }
- { CHAR: e "." }
- { CHAR: f "..-." }
- { CHAR: g "--." }
- { CHAR: h "...." }
- { CHAR: i ".." }
- { CHAR: j ".---" }
- { CHAR: k "-.-" }
- { CHAR: l ".-.." }
- { CHAR: m "--" }
- { CHAR: n "-." }
- { CHAR: o "---" }
- { CHAR: p ".--." }
- { CHAR: q "--.-" }
- { CHAR: r ".-." }
- { CHAR: s "..." }
- { CHAR: t "-" }
- { CHAR: u "..-" }
- { CHAR: v "...-" }
- { CHAR: w ".--" }
- { CHAR: x "-..-" }
- { CHAR: y "-.--" }
- { CHAR: z "--.." }
- { CHAR: 1 ".----" }
- { CHAR: 2 "..---" }
- { CHAR: 3 "...--" }
- { CHAR: 4 "....-" }
- { CHAR: 5 "....." }
- { CHAR: 6 "-...." }
- { CHAR: 7 "--..." }
- { CHAR: 8 "---.." }
- { CHAR: 9 "----." }
- { CHAR: 0 "-----" }
- { CHAR: . ".-.-.-" }
- { CHAR: , "--..--" }
- { CHAR: ? "..--.." }
- { CHAR: ' ".----." }
- { CHAR: ! "-.-.--" }
- { CHAR: / "-..-." }
- { CHAR: ( "-.--." }
- { CHAR: ) "-.--.-" }
- { CHAR: & ".-..." }
- { CHAR: : "---..." }
- { CHAR: ; "-.-.-." }
- { CHAR: = "-...- " }
- { CHAR: + ".-.-." }
- { CHAR: - "-....-" }
- { CHAR: _ "..--.-" }
- { CHAR: " ".-..-." }
- { CHAR: $ "...-..-" }
- { CHAR: @ ".--.-." }
- { CHAR: \s "/" }
- } ;
-
-: ch>morse-assoc ( -- assoc )
- morse-codes >hashtable ;
-
-: morse>ch-assoc ( -- assoc )
- morse-codes [ reverse ] map >hashtable ;
-
-PRIVATE>
-
-: ch>morse ( ch -- str )
- ch>lower ch>morse-assoc at* swap "" ? ;
-
-: morse>ch ( str -- ch )
- morse>ch-assoc at* swap f ? ;
-
-: >morse ( str -- str )
- [
- [ CHAR: \s , ] [ ch>morse % ] interleave
- ] "" make ;
-
-<PRIVATE
-
-: dot-char ( -- ch ) CHAR: . ;
-: dash-char ( -- ch ) CHAR: - ;
-: char-gap-char ( -- ch ) CHAR: \s ;
-: word-gap-char ( -- ch ) CHAR: / ;
-
-: =parser ( obj -- parser )
- [ = ] curry satisfy ;
-
-LAZY: 'dot' ( -- parser )
- dot-char =parser ;
-
-LAZY: 'dash' ( -- parser )
- dash-char =parser ;
-
-LAZY: 'char-gap' ( -- parser )
- char-gap-char =parser ;
-
-LAZY: 'word-gap' ( -- parser )
- word-gap-char =parser ;
-
-LAZY: 'morse-char' ( -- parser )
- 'dot' 'dash' <|> <+> ;
-
-LAZY: 'morse-word' ( -- parser )
- 'morse-char' 'char-gap' list-of ;
-
-LAZY: 'morse-words' ( -- parser )
- 'morse-word' 'word-gap' list-of ;
-
-PRIVATE>
-
-: morse> ( str -- str )
- 'morse-words' parse car parsed>> [
- [
- >string morse>ch
- ] map >string
- ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
-
-<PRIVATE
-SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
-
-: queue ( symbol -- )
- get source get swap queue-buffer ;
-
-: dot ( -- ) dot-buffer queue ;
-: dash ( -- ) dash-buffer queue ;
-: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
-: letter-gap ( -- ) letter-gap-buffer queue ;
-
-: beep-freq 880 ;
-
-: <morse-buffer> ( -- buffer )
- half-sample-freq <8bit-mono-buffer> ;
-
-: sine-buffer ( seconds -- id )
- beep-freq swap <morse-buffer> >sine-wave-buffer
- send-buffer id>> ;
-
-: silent-buffer ( seconds -- id )
- <morse-buffer> >silent-buffer send-buffer id>> ;
-
-: make-buffers ( unit-length -- )
- {
- [ sine-buffer dot-buffer set ]
- [ 3 * sine-buffer dash-buffer set ]
- [ silent-buffer intra-char-gap-buffer set ]
- [ 3 * silent-buffer letter-gap-buffer set ]
- } cleave ;
-
-: playing-morse ( quot unit-length -- )
- [
- init-openal 1 gen-sources first source set make-buffers
- call
- source get source-play
- ] with-scope ;
-
-: play-char ( ch -- )
- [ intra-char-gap ] [
- {
- { dot-char [ dot ] }
- { dash-char [ dash ] }
- { word-gap-char [ intra-char-gap ] }
- } case
- ] interleave ;
-
-PRIVATE>
-
-: play-as-morse* ( str unit-length -- )
- [
- [ letter-gap ] [ ch>morse play-char ] interleave
- ] swap playing-morse ;
-
-: play-as-morse ( str -- )
- 0.05 play-as-morse* ;
+++ /dev/null
-Converts between text and morse code, and plays morse code.
+++ /dev/null
-Chris Double
+++ /dev/null
-Chris Double
+++ /dev/null
-USING: namespaces system ;
-IN: openal.backend
-
-HOOK: load-wav-file os ( filename -- format data size frequency )
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-IN: openal.example\r
-USING: openal kernel alien threads sequences calendar ;\r
-\r
-: play-hello ( -- )\r
- init-openal\r
- 1 gen-sources\r
- first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param\r
- source-play\r
- 1000 milliseconds sleep ;\r
- \r
-: (play-file) ( source -- )\r
- 100 milliseconds sleep\r
- dup source-playing? [ (play-file) ] [ drop ] if ;\r
-\r
-: play-file ( filename -- )\r
- init-openal\r
- create-buffer-from-file \r
- 1 gen-sources\r
- first dup >r AL_BUFFER rot set-source-param r>\r
- dup source-play\r
- check-error\r
- (play-file) ;\r
-\r
-: play-wav ( filename -- )\r
- init-openal\r
- create-buffer-from-wav \r
- 1 gen-sources\r
- first dup >r AL_BUFFER rot set-source-param r>\r
- dup source-play\r
- check-error\r
- (play-file) ;
\ No newline at end of file
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel alien alien.syntax shuffle
-combinators.lib openal.backend namespaces system ;
-IN: openal.macosx
-
-LIBRARY: alut
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
-
-M: macosx load-wav-file ( path -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ alutLoadWAVFile ] 4keep
- [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays alien system combinators alien.syntax namespaces
- alien.c-types sequences vocabs.loader shuffle
- openal.backend specialized-arrays.uint ;
-IN: openal
-
-<< "alut" {
- { [ os windows? ] [ "alut.dll" ] }
- { [ os macosx? ] [
- "/System/Library/Frameworks/OpenAL.framework/OpenAL"
- ] }
- { [ os unix? ] [ "libalut.so" ] }
- } cond "cdecl" add-library >>
-
-<< "openal" {
- { [ os windows? ] [ "OpenAL32.dll" ] }
- { [ os macosx? ] [
- "/System/Library/Frameworks/OpenAL.framework/OpenAL"
- ] }
- { [ os unix? ] [ "libopenal.so" ] }
- } cond "cdecl" add-library >>
-
-LIBRARY: openal
-
-TYPEDEF: char ALboolean
-TYPEDEF: char ALchar
-TYPEDEF: char ALbyte
-TYPEDEF: uchar ALubyte
-TYPEDEF: short ALshort
-TYPEDEF: ushort ALushort
-TYPEDEF: int ALint
-TYPEDEF: uint ALuint
-TYPEDEF: int ALsizei
-TYPEDEF: int ALenum
-TYPEDEF: float ALfloat
-TYPEDEF: double ALdouble
-
-CONSTANT: AL_INVALID -1
-CONSTANT: AL_NONE 0
-CONSTANT: AL_FALSE 0
-CONSTANT: AL_TRUE 1
-CONSTANT: AL_SOURCE_RELATIVE HEX: 202
-CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001
-CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002
-CONSTANT: AL_PITCH HEX: 1003
-CONSTANT: AL_POSITION HEX: 1004
-CONSTANT: AL_DIRECTION HEX: 1005
-CONSTANT: AL_VELOCITY HEX: 1006
-CONSTANT: AL_LOOPING HEX: 1007
-CONSTANT: AL_BUFFER HEX: 1009
-CONSTANT: AL_GAIN HEX: 100A
-CONSTANT: AL_MIN_GAIN HEX: 100D
-CONSTANT: AL_MAX_GAIN HEX: 100E
-CONSTANT: AL_ORIENTATION HEX: 100F
-CONSTANT: AL_CHANNEL_MASK HEX: 3000
-CONSTANT: AL_SOURCE_STATE HEX: 1010
-CONSTANT: AL_INITIAL HEX: 1011
-CONSTANT: AL_PLAYING HEX: 1012
-CONSTANT: AL_PAUSED HEX: 1013
-CONSTANT: AL_STOPPED HEX: 1014
-CONSTANT: AL_BUFFERS_QUEUED HEX: 1015
-CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016
-CONSTANT: AL_SEC_OFFSET HEX: 1024
-CONSTANT: AL_SAMPLE_OFFSET HEX: 1025
-CONSTANT: AL_BYTE_OFFSET HEX: 1026
-CONSTANT: AL_SOURCE_TYPE HEX: 1027
-CONSTANT: AL_STATIC HEX: 1028
-CONSTANT: AL_STREAMING HEX: 1029
-CONSTANT: AL_UNDETERMINED HEX: 1030
-CONSTANT: AL_FORMAT_MONO8 HEX: 1100
-CONSTANT: AL_FORMAT_MONO16 HEX: 1101
-CONSTANT: AL_FORMAT_STEREO8 HEX: 1102
-CONSTANT: AL_FORMAT_STEREO16 HEX: 1103
-CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020
-CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021
-CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022
-CONSTANT: AL_MAX_DISTANCE HEX: 1023
-CONSTANT: AL_FREQUENCY HEX: 2001
-CONSTANT: AL_BITS HEX: 2002
-CONSTANT: AL_CHANNELS HEX: 2003
-CONSTANT: AL_SIZE HEX: 2004
-CONSTANT: AL_UNUSED HEX: 2010
-CONSTANT: AL_PENDING HEX: 2011
-CONSTANT: AL_PROCESSED HEX: 2012
-CONSTANT: AL_NO_ERROR AL_FALSE
-CONSTANT: AL_INVALID_NAME HEX: A001
-CONSTANT: AL_ILLEGAL_ENUM HEX: A002
-CONSTANT: AL_INVALID_ENUM HEX: A002
-CONSTANT: AL_INVALID_VALUE HEX: A003
-CONSTANT: AL_ILLEGAL_COMMAND HEX: A004
-CONSTANT: AL_INVALID_OPERATION HEX: A004
-CONSTANT: AL_OUT_OF_MEMORY HEX: A005
-CONSTANT: AL_VENDOR HEX: B001
-CONSTANT: AL_VERSION HEX: B002
-CONSTANT: AL_RENDERER HEX: B003
-CONSTANT: AL_EXTENSIONS HEX: B004
-CONSTANT: AL_DOPPLER_FACTOR HEX: C000
-CONSTANT: AL_DOPPLER_VELOCITY HEX: C001
-CONSTANT: AL_SPEED_OF_SOUND HEX: C003
-CONSTANT: AL_DISTANCE_MODEL HEX: D000
-CONSTANT: AL_INVERSE_DISTANCE HEX: D001
-CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002
-CONSTANT: AL_LINEAR_DISTANCE HEX: D003
-CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004
-CONSTANT: AL_EXPONENT_DISTANCE HEX: D005
-CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006
-
-FUNCTION: void alEnable ( ALenum capability ) ;
-FUNCTION: void alDisable ( ALenum capability ) ;
-FUNCTION: ALboolean alIsEnabled ( ALenum capability ) ;
-FUNCTION: ALchar* alGetString ( ALenum param ) ;
-FUNCTION: void alGetBooleanv ( ALenum param, ALboolean* data ) ;
-FUNCTION: void alGetIntegerv ( ALenum param, ALint* data ) ;
-FUNCTION: void alGetFloatv ( ALenum param, ALfloat* data ) ;
-FUNCTION: void alGetDoublev ( ALenum param, ALdouble* data ) ;
-FUNCTION: ALboolean alGetBoolean ( ALenum param ) ;
-FUNCTION: ALint alGetInteger ( ALenum param ) ;
-FUNCTION: ALfloat alGetFloat ( ALenum param ) ;
-FUNCTION: ALdouble alGetDouble ( ALenum param ) ;
-FUNCTION: ALenum alGetError ( ) ;
-FUNCTION: ALboolean alIsExtensionPresent ( ALchar* extname ) ;
-FUNCTION: void* alGetProcAddress ( ALchar* fname ) ;
-FUNCTION: ALenum alGetEnumValue ( ALchar* ename ) ;
-FUNCTION: void alListenerf ( ALenum param, ALfloat value ) ;
-FUNCTION: void alListener3f ( ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alListenerfv ( ALenum param, ALfloat* values ) ;
-FUNCTION: void alListeneri ( ALenum param, ALint value ) ;
-FUNCTION: void alListener3i ( ALenum param, ALint value1, ALint value2, ALint value3 ) ;
-FUNCTION: void alListeneriv ( ALenum param, ALint* values ) ;
-FUNCTION: void alGetListenerf ( ALenum param, ALfloat* value ) ;
-FUNCTION: void alGetListener3f ( ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3 ) ;
-FUNCTION: void alGetListenerfv ( ALenum param, ALfloat* values ) ;
-FUNCTION: void alGetListeneri ( ALenum param, ALint* value ) ;
-FUNCTION: void alGetListener3i ( ALenum param, ALint* value1, ALint* value2, ALint* value3 ) ;
-FUNCTION: void alGetListeneriv ( ALenum param, ALint* values ) ;
-FUNCTION: void alGenSources ( ALsizei n, ALuint* sources ) ;
-FUNCTION: void alDeleteSources ( ALsizei n, ALuint* sources ) ;
-FUNCTION: ALboolean alIsSource ( ALuint sid ) ;
-FUNCTION: void alSourcef ( ALuint sid, ALenum param, ALfloat value ) ;
-FUNCTION: void alSource3f ( ALuint sid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alSourcei ( ALuint sid, ALenum param, ALint value ) ;
-FUNCTION: void alSource3i ( ALuint sid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
-FUNCTION: void alSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
-FUNCTION: void alGetSourcef ( ALuint sid, ALenum param, ALfloat* value ) ;
-FUNCTION: void alGetSource3f ( ALuint sid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
-FUNCTION: void alGetSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alGetSourcei ( ALuint sid, ALenum param, ALint* value ) ;
-FUNCTION: void alGetSource3i ( ALuint sid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
-FUNCTION: void alGetSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
-FUNCTION: void alSourcePlayv ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourceStopv ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourceRewindv ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourcePausev ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourcePlay ( ALuint sid ) ;
-FUNCTION: void alSourceStop ( ALuint sid ) ;
-FUNCTION: void alSourceRewind ( ALuint sid ) ;
-FUNCTION: void alSourcePause ( ALuint sid ) ;
-FUNCTION: void alSourceQueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
-FUNCTION: void alSourceUnqueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
-FUNCTION: void alGenBuffers ( ALsizei n, ALuint* buffers ) ;
-FUNCTION: void alDeleteBuffers ( ALsizei n, ALuint* buffers ) ;
-FUNCTION: ALboolean alIsBuffer ( ALuint bid ) ;
-FUNCTION: void alBufferData ( ALuint bid, ALenum format, void* data, ALsizei size, ALsizei freq ) ;
-FUNCTION: void alBufferf ( ALuint bid, ALenum param, ALfloat value ) ;
-FUNCTION: void alBuffer3f ( ALuint bid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alBufferi ( ALuint bid, ALenum param, ALint value ) ;
-FUNCTION: void alBuffer3i ( ALuint bid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
-FUNCTION: void alBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
-FUNCTION: void alGetBufferf ( ALuint bid, ALenum param, ALfloat* value ) ;
-FUNCTION: void alGetBuffer3f ( ALuint bid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
-FUNCTION: void alGetBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alGetBufferi ( ALuint bid, ALenum param, ALint* value ) ;
-FUNCTION: void alGetBuffer3i ( ALuint bid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
-FUNCTION: void alGetBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
-FUNCTION: void alDopplerFactor ( ALfloat value ) ;
-FUNCTION: void alDopplerVelocity ( ALfloat value ) ;
-FUNCTION: void alSpeedOfSound ( ALfloat value ) ;
-FUNCTION: void alDistanceModel ( ALenum distanceModel ) ;
-
-LIBRARY: alut
-
-CONSTANT: ALUT_API_MAJOR_VERSION 1
-CONSTANT: ALUT_API_MINOR_VERSION 1
-CONSTANT: ALUT_ERROR_NO_ERROR 0
-CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
-CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
-CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
-CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
-CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
-CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
-CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
-CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
-CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
-CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
-CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
-CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
-CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
-CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
-CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
-CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
-CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
-CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
-CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
-CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
-CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
-CONSTANT: ALUT_LOADER_BUFFER HEX: 300
-CONSTANT: ALUT_LOADER_MEMORY HEX: 301
-
-FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutExit ( ) ;
-FUNCTION: ALenum alutGetError ( ) ;
-FUNCTION: char* alutGetErrorString ( ALenum error ) ;
-FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
-FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
-FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
-FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
-FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
-FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
-FUNCTION: ALint alutGetMajorVersion ( ) ;
-FUNCTION: ALint alutGetMinorVersion ( ) ;
-FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
-
-FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
-
-SYMBOL: init
-
-: init-openal ( -- )
- init get-global expired? [
- f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
- 1337 <alien> init set-global
- ] when ;
-
-: exit-openal ( -- )
- init get-global expired? [
- alutExit 0 = [ "Could not close OpenAL" throw ] when
- f init set-global
- ] unless ;
-
-: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
-
-: gen-sources ( size -- seq )
- dup <uint-array> 2dup underlying>> alGenSources swap ;
-
-: gen-buffers ( size -- seq )
- dup <uint-array> 2dup underlying>> alGenBuffers swap ;
-
-: gen-buffer ( -- buffer ) 1 gen-buffers first ;
-
-: create-buffer-from-file ( filename -- buffer )
- alutCreateBufferFromFile dup AL_NONE = [
- "create-buffer-from-file failed" throw
- ] when ;
-
-os macosx? "openal.macosx" "openal.other" ? require
-
-: create-buffer-from-wav ( filename -- buffer )
- gen-buffer dup rot load-wav-file
- [ alBufferData ] 4keep alutUnloadWAV ;
-
-: queue-buffers ( source buffers -- )
- [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ;
-
-: queue-buffer ( source buffer -- )
- 1array queue-buffers ;
-
-: set-source-param ( source param value -- )
- alSourcei ;
-
-: get-source-param ( source param -- value )
- 0 <uint> dup [ alGetSourcei ] dip *uint ;
-
-: set-buffer-param ( source param value -- )
- alBufferi ;
-
-: get-buffer-param ( source param -- value )
- 0 <uint> dup [ alGetBufferi ] dip *uint ;
-
-: source-play ( source -- ) alSourcePlay ;
-
-: source-stop ( source -- ) alSourceStop ;
-
-: check-error ( -- )
- alGetError dup ALUT_ERROR_NO_ERROR = [
- drop
- ] [
- alGetString throw
- ] if ;
-
-: source-playing? ( source -- bool )
- AL_SOURCE_STATE get-source-param AL_PLAYING = ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: openal.backend alien.c-types kernel alien alien.syntax
-shuffle combinators.lib ;
-IN: openal.other
-
-LIBRARY: alut
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
-
-M: object load-wav-file ( filename -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ 0 <char> alutLoadWAVFile ] 4keep
- >r >r >r *int r> *void* r> *int r> *int ;
+++ /dev/null
-OpenAL 3D audio library binding
+++ /dev/null
-bindings
-audio
+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged ;
-IN: synth.buffers
-
-TUPLE: buffer sample-freq 8bit? id ;
-
-: <buffer> ( sample-freq 8bit? -- buffer )
- f buffer boa ;
-
-TUPLE: mono-buffer < buffer data ;
-
-: <mono-buffer> ( sample-freq 8bit? -- buffer )
- f f mono-buffer boa ;
-
-: <8bit-mono-buffer> ( sample-freq -- buffer ) t <mono-buffer> ;
-: <16bit-mono-buffer> ( sample-freq -- buffer ) f <mono-buffer> ;
-
-TUPLE: stereo-buffer < buffer left-data right-data ;
-
-: <stereo-buffer> ( sample-freq 8bit? -- buffer )
- f f f stereo-buffer boa ;
-
-: <8bit-stereo-buffer> ( sample-freq -- buffer ) t <stereo-buffer> ;
-: <16bit-stereo-buffer> ( sample-freq -- buffer ) f <stereo-buffer> ;
-
-PREDICATE: 8bit-buffer < buffer 8bit?>> ;
-PREDICATE: 16bit-buffer < buffer 8bit?>> not ;
-INTERSECTION: 8bit-mono-buffer 8bit-buffer mono-buffer ;
-INTERSECTION: 16bit-mono-buffer 16bit-buffer mono-buffer ;
-INTERSECTION: 8bit-stereo-buffer 8bit-buffer stereo-buffer ;
-INTERSECTION: 16bit-stereo-buffer 16bit-buffer stereo-buffer ;
-
-GENERIC: buffer-format ( buffer -- format )
-M: 8bit-mono-buffer buffer-format drop AL_FORMAT_MONO8 ;
-M: 16bit-mono-buffer buffer-format drop AL_FORMAT_MONO16 ;
-M: 8bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO8 ;
-M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ;
-
-: 8bit-buffer-data ( seq -- data size )
- [ 128 * >integer 128 + ] uchar-array{ } map-as [ underlying>> ] [ length ] bi ;
-
-: 16bit-buffer-data ( seq -- data size )
- [ 32768 * >integer ] short-array{ } map-as [ underlying>> ] [ byte-length ] bi ;
-
-: stereo-data ( stereo-buffer -- left right )
- [ left-data>> ] [ right-data>> ] bi@ ;
-
-: interleaved-stereo-data ( stereo-buffer -- data )
- stereo-data <2merged> ;
-
-GENERIC: buffer-data ( buffer -- data size )
-M: 8bit-mono-buffer buffer-data data>> 8bit-buffer-data ;
-M: 16bit-mono-buffer buffer-data data>> 16bit-buffer-data ;
-M: 8bit-stereo-buffer buffer-data
- interleaved-stereo-data 8bit-buffer-data ;
-M: 16bit-stereo-buffer buffer-data
- interleaved-stereo-data 16bit-buffer-data ;
-
-: telephone-sample-freq 8000 ;
-: half-sample-freq 22050 ;
-: cd-sample-freq 44100 ;
-: digital-sample-freq 48000 ;
-: professional-sample-freq 88200 ;
-
-: send-buffer ( buffer -- buffer )
- {
- [ gen-buffer dup [ >>id ] dip ]
- [ buffer-format ]
- [ buffer-data ]
- [ sample-freq>> alBufferData ]
- } cleave ;
-
-: ?send-buffer ( buffer -- buffer )
- dup id>> [ send-buffer ] unless ;
-
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel namespaces make openal sequences
-synth synth.buffers ;
-IN: synth.example
-
-: play-sine-wave ( freq seconds sample-freq -- )
- init-openal
- <16bit-mono-buffer> >sine-wave-buffer send-buffer id>>
- 1 gen-sources first
- [ AL_BUFFER rot set-source-param ] [ source-play ] bi
- check-error ;
-
-: test-instrument1 ( -- harmonics )
- [
- 1 0.5 <harmonic> ,
- 2 0.125 <harmonic> ,
- 3 0.0625 <harmonic> ,
- 4 0.03125 <harmonic> ,
- ] { } make ;
-
-: test-instrument2 ( -- harmonics )
- [
- 1 0.25 <harmonic> ,
- 2 0.25 <harmonic> ,
- 3 0.25 <harmonic> ,
- 4 0.25 <harmonic> ,
- ] { } make ;
-
-: sine-instrument ( -- harmonics )
- 1 1 <harmonic> 1array ;
-
-: test-note-buffer ( note -- )
- init-openal
- test-instrument2 swap cd-sample-freq <16bit-mono-buffer>
- >note send-buffer id>>
- 1 gen-sources first [ swap queue-buffer ] [ source-play ] bi
- check-error ;
+++ /dev/null
-Simple sound synthesis using OpenAL.
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
-IN: synth
-
-MEMO: single-sine-wave ( samples/wave -- seq )
- pi 2 * over / [ * sin ] curry map ;
-
-: (sine-wave) ( samples/wave n-samples -- seq )
- [ single-sine-wave ] dip <repeating> ;
-
-: sine-wave ( sample-freq freq seconds -- seq )
- pick * >integer [ /i ] dip (sine-wave) ;
-
-: >sine-wave-buffer ( freq seconds buffer -- buffer )
- [ sample-freq>> -rot sine-wave ] keep swap >>data ;
-
-: >silent-buffer ( seconds buffer -- buffer )
- tuck sample-freq>> * >integer 0 <repetition> >>data ;
-
-TUPLE: harmonic n amplitude ;
-C: <harmonic> harmonic
-
-TUPLE: note hz secs ;
-C: <note> note
-
-: harmonic-freq ( note harmonic -- freq )
- n>> swap hz>> * ;
-
-:: note-harmonic-data ( harmonic note buffer -- data )
- buffer sample-freq>> note harmonic harmonic-freq note secs>> sine-wave
- harmonic amplitude>> <scaled> ;
-
-: >note ( harmonics note buffer -- buffer )
- dup -roll [ note-harmonic-data ] 2curry map <summed> >>data ;
-
copy_registered_locals();
copy_stack_elements(extra_roots_region,extra_roots);
- save_stacks();
- F_CONTEXT *stacks = stack_chain;
-
- while(stacks)
+ if(!performing_compaction)
{
- copy_stack_elements(stacks->datastack_region,stacks->datastack);
- copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
+ save_stacks();
+ F_CONTEXT *stacks = stack_chain;
+
+ while(stacks)
+ {
+ copy_stack_elements(stacks->datastack_region,stacks->datastack);
+ copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
- copy_handle(&stacks->catchstack_save);
- copy_handle(&stacks->current_callback_save);
+ copy_handle(&stacks->catchstack_save);
+ copy_handle(&stacks->current_callback_save);
- mark_active_blocks(stacks);
+ mark_active_blocks(stacks);
- stacks = stacks->next;
+ stacks = stacks->next;
+ }
}
int i;
F_ZONE *newspace;
bool performing_gc;
+bool performing_compaction;
CELL collecting_gen;
/* if true, we collecting AGING space for the second time, so if it is still
userenv[i] = F;
/* do a full GC + code heap compaction */
+ performing_compaction = true;
compact_code_heap();
+ performing_compaction = false;
UNREGISTER_C_STRING(path);
projects / factor.git / commitdiff