.#*
*.swo
checksums.txt
+*.so
+a.out
a terminal listener.
For X11 support, you need recent development libraries for libc,
-Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
+Pango, X11, and OpenGL. On a Debian-derived Linux distribution
(like Ubuntu), you can use the following line to grab everything:
- sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
+ sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
If your DISPLAY environment variable is set, the UI will start
automatically:
[ resume ] curry instant later drop\r
] "test" suspend drop\r
] unit-test\r
-\r
-\ alarm-thread-loop must-infer\r
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
-\ expand-constants must-infer
-
CONSTANT: xyz 123
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
-! 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 ;
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
[ malformed-base64? ] must-fail-with
-
-\ >base64 must-infer
-\ base64> must-infer
IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
-\ sorted-member? must-infer
-
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
"." write flush
-{ (compile) } compile-unoptimized
+{ compile-word } compile-unoptimized
"." write flush
(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*
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
-\ ' must-infer
-\ write-image must-infer
-
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
-: do-crossref ( -- )
- "Cross-referencing..." print flush
- H{ } clone crossref set-global
- xref-words
- xref-generics
- xref-sources ;
-
: load-components ( -- )
"include" "exclude"
[ get-global " " split harvest ] bi@
(command-line) parse-command-line
- do-crossref
-
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
"stage2: deployment mode" print
] [
"listener" require
+ "debugger" require
+ "tools.errors" require
"none" require
] if
continuations system math.order threads ;
IN: calendar.tests
-\ time+ must-infer
-\ time* must-infer
-\ time- must-infer
-
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
-USING: tools.test kernel ;
+USING: tools.test kernel accessors ;
IN: calendar.format.macros
[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test
: compiled-test-1 ( -- n )
{ [ 1 throw ] [ 2 ] } attempt-all-quots ;
-\ compiled-test-1 must-infer
+\ compiled-test-1 def>> must-infer
[ 2 ] [ compiled-test-1 ] unit-test
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test combinators.smart math kernel ;
+USING: tools.test combinators.smart math kernel accessors ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
: nested-smart-combo-test ( -- array )
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
-\ nested-smart-combo-test must-infer
+\ nested-smart-combo-test def>> must-infer
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
kernel.private math ;
-\ build-cfg must-infer
-
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
- [ build-tree-from-word optimize-tree ] keep build-cfg ;
+ [ build-tree optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers?
USING: compiler.cfg.linear-scan.assignment tools.test ;
IN: compiler.cfg.linear-scan.assignment.tests
-\ assign-registers must-infer
+
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;
-\ build-mr must-infer
+
{ $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:"
+"The " { $link compile-word } " 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" } ")." }
+ { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". 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 } "." }
+ { "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 compile-dependency } "." }
}
"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
{ $values { "word" word } }
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
-HELP: (compile)
+HELP: compile-word
{ $values { "word" word } }
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
SYMBOL: compiled
: queue-compile? ( word -- ? )
+ #! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
[ compiled get key? ]
: queue-compile ( word -- )
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
-: maybe-compile ( word -- )
- dup optimized>> [ drop ] [ queue-compile ] if ;
-
-SYMBOLS: +optimized+ +unoptimized+ ;
-
-: ripple-up ( words -- )
- dup "compiled-status" word-prop +unoptimized+ eq?
- [ usage [ word? ] filter ] [ compiled-usage keys ] if
- [ queue-compile ] each ;
-
-: ripple-up? ( status word -- ? )
- [
- [ nip changed-effects get key? ]
- [ "compiled-status" word-prop eq? not ] 2bi or
- ] keep "compiled-status" word-prop and ;
+: recompile-callers? ( word -- ? )
+ changed-effects get key? ;
-: save-compiled-status ( word status -- )
- [ over ripple-up? [ ripple-up ] [ drop ] if ]
- [ "compiled-status" set-word-prop ]
- 2bi ;
+: recompile-callers ( words -- )
+ #! If a word's stack effect changed, recompile all words that
+ #! have compiled calls to it.
+ dup recompile-callers?
+ [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
: start ( word -- )
"trace-compilation" get [ dup name>> print flush ] when
f swap compiler-error ;
: ignore-error? ( word error -- ? )
+ #! Ignore warnings on inline combinators, macros, and special
+ #! words such as 'call'.
[
{
- [ inline? ]
[ macro? ]
- [ "transform-quot" word-prop ]
- [ "no-compile" word-prop ]
+ [ inline? ]
[ "special" word-prop ]
+ [ "no-compile" word-prop ]
} 1||
] [ error-type +compiler-warning+ eq? ] bi* and ;
-: (fail) ( word -- * )
+: finish ( word -- )
+ #! Recompile callers if the word's stack effect changed, then
+ #! save the word's dependencies so that if they change, the
+ #! word can get recompiled too.
+ [ recompile-callers ]
[ compiled-unxref ]
- [ f swap compiled get set-at ]
- [ +unoptimized+ save-compiled-status ]
- tri
- return ;
+ [
+ dup crossref? [
+ dependencies get
+ generic-dependencies get
+ compiled-xref
+ ] [ drop ] if
+ ] tri ;
+
+: deoptimize-with ( word def -- * )
+ #! If the word failed to infer, compile it with the
+ #! non-optimizing compiler.
+ swap [ finish ] [ compiled get set-at ] bi return ;
-: fail ( word error -- * )
- [ 2dup ignore-error? [ drop f ] when swap compiler-error ] [ drop (fail) ] 2bi ;
+: not-compiled-def ( word error -- def )
+ '[ _ _ not-compiled ] [ ] like ;
+
+: deoptimize ( word error -- * )
+ #! If the error is ignorable, compile the word with the
+ #! non-optimizing compiler, using its definition. Otherwise,
+ #! if the compiler error is not ignorable, use a dummy
+ #! definition from 'not-compiled-def' which throws an error.
+ 2dup ignore-error?
+ [ drop f over def>> ]
+ [ 2dup not-compiled-def ] if
+ [ swap compiler-error ] [ deoptimize-with ] bi-curry* bi ;
: frontend ( word -- nodes )
- dup contains-breakpoints? [ (fail) ] [
- [ build-tree-from-word ] [ fail ] recover optimize-tree
+ #! If the word contains breakpoints, don't optimize it, since
+ #! the walker does not support this.
+ dup contains-breakpoints? [ dup def>> deoptimize-with ] [
+ [ build-tree ] [ deoptimize ] recover optimize-tree
] if ;
+: compile-dependency ( word -- )
+ #! If a word calls an unoptimized word, try to compile the callee.
+ dup optimized>> [ drop ] [ queue-compile ] if ;
+
! Only switch this off for debugging.
SYMBOL: compile-dependencies?
t compile-dependencies? set-global
+: compile-dependencies ( asm -- )
+ compile-dependencies? get
+ [ calls>> [ compile-dependency ] each ] [ drop ] if ;
+
: save-asm ( asm -- )
[ [ code>> ] [ label>> ] bi compiled get set-at ]
- [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
+ [ compile-dependencies ]
bi ;
: backend ( nodes word -- )
save-asm
] each ;
-: finish ( word -- )
- [ +optimized+ save-compiled-status ]
- [ compiled-unxref ]
- [
- dup crossref?
- [
- dependencies get
- generic-dependencies get
- compiled-xref
- ] [ drop ] if
- ] tri ;
-
-: (compile) ( word -- )
+: compile-word ( word -- )
+ #! We return early if the word has breakpoints or if it
+ #! failed to infer.
'[
_ {
[ start ]
] with-return ;
: compile-loop ( deque -- )
- [ (compile) yield-hook get call( -- ) ] slurp-deque ;
+ [ compile-word yield-hook get call( -- ) ] slurp-deque ;
: decompile ( word -- )
- f 2array 1array modify-code-heap ;
+ dup def>> 2array 1array modify-code-heap ;
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
f compiler-impl set-global ;
: recompile-all ( -- )
- forget-errors all-words compile ;
+ all-words compile ;
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 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 } related-words
-
ABOUT: "compiler-errors"
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors source-files.errors kernel namespaces assocs
-tools.errors ;
+USING: accessors source-files.errors kernel namespaces assocs ;
IN: compiler.errors
TUPLE: compiler-error < source-file-error ;
{ 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-errors get-global pick
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
-: compiler-errors. ( type -- )
- errors-of-type values errors. ;
-
-: :errors ( -- ) +compiler-error+ compiler-errors. ;
-
-: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
-
-: :linkage ( -- ) +linkage-error+ compiler-errors. ;
+ERROR: not-compiled word error ;
\ No newline at end of file
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 ] [
+++ /dev/null
-IN: compiler.tests
-USING: words kernel stack-checker alien.strings tools.test
-compiler.units ;
-
-[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test
: lift-loop-tail-test-2 ( -- a b c )
10 [ ] lift-loop-tail-test-1 1 2 3 ;
-\ lift-loop-tail-test-2 must-infer
+\ lift-loop-tail-test-2 def>> must-infer
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
: member-test ( obj -- ? ) { + - * / /i } member? ;
-\ member-test must-infer
-[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test
+\ member-test def>> must-infer
+[ ] [ \ member-test build-tree optimize-tree drop ] unit-test
[ t ] [ \ + member-test ] unit-test
[ f ] [ \ append member-test ] unit-test
dup "a" get { array-capacity } declare >=
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
-\ interval-inference-bug must-infer
+[ t ] [ \ interval-inference-bug optimized>> ] unit-test
[ ] [ 1 "a" set 2 "b" set ] unit-test
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
--- /dev/null
+IN: compiler.tests.redefine0
+USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
+namespaces macros assocs ;
+
+! Test ripple-up behavior
+: test-1 ( -- a ) 3 ;
+: test-2 ( -- ) test-1 ;
+
+[ test-2 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test
+
+{ 0 0 } [ test-1 ] must-infer-as
+
+[ ] [ test-2 ] unit-test
+
+[ ] [
+ [
+ \ test-1 forget
+ \ test-2 forget
+ ] with-compilation-unit
+] unit-test
+
+: test-3 ( a -- ) drop ;
+: test-4 ( -- ) [ 1 2 3 ] test-3 ;
+
+[ ] [ test-4 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test
+
+[ test-4 ] [ not-compiled? ] must-fail-with
+
+[ ] [
+ [
+ \ test-3 forget
+ \ test-4 forget
+ ] with-compilation-unit
+] unit-test
+
+: test-5 ( a -- quot ) ;
+: test-6 ( a -- b ) test-5 ;
+
+[ 31337 ] [ 31337 test-6 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test
+
+[ 31337 test-6 ] [ not-compiled? ] must-fail-with
+
+[ ] [
+ [
+ \ test-5 forget
+ \ test-6 forget
+ ] with-compilation-unit
+] unit-test
+
+GENERIC: test-7 ( a -- b )
+
+M: integer test-7 + ;
+
+: test-8 ( a -- b ) 255 bitand test-7 ;
+
+[ 1 test-7 ] [ not-compiled? ] must-fail-with
+[ 1 test-8 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 USING: macros math kernel ; GENERIC: test-7 ( x y -- z ) : test-8 ( a b -- c ) 255 bitand test-7 ;" eval( -- ) ] unit-test
+
+[ 4 ] [ 1 3 test-7 ] unit-test
+[ 4 ] [ 1 259 test-8 ] unit-test
+
+[ ] [
+ [
+ \ test-7 forget
+ \ test-8 forget
+ ] with-compilation-unit
+] unit-test
+
+! Indirect dependency on an unoptimized word
+: test-9 ( -- ) ;
+<< SYMBOL: quot
+[ test-9 ] quot set-global >>
+MACRO: test-10 ( -- quot ) quot get ;
+: test-11 ( -- ) test-10 ;
+
+[ ] [ test-11 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) 1 ;" eval( -- ) ] unit-test
+
+! test-11 should get recompiled now
+
+[ test-11 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- a ) 1 ;" eval( -- ) ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) ;" eval( -- ) ] unit-test
+
+[ ] [ test-11 ] unit-test
+
+quot global delete-at
+
+[ ] [
+ [
+ \ test-9 forget
+ \ test-10 forget
+ \ test-11 forget
+ \ quot forget
+ ] with-compilation-unit
+] unit-test
\ No newline at end of file
[ 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
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
] with-compilation-unit
] unit-test
-
-! Test ripple-up behavior
-: hey ( -- ) ;
-: there ( -- ) hey ;
-
-[ t ] [ \ hey optimized>> ] unit-test
-[ t ] [ \ there optimized>> ] 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
-[ t ] [ \ there optimized>> ] unit-test
-
-: good ( -- ) ;
-: bad ( -- ) good ;
-: ugly ( -- ) bad ;
-
-[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly optimized>> ] unit-test
-
-[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
-
-[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" (( -- )) eval ] unit-test
-
-[ f ] [ \ good optimized>> ] unit-test
-[ f ] [ \ bad optimized>> ] unit-test
-[ f ] [ \ ugly optimized>> ] unit-test
-
-[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
-
-[ ] [ "IN: compiler.tests : good ( -- ) ;" (( -- )) eval ] unit-test
-
-[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly optimized>> ] unit-test
-
-[ f ] [ \ good compiled-usage assoc-empty? ] 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
--- /dev/null
+IN: compiler.tests.redefine16
+USING: eval tools.test definitions words compiler.units
+quotations stack-checker ;
+
+[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
+
+[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] 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
[
arrays memory vocabs parser eval ;
IN: compiler.tests
-\ (compile) must-infer
-
! Test empty word
[ ] [ [ ] compile-call ] 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>>" (( -- obj )) eval
+ "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
] unit-test
] times
IN: compiler.tree.builder
HELP: build-tree
-{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } }
+{ $values { "word/quot" { $or word quotation } } { "nodes" "a sequence of nodes" } }
{ $description "Attempts to construct tree SSA IR from a quotation." }
{ $notes "This is the first stage of the compiler." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
-HELP: build-tree-with
-{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
-{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." }
-{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
+HELP: build-sub-tree
+{ $values { "#call" #call } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } }
+{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ;
IN: compiler.tree.builder.tests
USING: compiler.tree.builder tools.test sequences kernel
-compiler.tree ;
-
-\ build-tree must-infer
-\ build-tree-with must-infer
-\ build-tree-from-word must-infer
+compiler.tree stack-checker stack-checker.errors ;
: inline-recursive ( -- ) inline-recursive ; inline recursive
-[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test
+[ t ] [ \ inline-recursive build-tree [ #recursive? ] any? ] unit-test
+
+: bad-recursion-1 ( a -- b )
+ dup [ drop bad-recursion-1 5 ] [ ] if ;
+
+[ \ bad-recursion-1 build-tree ] [ inference-error? ] must-fail-with
+
+FORGET: bad-recursion-1
+
+: bad-recursion-2 ( obj -- obj )
+ dup [ dup first swap second bad-recursion-2 ] [ ] if ;
+
+[ \ bad-recursion-2 build-tree ] [ inference-error? ] must-fail-with
+
+FORGET: bad-recursion-2
+
+: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
+
+[ \ bad-bin build-tree ] [ inference-error? ] must-fail-with
+
+FORGET: bad-bin
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors quotations kernel sequences namespaces
-assocs words arrays vectors hints combinators compiler.tree
+USING: fry locals accessors quotations kernel sequences namespaces
+assocs words arrays vectors hints combinators continuations
+effects compiler.tree
stack-checker
stack-checker.state
stack-checker.errors
stack-checker.recursive-state ;
IN: compiler.tree.builder
-: with-tree-builder ( quot -- nodes )
- '[ V{ } clone stack-visitor set @ ]
- with-infer nip ; inline
+<PRIVATE
-: build-tree ( quot -- nodes )
- #! Not safe to call from inference transforms.
- [ f initial-recursive-state infer-quot ] with-tree-builder ;
+GENERIC: (build-tree) ( quot -- )
-: build-tree-with ( in-stack quot -- nodes out-stack )
- #! Not safe to call from inference transforms.
- [
- [ >vector \ meta-d set ]
- [ f initial-recursive-state infer-quot ] bi*
- ] with-tree-builder
- unclip-last in-d>> ;
+M: callable (build-tree) f initial-recursive-state infer-quot ;
+
+: check-no-compile ( word -- )
+ dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
-: build-sub-tree ( #call quot -- nodes )
- [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
- over ends-with-terminate?
- [ drop swap [ f swap #push ] map append ]
- [ rot #copy suffix ]
- if ;
+: check-effect ( word effect -- )
+ swap required-stack-effect 2dup effect<=
+ [ 2drop ] [ effect-error ] if ;
-: (build-tree-from-word) ( word -- )
- dup initial-recursive-state recursive-state set
- dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
- [ 1quotation ] [ specialized-def ] if
- infer-quot-here ;
+: inline-recursive? ( word -- ? )
+ [ "inline" word-prop ] [ "recursive" word-prop ] bi and ;
-: check-cannot-infer ( word -- )
- dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
+: word-body ( word -- quot )
+ dup inline-recursive? [ 1quotation ] [ specialized-def ] if ;
-TUPLE: do-not-compile word ;
+M: word (build-tree)
+ {
+ [ initial-recursive-state recursive-state set ]
+ [ check-no-compile ]
+ [ word-body infer-quot-here ]
+ [ current-effect check-effect ]
+ } cleave ;
-: check-no-compile ( word -- )
- dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
+: build-tree-with ( in-stack word/quot -- nodes )
+ [
+ V{ } clone stack-visitor set
+ [ [ >vector \ meta-d set ] [ length d-in set ] bi ]
+ [ (build-tree) ]
+ bi*
+ ] with-infer nip ;
+
+PRIVATE>
+
+: build-tree ( word/quot -- nodes )
+ [ f ] dip build-tree-with ;
-: build-tree-from-word ( word -- nodes )
+:: build-sub-tree ( #call word/quot -- nodes/f )
+ #! We don't want methods on mixins to have a declaration for that mixin.
+ #! This slows down compiler.tree.propagation.inlining since then every
+ #! inlined usage of a method has an inline-dependency on the mixin, and
+ #! not the more specific type at the call site.
+ specialize-method? off
[
- [
- {
- [ check-cannot-infer ]
- [ check-no-compile ]
- [ (build-tree-from-word) ]
- [ finish-word ]
- } cleave
- ] maybe-cannot-infer
- ] with-tree-builder ;
+ #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
+ {
+ { [ dup not ] [ ] }
+ { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
+ [ in-d #call out-d>> #copy suffix ]
+ } cond
+ ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
: contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;
IN: compiler.tree.checker.tests
USING: compiler.tree.checker tools.test ;
-\ check-nodes must-infer
+
SYMBOL: branch-out
-: check-branch ( nodes -- stack )
+: check-branch ( nodes -- datastack )
[
datastack [ clone ] change
- V{ } clone retainstack set
- (check-stack-flow)
- terminated? get [ assert-retainstack-empty ] unless
- terminated? get f datastack get ?
+ retainstack [ clone ] change
+ retainstack get clone [ (check-stack-flow) ] dip
+ terminated? get [ drop f ] [
+ retainstack get assert=
+ datastack get
+ ] if
] with-scope ;
M: #branch check-stack-flow*
] unit-test
[ t ] [
- [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+ [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )
sequences.private arrays classes kernel.private ;
IN: compiler.tree.dead-code.tests
-\ remove-dead-code must-infer
-
: count-live-values ( quot -- n )
build-tree
analyze-recursive
IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
-\ optimized. must-infer
-\ optimizer-report. must-infer
-
[ [ <=> ] sort ] optimized.
[ <reversed> [ print ] each ] optimizer-report.
\ No newline at end of file
: make-report ( word/quot -- assoc )
[
- dup word? [ build-tree-from-word ] [ build-tree ] if
- optimize-tree
+ build-tree optimize-tree
H{ } clone words-called set
H{ } clone generics-called set
binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests
-\ compute-def-use must-infer
-
[ t ] [
[ 1 2 3 ] build-tree compute-def-use drop
def-use get {
compiler.tree.checker
kernel.private ;
-\ escape-analysis must-infer
-
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )
compiler.tree compiler.tree.checker
sequences accessors tools.test kernel math ;
-\ count-introductions must-infer
-\ normalize must-infer
-
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
-: foo ( a b -- b a ) 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
USING: compiler.tree.optimizer tools.test ;
IN: compiler.tree.optimizer.tests
-\ optimize-tree must-infer
+
SYMBOL: check-optimizer?
+: ?check ( nodes -- nodes' )
+ check-optimizer? get [
+ compute-def-use
+ dup check-nodes
+ ] when ;
+
: optimize-tree ( nodes -- nodes' )
analyze-recursive
normalize
propagate
cleanup
+ ?check
dup run-escape-analysis? [
escape-analysis
unbox-tuples
apply-identities
compute-def-use
remove-dead-code
- check-optimizer? get [
- compute-def-use
- dup check-nodes
- ] when
+ ?check
compute-def-use
optimize-modular-arithmetic
finalize ;
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations classes fry combinators.smart
+words namespaces continuations classes fry combinators.smart hints
+locals
compiler.tree
compiler.tree.builder
compiler.tree.recursive
SYMBOL: inlining-count
! Splicing nodes
-GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
-
-M: word splicing-nodes
+: splicing-call ( #call word -- nodes )
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
-M: callable splicing-nodes
- build-sub-tree analyze-recursive normalize ;
+: splicing-body ( #call quot/word -- nodes/f )
+ build-sub-tree dup [ analyze-recursive normalize ] when ;
! Dispatch elimination
+: undo-inlining ( #call -- ? )
+ f >>method f >>body f >>class drop f ;
+
+: propagate-body ( #call -- ? )
+ body>> (propagate) t ;
+
+GENERIC: splicing-nodes ( #call word/quot -- nodes/f )
+
+M: word splicing-nodes splicing-call ;
+
+M: callable splicing-nodes splicing-body ;
+
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
[ >>class ] dip
- over method>> over = [ drop ] [
- 2dup splicing-nodes
- [ >>method ] [ >>body ] bi*
+ over method>> over = [ drop propagate-body ] [
+ 2dup splicing-nodes dup [
+ [ >>method ] [ >>body ] bi* propagate-body
+ ] [ 2drop undo-inlining ] if
] if
- body>> (propagate) t
- ] [ 2drop f >>method f >>body f >>class drop f ] if ;
+ ] [ 2drop undo-inlining ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
[
[ classes-known? 2 0 ? ]
[
- {
- [ body-length-bias ]
- [ "default" word-prop -4 0 ? ]
- [ "specializer" word-prop 1 0 ? ]
- [ method-body? 1 0 ? ]
- } cleave
+ [ body-length-bias ]
+ [ "specializer" word-prop 1 0 ? ]
+ [ method-body? 1 0 ? ]
+ tri
node-count-bias
loop-nesting get 0 or 2 *
] bi*
[ history [ swap suffix ] change ]
bi ;
-: inline-word-def ( #call word quot -- ? )
- over history get memq? [ 3drop f ] [
- [
- [ remember-inlining ] dip
- [ drop ] [ splicing-nodes ] 2bi
- [ >>body drop ] [ count-nodes ] [ (propagate) ] tri
- ] with-scope node-count +@
- t
+:: inline-word ( #call word -- ? )
+ word history get memq? [ f ] [
+ #call word splicing-body [
+ [
+ word remember-inlining
+ [ ] [ count-nodes ] [ (propagate) ] tri
+ ] with-scope
+ [ #call (>>body) ] [ node-count +@ ] bi* t
+ ] [ f ] if*
] if ;
-: inline-word ( #call word -- ? )
- dup def>> inline-word-def ;
-
: inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
{ curry compose } memq? ;
: never-inline-word? ( word -- ? )
- [ deferred? ] [ { call execute } memq? ] bi or ;
+ [ deferred? ]
+ [ "default" word-prop ]
+ [ { call execute } memq? ] tri or or ;
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
call( #call -- word/quot/f )
object swap eliminate-dispatch ;
-: inline-instance-check ( #call word -- ? )
- over in-d>> second value-info literal>> dup class?
- [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
-
: (do-inlining) ( #call word -- ? )
#! If the generic was defined in an outer compilation unit,
#! then it doesn't have a definition yet; the definition
#! discouraged, but it should still work.)
{
{ [ dup never-inline-word? ] [ 2drop f ] }
- { [ dup \ instance? eq? ] [ inline-instance-check ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
] [ 2drop object-info ] if
] "outputs" set-word-prop
+\ instance? [
+ in-d>> second value-info literal>> dup class?
+ [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
+] "custom-inlining" set-word-prop
+
\ equal? [
! If first input has a known type and second input is an
! object, we convert this to [ swap equal? ].
math.intervals ;
IN: compiler.tree.propagation.tests
-\ propagate must-infer
-
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
-\ analyze-recursive must-infer
-
: label-is-loop? ( nodes word -- ? )
[
{
} 2&&
] curry contains-node? ;
-\ label-is-loop? must-infer
-
: label-is-not-loop? ( nodes word -- ? )
[
{
} 2&&
] curry contains-node? ;
-\ label-is-not-loop? must-infer
-
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
math.private sorting math.order binary-search sequences.private
slots.private ;
-\ unbox-tuples must-infer
-
: test-unboxing ( quot -- )
build-tree
analyze-recursive
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
-
-"cpu.ppc.assembler" words [ must-infer ] each
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
USING: db.pools tools.test continuations io.files io.files.temp
io.directories namespaces accessors kernel math destructors ;
-\ <db-pool> must-infer
-
{ 1 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
USING: concurrency.combinators db.pools db.sqlite db.tuples
db.types kernel math random threads tools.test db sequences
io prettyprint db.postgresql db.sqlite accessors io.files.temp
-namespaces fry system ;
+namespaces fry system math.parser ;
IN: db.tester
: postgresql-test-db ( -- postgresql-db )
{ "z" "Z" { VARCHAR 256 } +not-null+ }
} define-persistent
+: test-1-tuple ( -- tuple )
+ f 100 random 100 random 100 random [ number>string ] tri@
+ test-1 boa ;
+
: db-tester ( test-db -- )
[
[
drop
10 [
dup [
- f 100 random 100 random 100 random test-1 boa
- insert-tuple yield
+ test-1-tuple insert-tuple yield
] with-db
] times
] with parallel-each
<db-pool> [
10 [
10 [
- f 100 random 100 random 100 random test-1 boa
- insert-tuple yield
+ test-1-tuple insert-tuple yield
] times
] parallel-each
] with-pooled-db
[ test-string-encoding ] test-sqlite
[ test-string-encoding ] test-postgresql
-! Don't comment these out. These words must infer
-\ bind-tuple must-infer
-\ insert-tuple must-infer
-\ update-tuple must-infer
-\ delete-tuples must-infer
-\ select-tuple must-infer
-\ define-persistent must-infer
-\ ensure-table must-infer
-\ create-table must-infer
-\ drop-table must-infer
-
: test-queries ( -- )
[ ] [ exam ensure-table ] unit-test
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
USING: debugger kernel continuations tools.test ;\r
\r
[ ] [ [ drop ] [ error. ] recover ] unit-test\r
+\r
+[ f ] [ { } vm-error? ] unit-test\r
+[ f ] [ { "A" "B" } vm-error? ] unit-test
\ No newline at end of file
: divide-by-zero-error. ( obj -- )
"Division by zero" print drop ;
-: signal-error. ( obj -- )
- "Operating system signal " write third . ;
+HOOK: signal-error. os ( obj -- )
: array-size-error. ( obj -- )
"Invalid array size: " write dup third .
: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
-PREDICATE: kernel-error < array
+PREDICATE: vm-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
[ second 0 15 between? ]
} cond ;
-: kernel-errors ( error -- n errors )
+: vm-errors ( error -- n errors )
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }
{ 15 [ memory-error. ] }
} ; inline
-M: kernel-error error. dup kernel-errors case ;
+M: vm-error summary drop "VM error" ;
-M: kernel-error error-help kernel-errors at first ;
+M: vm-error error. dup vm-errors case ;
+
+M: vm-error error-help vm-errors at first ;
M: no-method summary
drop "No suitable method" ;
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
-M: wrong-values summary drop "Quotation called with wrong stack effect" ;
\ No newline at end of file
+M: wrong-values summary drop "Quotation called with wrong stack effect" ;
+
+{
+ { [ os windows? ] [ "debugger.windows" require ] }
+ { [ os unix? ] [ "debugger.unix" require ] }
+} cond
\ 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: debugger io kernel math prettyprint sequences system ;
+IN: debugger.unix
+
+CONSTANT: signal-names
+{
+ "SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT"
+ "SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS"
+ "SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP"
+ "SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU"
+ "SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO"
+ "SIGUSR1" "SIGUSR2"
+}
+
+: signal-name ( n -- str/f ) 1- signal-names ?nth ;
+
+: signal-name. ( n -- )
+ signal-name [ " (" ")" surround write ] when* ;
+
+M: unix signal-error. ( obj -- )
+ "Unix signal #" write
+ third [ pprint ] [ signal-name. ] bi nl ;
--- /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 io prettyprint sequences system ;
+IN: debugger.windows
+
+M: windows signal-error. "Windows exception #" write third .h ;
\ No newline at end of file
[ 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 ;
Eduardo Cavazos
+Doug Coleman
IN: editors.emacs
ARTICLE: "editors.emacs" "Integration with Emacs"
-"Put this in your " { $snippet ".emacs" } " file:"
+"Full Emacs integration with Factor requires the use of two executable files -- " { $snippet "emacs" } " and " { $snippet "emacsclient" } ", which act as a client/server pair. To start the server, run the " { $snippet "emacs" } " binary and run " { $snippet "M-x server-start" } " or start " { $snippet "emacs" } " with the following line in your " { $snippet ".emacs" } " file:"
{ $code "(server-start)" }
+"On Windows, if you install Emacs to " { $snippet "Program Files" } " or " { $snippet "Program Files(x86)" } ", Factor will automatically detect the path to " { $snippet "emacsclient.exe" } ". On Unix systems, make sure that " { $snippet "emacsclient" } " is in your path. To set the path manually, use the following snippet:"
+{ $code "USE: edtiors.emacs"
+ "\"/my/crazy/bin/emacsclient\" emacsclient-path set-global"
+}
+
"If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:"
{ $code "(setq server-window 'switch-to-buffer-other-frame)" }
-{ $see-also "editor" } ;
-ABOUT: "editors.emacs"
\ No newline at end of file
+"To quickly scaffold a " { $snippet ".emacs" } " file, run the following code:"
+{ $code "USE: tools.scaffold"
+ "scaffold-emacs"
+}
+
+{ $see-also "editor" }
+
+;
+
+ABOUT: "editors.emacs"
: emacsclient ( file line -- )
[
- { [ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
+ {
+ [ emacsclient-path get-global ]
+ [ default-emacsclient dup emacsclient-path set-global ]
+ } 0|| ,
"--no-wait" ,
number>string "+" prepend ,
,
-Doug Coleman
+Slava Pestov
--- /dev/null
+unportable
--- /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.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
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
-[ "USING: fry locals.backend ; f '[ load-local _ ]" (( -- quot )) 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 } } ] [
>>
-\ sqsq must-infer
-
[ 16 ] [ 2 sqsq ] unit-test
<<
USING: furnace.auth tools.test ;
IN: furnace.auth.tests
-\ logged-in-username must-infer
-\ <protected> must-infer
-\ new-realm must-infer
IN: furnace.auth.features.edit-profile.tests
USING: tools.test furnace.auth.features.edit-profile ;
-\ allow-edit-profile must-infer
+
IN: furnace.auth.features.recover-password
USING: tools.test furnace.auth.features.recover-password ;
-\ allow-password-recovery must-infer
+
IN: furnace.auth.features.registration.tests
USING: tools.test furnace.auth.features.registration ;
-\ allow-registration must-infer
+
IN: furnace.auth.login.tests\r
USING: tools.test furnace.auth.login ;\r
\r
-\ <login-realm> must-infer\r
+\r
IN: furnace.db.tests
USING: tools.test furnace.db ;
-\ <db-persistence> must-infer
+
\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
: 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
{ $values { "topic" "an article name or a word" } }
{ $description "Sets the " { $link article-parent } " of each child of this article." }
$low-level-note ;
-
-HELP: unxref-article
-{ $values { "topic" "an article name or a word" } }
-{ $description "Clears the " { $link article-parent } " of each child of this article." }
-$low-level-note ;
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
[ ] [
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs math fry
io kernel namespaces prettyprint prettyprint.sections
: article-children ( topic -- seq )
{ $subsection } article-links ;
-M: link uses
- { $subsection $link $see-also } article-links ;
-
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
article-children [ set-article-parent ] with each ;
: xref-article ( topic -- )
- dup >link xref dup set-article-parents ;
-
-: unxref-article ( topic -- )
- >link unxref ;
+ dup set-article-parents ;
: prev/next ( obj seq n -- obj' )
[ [ index dup ] keep ] dip swap
"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
{ $heading "Documentation conventions" }
"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article."
$nl
-"Every article has links to parent articles at the top. These can be persued if the article is too specific."
+"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific."
$nl
"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are."
{ $heading "Vocabulary naming conventions" }
"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")."
$nl
-"You should should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
+"You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
{ $heading "Word naming conventions" }
"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:"
{ $table
{ $heading "Abstractions" }
{ $subsection "objects" }
{ $subsection "destructors" }
+{ $subsection "parsing-words" }
{ $subsection "macros" }
{ $subsection "fry" }
{ $heading "Program organization" }
error get (:help) ;
: remove-article ( name -- )
- dup articles get key? [
- dup unxref-article
- dup articles get delete-at
- ] when drop ;
+ articles get delete-at ;
: add-article ( article name -- )
[ remove-article ] keep
xref-article ;
: remove-word-help ( word -- )
- dup word-help [ dup unxref-article ] when
f "help" set-word-prop ;
: set-word-help ( content word -- )
TUPLE: blahblah quux ;
-[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
+[ "int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ quux>> print-topic ] unit-test
[ ] [ \ >>quux print-topic ] unit-test
[ "a string, a fixnum, or an integer" ]
[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test
-\ print-element must-infer
-\ print-topic must-infer
\ No newline at end of file
! Images
: $image ( element -- )
- [ [ "" ] dip first image associate format ] ($span) ;
+ [ first write-image ] ($span) ;
: <$image> ( path -- element )
1array \ $image prefix ;
dup name>> a/an write bl ($link) ;
M: string ($instance)
- dup a/an write bl $snippet ;
+ write ;
M: f ($instance)
drop { f } $link ;
[
[ "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
namespaces assocs source-files eval ;
IN: help.topics.tests
-\ article-name must-infer
-\ article-title must-infer
-\ article-content must-infer
-\ article-parent must-infer
-
! Test help cross-referencing
[ ] [ "Test B" { "Hello world." } <article> { "test" "b" } add-article ] unit-test
} "\n" join
[
"testfile" source-file file set
- (( -- )) eval
+ eval( -- )
] with-scope
] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
-byte-arrays byte-vectors io.binary io.streams.string splitting
-math math.parser generic generic.standard generic.standard.engines classes
-hashtables ;
+byte-arrays byte-vectors io.binary io.streams.string splitting math
+math.parser generic generic.standard generic.standard.engines classes
+hashtables namespaces ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
-: method-declaration ( method -- quot )
- [ "method-generic" word-prop dispatch# object <array> ]
- [ "method-class" word-prop ]
- bi prefix ;
+! compiler.tree.propagation.inlining sets this to f
+SYMBOL: specialize-method?
+
+t specialize-method? set-global
: specialize-method ( quot method -- quot' )
- [ method-declaration '[ _ declare ] prepend ]
+ [
+ specialize-method? get [
+ [ "method-class" word-prop ] [ "method-generic" word-prop ] bi
+ method-declaration prepend
+ ] [ drop ] if
+ ]
[ "method-generic" word-prop "specializer" word-prop ] bi
[ specialize-quot ] when* ;
SYNTAX: HINTS:
scan-object
- [ redefined ]
+ [ changed-definition ]
[ parse-definition "specializer" set-word-prop ] bi ;
! Default specializers
html.components html.forms namespaces
xml.writer ;
-\ render must-infer
-
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
USING: http.client http.client.private http tools.test
namespaces urls ;
-\ download must-infer
-
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
: 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
assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
-\ find-responder must-infer
-
TUPLE: mock-responder path ;
C: <mock-responder> mock-responder
USING: http http.server.redirection urls accessors
namespaces tools.test present kernel ;
-\ relative-to-request must-infer
-
[
<request>
<url>
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
-\ make-http-error must-infer
-
[ "text/plain; charset=UTF-8" ] [
<response>
"text/plain" >>content-type
swap >>fill 0 >>pos drop ;
: buffer-capacity ( buffer -- n )
- [ size>> ] [ fill>> ] bi - ; inline
+ [ size>> ] [ fill>> ] bi - >fixnum ; inline
: buffer-empty? ( buffer -- ? )
fill>> zero? ; inline
--- /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* ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays continuations deques dlists fry
io.directories io.files io.files.info io.pathnames kernel
-sequences system vocabs.loader ;
+sequences system vocabs.loader locals math namespaces
+sorting assocs ;
IN: io.directories.search
<PRIVATE
dup directory-files [ append-path ] with map ;
: push-directory ( path iter -- )
- [ qualified-directory ] dip [
- [ queue>> ] [ bfs>> ] bi
+ [ qualified-directory ] dip '[
+ _ [ queue>> ] [ bfs>> ] bi
[ push-front ] [ push-back ] if
- ] curry each ;
+ ] each ;
: <directory-iterator> ( path bfs? -- iterator )
<dlist> directory-iterator boa
[ over push-directory next-file ] [ nip ] if
] if ;
-: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
- over next-file [
- over call
- [ 2nip ] [ iterate-directory ] if*
+:: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
+ iter next-file [
+ quot call [ iter quot iterate-directory ] unless*
] [
- 2drop f
+ f
] if* ; inline recursive
PRIVATE>
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
'[ _ _ find-all-files ] map concat ; inline
+: with-qualified-directory-files ( path quot -- )
+ '[
+ "" directory-files current-directory get
+ '[ _ prepend-path ] map @
+ ] with-directory ; inline
+
+: with-qualified-directory-entries ( path quot -- )
+ '[
+ "" directory-entries current-directory get
+ '[ [ _ prepend-path ] change-name ] map @
+ ] with-directory ; inline
+
+: directory-size ( path -- n )
+ 0 swap t [ link-info size-on-disk>> + ] each-file ;
+
+: directory-usage ( path -- assoc )
+ [
+ [
+ [ name>> dup ] [ directory? ] bi [
+ directory-size
+ ] [
+ link-info size-on-disk>>
+ ] if
+ ] { } map>assoc
+ ] with-qualified-directory-entries sort-values ;
+
os windows? [ "io.directories.search.windows" require ] when
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
[ { 256 } >string latin1 encode ] must-fail
-[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
+[ B{ 255 } ] [ { 255 } >string latin1 encode ] unit-test
[ "bar" ] [ "bar" latin1 decode ] unit-test
-[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
-[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test
+[ { CHAR: b 233 CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
+[ { HEX: fffd HEX: 20AC } ] [ B{ HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test
[ t ] [ \ latin1 8-bit-encoding? ] unit-test
[ "bar" ] [ "bar" \ latin1 decode ] unit-test
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test
[ { 128 } >string ascii encode ] must-fail
-[ B{ 127 } ] [ { 127 } ascii encode ] unit-test
+[ B{ 127 } ] [ { 127 } >string ascii encode ] unit-test
[ "bar" ] [ "bar" ascii decode ] unit-test
-[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test
+[ { CHAR: b HEX: fffd CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } ascii decode >array ] unit-test
[ "hello" ] [ "hello" gb18030 encode >string ] unit-test
[ "hello" ] [ "hello" gb18030 decode ] unit-test
[ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } ]
-[ B{ HEX: B7 HEX: B8 } gb18030 encode ] unit-test
+[ B{ HEX: B7 HEX: B8 } >string gb18030 encode ] unit-test
[ { HEX: B7 HEX: B8 } ]
[ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } gb18030 decode >array ] unit-test
[ { HEX: B7 CHAR: replacement-character } ]
[ { HEX: B7 } ]
[ B{ HEX: A1 HEX: A4 } gb18030 decode >array ] unit-test
[ { CHAR: replacement-character } ]
-[ B{ HEX: A1 } gb18030 decode >array ] unit-test
+[ B{ HEX: A1 } >string gb18030 decode >array ] unit-test
[ { HEX: 44D7 HEX: 464B } ]
[ B{ HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 }
gb18030 decode >array ] unit-test
[ { HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } ]
-[ { HEX: 44D7 HEX: 464B } gb18030 encode >array ] unit-test
+[ { HEX: 44D7 HEX: 464B } >string gb18030 encode >array ] unit-test
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test io.encodings.utf16 arrays sbufs
-io.streams.byte-array sequences io.encodings io
+io.streams.byte-array sequences io.encodings io strings
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf16.tests
-[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test
-[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
+[ { CHAR: x } ] [ B{ 0 CHAR: x } utf16be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ B{ HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
-[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test
+[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } >string utf16be encode >array ] unit-test
-[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
+[ { CHAR: x } ] [ B{ CHAR: x 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ B{ HEX: 34 HEX: D8 HEX: 1E HEX: DD } >string utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } >string utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } >string utf16le decode >array ] unit-test
-[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
+[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16le encode >array ] unit-test
-[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
-[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
-[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
+[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16 encode >array ] unit-test
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test io.encodings.utf32 arrays sbufs
-io.streams.byte-array sequences io.encodings io
+io.streams.byte-array sequences io.encodings io strings
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf32.tests
-[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test
-[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test
+[ { CHAR: x } ] [ B{ 0 0 0 CHAR: x } utf32be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ B{ 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ 0 1 HEX: D1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ 0 1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ 0 } utf32be decode >array ] unit-test
[ { } ] [ { } utf32be decode >array ] unit-test
-[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test
+[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } >string utf32be encode >array ] unit-test
-[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test
-[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test
+[ { CHAR: x } ] [ B{ CHAR: x 0 0 0 } utf32le decode >array ] unit-test
+[ { HEX: 1d11e } ] [ B{ HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ HEX: 1e } utf32le decode >array ] unit-test
[ { } ] [ { } utf32le decode >array ] unit-test
-[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test
+[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32le encode >array ] unit-test
-[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
-[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
-[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test
+[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32 encode >array ] unit-test
sequences io.files.temp ;
IN: io.files.info.tests
-\ file-info must-infer
-\ link-info must-infer
-
[ t ] [
temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
temp-directory "test41" append-path utf8 file-contents "hi41" =
IN: io.files.info
! File info
-TUPLE: file-info type size permissions created modified
+TUPLE: file-info type size size-on-disk permissions created modified
accessed ;
HOOK: file-info os ( path -- info )
{
{ [ os unix? ] [ "io.files.info.unix." os name>> append ] }
{ [ os windows? ] [ "io.files.info.windows" ] }
-} cond require
\ No newline at end of file
+} cond require
M: unix new-file-info ( -- class ) unix-file-info new ;
+CONSTANT: standard-unix-block-size 512
+
M: unix stat>file-info ( stat -- file-info )
[ new-file-info ] dip
{
[ stat-st_rdev >>rdev ]
[ stat-st_blocks >>blocks ]
[ stat-st_blksize >>blocksize ]
+ [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
} cleave ;
: n>file-type ( n -- type )
windows.time windows accessors alien.c-types combinators
generalizations system alien.strings io.encodings.utf16n
sequences splitting windows.errors fry continuations destructors
-calendar ascii combinators.short-circuit ;
+calendar ascii combinators.short-circuit locals ;
IN: io.files.info.windows
+:: round-up-to ( n multiple -- n' )
+ n multiple rem dup 0 = [
+ drop n
+ ] [
+ multiple swap - n +
+ ] if ;
+
TUPLE: windows-file-info < file-info attributes ;
+: get-compressed-file-size ( path -- n )
+ "DWORD" <c-object> [ GetCompressedFileSize ] keep
+ over INVALID_FILE_SIZE = [
+ win32-error-string throw
+ ] [
+ *uint >64bit
+ ] if ;
+
+: set-windows-size-on-disk ( file-info path -- file-info )
+ over attributes>> +compressed+ swap member? [
+ get-compressed-file-size
+ ] [
+ drop dup size>> 4096 round-up-to
+ ] if >>size-on-disk ;
+
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
{
] if ;
M: windows file-info ( path -- info )
- normalize-path get-file-information-stat ;
+ normalize-path
+ [ get-file-information-stat ]
+ [ set-windows-size-on-disk ] bi ;
M: windows link-info ( path -- info )
file-info ;
[ 123 ] [
"core" ".test" [
- [ [ 123 CHAR: a <repetition> ] dip ascii set-file-contents ]
+ [ [ 123 CHAR: a <string> ] dip ascii set-file-contents ]
[ file-info size>> ] bi
] cleanup-unique-file
] unit-test
windows.kernel32 kernel libc math threads system environment
alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings assocs
-namespaces make accessors tr windows.time ;
+namespaces make accessors tr windows.time windows.shell32 ;
IN: io.files.windows.nt
M: winnt cwd
[ dup windows-file-size ] [ drop 0 ] recover
[ (open-append) ] dip >>ptr ;
-M: winnt home "USERPROFILE" os-env ;
+M: winnt home
+ {
+ [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
+ [ "USERPROFILE" os-env ]
+ [ my-documents ]
+ } 0|| ;
IN: io.launcher.tests
USING: tools.test io.launcher ;
-\ <process-stream> must-infer
-\ <process-reader> must-infer
-\ <process-writer> must-infer
[ 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
io.pathnames io.files.temp io.directories.hierarchy ;
IN: io.monitors.recursive.tests
-\ pump-thread must-infer
-
SINGLETON: mock-io-backend
TUPLE: counter i ;
IN: io.monitors.windows.nt.tests\r
USING: io.monitors.windows.nt tools.test ;\r
\r
-\ fill-queue-thread must-infer\r
+\r
HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
-HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ;
+HINTS: encoder-write { object output-port utf8 } { object output-port ascii } ;
concurrency.promises byte-arrays locals calendar io.timeouts
io.sockets.secure.unix.debug ;
-\ <secure-config> must-infer
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
[ ] [ <promise> "port" set ] unit-test
] with-destructors ;
: <client> ( remote encoding -- stream local )
- [ (client) -rot ] dip <encoder-duplex> swap ;
+ [ (client) ] dip swap [ <encoder-duplex> ] dip ;
SYMBOL: local-address
USING: tools.test io.streams.byte-array io.encodings.binary
io.encodings.utf8 io kernel arrays strings namespaces ;
-[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
+[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
-[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
+[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
[ B{ 121 120 } 0 ] [
512 <sbuf> ;
: with-string-writer ( quot -- str )
- <string-writer> swap [ output-stream get ] compose with-output-stream*
- >string ; inline
\ No newline at end of file
+ <string-writer> [
+ swap with-output-stream*
+ ] keep >string ; inline
\ No newline at end of file
IN: io.styles.tests
USING: io.styles tools.test ;
-
-\ stream-format must-infer
-\ stream-write-table must-infer
-\ make-span-stream must-infer
-\ make-block-stream must-infer
-\ make-cell-stream must-infer
\ No newline at end of file
] "" make ;
: write-object ( str obj -- ) presented associate format ;
+
+: write-image ( image -- ) [ "" ] dip image associate format ;
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
-\ lcs must-infer
-\ diff must-infer
-\ levenshtein must-infer
-
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
"\\ + 1 2 3 4" parse-interactive
"cont" get continue-with
] ignore-errors
- "USE: debugger :1" (( -- quot )) eval
+ "USE: debugger :1" eval( -- quot )
] callcc1
] unit-test
] with-file-vocabs
: 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 )
IN: locals.backend.tests
-USING: tools.test locals.backend kernel arrays ;
+USING: tools.test locals.backend kernel arrays accessors ;
: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
-\ get-local-test-1 must-infer
+\ get-local-test-1 def>> must-infer
[ 3 ] [ get-local-test-1 ] unit-test
: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
-\ get-local-test-2 must-infer
+\ get-local-test-2 def>> must-infer
[ 3 ] [ get-local-test-2 ] unit-test
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
-:: let-test-5 ( a -- b )
- a [let | a [ ] b [ ] | a b 2array ] ;
+:: let-test-5 ( a b -- b )
+ a b [let | a [ ] b [ ] | a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
SYMBOL: a
:: use-test ( a b c -- a b c )
- USE: kernel ;
+ USE: kernel
+ a b c ;
[ t ] [ a symbol? ] unit-test
[ ] [ \ lambda-generic see ] unit-test
-:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
+:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ;
-[ "[let | a! [ ] | ]" ] [
+[ "[let | a! [ 3 ] | ]" ] [
\ unparse-test-1 "lambda" word-prop body>> first unparse
] unit-test
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
{ [ a b > ] [ 5 ] }
} cond ;
-\ cond-test must-infer
+\ cond-test def>> must-infer
[ 3 ] [ 1 2 cond-test ] unit-test
[ 4 ] [ 2 2 cond-test ] unit-test
:: 0&&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
-\ 0&&-test must-infer
+\ 0&&-test def>> must-infer
[ f ] [ 1.5 0&&-test ] unit-test
[ f ] [ 3 0&&-test ] unit-test
:: &&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
-\ &&-test must-infer
+\ &&-test def>> must-infer
[ f ] [ 1.5 &&-test ] unit-test
[ f ] [ 3 &&-test ] unit-test
]
] ;
-\ let-and-cond-test-1 must-infer
+\ let-and-cond-test-1 def>> must-infer
[ 20 ] [ let-and-cond-test-1 ] unit-test
]
] ;
-\ let-and-cond-test-2 must-infer
+\ let-and-cond-test-2 def>> must-infer
[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
{ 5 [ a a ^ ] }
} case ;
-\ big-case-test must-infer
+\ big-case-test def>> must-infer
[ 9 ] [ 3 big-case-test ] unit-test
[| x | x 12 + { "howdy" } nth ]
} case ;
-\ littledan-case-problem-1 must-infer
+\ littledan-case-problem-1 def>> must-infer
[ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test
[ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test
[| x | x a - { "howdy" } nth ]
} case ;
-\ littledan-case-problem-2 must-infer
+\ littledan-case-problem-2 def>> must-infer
[ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test
[ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test
[| x | x a - { "howdy" } nth ]
} cond ;
-\ littledan-cond-problem-1 must-infer
+\ littledan-cond-problem-1 def>> must-infer
[ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
[ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
: littledan-case-problem-4 ( a -- b )
[ 1 + ] littledan-case-problem-3 ;
-\ littledan-case-problem-4 must-infer
+\ littledan-case-problem-4 def>> must-infer
*/
GENERIC: lambda-method-forget-test ( a -- b )
-M:: integer lambda-method-forget-test ( a -- b ) ;
+M:: integer lambda-method-forget-test ( a -- b ) a ;
[ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
[
"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
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
-\ funny-macro-test must-infer
+\ funny-macro-test def>> must-infer
[ t ] [ 3 funny-macro-test ] unit-test
[ 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
:: FAILdog-1 ( -- b ) { [| c | c ] } ;
-\ FAILdog-1 must-infer
+\ FAILdog-1 def>> must-infer
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
-\ FAILdog-2 must-infer
+\ FAILdog-2 def>> must-infer
[ 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
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
] ;
-\ wlet-&&-test must-infer
+\ wlet-&&-test def>> must-infer
[ f ] [ 1.5 wlet-&&-test ] unit-test
[ f ] [ 3 wlet-&&-test ] unit-test
[ f ] [ 8 wlet-&&-test ] unit-test
: fry-locals-test-1 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
-\ fry-locals-test-1 must-infer
+\ fry-locals-test-1 def>> must-infer
[ 10 ] [ fry-locals-test-1 ] unit-test
:: fry-locals-test-2 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
-\ fry-locals-test-2 must-infer
+\ fry-locals-test-2 def>> must-infer
[ 10 ] [ fry-locals-test-2 ] unit-test
[ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] 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
PRIVATE>
: define-macro ( word definition effect -- )
- real-macro-effect
- [ [ memoize-quot [ call ] append ] keep define-declared ]
- [ drop "macro" set-word-prop ]
- 3bi ;
+ real-macro-effect {
+ [ [ memoize-quot [ call ] append ] keep define-declared ]
+ [ drop "macro" set-word-prop ]
+ [ 2drop changed-effect ]
+ } 3cleave ;
SYNTAX: MACRO: (:) define-macro ;
} 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 )
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
-\ foo must-infer
+\ foo def>> must-infer
[ 1 ] [ { 1 } flags ] unit-test
: comparison-test ( -- ? )
random-interval random-interval random-comparison
- [ [ [ random-element ] bi@ ] dip first execute ] 3keep
- second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
+ [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep
+ second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ;
[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
--- /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
! 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
"tester" get
"model-c" get value>>
] unit-test
-
-\ model-changed must-infer
-\ set-model must-infer
: 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 -- )
"x[i][j].y" primary
] unit-test
-'ebnf' compile must-infer
-
{ V{ V{ "a" "b" } "c" } } [
"abc" [EBNF a="a" "b" foo=(a "c") EBNF]
] unit-test
] unit-test
{ } [
- "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" (( -- )) eval
+ "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
peg peg.private peg.parsers accessors words math accessors ;
IN: peg.tests
-\ parse must-infer
-
[ ] [ reset-pegs ] unit-test
[
[ ] [ enable-compiler ] unit-test
[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
-
-[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test
\ No newline at end of file
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
] unit-test
-\ search must-infer
-\ replace must-infer
persistent.sequences sequences kernel arrays random namespaces
vectors math math.order ;
-\ new-nth must-infer
-\ ppush must-infer
-\ ppop must-infer
-
[ 0 ] [ PV{ } length ] unit-test
[ 1 ] [ 3 PV{ } ppush length ] unit-test
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
drop ;
[ "drop ;" ] [
- \ blah f "inferred-effect" set-word-prop
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test
! 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
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 )
+: regexp-fails ( string -- )
'[ _ parse-regexp ] must-fail ;
{
eval strings multiline accessors ;
IN: regexp-tests
-\ <regexp> must-infer
-\ compile-regexp must-infer
-\ matches? must-infer
-
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
[ t ] [ "a" "a*" <regexp> matches? ] unit-test
! 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."
concurrency.promises system ;
IN: smtp.tests
-\ send-email must-infer
-
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ "hello\nworld" validate-address ] must-fail
[ { "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.
+! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels,
+! 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 io.encodings.string
+io.encodings.utf8 io.encodings.iana io.encodings.binary
+io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf
+kernel logging sequences combinators splitting assocs strings
+math.order math.parser random system calendar summary calendar.format
+accessors sets hashtables base64 debugger classes prettyprint 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
- >base64-lines write crlf
+: send-body ( email -- )
+ binary encode-output
+ [ body>> ] [ encoding>> ] bi encode >base64-lines write
+ ascii encode-output crlf
"." command ;
: quit ( -- )
: 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 ;
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic io io.streams.string kernel math
namespaces parser sequences strings vectors words quotations
effects classes continuations assocs combinators
compiler.errors accessors math.order definitions sets
-generic.standard.engines.tuple hints stack-checker.state
+generic.standard.engines.tuple hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
IN: stack-checker.backend
meta-r empty? [ too-many->r ] unless ;
: infer-quot-here ( quot -- )
- meta-r [
- V{ } clone \ meta-r set
- [ apply-object terminated? get not ] all?
- [ commit-literals check->r ] [ literals get delete-all ] if
- ] dip \ meta-r set ;
+ [ apply-object terminated? get not ] all?
+ [ commit-literals ] [ literals get delete-all ] if ;
: infer-quot ( quot rstate -- )
recursive-state get [
] if ;
: infer->r ( n -- )
- consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
+ terminated? get [ drop ] [
+ consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi
+ ] if ;
: infer-r> ( n -- )
- consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
-
-: undo-infer ( -- )
- recorded get [ f "inferred-effect" set-word-prop ] each ;
+ terminated? get [ drop ] [
+ consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi
+ ] if ;
: (consume/produce) ( effect -- inputs outputs )
[ in>> length consume-d ] [ out>> length produce-d ] bi ;
[ terminated?>> [ terminate ] when ]
bi ; inline
-: infer-word-def ( word -- )
- [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
-
: end-infer ( -- )
+ terminated? get [ check->r ] unless
meta-d clone #return, ;
: required-stack-effect ( word -- effect )
dup stack-effect [ ] [ missing-effect ] ?if ;
-: check-effect ( word effect -- )
- over required-stack-effect 2dup effect<=
- [ 3drop ] [ effect-error ] if ;
-
-: finish-word ( word -- )
- [ current-effect check-effect ]
- [ recorded get push ]
- [ t "inferred-effect" set-word-prop ]
- tri ;
-
-: cannot-infer-effect ( word -- * )
- "cannot-infer" word-prop rethrow ;
-
-: maybe-cannot-infer ( word quot -- )
- [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
-
-: infer-word ( word -- effect )
- [
- [
- init-inference
- init-known-values
- stack-visitor off
- dependencies off
- generic-dependencies off
- [ infer-word-def end-infer ]
- [ finish-word ]
- [ stack-effect ]
- tri
- ] with-scope
- ] maybe-cannot-infer ;
-
: apply-word/effect ( word effect -- )
swap '[ _ #call, ] consume/produce ;
-: call-recursive-word ( word -- )
- dup required-stack-effect apply-word/effect ;
-
-: cached-infer ( word -- )
- dup stack-effect apply-word/effect ;
+: infer-word ( word -- )
+ {
+ { [ dup macro? ] [ do-not-compile ] }
+ { [ dup "no-compile" word-prop ] [ do-not-compile ] }
+ [ dup required-stack-effect apply-word/effect ]
+ } cond ;
: with-infer ( quot -- effect visitor )
[
- [
- V{ } clone recorded set
- init-inference
- init-known-values
- stack-visitor off
- call
- end-infer
- current-effect
- stack-visitor get
- ] [ ] [ undo-infer ] cleanup
+ init-inference
+ init-known-values
+ stack-visitor off
+ call
+ end-infer
+ current-effect
+ stack-visitor get
] with-scope ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
-stack-checker stack-checker.transforms ;
+stack-checker stack-checker.transforms words ;
IN: stack-checker.call-effect
! call( and execute( have complex expansions.
\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
+\ call-effect-slow t "no-compile" set-word-prop
+
: call-effect-fast ( quot effect inline-cache -- )
2over call-effect-unsafe?
[ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
]
] 0 define-transform
+\ call-effect t "no-compile" set-word-prop
+
: execute-effect-slow ( word effect -- )
[ '[ _ execute ] ] dip call-effect-slow ; inline
inline-cache new '[ _ _ execute-effect-ic ] ;
\ execute-effect [ execute-effect>quot ] 1 define-transform
+
+\ execute-effect t "no-compile" set-word-prop
\ No newline at end of file
: inference-warning ( ... class -- * )
+compiler-warning+ (inference-error) ; inline
+TUPLE: do-not-compile word ;
+
+: do-not-compile ( word -- * ) \ do-not-compile inference-warning ;
+
TUPLE: literal-expected what ;
: literal-expected ( what -- * ) \ literal-expected inference-warning ;
: missing-effect ( word -- * )
pretty-word \ missing-effect inference-error ;
-TUPLE: effect-error word inferred declared ;
+TUPLE: effect-error inferred declared ;
-: effect-error ( word inferred declared -- * )
+: effect-error ( inferred declared -- * )
\ effect-error inference-error ;
TUPLE: recursive-quotation-error quot ;
] "" make ;
M: effect-error summary
- [
- "Stack effect declaration of the word " %
- word>> name>> % " is wrong" %
- ] "" make ;
+ drop "Stack effect declaration is wrong" ;
M: recursive-quotation-error error.
"The quotation " write
dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
alien-callback
-} [ t "special" set-word-prop ] each
+} [
+ [ t "special" set-word-prop ]
+ [ t "no-compile" set-word-prop ] bi
+] each
+
+! Exceptions to the above
+\ curry f "no-compile" set-word-prop
+\ compose f "no-compile" set-word-prop
+
+! More words not to compile
+\ call t "no-compile" set-word-prop
+\ call subwords [ t "no-compile" set-word-prop ] each
+
+\ execute t "no-compile" set-word-prop
+\ execute subwords [ t "no-compile" set-word-prop ] each
+
+\ effective-method t "no-compile" set-word-prop
+\ effective-method subwords [ t "no-compile" set-word-prop ] each
\ clear t "no-compile" set-word-prop
{ [ dup "primitive" word-prop ] [ infer-primitive ] }
{ [ dup "transform-quot" word-prop ] [ apply-transform ] }
{ [ dup "macro" word-prop ] [ apply-macro ] }
- { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
- { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
{ [ dup local? ] [ infer-local-reader ] }
{ [ dup local-reader? ] [ infer-local-reader ] }
{ [ dup local-writer? ] [ infer-local-writer ] }
{ [ dup local-word? ] [ infer-local-word ] }
- { [ dup recursive-word? ] [ call-recursive-word ] }
- [ dup infer-word apply-word/effect ]
+ [ infer-word ]
} cond ;
: define-primitive ( word inputs outputs -- )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences kernel sequences assocs
namespaces stack-checker.recursive-state.tree ;
IN: stack-checker.recursive-state
-TUPLE: recursive-state word words quotations inline-words ;
-
-: prepare-recursive-state ( word rstate -- rstate )
- swap >>word
- f >>quotations
- f >>inline-words ; inline
+TUPLE: recursive-state word quotations inline-words ;
: initial-recursive-state ( word -- state )
recursive-state new
- f >>words
- prepare-recursive-state ; inline
+ swap >>word
+ f >>quotations
+ f >>inline-words ; inline
f initial-recursive-state recursive-state set-global
-: add-recursive-state ( word -- rstate )
- recursive-state get clone
- [ word>> dup ] keep [ store ] change-words
- prepare-recursive-state ;
-
-: add-local-quotation ( recursive-state quot -- rstate )
+: add-local-quotation ( rstate quot -- rstate )
swap clone [ dupd store ] change-quotations ;
: add-inline-word ( word label -- rstate )
swap recursive-state get clone
[ store ] change-inline-words ;
-: recursive-word? ( word -- ? )
- recursive-state get 2dup word>> eq?
- [ 2drop t ] [ words>> lookup ] if ;
-
: inline-recursive-label ( word -- label/f )
recursive-state get inline-words>> lookup ;
"The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
} ;
-
HELP: infer
{ $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } }
{ $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
{ infer infer. } related-words
-
-HELP: forget-errors
-{ $description "Removes markers indicating which words do not have stack effects."
-$nl
-"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
-{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
-{ $code "forget-errors" }
-"Subsequent invocations of the compiler will consider all words for compilation." } ;
system compiler.units ;
IN: stack-checker.tests
-\ infer. must-infer
+[ 1234 infer ] must-fail
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
{ 1 1 } [ simple-recursion-2 ] must-infer-as
-: bad-recursion-2 ( obj -- obj )
- dup [ dup first swap second bad-recursion-2 ] [ ] if ;
-
-[ [ bad-recursion-2 ] infer ] must-fail
-
: funny-recursion ( obj -- obj )
dup [ funny-recursion 1 ] [ 2 ] if drop ;
over string? [ 2array throw ] unless
] must-infer-as
-! Regression
-
-! This order of branches works
-DEFER: do-crap
-: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
-: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
-[ [ do-crap ] infer ] must-fail
-
-! This one does not
-DEFER: do-crap*
-: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
-: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
-[ [ do-crap* ] infer ] must-fail
-
! Regression
: too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
{ 2 1 } [ too-deep ] must-infer-as
-! Error reporting is wrong
-MATH: xyz ( a b -- c )
-M: fixnum xyz 2array ;
-M: float xyz
- [ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ;
-
-[ [ xyz ] infer ] [ inference-error? ] must-fail-with
-
-! Doug Coleman discovered this one while working on the
-! calendar library
-DEFER: A
-DEFER: B
-DEFER: C
-
-: A ( a -- )
- dup {
- [ drop ]
- [ A ]
- [ \ A no-method ]
- [ dup C A ]
- } dispatch ;
-
-: B ( b -- )
- dup {
- [ C ]
- [ B ]
- [ \ B no-method ]
- [ dup B B ]
- } dispatch ;
-
-: C ( c -- )
- dup {
- [ A ]
- [ C ]
- [ \ C no-method ]
- [ dup B C ]
- } dispatch ;
-
-{ 1 0 } [ A ] must-infer-as
-{ 1 0 } [ B ] must-infer-as
-{ 1 0 } [ C ] must-infer-as
-
-! I found this bug by thinking hard about the previous one
-DEFER: Y
-: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
-: Y ( a b -- c d ) X ;
-
-{ 2 2 } [ X ] must-infer-as
-{ 2 2 } [ Y ] must-infer-as
-
-! This one comes from UI code
-DEFER: #1
-: #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline
-: #3 ( a -- ) [ #1 ] #2 ;
-: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
-: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
-
-[ \ #4 def>> infer ] must-fail
-[ [ #1 ] infer ] must-fail
-
-! Similar
-DEFER: bar
-: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
-: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
-
-[ [ foo ] infer ] must-fail
-
-[ 1234 infer ] must-fail
-
! This used to hang
[ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
[ inference-error? ] must-fail-with
-! This form should not have a stack effect
-
-: bad-recursion-1 ( a -- b )
- dup [ drop bad-recursion-1 5 ] [ ] if ;
-
-[ [ bad-recursion-1 ] infer ] must-fail
-
-: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
-[ [ bad-bin ] infer ] must-fail
-
[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
! Regression
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
-! Test number protocol
-\ bitor must-infer
-\ bitand must-infer
-\ bitxor must-infer
-\ mod must-infer
-\ /i must-infer
-\ /f must-infer
-\ /mod must-infer
-\ + must-infer
-\ - must-infer
-\ * must-infer
-\ / must-infer
-\ < must-infer
-\ <= must-infer
-\ > must-infer
-\ >= must-infer
-\ number= must-infer
-
-! Test object protocol
-\ = must-infer
-\ clone must-infer
-\ hashcode* must-infer
-
-! Test sequence protocol
-\ length must-infer
-\ nth must-infer
-\ set-length must-infer
-\ set-nth must-infer
-\ new must-infer
-\ new-resizable must-infer
-\ like must-infer
-\ lengthen must-infer
-
-! Test assoc protocol
-\ at* must-infer
-\ set-at must-infer
-\ new-assoc must-infer
-\ delete-at must-infer
-\ clear-assoc must-infer
-\ assoc-size must-infer
-\ assoc-like must-infer
-\ assoc-clone-like must-infer
-\ >alist must-infer
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
-! Test some random library words
-\ 1quotation must-infer
-\ string>number must-infer
-\ get must-infer
-
-\ push must-infer
-\ append must-infer
-\ peek must-infer
-
-\ reverse must-infer
-\ member? must-infer
-\ remove must-infer
-\ natural-sort must-infer
-
-\ forget must-infer
-\ define-class must-infer
-\ define-tuple-class must-infer
-\ define-union-class must-infer
-\ define-predicate-class must-infer
-\ instance? must-infer
-\ next-method-quot must-infer
-
! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
-\ dispose must-infer
-
-! Test stream protocol
-\ set-timeout must-infer
-\ stream-read must-infer
-\ stream-read1 must-infer
-\ stream-readln must-infer
-\ stream-read-until must-infer
-\ stream-write must-infer
-\ stream-write1 must-infer
-\ stream-nl must-infer
-\ stream-flush must-infer
-
-! Test stream utilities
-\ lines must-infer
-\ contents must-infer
-
-! Test prettyprinting
-\ . must-infer
-\ short. must-infer
-\ unparse must-infer
-
-\ describe must-infer
-\ error. must-infer
-
-! Test odds and ends
-\ io-thread must-infer
-
-! Incorrect stack declarations on inline recursive words should
-! be caught
-: fooxxx ( a b -- c ) over [ foo ] when ; inline
-: barxxx ( a b -- c ) fooxxx ;
-
-[ [ barxxx ] infer ] must-fail
-
! A typo
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
-
DEFER: an-inline-word
: normal-word-3 ( -- )
[ custom-error inference-error ] infer
] unit-test
-[ T{ effect f 1 2 t } ] [
+[ T{ effect f 1 1 t } ] [
[ dup [ 3 throw ] dip ] infer
] unit-test
! Regression
-: missing->r-check ( a -- ) 1 load-locals ;
-
-[ [ missing->r-check ] infer ] must-fail
+[ [ 1 load-locals ] infer ] must-fail
! Corner case
[ [ [ f dup ] [ dup ] produce ] infer ] must-fail
[ [ [ f dup ] [ ] while ] infer ] must-fail
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
-
[ [ erg's-inference-bug ] infer ] must-fail
-
-: inference-invalidation-a ( -- ) ;
-: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
-: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
-
-[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
-
-{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
-
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" (( -- )) eval ] unit-test
-
-[ 3 ] [ inference-invalidation-c ] unit-test
-
-{ 0 1 } [ inference-invalidation-c ] must-infer-as
-
-GENERIC: inference-invalidation-d ( obj -- )
-
-M: object inference-invalidation-d inference-invalidation-c 2drop ;
-
-\ inference-invalidation-d must-infer
-
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" (( -- )) eval ] unit-test
-
-[ [ inference-invalidation-d ] infer ] must-fail
+FORGET: erg's-inference-bug
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
[ [ bad-recursion-3 ] infer ] must-fail
+FORGET: bad-recursion-3
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
[ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
+FORGET: unbalanced-retain-usage
+
DEFER: eee'
: ddd' ( ? -- ) [ f eee' ] when ; inline recursive
: eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
[ forget-test ] must-infer
[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
[ forget-test ] must-infer
+
+[ [ cond ] infer ] must-fail
+[ [ bi ] infer ] must-fail
+[ at ] must-infer
\ No newline at end of file
#! Safe to call from inference transforms.
infer effect>string print ;
-: forget-errors ( -- )
- all-words [
- dup subwords [ f "cannot-infer" set-word-prop ] each
- f "cannot-infer" set-word-prop
- ] each ;
-
-: forget-effects ( -- )
- forget-errors
- all-words [
- dup subwords [ f "inferred-effect" set-word-prop ] each
- f "inferred-effect" set-word-prop
- ] each ;
-
"stack-checker.call-effect" require
\ No newline at end of file
: init-inference ( -- )
terminated? off
V{ } clone \ meta-d set
+ V{ } clone \ meta-r set
V{ } clone literals set
0 d-in set ;
: depends-on-generic ( generic class -- )
generic-dependencies get dup
[ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
-
-! Words we've inferred the stack effect of, for rollback
-SYMBOL: recorded
quotations stack-checker stack-checker.errors accessors combinators words arrays
classes classes.tuple ;
+: compose-n ( quot n -- ) "OOPS" throw ;
+
+<<
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
-: compose-n ( quot n -- ) compose-n-quot call ;
\ compose-n [ compose-n-quot ] 2 define-transform
+\ compose-n t "no-compile" set-word-prop
+>>
+
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.transforms
-: give-up-transform ( word -- )
- {
- { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
- { [ dup recursive-word? ] [ call-recursive-word ] }
- [ dup infer-word apply-word/effect ]
- } cond ;
-
: call-transformer ( word stack quot -- newquot )
'[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
[ transform-expansion-error ]
word inlined-dependency depends-on
values [ length meta-d shorten-by ] [ #drop, ] bi
rstate infer-quot
- ] [ word give-up-transform ] if* ;
+ ] [ word infer-word ] if* ;
: literals? ( values -- ? ) [ literal-value? ] all? ;
[ first literal recursion>> ] tri
] if
((apply-transform))
- ] [ 2drop give-up-transform ] if ;
+ ] [ 2drop infer-word ] if ;
: apply-transform ( word -- )
[ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
! Combinators
\ cond [ cond>quot ] 1 define-transform
+\ cond t "no-compile" set-word-prop
+
\ case [
[
[ no-case ]
] if-empty
] 1 define-transform
+\ case t "no-compile" set-word-prop
+
\ cleave [ cleave>quot ] 1 define-transform
+\ cleave t "no-compile" set-word-prop
+
\ 2cleave [ 2cleave>quot ] 1 define-transform
+\ 2cleave t "no-compile" set-word-prop
+
\ 3cleave [ 3cleave>quot ] 1 define-transform
+\ 3cleave t "no-compile" set-word-prop
+
\ spread [ spread>quot ] 1 define-transform
+\ spread t "no-compile" set-word-prop
+
\ (call-next-method) [
[
[ "method-class" word-prop ]
] bi
] 1 define-transform
+\ (call-next-method) t "no-compile" set-word-prop
+
! Constructors
\ boa [
dup tuple-class? [
] [ drop f ] if
] 1 define-transform
+\ boa t "no-compile" set-word-prop
+M\ tuple-class boa t "no-compile" set-word-prop
+
\ new [
dup tuple-class? [
dup inlined-dependency depends-on
calendar urls xml.writer ;
IN: syndication.tests
-\ download-feed must-infer
-\ feed>xml must-infer
-
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
[ 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 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 )
[
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.crossref ;
IN: tools.continuations
<PRIVATE
-USING: help.markup help.syntax words definitions prettyprint ;
+USING: help.markup help.syntax words definitions prettyprint
+tools.crossref.private math quotations assocs kernel ;
IN: tools.crossref
-ARTICLE: "tools.crossref" "Cross-referencing tools"
+ARTICLE: "tools.crossref" "Definition cross referencing"
+"Definitions can answer a sequence of definitions they directly depend on:"
+{ $subsection uses }
+"An inverted index of the above:"
+{ $subsection get-crossref }
+"Words to access it:"
+{ $subsection usage }
+{ $subsection smart-usage }
+"Tools for interactive use:"
{ $subsection usage. }
+{ $subsection vocab-uses. }
+{ $subsection vocab-usage. }
{ $see-also "definitions" "words" "see" } ;
ABOUT: "tools.crossref"
+HELP: uses
+{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
+{ $description "Outputs a sequence of definitions directory called by the given definition." }
+{ $notes "The sequence might include the definition itself, if it is a recursive word." }
+{ $examples
+ "We can ask the " { $link sq } " word to produce a list of words it calls:"
+ { $unchecked-example "\ sq uses ." "{ dup * }" }
+} ;
+
+HELP: crossref
+{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } ". This variable is reset to " { $link f } " every time a definition is added or removed. Call " { $link get-crossref } " to lazily construct the graph instead of using this variable directly." } ;
+
+HELP: get-crossref
+{ $values { "crossref" assoc } }
+{ $description "Outputs the cross-referencing index, mapping definitions to usages, building it first if necessary." }
+{ $notes "This word is used to implement " { $link usage } " and " { $link usage. } "." } ;
+
+HELP: crossref-def
+{ $values { "defspec" "a definition specifier" } }
+{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." }
+$low-level-note ;
+
+HELP: usage
+{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
+{ $description "Outputs a sequence of definitions that directly call the given definition." }
+{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
+
HELP: usage.
{ $values { "word" "a word" } }
{ $description "Prints an list of all callers of a word. This may include the word itself, if it is recursive." }
{ $examples { $code "\\ reverse usage." } } ;
+HELP: quot-uses
+{ $values { "obj" object } { "assoc" "an assoc with words as keys" } }
+{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ;
+
{ usage usage. } related-words
USING: math kernel sequences io.files io.pathnames
tools.crossref tools.test parser namespaces source-files generic
-definitions ;
+definitions words accessors compiler.units ;
IN: tools.crossref.tests
GENERIC: foo ( a b -- c )
[ t ] [ integer \ foo method \ + usage member? ] unit-test
[ t ] [ \ foo usage [ pathname? ] any? ] unit-test
+
+! Issues with forget
+GENERIC: generic-forget-test-1 ( a b -- c )
+
+M: integer generic-forget-test-1 / ;
+
+[ t ] [
+ \ / usage [ word? ] filter
+ [ name>> "integer=>generic-forget-test-1" = ] any?
+] unit-test
+
+[ ] [
+ [ \ generic-forget-test-1 forget ] with-compilation-unit
+] unit-test
+
+[ f ] [
+ \ / usage [ word? ] filter
+ [ name>> "integer=>generic-forget-test-1" = ] any?
+] unit-test
+
+GENERIC: generic-forget-test-2 ( a b -- c )
+
+M: sequence generic-forget-test-2 = ;
+
+[ t ] [
+ \ = usage [ word? ] filter
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
+] unit-test
+
+[ ] [
+ [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit
+] unit-test
+
+[ f ] [
+ \ = usage [ word? ] filter
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
+] unit-test
\ No newline at end of file
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs definitions io io.styles kernel prettyprint
-sorting see ;
+USING: words assocs definitions io io.pathnames io.styles kernel
+prettyprint sorting see sets sequences arrays hashtables help.crossref
+help.topics help.markup quotations accessors source-files namespaces
+graphs vocabs generic generic.standard.engines.tuple threads
+compiler.units init ;
IN: tools.crossref
+SYMBOL: crossref
+
+GENERIC: uses ( defspec -- seq )
+
+<PRIVATE
+
+SYMBOL: visited
+
+GENERIC# quot-uses 1 ( obj assoc -- )
+
+M: object quot-uses 2drop ;
+
+M: word quot-uses over crossref? [ conjoin ] [ 2drop ] if ;
+
+: (seq-uses) ( seq assoc -- )
+ [ quot-uses ] curry each ;
+
+: seq-uses ( seq assoc -- )
+ over visited get memq? [ 2drop ] [
+ over visited get push
+ (seq-uses)
+ ] if ;
+
+: assoc-uses ( assoc' assoc -- )
+ over visited get memq? [ 2drop ] [
+ over visited get push
+ [ >alist ] dip (seq-uses)
+ ] if ;
+
+M: array quot-uses seq-uses ;
+
+M: hashtable quot-uses assoc-uses ;
+
+M: callable quot-uses seq-uses ;
+
+M: wrapper quot-uses [ wrapped>> ] dip quot-uses ;
+
+M: callable uses ( quot -- assoc )
+ V{ } clone visited [
+ H{ } clone [ quot-uses ] keep keys
+ ] with-variable ;
+
+M: word uses def>> uses ;
+
+M: link uses { $subsection $link $see-also } article-links ;
+
+M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ;
+
+GENERIC: crossref-def ( defspec -- )
+
+M: object crossref-def
+ dup uses crossref get add-vertex ;
+
+M: word crossref-def
+ [ call-next-method ] [ subwords [ crossref-def ] each ] bi ;
+
+: build-crossref ( -- crossref )
+ "Computing usage index... " write flush yield
+ H{ } clone crossref [
+ all-words
+ source-files get keys [ <pathname> ] map
+ [ [ crossref-def ] each ] bi@
+ crossref get
+ ] with-variable
+ "done" print flush ;
+
+: get-crossref ( -- crossref )
+ crossref global [ drop build-crossref ] cache ;
+
+GENERIC: irrelevant? ( defspec -- ? )
+
+M: object irrelevant? drop f ;
+
+M: default-method irrelevant? drop t ;
+
+M: engine-word irrelevant? drop t ;
+
+PRIVATE>
+
+: usage ( defspec -- seq ) get-crossref at keys ;
+
+GENERIC: smart-usage ( defspec -- seq )
+
+M: object smart-usage usage [ irrelevant? not ] filter ;
+
+M: method-body smart-usage "method-generic" word-prop smart-usage ;
+
+M: f smart-usage drop \ f smart-usage ;
+
: synopsis-alist ( definitions -- alist )
[ [ synopsis ] keep ] { } map>assoc ;
: usage. ( word -- )
smart-usage sorted-definitions. ;
+
+: vocab-xref ( vocab quot -- vocabs )
+ [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
+ [
+ [ [ word? ] [ generic? not ] bi and ] filter [
+ dup method-body?
+ [ "method-generic" word-prop ] when
+ vocabulary>>
+ ] map
+ ] gather natural-sort remove sift ; inline
+
+: vocabs. ( seq -- )
+ [ dup >vocab-link write-object nl ] each ;
+
+: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
+
+: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;
+
+: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
+
+: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;
+
+<PRIVATE
+
+SINGLETON: invalidate-crossref
+
+M: invalidate-crossref definitions-changed 2drop crossref global delete-at ;
+
+[ invalidate-crossref add-definition-observer ] "tools.crossref" add-init-hook
+
+PRIVATE>
\ No newline at end of file
QUALIFIED: init
QUALIFIED: layouts
QUALIFIED: source-files
+QUALIFIED: source-files.errors
QUALIFIED: vocabs
IN: tools.deploy.shaker
{
"alias"
"boa-check"
- "cannot-infer"
"coercer"
"combination"
- "compiled-status"
"compiled-generic-uses"
"compiled-uses"
"constraints"
"identities"
"if-intrinsics"
"infer"
- "inferred-effect"
"inline"
"inlined-block"
"input-classes"
compiled-crossref
compiled-generic-crossref
compiler-impl
+ compiler.errors:compiler-errors
definition-observers
- definitions:crossref
interactive-vocabs
layouts:num-tags
layouts:num-types
lexer-factory
print-use-hook
root-cache
+ source-files.errors:error-types
vocabs:dictionary
vocabs:load-vocab-hook
word
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
- [ save-image-and-exit ] call-clear ;
+ save-image-and-exit ;
SYMBOL: deploy-vocab
: 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
IN: tools.errors
-USING: help.markup help.syntax source-files.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" } }
--- /dev/null
+USING: compiler.errors stack-checker.errors tools.test words ;
+IN: tools.errors
+
+DEFER: blah
+
+[ ] [
+ {
+ T{ compiler-error
+ { error
+ T{ inference-error
+ f
+ T{ do-not-compile f blah }
+ +compiler-error+
+ blah
+ }
+ }
+ { asset blah }
+ }
+ } errors.
+] unit-test
\ No newline at end of file
! 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 ;
+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 summary
- error>> summary ;
-
M: source-file-error compute-restarts
error>> compute-restarts ;
M: source-file-error error-help
error>> error-help ;
-M: source-file-error error.
+CONSTANT: +listener-input+ "<Listener input>"
+
+M: source-file-error summary
[
- [
- [
- [ file>> [ % ": " % ] when* ]
- [ line#>> [ # "\n" % ] when* ] bi
- ] "" make
- ] [
- [
- presented set
- bold font-style set
- ] H{ } make-assoc
- ] bi format
- ] [ error>> error. ] bi ;
+ [ 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 "==== " write +listener-input+ or 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. ;
+
+M: not-compiled summary
+ word>> name>> "The word " " cannot be executed because it failed to compile" surround ;
+
+M: not-compiled error.
+ [ summary print nl ] [ error>> error. ] bi ;
\ 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
USING: tools.test tools.memory ;
IN: tools.memory.tests
-\ room. must-infer
[ ] [ room. ] unit-test
-
-\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test
-USING: tools.profiler.private tools.time help.markup help.syntax
-quotations io strings words definitions ;
+USING: tools.profiler.private tools.time tools.crossref
+help.markup help.syntax quotations io strings words definitions ;
IN: tools.profiler
ARTICLE: "profiler-limitations" "Profiler limitations"
{ $subsection vocabs-profile. }
{ $subsection method-profile. }
{ $subsection "profiler-limitations" }
-{ $see-also "ui-profiler" } ;
+{ $see-also "ui.tools.profiler" } ;
ABOUT: "profiling"
[ 1 ] [ \ foobar counter>> ] unit-test
-: fooblah ( -- ) { } [ ] like call ;
+: fooblah ( -- ) { } [ ] like call( -- ) ;
: foobaz ( -- ) fooblah fooblah ;
USING: accessors words sequences math prettyprint kernel arrays io
io.styles namespaces assocs kernel.private strings combinators
sorting math.parser vocabs definitions tools.profiler.private
-continuations generic compiler.units sets classes fry ;
+tools.crossref continuations generic compiler.units sets classes fry ;
IN: tools.profiler
: profile ( quot -- )
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 ;
{ $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ;
HELP: must-infer
-{ $values { "word/quot" "a quotation or a word" } }
-{ $description "Ensures that the quotation or word has a static stack effect without running it." }
+{ $values { "quot" quotation } }
+{ $description "Ensures that the quotation has a static stack effect without running it." }
{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ;
HELP: must-infer-as
IN: tools.test.tests
-USING: tools.test ;
+USING: tools.test tools.test.private namespaces kernel sequences ;
-\ test-all must-infer
+: fake-unit-test ( quot -- )
+ [
+ "fake" file set
+ V{ } clone test-failures set
+ call
+ test-failures get
+ ] with-scope ; inline
+
+[ 1 ] [
+ [
+ [ "OOPS" ] must-fail
+ ] fake-unit-test length
+] unit-test
\ No newline at end of file
f file get f failure ;
:: (unit-test) ( output input -- error ? )
- [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; inline
+ [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ;
: short-effect ( effect -- pair )
[ in>> length ] [ out>> length ] bi 2array ;
:: (must-infer-as) ( effect quot -- error ? )
- [ quot infer short-effect effect assert= f f ] [ t ] recover ; inline
+ [ quot infer short-effect effect assert= f f ] [ t ] recover ;
-:: (must-infer) ( word/quot -- error ? )
- word/quot dup word? [ '[ _ execute ] ] when :> quot
- [ quot infer drop f f ] [ t ] recover ; inline
+:: (must-infer) ( quot -- error ? )
+ [ quot infer drop f f ] [ t ] recover ;
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
+ [ { } quot with-datastack drop did-not-fail t ]
+ [ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover ;
:: (must-fail) ( quot -- error ? )
- [ quot call did-not-fail t ] [ drop f f ] recover ; inline
+ [ { } quot with-datastack drop did-not-fail t ] [ drop f f ] recover ;
: experiment-title ( word -- string )
"(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;
TEST: must-fail-with
TEST: must-fail
-M: test-failure summary
- asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ;
-
M: test-failure error. ( error -- )
- [ call-next-method ]
- [ traceback-button. ]
- bi ;
+ {
+ [ summary print nl ]
+ [ asset>> [ experiment. nl ] when* ]
+ [ error>> error. ]
+ [ traceback-button. ]
+ } cleave ;
: :test-failures ( -- ) test-failures get errors. ;
sets accessors generic definitions words ;\r
IN: tools.vocabs\r
\r
-: vocab-xref ( vocab quot -- vocabs )\r
- [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map\r
- [\r
- [ [ word? ] [ generic? not ] bi and ] filter [\r
- dup method-body?\r
- [ "method-generic" word-prop ] when\r
- vocabulary>>\r
- ] map\r
- ] gather natural-sort remove sift ; inline\r
-\r
-: vocabs. ( seq -- )\r
- [ dup >vocab-link write-object nl ] each ;\r
-\r
-: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;\r
-\r
-: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;\r
-\r
-: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;\r
-\r
-: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;\r
-\r
: vocab-tests-file ( vocab -- path )\r
dup "-tests.factor" vocab-dir+ vocab-append-path dup\r
[ dup exists? [ drop f ] unless ] [ drop f ] if ;\r
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
IN: ui.event-loop.tests
USING: ui.event-loop tools.test ;
-
-\ event-loop must-infer
IN: ui.gadgets.books.tests
USING: tools.test ui.gadgets.books ;
-
-\ <book> must-infer
} <radio-buttons> "religion" set
] unit-test
-\ <radio-buttons> must-infer
-
-\ <checkbox> must-infer
-
[ 0 ] [
"religion" get gadget-child value>>
] unit-test
] with-grafted-gadget
] unit-test
-\ <editor> must-infer
-
"hello" <model> <model-field> "field" set
"field" get [
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
] with-string-writer print
-
-\ <gadget> must-infer
-\ unparent must-infer
-\ add-gadget must-infer
-\ add-gadgets must-infer
-\ clear-gadget must-infer
-
-\ relayout must-infer
-\ relayout-1 must-infer
-\ pref-dim must-infer
-
-\ graft* must-infer
-\ ungraft* must-infer
\ 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>
[ { 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
model>> dependencies>> [ range-max value>> ] map
{ 0 0 } =
] unit-test
-
-\ <scroller> must-infer
IN: ui.gestures.tests
USING: tools.test ui.gestures ;
-
-\ handle-gesture must-infer
-\ send-queued-gesture must-infer
\ No newline at end of file
[ ] [
[ { $operations \ + } print-element ] with-string-writer drop
] unit-test
-
-\ object-operations must-infer
\ No newline at end of file
IN: ui.render.tests
USING: ui.render tools.test ;
-
-\ draw-gadget must-infer
\ No newline at end of file
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."
IN: ui.tools.browser.tests
USING: tools.test ui.gadgets.debug ui.tools.browser math ;
-\ <browser-gadget> must-infer
[ ] [ \ + <browser-gadget> [ ] with-grafted-gadget ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs definitions fry help.topics kernel
colors.constants math.rectangles models.arrow namespaces sequences
-sorting definitions.icons ui.gadgets ui.gadgets.glass
+sorting definitions.icons tools.crossref ui.gadgets ui.gadgets.glass
ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables
ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations
ui.pens.solid ui.images ;
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
+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 ;
+ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener
+compiler.errors calendar tools.errors ;
IN: ui.tools.error-list
CONSTANT: source-file-icon
: <error-toggle> ( -- model gadget )
#! Linkage errors are not shown by default.
- error-types get keys [ dup +linkage-error+ eq? not <model> ] { } map>assoc
+ error-types get [ fatal?>> <model> ] assoc-map
[ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
[ <mapping> ] bi ;
M: source-file-renderer row-columns
drop first2 [
[ source-file-icon ]
- [ "<Listener input>" or ]
+ [ +listener-input+ or ]
[ length number>string ] tri*
] output>array ;
{
[ error-type error-icon ]
[ line#>> [ number>string ] [ "" ] if* ]
- [ asset>> unparse-short ]
+ [ asset>> [ unparse-short ] [ "" ] if* ]
[ error>> summary ]
} cleave
] output>array ;
M: error-renderer column-alignment drop { 0 1 0 0 } ;
: sort-errors ( seq -- seq' )
- [ [ [ asset>> unparse-short ] [ line#>> ] bi 2array ] keep ] { } map>assoc
+ [ [ [ line#>> ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc
sort-keys values ;
: file-matches? ( error pathname/f -- ? )
IN: ui.tools.inspector.tests
USING: tools.test ui.tools.inspector math models ;
-\ <inspector-gadget> must-infer
-
[ ] [ \ + <model> <inspector-gadget> com-edit-slot ] unit-test
\ No newline at end of file
calendar concurrency.promises io ui.tools.common ;
IN: ui.tools.listener.tests
-\ <interactor> must-infer
-
[
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
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.error-list ;
+ui.tools.listener.history ui.tools.error-list ui.images ;
FROM: source-files.errors => all-errors ;
IN: ui.tools.listener
: interactor-busy? ( interactor -- ? )
#! We're busy if there's no thread to resume.
- [ waiting>> ]
- [ thread>> dup [ thread-registered? ] when ]
- bi and not ;
+ {
+ [ waiting>> ]
+ [ thread>> dup [ thread-registered? ] when ]
+ } 1&& not ;
SLOT: vocabs
over set-caret
mark>caret ;
-TUPLE: listener-gadget < tool input output scroller ;
+TUPLE: listener-gadget < tool error-summary output scroller input ;
{ 600 700 } listener-gadget set-tool-dim
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
-: init-listener ( listener -- listener )
+: init-input/output ( listener -- listener )
<interactor>
[ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
dup listener-streams >>output drop ;
-: <listener-gadget> ( -- gadget )
+: <error-summary> ( -- gadget )
+ <pane> COLOR: light-yellow <solid> >>interior ;
+
+: init-error-summary ( listener -- listener )
+ <error-summary> >>error-summary
+ dup error-summary>> f track-add ;
+
+: <listener-gadget> ( -- listener )
vertical listener-gadget new-track
add-toolbar
- init-listener
+ init-input/output
dup output>> <scroller> >>scroller
- dup scroller>> 1 track-add ;
+ dup scroller>> 1 track-add
+ init-error-summary ;
M: listener-gadget focusable-child*
input>> dup popup>> or ;
{ T{ key-down f { C+ } "r" } history-completion-popup }
} define-command-map
-: ui-error-summary ( -- )
- all-errors [
- [ error-type ] map prune
- [ error-icon-path 1array \ $image prefix " " 2array ] { } map-as
- { "Press " { $command tool "common" show-error-list } " to view errors." }
- append print-element nl
- ] unless-empty ;
+: error-summary. ( listener -- )
+ error-summary>> [
+ error-counts keys [
+ H{ { table-gap { 3 3 } } } [
+ [ [ [ icon>> write-image ] with-cell ] each ] with-row
+ ] tabular-output
+ { "Press " { $command tool "common" show-error-list } " to view errors." }
+ print-element
+ ] unless-empty
+ ] with-pane ;
: 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
+ [ '[ [ _ input>> ] 2dip debugger-popup ] error-hook set ]
+ [ '[ _ error-summary. ] error-summary-hook set ] bi
tip-of-the-day. nl
listener
] with-streams* ;
IN: ui.tools.profiler
-USING: help.markup help.syntax ui.operations help.tips ;
+USING: help.markup help.syntax ui.operations ui.commands help.tips ;
-ARTICLE: "ui.tools.profiler" "UI profiler tool"
+ARTICLE: "ui.tools.profiler" "UI profiler tool"
"The " { $vocab-link "ui.tools.profiler" } " vocabulary implements a graphical tool for viewing profiling results (see " { $link "profiling" } ")."
$nl
-"To use the profiler, enter a piece of code in the listener's input area and press " { $operation com-profile } "." ;
+"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
+$nl
+"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring."
+$nl
+"Consult " { $link "profiling" } " for details about the profiler itself." ;
TIP: "Press " { $operation com-profile } " to run the code in the input field with profiling enabled (" { $link "ui.tools.profiler" } ")." ;
USING: ui.tools.profiler tools.test ;
-\ profiler-window must-infer
+
$nl
"For more about presentation gadgets, see " { $link "ui.gadgets.presentations" } "." ;
-ARTICLE: "ui-profiler" "UI profiler"
-"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
-$nl
-"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
-$nl
-"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring."
-$nl
-"Consult " { $link "profiling" } " for details about the profiler itself."
-{ $command-map profiler-gadget "toolbar" }
-"The profiler is an instance of " { $link profiler-gadget } "." ;
-
ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X"
"On Mac OS X, the Factor UI offers additional features which integrate with this operating system."
$nl
USING: ui.tools.walker tools.test ;
IN: ui.tools.walker.tests
-\ <walker-gadget> must-infer
IN: ui.tests
USING: ui ui.private tools.test ;
-
-\ open-window must-infer
-\ update-ui must-infer
\ No newline at end of file
[ concat [ quot call [ "" like ] map ] curry ] bi unit-test
] each ;
-: grapheme-test ( tests quot -- )
+: grapheme-test ( tests -- )
[
[ 1quotation ]
[ concat [ >graphemes [ "" like ] map ] curry ] bi unit-test
unicode.case.private ;
IN: unicode.case.tests
-\ >upper must-infer
-\ >lower must-infer
-\ >title must-infer
-
[ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test
[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
: test-two ( str1 str2 -- )\r
[ +lt+ ] -rot [ string<=> ] 2curry unit-test ;\r
\r
-: test-equality ( str1 str2 -- )\r
+: test-equality ( str1 str2 -- ? ? ? ? )\r
{ primary= secondary= tertiary= quaternary= }\r
- [ execute ] with with each ;\r
+ [ execute( a b -- ? ) ] with with map\r
+ first4 ;\r
\r
[ f f f f ] [ "hello" "hi" test-equality ] unit-test\r
[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test\r
locals math quotations assocs combinators unicode.normalize.private ;
IN: unicode.normalize.tests
-{ nfc nfkc nfd nfkd } [ must-infer ] each
-
[ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test
[ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test
[ ] [ all-groups drop ] unit-test
-\ all-groups must-infer
-
[ t ] [ real-group-name string? ] unit-test
[ t ] [ effective-group-name string? ] unit-test
USING: tools.test unix.users kernel strings math ;
IN: unix.users.tests
-
[ ] [ all-users drop ] unit-test
-\ all-users must-infer
-
[ t ] [ real-user-name string? ] unit-test
[ t ] [ effective-user-name string? ] unit-test
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 ;
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
: (callbacks>vtbl) ( callbacks -- vtbl )
- [ execute ] void*-array{ } map-as malloc-byte-array ;
+ [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ;
: (callbacks>vtbls) ( callbacks -- vtbls )
[ (callbacks>vtbl) ] map ;
--- /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: GetCommTimeouts
! FUNCTION: GetComPlusPackageInstallStatus
! FUNCTION: GetCompressedFileSizeA
-! FUNCTION: GetCompressedFileSizeW
+FUNCTION: DWORD GetCompressedFileSizeW ( LPCTSTR lpFileName, LPDWORD lpFileSizeHigh ) ;
+ALIAS: GetCompressedFileSize GetCompressedFileSizeW
FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ;
ALIAS: GetComputerName GetComputerNameW
FUNCTION: BOOL GetComputerNameExW ( COMPUTER_NAME_FORMAT NameType, LPTSTR lpBuffer, LPDWORD lpnSize ) ;
! 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
[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test
[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
-\ wrap-string must-infer
-
[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test
} 35 35 wrap-words [ { } like ] map
] unit-test
-\ wrap-words must-infer
--- /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
: create-window-mask ( -- n )
- { CWColormap CWEventMask } flags ;
+ { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
: create-colormap ( visinfo -- colormap )
[ dpy get root get ] dip XVisualInfo-visual AllocNone
: 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
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 ; inline
+X-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ;
calc-arith
] unit-test
-\ calc-arith must-infer
-
XML-NS: foo http://blah.com
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
-\ <XML must-infer
[ [XML <-> XML] ] must-infer
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
IN: xml.test.state
: string-parse ( str quot -- )
- [ <string-reader> ] dip with-state ;
+ [ <string-reader> ] dip with-state ; inline
: take-rest ( -- string )
[ f ] take-until ;
sequences.deep accessors io.streams.string ;
! This is insufficient
-\ read-xml must-infer
[ [ drop ] each-element ] must-infer
-\ string>xml must-infer
SYMBOL: xml-file
[ ] [
xml-tests [ unit-test ] assoc-each ;
: works? ( result quot -- ? )
- [ first ] [ call ] bi* = ;
+ [ first ] [ call( -- result ) ] bi* = ;
: partition-xml-tests ( -- successes failures )
xml-tests [ first2 works? ] partition ;
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.data xml.writer tools.test fry xml kernel multiline
+USING: xml.data xml.writer tools.test fry xml xml.syntax kernel multiline
xml.writer.private io.streams.string xml.traversal sequences
-io.encodings.utf8 io.files accessors io.directories ;
+io.encodings.utf8 io.files accessors io.directories math math.parser ;
IN: xml.writer.tests
-\ write-xml must-infer
-\ xml>string must-infer
-\ pprint-xml must-infer
! Add a test for pprint-xml with sensitive-tags
[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
[ ] [ "<?xml version='1.0' encoding='UTF-16BE'?><x/>" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test
[ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test
[ ] [ test-file delete-file ] unit-test
+
+[ ] [
+ { 1 2 3 4 } [
+ [ number>string ] [ sq number>string ] bi
+ [XML <tr><td><-></td><td><-></td></tr> XML]
+ ] map [XML <h2>Timings</h2> <table><-></table> XML]
+ pprint-xml
+] unit-test
\ No newline at end of file
\r
: indent-string ( -- string )\r
xml-pprint? get\r
- [ indentation get indenter get <repetition> concat ]\r
+ [ indentation get indenter get <repetition> "" join ]\r
[ "" ] if ;\r
\r
: ?indent ( -- )\r
tools.test multiline splitting memoize
kernel io.streams.string xml.writer ;
-\ htmlize-file must-infer
-
[ ] [ \ (load-mode) reset-memoized ] unit-test
[ ] [
return 1;
}
+exit_script() {
+ if [[ $FIND_MAKE_TARGET -eq true ]] ; then
+ echo $MAKE_TARGET;
+ fi
+ exit $1
+}
+
ensure_program_installed() {
installed=0;
for i in $* ;
$ECHO -n "any of [ $* ]"
fi
$ECHO " and try again."
- exit 1
+ exit_script 1;
fi
}
RET=$?
if [[ $RET -ne 0 ]] ; then
$ECHO $1 failed
- exit 2
+ exit_script 2
fi
}
if [[ $GCC_VERSION == *3.3.* ]] ; then
$ECHO "You have a known buggy version of gcc (3.3)"
$ECHO "Install gcc 3.4 or higher and try again."
- exit 3
+ exit_script 3
elif [[ $GCC_VERSION == *4.3.* ]] ; then
MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate"
fi
if [[ -d "factor" ]] ; then
$ECHO "A directory called 'factor' already exists."
$ECHO "Rename or delete it and try again."
- exit 4
+ exit_script 4
fi
}
$ECHO "OS, ARCH, or WORD is empty. Please report this."
echo $MAKE_TARGET
- exit 5
+ exit_script 5
fi
}
echo "You are likely in the wrong directory."
echo "Run this script from your factor directory:"
echo " ./build-support/factor.sh"
- exit 6
+ exit_script 6
fi
}
bootstrap) get_config_info; bootstrap ;;
report) find_build_info ;;
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
- make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
+ make-target) FIND_MAKE_TARGET=true; ECHO=false; find_build_info; exit_script ;;
*) usage ;;
esac
"Creating primitives and basic runtime structures..." print flush
-crossref off
-
H{ } clone sub-primitives set
"vocab:bootstrap/syntax.factor" parse-file
IN: checksums.tests
USING: checksums tools.test ;
-\ checksum-bytes must-infer
-\ checksum-stream must-infer
-\ checksum-lines must-infer
-\ checksum-file must-infer
classes.tuple accessors ;\r
IN: classes.algebra.tests\r
\r
-\ class< must-infer\r
-\ class-and must-infer\r
-\ class-or must-infer\r
-\ flatten-class must-infer\r
-\ flatten-builtin-class must-infer\r
-\r
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
\r
: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
sequences strings tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files compiler.units
-kernel.private sorting vocabs memory eval accessors ;
+kernel.private sorting vocabs memory eval accessors sets ;
IN: classes.tests
[ t ] [ 3 object instance? ] unit-test
[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
-[ t ] [
+[ { } { } ] [
all-words [ class? ] filter
implementors-map get keys
- [ natural-sort ] bi@ =
+ [ natural-sort ] bi@
+ [ diff ] [ swap diff ] 2bi
] 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
[ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
[ reset-class ]
[ ?define-symbol ]
- [ redefined ]
+ [ changed-definition ]
[ ]
} cleave
] dip [ assoc-union ] curry change-props
[ 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
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 (( -- tuple )) eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
"T{ parsing-corner-case"
" { x 3 }"
"}"
- } "\n" join (( -- tuple )) eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
"T{ parsing-corner-case {"
" x 3 }"
"}"
- } "\n" join (( -- tuple )) eval
+ } "\n" join eval( -- tuple )
] unit-test
{
"USE: classes.tuple.parser.tests T{ parsing-corner-case"
" { x 3 }"
- } "\n" join (( -- tuple )) eval
+ } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
[
{
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
- } "\n" join (( -- tuple )) eval
+ } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting summary
columns math.order classes.private slots slots.private eval see
-words.symbol ;
+words.symbol compiler.errors ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
[ 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
! Make sure we handle changing shapes!
TUPLE: point x y ;
-C: <point> point
-
-[ ] [ 100 200 <point> "p" set ] unit-test
+[ ] [ 100 200 point boa "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
[ ] [ \ yo-momma forget ] unit-test
[ ] [ \ <yo-momma> forget ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] unit-test
-
- [ f ] [ \ yo-momma crossref get at ] unit-test
] with-compilation-unit
TUPLE: loc-recording ;
C: <erg's-reshape-problem> erg's-reshape-problem
-! We want to make sure constructors are recompiled when
-! tuples are reshaped
-: 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
-
-[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
-
-[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
-
! Inheritance
TUPLE: computer cpu ram ;
C: <computer> computer
] 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 ; C: <computer> computer C: <laptop> laptop C: <server> server" 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 ; C: <computer> computer C: <laptop> laptop C: <server> server" 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 ; C: <computer> computer C: <laptop> laptop C: <server> server" 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 ; C: <computer> computer C: <laptop> laptop C: <server> server" 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? ; C: <computer> computer" 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 ; C: <computer> computer C: <laptop> laptop C: <server> server" 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 ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
-C: <test2> test2
-
-"a" "b" <test2> "test" set
+"a" "b" test2 boa "test" set
: test-a/b ( -- )
[ "a" ] [ "test" get a>> ] unit-test
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 ;
TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
-C: <constructor-update-2> constructor-update-2
+: <constructor-update-2> ( a b c -- tuple ) constructor-update-2 boa ;
{ 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
+
+{ 3 1 } [ <constructor-update-2> ] must-infer-as
-{ 5 1 } [ <constructor-update-2> ] must-infer-as
+[ 1 2 3 4 5 <constructor-update-2> ] [ not-compiled? ] must-fail-with
-[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
+[ ] [ [ \ <constructor-update-2> forget ] with-compilation-unit ] unit-test
! Redefinition problem
TUPLE: redefinition-problem ;
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
[ 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
: foo ( a b -- c ) declared-types boa ;
-\ foo must-infer
+\ foo def>> must-infer
[ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
: blah ( -- vec ) vector new ;
-\ blah must-infer
+[ vector new ] must-infer
[ V{ } ] [ blah ] 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
2drop
[
[ update-tuples-after ]
- [ redefined ]
+ [ changed-definition ]
bi
] each-subclass
]
[ 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
{ $subsection "combinators.short-circuit" }
{ $subsection "combinators.smart" }
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
-$nl
-"The " { $vocab-link "combinators" } " provides some less frequently-used features."
-$nl
-"A combinator which can help with implementing methods on " { $link hashcode* } ":"
-{ $subsection recursive-hashcode }
{ $subsection "combinators-quot" }
-"Advanced topics:"
{ $see-also "quotations" } ;
ABOUT: "combinators"
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond ;
-\ cond-test-1 must-infer
+\ cond-test-1 def>> must-infer
[ "even" ] [ 2 cond-test-1 ] unit-test
[ "odd" ] [ 3 cond-test-1 ] unit-test
[ drop "something else" ]
} cond ;
-\ cond-test-2 must-infer
+\ cond-test-2 def>> must-infer
[ "true" ] [ t cond-test-2 ] unit-test
[ "false" ] [ f cond-test-2 ] unit-test
{ [ dup f = ] [ drop "false" ] }
} cond ;
-\ cond-test-3 must-infer
+\ cond-test-3 def>> must-infer
[ "something else" ] [ t cond-test-3 ] unit-test
[ "something else" ] [ f cond-test-3 ] unit-test
{
} cond ;
-\ cond-test-4 must-infer
+\ cond-test-4 def>> must-infer
[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
{ 4 [ "four" ] }
} case ;
-\ case-test-1 must-infer
+\ case-test-1 def>> must-infer
[ "two" ] [ 2 case-test-1 ] unit-test
[ sq ]
} case ;
-\ case-test-2 must-infer
+\ case-test-2 def>> must-infer
[ 25 ] [ 5 case-test-2 ] unit-test
[ sq ]
} case ;
-\ case-test-3 must-infer
+\ case-test-3 def>> must-infer
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
[ drop "demasiado" ]
} case ;
-\ case-test-4 must-infer
+\ case-test-4 def>> must-infer
[ "uno" ] [ 1 case-test-4 ] unit-test
[ "dos" ] [ 2 case-test-4 ] unit-test
[ drop "demasiado" print ]
} case ;
-\ case-test-5 must-infer
+\ case-test-5 def>> must-infer
[ ] [ 1 case-test-5 ] unit-test
{ 3 [ "three" ] }
} case ;
-\ test-case-6 must-infer
+\ test-case-6 def>> must-infer
[ "three" ] [ 3 test-case-6 ] unit-test
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
{ \ ] [ "KFC" ] }
} case ;
-\ test-case-7 must-infer
+\ test-case-7 def>> must-infer
[ "plus" ] [ \ + test-case-7 ] unit-test
{ $values { "alist" "an alist" } }
{ $description "Stores compiled code definitions in the code heap. The alist maps words to the following:"
{ $list
- { { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." }
- { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." }
+ { "a quotation - in this case, the quotation is compiled with the non-optimizing compiler and the word will call the quotation when executed." }
+ { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data and the word will call the code block when executed." }
} }
{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;
-USING: definitions compiler.units tools.test arrays sequences words kernel
+USING: compiler definitions compiler.units tools.test arrays sequences words kernel
accessors namespaces fry eval ;
IN: compiler.units.tests
! Non-optimizing compiler bugs
[ 1 1 ] [
- "A" "B" <word> [ [ 1 ] dip ] >>def dup f 2array 1array modify-code-heap
+ "A" "B" <word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
1 swap execute
] unit-test
[ "A" "B" ] [
+ disable-compiler
+
gensym "a" set
gensym "b" set
[
"a" get [ "B" ] define
] with-compilation-unit
"b" get execute
+
+ enable-compiler
] unit-test
-! Notify observers even if compilation unit did nothing
+! Check that we notify observers
SINGLETON: observer
observer add-definition-observer
M: observer definitions-changed 2drop global [ counter inc ] bind ;
-[ ] with-compilation-unit
+[ gensym [ ] (( -- )) define-declared ] with-compilation-unit
[ 1 ] [ counter get-global ] unit-test
DEFER: nesting-test
-[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" (( -- )) eval ] unit-test
+[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test
observer remove-definition-observer
HOOK: recompile compiler-impl ( words -- alist )
! Non-optimizing compiler
-M: f recompile [ f ] { } map>assoc ;
+M: f recompile [ dup def>> ] { } map>assoc ;
! Trivial compiler. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
update-tuples
process-forgotten-definitions
modify-code-heap
- updated-definitions notify-definition-observers
+ updated-definitions dup assoc-empty? [ drop ] [ notify-definition-observers ] if
notify-error-observers ;
: with-nested-compilation-unit ( quot -- )
gc
] unit-test
-[ f ] [ { } kernel-error? ] unit-test
-[ f ] [ { "A" "B" } kernel-error? ] unit-test
-
! ! See how well callstack overflow is handled
! [ clear drop ] must-fail
!
! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail
-: don't-compile-me ( n -- ) { } [ ] each ;
-
-: foo ( -- ) callstack "c" set 3 don't-compile-me ;
+: don't-compile-me ( -- ) ;
+: foo ( -- ) callstack "c" set don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ;
-[ 1 3 2 ] [ bar ] unit-test
+<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
+
+[ 1 2 ] [ bar ] unit-test
[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
-\ with-datastack must-infer
+[ with-datastack ] must-infer
{ $subsection set-where }
"Definitions can be removed:"
{ $subsection forget }
-"Definitions can answer a sequence of definitions they directly depend on:"
-{ $subsection uses }
"Definitions must implement a few operations used for printing them in source form:"
{ $subsection definer }
{ $subsection definition }
{ $see-also "see" } ;
-ARTICLE: "definition-crossref" "Definition cross referencing"
-"A common cross-referencing system is used to track definition usages:"
-{ $subsection crossref }
-{ $subsection xref }
-{ $subsection unxref }
-{ $subsection delete-xref }
-{ $subsection usage } ;
-
ARTICLE: "definition-checking" "Definition sanity checking"
"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions."
$nl
}
"For every source file loaded into the system, a list of definitions is maintained. Pathname objects implement the definition protocol, acting over the definitions their source files contain. See " { $link "source-files" } " for details."
{ $subsection "definition-protocol" }
-{ $subsection "definition-crossref" }
{ $subsection "definition-checking" }
{ $subsection "compilation-units" }
"A parsing word to remove definitions:"
{ $values { "definitions" "a sequence of definition specifiers" } }
{ $description "Forgets every definition in a sequence." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
-
-HELP: uses
-{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
-{ $description "Outputs a sequence of definitions directory called by the given definition." }
-{ $notes "The sequence might include the definition itself, if it is a recursive word." }
-{ $examples
- "We can ask the " { $link sq } " word to produce a list of words it calls:"
- { $unchecked-example "\ sq uses ." "{ dup * }" }
-} ;
-
-HELP: crossref
-{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } "." } ;
-
-HELP: xref
-{ $values { "defspec" "a definition specifier" } }
-{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." }
-$low-level-note ;
-
-HELP: usage
-{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
-{ $description "Outputs a sequence of definitions that directly call the given definition." }
-{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
-
-HELP: unxref
-{ $values { "defspec" "a definition specifier" } }
-{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." }
-{ $notes "This word is called before a word is redefined." } ;
-
-HELP: delete-xref
-{ $values { "defspec" "a definition specifier" } }
-{ $description "Remove the vertex which represents the definition from the " { $link crossref } " graph." }
-{ $notes "This word is called before a word is forgotten." }
-{ $see-also forget } ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces assocs graphs math math.order ;
+USING: kernel sequences namespaces assocs math ;
IN: definitions
MIXIN: definition
SYMBOL: changed-effects
-: changed-effect ( word -- )
- dup changed-effects get set-in-unit ;
-
SYMBOL: changed-generics
SYMBOL: outdated-generics
GENERIC: definer ( defspec -- start end )
GENERIC: definition ( defspec -- seq )
-
-SYMBOL: crossref
-
-GENERIC: uses ( defspec -- seq )
-
-M: object uses drop f ;
-
-: xref ( defspec -- ) dup uses crossref get add-vertex ;
-
-: usage ( defspec -- seq ) crossref get at keys ;
-
-GENERIC: irrelevant? ( defspec -- ? )
-
-M: object irrelevant? drop f ;
-
-GENERIC: smart-usage ( defspec -- seq )
-
-M: f smart-usage drop \ f smart-usage ;
-
-M: object smart-usage usage [ irrelevant? not ] filter ;
-
-: unxref ( defspec -- )
- dup uses crossref get remove-vertex ;
-
-: delete-xref ( defspec -- )
- dup unxref crossref get delete-at ;
[ 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 ;
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
! Issues with forget
-GENERIC: generic-forget-test-1 ( a b -- c )
+GENERIC: generic-forget-test ( a -- b )
-M: integer generic-forget-test-1 / ;
+M: f generic-forget-test ;
-[ t ] [
- \ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] any?
-] unit-test
-
-[ ] [
- [ \ generic-forget-test-1 forget ] with-compilation-unit
-] unit-test
-
-[ f ] [
- \ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] any?
-] unit-test
-
-GENERIC: generic-forget-test-2 ( a b -- c )
-
-M: sequence generic-forget-test-2 = ;
-
-[ t ] [
- \ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] any?
-] unit-test
-
-[ ] [
- [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit
-] unit-test
-
-[ f ] [
- \ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] any?
-] unit-test
-
-GENERIC: generic-forget-test-3 ( a -- b )
-
-M: f generic-forget-test-3 ;
-
-[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
+[ ] [ \ f \ generic-forget-test method "m" set ] unit-test
[ ] [ [ "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 ;" eval( -- ) ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
-[ f ] [ f generic-forget-test-3 ] unit-test
-
-: a-word ( -- ) ;
-
-GENERIC: a-generic ( a -- b )
-
-M: integer a-generic a-word ;
-
-[ ] [ \ integer \ a-generic method "m" set ] unit-test
-
-[ t ] [ "m" get \ a-word usage memq? ] unit-test
-
-[ ] [ "IN: generic.tests : a-generic ( -- ) ;" (( -- )) eval ] unit-test
-
-[ f ] [ "m" get \ a-word usage memq? ] unit-test
+[ f ] [ f generic-forget-test ] unit-test
! erg's regression
[ ] [
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
PREDICATE: default-method < word "default" word-prop ;
-M: default-method irrelevant? drop t ;
-
: <default-method> ( generic combination -- method )
[ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
[ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
[ call-next-method ] bi
] if ;
-M: method-body smart-usage
- "method-generic" word-prop smart-usage ;
-
M: sequence update-methods ( class seq -- )
implementors [
[ changed-generic ] [ remake-generic drop ] 2bi
M: class forget-methods
[ implementors ] [ [ swap method ] curry ] bi map forget-all ;
-
-: xref-generics ( -- )
- all-words [ subwords [ xref ] each ] each ;
M: engine-word crossref? "forgotten" word-prop not ;
-M: engine-word irrelevant? drop t ;
-
: remember-engine ( word -- )
generic get "engines" word-prop push ;
V{ } my-var [ call-next-hooker ] with-variable
] unit-test
-! Cross-referencing with generic words
-TUPLE: xref-tuple-1 ;
-TUPLE: xref-tuple-2 < xref-tuple-1 ;
-
-: (xref-test) ( obj -- ) drop ;
-
-GENERIC: xref-test ( obj -- )
-
-M: xref-tuple-1 xref-test (xref-test) ;
-M: xref-tuple-2 xref-test (xref-test) ;
-
-[ t ] [
- \ xref-test
- \ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
-] unit-test
-
-[ t ] [
- \ xref-test
- \ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
-] unit-test
-
[ t ] [
{ } \ nth effective-method nip \ sequence \ nth method eq?
] unit-test
M: encoder stream-write1
>encoder< encode-char ;
-: encoder-write ( string stream encoding -- )
+GENERIC# encoder-write 2 ( string stream encoding -- )
+
+M: string encoder-write
[ encode-char ] 2curry each ;
M: encoder stream-write
utf8 decode >array ;
: encode-utf8-w/stream ( array -- newarray )
- utf8 encode >array ;
+ >string utf8 encode >array ;
[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test
USING: arrays debugger.threads destructors io io.directories
io.encodings.8-bit io.encodings.ascii io.encodings.binary
io.files io.files.private io.files.temp io.files.unique kernel
-make math sequences system threads tools.test ;
+make math sequences system threads tools.test generic.standard ;
IN: io.files.tests
-\ exists? must-infer
-\ (exists?) must-infer
-
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
-10 seek-absolute seek-input
] with-file-reader
] must-fail
+
+[
+ "non-string-error" unique-file ascii [
+ { } write
+ ] with-file-writer
+] [ no-method? ] must-fail-with
+
+[
+ "non-byte-array-error" unique-file binary [
+ "" write
+ ] with-file-writer
+] [ no-method? ] must-fail-with
\ No newline at end of file
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs
-sequences.private accessors locals.backend grouping ;
+sequences.private accessors locals.backend grouping words ;
IN: kernel.tests
[ 0 ] [ f size ] unit-test
: overflow-d ( -- ) 3 overflow-d ;
-[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
-
-[ ] [ :c ] unit-test
-
: (overflow-d-alt) ( -- n ) 3 ;
: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
+: overflow-r ( -- ) 3 load-local overflow-r ;
+
+<<
+{ overflow-d (overflow-d-alt) overflow-d-alt overflow-r }
+[ t "no-compile" set-word-prop ] each
+>>
+
+[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
+
+[ ] [ :c ] unit-test
+
[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ [ :c ] with-string-writer drop ] unit-test
-: overflow-r ( -- ) 3 load-local overflow-r ;
-
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
[ ] [ :c ] unit-test
[ ] [ :c ] unit-test
! Doesn't compile; important
-: foo ( a -- b ) 5 + 0 [ ] each ;
+: foo ( a -- b ) ;
+
+<< \ foo t "no-compile" set-word-prop >>
[ drop foo ] must-fail
[ ] [ :c ] unit-test
[ pick ] dip swap [ pick ] dip swap
< [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
-: loop ( obj obj -- )
+: loop ( obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
[ loop ] must-fail
! Discovered on Windows
-: total-failure-1 ( -- ) "" [ ] map unimplemented ;
+: total-failure-1 ( -- a ) "" [ ] map unimplemented ;
[ total-failure-1 ] must-fail
classes.builtin arrays quotations io.launcher system ;
IN: memory.tests
+[ ] [ { } { } become ] unit-test
+
! LOL
[ ] [
vm
"This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "."
{ $subsection "parser-files" }
"The parser can be extended."
-{ $subsection "parsing-words" }
{ $subsection "parser-lexer" }
"The parser can be invoked reflectively;"
{ $subsection parse-stream }
-{ $see-also "definitions" "definition-checking" } ;
+{ $see-also "parsing-words" "definitions" "definition-checking" } ;
ABOUT: "parser"
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 source-files.errors ;
+vocabs.parser words.symbol multiline source-files.errors
+tools.crossref ;
IN: parser.tests
-\ run-file must-infer
-
[
[ 1 [ 2 [ 3 ] 4 ] 5 ]
- [ "1\n[\n2\n[\n3\n]\n4\n]\n5" (( -- a b c )) 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\"" (( -- string )) eval ]
+ [ "\"hello world\"" eval( -- string ) ]
unit-test
[ "\n\r\t\\" ]
- [ "\"\\n\\r\\t\\\\\"" (( -- string )) eval ]
+ [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ]
unit-test
[ "hello world" ]
[
"IN: parser.tests : hello ( -- str ) \"hello world\" ;"
- (( -- )) eval "USE: parser.tests hello" (( -- string )) 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\"" (( -- string )) eval ]
+ [ "\"\\u000020\"" eval( -- string ) ]
unit-test
[ "'" ]
- [ "\"\\u000027\"" (( -- string )) eval ]
+ [ "\"\\u000027\"" eval( -- string ) ]
unit-test
! Test EOL comments in multiline strings.
- [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" (( -- string )) 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." (( -- n )) 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" (( -- obj )) eval ] must-fail
- [ "OCT: 999" (( -- obj )) eval ] must-fail
- [ "BIN: --0" (( -- obj )) 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" (( -- word )) eval
+ "USE: parser.tests \\ foo" eval( -- word )
"foo" "parser.tests" lookup eq?
] 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: \\" (( -- n )) eval ] unit-test
-[ 92 ] [ "CHAR: \\\\" (( -- n )) eval ] unit-test
+[ 92 ] [ "CHAR: \\" eval( -- n ) ] unit-test
+[ 92 ] [ "CHAR: \\\\" eval( -- n ) ] 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" (( -- n )) 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
"math.order"
"memory"
"namespaces"
+ "parser"
"prettyprint"
"see"
"sequences"
"tools.annotations"
"tools.crossref"
"tools.disassembler"
+ "tools.errors"
"tools.memory"
"tools.profiler"
"tools.test"
: finish-parsing ( lines quot -- )
file get
- [ record-form ]
+ [ record-top-level-form ]
[ record-definitions ]
[ record-checksum ]
tri ;
{ $subsection wrapper }
{ $subsection literalize }
"Wrapper literal syntax is documented in " { $link "syntax-words" } "."
+{ $example
+ "IN: scratchpad"
+ "DEFER: my-word"
+ "\\ my-word name>> ."
+ "\"my-word\""
+}
{ $see-also "combinators" } ;
ABOUT: "quotations"
[ 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 ;
: 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 ;
+TUPLE: error-type type word plural icon quot forget-quot { fatal? initial: t } ;
GENERIC: error-type ( error -- type )
error-types get at icon>> ;
: error-counts ( -- alist )
- error-types get [ nip dup quot>> call( -- seq ) length ] assoc-map ;
+ error-types get
+ [ nip dup quot>> call( -- seq ) length ] assoc-map
+ [ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ;
: error-summary ( -- )
- error-counts
- [ nip 0 > ] assoc-filter
- [
+ error-counts [
over
[ word>> write ]
[ " - show " write number>string write bl ]
{ $subsection source-file }
"Words intended for the parser:"
{ $subsection record-checksum }
-{ $subsection record-form }
-{ $subsection xref-source }
-{ $subsection unxref-source }
+{ $subsection record-definitions }
"Removing a source file from the database:"
{ $subsection forget-source }
"Updating the database:"
{ $description "Records the CRC32 checksm of the source file's contents." }
$low-level-note ;
-HELP: xref-source
-{ $values { "source-file" source-file } }
-{ $description "Adds the source file to the " { $link crossref } " graph enabling words to find source files which reference them in their top level forms." }
-$low-level-note ;
-
-HELP: unxref-source
-{ $values { "source-file" source-file } }
-{ $description "Removes the source file from the " { $link crossref } " graph." }
-$low-level-note ;
-
-HELP: xref-sources
-{ $description "Adds all loaded source files to the " { $link crossref } " graph. This is done during bootstrap." }
-$low-level-note ;
-
-HELP: record-form
-{ $values { "quot" quotation } { "source-file" source-file } }
-{ $description "Records usage information for a source file's top level form." }
-$low-level-note ;
-
HELP: reset-checksums
{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ;
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces
sequences strings vectors words quotations io io.files
TUPLE: source-file
path
+top-level-form
checksum
-uses definitions ;
+definitions ;
+
+: record-top-level-form ( quot file -- )
+ (>>top-level-form) H{ } notify-definition-observers ;
: record-checksum ( lines source-file -- )
[ crc32 checksum-lines ] dip (>>checksum) ;
-: (xref-source) ( source-file -- pathname uses )
- [ path>> <pathname> ]
- [ uses>> [ crossref? ] filter ] bi ;
-
-: xref-source ( source-file -- )
- (xref-source) crossref get add-vertex ;
-
-: unxref-source ( source-file -- )
- (xref-source) crossref get remove-vertex ;
-
-: xref-sources ( -- )
- source-files get [ nip xref-source ] assoc-each ;
-
-: record-form ( quot source-file -- )
- [ quot-uses keys ] dip
- [ unxref-source ] [ (>>uses) ] [ xref-source ] tri ;
-
: record-definitions ( file -- )
new-definitions get >>definitions drop ;
M: pathname where string>> 1 2array ;
: forget-source ( path -- )
- [
- source-file
- [ unxref-source ]
- [ definitions>> [ keys forget-all ] each ] bi
- ]
- [ source-files get delete-at ]
- bi ;
+ source-files get delete-at*
+ [ definitions>> [ keys forget-all ] each ] [ drop ] if ;
M: pathname forget*
string>> forget-source ;
{ $description "Literal stack effect syntax." }
{ $notes "Useful for meta-programming with " { $link define-declared } "." }
{ $examples
- { $code
+ { $example
+ "USING: compiler.units kernel math prettyprint random words ;"
+ "IN: scratchpad"
+ ""
"SYMBOL: my-dynamic-word"
- "USING: math random words ;"
- "3 { [ + ] [ - ] [ * ] [ / ] } random curry"
- "(( x -- y )) define-declared"
+ ""
+ "["
+ " my-dynamic-word 2 { [ + ] [ * ] } random curry"
+ " (( x -- y )) define-declared"
+ "] with-compilation-unit"
+ ""
+ "2 my-dynamic-word ."
+ "4"
}
} ;
{ $syntax "execute( stack -- effect )" }
{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
-{ POSTPONE: call( POSTPONE: execute( } related-words
\ No newline at end of file
+{ POSTPONE: call( POSTPONE: execute( } related-words
forget-junk
[ { } ] [
- "IN: xabbabbja" (( -- )) eval "xabbabbja" vocab-files
+ "IN: xabbabbja" eval( -- ) "xabbabbja" vocab-files
] unit-test
[ "xabbabbja" forget-vocab ] with-compilation-unit
IN: words.alias.tests
ALIAS: foo +
-[ ] [ "IN: words.alias.tests CONSTANT: foo 5" (( -- )) eval ] unit-test
+[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval( -- ) ] unit-test
[ (( -- value )) ] [ \ foo stack-effect ] unit-test
{ { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } }
- { { $snippet "\"infer\"" } { $link "macros" } }
-
- { { { $snippet "\"inferred-effect\"" } } { $link "inference" } }
-
{ { $snippet "\"specializer\"" } { $link "hints" } }
{ { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" }
HELP: execute ( word -- )
{ $values { "word" word } }
-{ $description "Executes a word." }
+{ $description "Executes a word. Words which call execute must be inlined in order to compile when called from other words." }
{ $examples
- { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ;\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
+ { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
} ;
+{ execute POSTPONE: execute( } related-words
+
HELP: deferred
{ $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ;
"This word must be called from inside " { $link with-compilation-unit } "."
} ;
-HELP: quot-uses
-{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } }
-{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ;
-
HELP: delimiter?
{ $values { "obj" object } { "?" "a boolean" } }
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
! 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
FORGET: another-forgotten
: another-forgotten ( -- ) ;
-! I forgot remove-crossref calls!
-: fee ( -- ) ;
-: foe ( -- ) fee ;
-: fie ( -- ) foe ;
-
-[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test
-[ t ] [ \ foe usage empty? ] unit-test
-[ f ] [ \ foe crossref get key? ] unit-test
-
-FORGET: foe
-
-! xref should not retain references to gensyms
-[ ] [
- [ gensym [ * ] define ] with-compilation-unit
-] unit-test
-
-[ t ] [
- \ * usage [ word? ] filter [ crossref? ] all?
-] unit-test
-
-DEFER: calls-a-gensym
-[ ] [
- [
- \ calls-a-gensym
- gensym dup "x" set 1quotation
- (( x -- x )) define-declared
- ] with-compilation-unit
-] unit-test
-
-[ f ] [ "x" get crossref get at ] unit-test
-
-! more xref buggery
-[ f ] [
- GENERIC: xyzzle ( x -- x )
- : a ( -- ) ; \ a
- M: integer xyzzle a ;
- FORGET: a
- M: object xyzzle ;
- crossref get at
-] unit-test
-
-! regression
-GENERIC: freakish ( x -- y )
-: bar ( x -- y ) freakish ;
-M: array freakish ;
-[ t ] [ \ bar \ freakish usage member? ] unit-test
DEFER: x
[ x ] [ undefined? ] must-fail-with
[ ] [ "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
-SYMBOL: quot-uses-a
-SYMBOL: quot-uses-b
-
-[ ] [
- [
- quot-uses-a [ 2 3 + ] define
- ] with-compilation-unit
-] unit-test
-
-[ { + } ] [ \ quot-uses-a uses ] unit-test
-
-[ ] [
- [
- quot-uses-b 2 [ 3 + ] curry define
- ] with-compilation-unit
-] unit-test
-
-[ { + } ] [ \ quot-uses-b uses ] unit-test
-
"undef-test" "words.tests" lookup [
[ 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
[ { } ]
keys [ "forgotten" word-prop ] any?
] filter
] unit-test
-
-[ { } ] [
- crossref get keys
- [ word? ] filter [ "forgotten" word-prop ] filter
-] unit-test
GENERIC: crossref? ( word -- ? )
M: word crossref?
- dup "forgotten" word-prop [
- drop f
- ] [
- vocabulary>> >boolean
- ] if ;
-
-GENERIC: compiled-crossref? ( word -- ? )
-
-M: word compiled-crossref? crossref? ;
-
-GENERIC# (quot-uses) 1 ( obj assoc -- )
-
-M: object (quot-uses) 2drop ;
-
-M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
-
-: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
-
-M: array (quot-uses) seq-uses ;
-
-M: hashtable (quot-uses) [ >alist ] dip seq-uses ;
-
-M: callable (quot-uses) seq-uses ;
-
-M: wrapper (quot-uses) [ wrapped>> ] dip (quot-uses) ;
-
-: quot-uses ( quot -- assoc )
- global [ H{ } clone [ (quot-uses) ] keep ] bind ;
-
-M: word uses ( word -- seq )
- def>> quot-uses keys ;
+ dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ;
SYMBOL: compiled-crossref
: inline? ( word -- ? ) "inline" word-prop ; inline
-SYMBOL: visited
-
-CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" }
-
-: (redefined) ( word -- )
- dup visited get key? [ drop ] [
- [ reset-on-redefine reset-props ]
- [ visited get conjoin ]
- [
- crossref get at keys
- [ word? ] filter
- [
- [ reset-on-redefine [ word-prop ] with any? ]
- [ inline? ]
- bi or
- ] filter
- [ (redefined) ] each
- ] tri
- ] if ;
+GENERIC: subwords ( word -- seq )
-: redefined ( word -- )
- [ H{ } clone visited [ (redefined) ] with-variable ]
- [ changed-definition ]
- bi ;
+M: word subwords drop f ;
: define ( word def -- )
- [ ] like
- over unxref
- over redefined
- >>def
- dup crossref? [ dup xref ] when drop ;
+ over changed-definition [ ] like >>def drop ;
+
+: changed-effect ( word -- )
+ [ dup changed-effects get set-in-unit ]
+ [ dup primitive? [ drop ] [ changed-definition ] if ] bi ;
: set-stack-effect ( effect word -- )
2dup "declared-effect" word-prop = [ 2drop ] [
- swap
- [ drop changed-effect ]
- [ "declared-effect" set-word-prop ]
- [ drop dup primitive? [ drop ] [ redefined ] if ]
+ [ nip changed-effect ]
+ [ nip subwords [ changed-effect ] each ]
+ [ swap "declared-effect" set-word-prop ]
2tri
] if ;
[ nip swap set-stack-effect ] [ drop define ] 3bi ;
: make-inline ( word -- )
- t "inline" set-word-prop ;
+ dup inline? [ drop ] [
+ [ t "inline" set-word-prop ]
+ [ changed-effect ]
+ bi
+ ] if ;
: make-recursive ( word -- )
t "recursive" set-word-prop ;
"writer" "delimiter"
} reset-props ;
-GENERIC: subwords ( word -- seq )
-
-M: word subwords drop f ;
-
: reset-generic ( word -- )
[ subwords forget-all ]
[ reset-word ]
M: word forget*
dup "forgotten" word-prop [ drop ] [
- [ delete-xref ]
[ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
[ t "forgotten" set-word-prop ]
- tri
+ bi
] if ;
M: word hashcode*
M: word literalize <wrapper> ;
-: xref-words ( -- ) all-words [ xref ] each ;
-
INSTANCE: word definition
\ No newline at end of file
;\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
+++ /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
USING: accessors arrays combinators definitions generalizations
help help.markup help.topics kernel sequences sorting vocabs
-words combinators.smart ;
+words combinators.smart tools.crossref ;
IN: annotations
<PRIVATE
: 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes kernel sequences sets
-io prettyprint multi-methods ;
-IN: boolean-expr
-
-! Demonstrates the use of Unicode symbols in source files, and
-! multi-method dispatch.
-
-TUPLE: ⋀ x y ;
-TUPLE: ⋁ x y ;
-TUPLE: ¬ x ;
-
-SINGLETONS: ⊤ ⊥ ;
-
-SINGLETONS: P Q R S T U V W X Y Z ;
-
-UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ;
-
-GENERIC: ⋀ ( x y -- expr )
-
-METHOD: ⋀ { ⊤ □ } nip ;
-METHOD: ⋀ { □ ⊤ } drop ;
-METHOD: ⋀ { ⊥ □ } drop ;
-METHOD: ⋀ { □ ⊥ } nip ;
-
-METHOD: ⋀ { ⋁ □ } [ [ x>> ] dip ⋀ ] [ [ y>> ] dip ⋀ ] 2bi ⋁ ;
-METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
-
-METHOD: ⋀ { □ □ } \ ⋀ boa ;
-
-GENERIC: ⋁ ( x y -- expr )
-
-METHOD: ⋁ { ⊤ □ } drop ;
-METHOD: ⋁ { □ ⊤ } nip ;
-METHOD: ⋁ { ⊥ □ } nip ;
-METHOD: ⋁ { □ ⊥ } drop ;
-
-METHOD: ⋁ { □ □ } \ ⋁ boa ;
-
-GENERIC: ¬ ( x -- expr )
-
-METHOD: ¬ { ⊤ } drop ⊥ ;
-METHOD: ¬ { ⊥ } drop ⊤ ;
-
-METHOD: ¬ { ⋀ } [ x>> ¬ ] [ y>> ¬ ] bi ⋁ ;
-METHOD: ¬ { ⋁ } [ x>> ¬ ] [ y>> ¬ ] bi ⋀ ;
-
-METHOD: ¬ { □ } \ ¬ boa ;
-
-: → ( x y -- expr ) ¬ ⋀ ;
-: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ;
-: ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ;
-
-GENERIC: (cnf) ( expr -- cnf )
-
-METHOD: (cnf) { ⋀ } [ x>> (cnf) ] [ y>> (cnf) ] bi append ;
-METHOD: (cnf) { □ } 1array ;
-
-GENERIC: cnf ( expr -- cnf )
-
-METHOD: cnf { ⋁ } [ x>> cnf ] [ y>> cnf ] bi append ;
-METHOD: cnf { □ } (cnf) 1array ;
-
-GENERIC: satisfiable? ( expr -- ? )
-
-METHOD: satisfiable? { ⊤ } drop t ;
-METHOD: satisfiable? { ⊥ } drop f ;
-
-: partition ( seq quot -- left right )
- [ [ not ] compose filter ] [ filter ] 2bi ; inline
-
-: (satisfiable?) ( seq -- ? )
- [ \ ¬ instance? ] partition [ x>> ] map intersect empty? ;
-
-METHOD: satisfiable? { □ }
- cnf [ (satisfiable?) ] any? ;
-
-GENERIC: (expr.) ( expr -- )
-
-METHOD: (expr.) { □ } pprint ;
-
-: op. ( expr -- )
- "(" write
- [ x>> (expr.) ]
- [ bl class pprint bl ]
- [ y>> (expr.) ]
- tri
- ")" write ;
-
-METHOD: (expr.) { ⋀ } op. ;
-METHOD: (expr.) { ⋁ } op. ;
-METHOD: (expr.) { ¬ } [ class pprint ] [ x>> (expr.) ] bi ;
-
-: expr. ( expr -- ) (expr.) nl ;
+++ /dev/null
-Simple boolean expression evaluator and simplifier
IN: contributors.tests
USING: contributors tools.test ;
-\ contributors must-infer
[ ] [ contributors ] unit-test
--- /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
+! - ...?
--- /dev/null
+unportable
io io.binary io.sockets io.encodings.binary
accessors
combinators.smart
- newfx
+ assocs
;
IN: dns
[
{
[ name>> dn->ba ]
- [ type>> type-table of uint16->ba ]
- [ class>> class-table of uint16->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
} cleave
] output>array concat ;
[
{
[ name>> dn->ba ]
- [ type>> type-table of uint16->ba ]
- [ class>> class-table of uint16->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
[ ttl>> uint32->ba ]
[
[ type>> ] [ rdata>> ] bi rdata->ba
[
{
[ qr>> 15 shift ]
- [ opcode>> opcode-table of 11 shift ]
+ [ opcode>> opcode-table at 11 shift ]
[ aa>> 10 shift ]
[ tc>> 9 shift ]
[ rd>> 8 shift ]
[ ra>> 7 shift ]
[ z>> 4 shift ]
- [ rcode>> rcode-table of 0 shift ]
+ [ rcode>> rcode-table at 0 shift ]
} cleave
] sum-outputs uint16->ba ;
[ get-name ]
[
skip-name
- [ 0 + get-double type-table key-of ]
- [ 2 + get-double class-table key-of ]
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
2bi
]
2bi query boa ;
[
skip-name
{
- [ 0 + get-double type-table key-of ]
- [ 2 + get-double class-table key-of ]
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
[ 4 + get-quad ]
- [ [ 10 + ] [ get-double type-table key-of ] 2bi get-rdata ]
+ [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
}
2cleave
]
get-double
{
[ 15 >> BIN: 1 bitand ]
- [ 11 >> BIN: 111 bitand opcode-table key-of ]
+ [ 11 >> BIN: 111 bitand opcode-table value-at ]
[ 10 >> BIN: 1 bitand ]
[ 9 >> BIN: 1 bitand ]
[ 8 >> BIN: 1 bitand ]
[ 7 >> BIN: 1 bitand ]
[ 4 >> BIN: 111 bitand ]
- [ BIN: 1111 bitand rcode-table key-of ]
+ [ BIN: 1111 bitand rcode-table value-at ]
}
cleave ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: message-query ( message -- query ) question-section>> 1st ;
+: message-query ( message -- query ) question-section>> first ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: kernel combinators sequences splitting math
- io.files io.encodings.utf8 random newfx dns.util ;
+ io.files io.encodings.utf8 random dns.util ;
IN: dns.misc
: resolv-conf-servers ( -- seq )
"/etc/resolv.conf" utf8 file-lines
[ " " split ] map
- [ 1st "nameserver" = ] filter
- [ 2nd ] map ;
+ [ first "nameserver" = ] filter
+ [ second ] map ;
: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
USING: kernel combinators sequences sets math threads namespaces continuations
debugger io io.sockets unicode.case accessors destructors
combinators.short-circuit combinators.smart
- newfx fry arrays
+ fry arrays
dns dns.util dns.misc ;
IN: dns.server
[ rr->rdata-names ] map concat ;
: extract-names ( message -- names )
- [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ;
+ [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fill-authority
: matching-cname? ( query -- rrs/f )
[ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs
[ empty? not ]
- [ 1st swap clone over rdata>> >>name query->rrs prefix-on ]
+ [ first swap clone over rdata>> >>name query->rrs swap prefix ]
[ 2drop f ]
1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: 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+ ] curry [ drop ] recover ] each
+ fuel-forget-error fuel-forget-output ;
: (fuel-eval-in) ( in -- )
- [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
+ [ 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: infix.ast infix.parser infix.tokenizer tools.test ;
IN: infix.parser.tests
-\ parse-infix must-infer
-\ build-infix-ast must-infer
-
[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test
[ T{ ast-negation f T{ ast-number { value 1 } } } ]
[ "-1" build-infix-ast ] unit-test
USING: infix.ast infix.tokenizer tools.test ;
IN: infix.tokenizer.tests
-\ tokenize-infix must-infer
[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test
[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test
[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ]
: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ;
: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
- [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
+ [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; inline
: spawning-irc ( quot: ( -- ) -- )
[ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline
--- /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 ;
+
+CONSTANT: units-per-full-roll 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
+
+CONSTANT: min-vertices 6
+CONSTANT: max-vertices 32
+
+CONSTANT: n-vertices 32
+
+! render enough of the tunnel that it looks continuous
+CONSTANT: n-segments-ahead 60
+CONSTANT: n-segments-behind 40
+
+! so that we can't see through the wall, we draw it a bit further away
+CONSTANT: wall-drawing-offset 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 ;
+
+CONSTANT: default-width 800
+CONSTANT: default-height 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
+CONSTANT: default-speed 1.0
+CONSTANT: max-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 literals 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
+
+CONSTANT: n-segments 5000
+
+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> ;
+
+CONSTANT: tunnel-segment-distance 0.4
+CONSTANT: random-rotation-angle $[ 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 ;
+
+CONSTANT: default-segment-radius 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 ;
+
+CONSTANT: distant 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 ;
+
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: io lint kernel math tools.test ;
-IN: lint.tests
-
-! Don't write code like this
-: lint1 ( obj -- ) [ "hi" print ] [ ] if ; ! when
-
-[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
-
-: lint2 ( n -- n' ) 1 + ; ! 1+
-[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
-
-: lint3 ( a b -- b a b ) dup -rot ; ! tuck
-
-[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors arrays assocs
-combinators.short-circuit fry hashtables io
-kernel math namespaces prettyprint quotations sequences
-sequences.deep sets slots.private vectors vocabs words
-kernel.private ;
-IN: lint
-
-SYMBOL: def-hash
-SYMBOL: def-hash-keys
-
-: set-hash-vector ( val key hash -- )
- 2dup at -rot [ ?push ] 2dip set-at ;
-
-: more-defs ( hash -- )
- {
- { -rot [ swap [ swap ] dip ] }
- { -rot [ swap swapd ] }
- { rot [ [ swap ] dip swap ] }
- { rot [ swapd swap ] }
- { over [ dup swap ] }
- { tuck [ dup -rot ] }
- { swapd [ [ swap ] dip ] }
- { 2nip [ nip nip ] }
- { 2drop [ drop drop ] }
- { 3drop [ drop drop drop ] }
- { pop* [ pop drop ] }
- { when [ [ ] if ] }
- { >boolean [ f = not ] }
- } swap '[ first2 _ set-hash-vector ] each ;
-
-: accessor-words ( -- seq )
-{
- alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
- alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
- <displaced-alien> alien-unsigned-cell set-alien-signed-cell
- set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
- set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
- set-alien-unsigned-8 set-alien-signed-8
- alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
- set-alien-float alien-float
-} ;
-
-: trivial-defs ( -- seq )
- {
- [ drop ] [ 2array ]
- [ bitand ]
-
- [ . ]
- [ get ]
- [ t ] [ f ]
- [ { } ]
- [ drop f ]
- [ "cdecl" ]
- [ first ] [ second ] [ third ] [ fourth ]
- [ ">" write ] [ "/>" write ]
- } ;
-
-! ! Add definitions
-H{ } clone def-hash set-global
-
-all-words [
- dup def>> dup callable?
- [ def-hash get-global set-hash-vector ] [ drop ] if
-] each
-
-! ! Remove definitions
-
-! Remove empty word defs
-def-hash get-global [ drop empty? not ] assoc-filter
-
-! Remove constants [ 1 ]
-[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
-
-! Remove words that are their own definition
-[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
-
-! Remove set-alien-cell, etc.
-[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
-
-! Remove trivial defs
-[ drop trivial-defs member? not ] assoc-filter
-
-! Remove numbers only defs
-[ drop [ number? ] all? not ] assoc-filter
-
-! Remove curry only defs
-[ drop [ \ curry = ] all? not ] assoc-filter
-
-! Remove tag defs
-[
- drop {
- [ length 3 = ]
- [ first \ tag = ] [ second number? ] [ third \ eq? = ]
- } 1&& not
-] assoc-filter
-
-[
- drop {
- [ [ wrapper? ] deep-any? ]
- [ [ hashtable? ] deep-any? ]
- } 1|| not
-] assoc-filter
-
-! Remove n m shift defs
-[
- drop dup length 3 = [
- [ first2 [ number? ] both? ]
- [ third \ shift = ] bi and not
- ] [ drop t ] if
-] assoc-filter
-
-! Remove [ n slot ]
-[
- drop dup length 2 =
- [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
-] assoc-filter
-
-
-dup more-defs
-
-[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
-
-: find-duplicates ( -- seq )
- def-hash get-global [ nip length 1 > ] assoc-filter ;
-
-GENERIC: lint ( obj -- seq )
-
-M: object lint ( obj -- seq ) drop f ;
-
-: subseq/member? ( subseq/member seq -- ? )
- { [ start ] [ member? ] } 2|| ;
-
-M: callable lint ( quot -- seq )
- [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
-
-M: word lint ( word -- seq )
- def>> dup callable? [ lint ] [ drop f ] if ;
-
-: word-path. ( word -- )
- [ vocabulary>> ] [ unparse ] bi ":" glue print ;
-
-: 4bl ( -- ) bl bl bl bl ;
-
-: (lint.) ( pair -- )
- first2 [ word-path. ] dip [
- [ 4bl . "-----------------------------------" print ]
- [ def-hash get-global at [ 4bl word-path. ] each nl ] bi
- ] each nl nl ;
-
-: lint. ( alist -- ) [ (lint.) ] each ;
-
-GENERIC: run-lint ( obj -- obj )
-
-: (trim-self) ( val key -- obj ? )
- def-hash get-global at*
- [ dupd remove empty? not ] [ drop f ] if ;
-
-: trim-self ( seq -- newseq )
- [ [ (trim-self) ] filter ] assoc-map ;
-
-: filter-symbols ( alist -- alist )
- [
- nip first dup def-hash get-global at
- [ first ] bi@ literalize = not
- ] assoc-filter ;
-
-M: sequence run-lint ( seq -- seq )
- [ dup lint ] { } map>assoc trim-self
- [ second empty? not ] filter filter-symbols ;
-
-M: word run-lint ( word -- seq ) 1array run-lint ;
-
-: lint-all ( -- seq ) all-words run-lint dup lint. ;
-
-: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
-
-: lint-word ( word -- seq ) 1array run-lint dup lint. ;
+++ /dev/null
-Finds potential mistakes in code
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
USING: tools.test mason.cleanup ;
IN: mason.cleanup.tests
-
-\ cleanup must-infer
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: 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
IN: mason.release.upload.tests
USING: mason.release.upload tools.test ;
-\ upload must-infer
: 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 ;
--- /dev/null
+Benchmarks
--- /dev/null
+{ "benchmarks" }
--- /dev/null
+H{ { "a" 1 } { "b" 2 } }
--- /dev/null
+Compile
+Log
--- /dev/null
+Compiler errors
--- /dev/null
+{ "compiler-errors" }
--- /dev/null
+"deadbeef"
--- /dev/null
+{ "help-lint" }
--- /dev/null
+Load everything
--- /dev/null
+{ "load-everything" }
--- /dev/null
+Test all errors
--- /dev/null
+{ "test-all" }
IN: mason.report.tests
-USING: mason.report tools.test ;
+USING: io.files io.directories kernel mason.report mason.common
+tools.test xml xml.writer ;
+
+{ 0 0 } [ [ ] with-report ] must-infer-as
+
+: verify-report ( -- )
+ [ t ] [ "report" exists? ] unit-test
+ [ ] [ "report" file>xml drop ] unit-test
+ [ ] [ "report" delete-file ] unit-test ;
+
+"resource:extra/mason/report/fake-data/" [
+ [ ] [
+ timings-table pprint-xml
+ ] unit-test
+
+ [ ] [ successful-report ] unit-test
+ verify-report
+
+ [ status-error ] [ 1234 compile-failed ] unit-test
+ verify-report
+
+ [ status-error ] [ 1235 boot-failed ] unit-test
+ verify-report
+
+ [ status-error ] [ 1236 test-failed ] unit-test
+ verify-report
+] with-directory
-! 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
+literals ;
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
+ } [
+ dup eval-file 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 tools.errors locals ;
+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 [ file>> ] map prune natural-sort summary-file to-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 get values
- compiler-errors-file
- compiler-error-messages-file
- do-step ;
-
: do-tests ( -- )
test-all test-failures get
test-all-vocabs-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* ;
+
+: do-compile-errors ( -- )
+ compiler-errors get values
+ compiler-errors-file
+ compiler-error-messages-file
+ do-step ;
: benchmark-ms ( quot -- ms )
benchmark 1000 /i ; inline
".." [
bootstrap-time get boot-time-file to-file
check-boot-image
- [ do-load do-compile-errors ] benchmark-ms load-time-file to-file
+ [ do-load ] benchmark-ms load-time-file to-file
[ generate-help ] benchmark-ms html-help-time-file to-file
[ do-tests ] benchmark-ms test-time-file to-file
[ do-help-lint ] benchmark-ms help-lint-time-file to-file
[ do-benchmarks ] benchmark-ms benchmark-time-file to-file
+ do-compile-errors
] with-directory ;
MAIN: do-all
\ 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: 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
[ 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
--- /dev/null
+Alex Chapman
+Diego Martinelli
--- /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" } { "morse" "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 a ? character." } ;
+
+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 a space character." } ;
+
+HELP: >morse
+{ $values
+ { "str" "A string of ASCII characters which can be translated into morse code" } { "newstr" "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 { "morse" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "plain" "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 ;
+IN: morse.tests
+
+[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test
+[ "..." ] [ CHAR: s ch>morse ] unit-test
+[ CHAR: s ] [ "..." morse>ch ] unit-test
+[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
+[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
+[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
+[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
+[ ".- -... -.-." ] [ "abc" >morse ] unit-test
+
+[ "abc" ] [ ".- -... -.-." morse> ] unit-test
+
+[ "morse code" ] [
+ [MORSE
+ -- --- .-. ... . /
+ -.-. --- -.. .
+ MORSE] >morse morse> ] unit-test
+
+[ "morse code 123" ] [
+ [MORSE
+ __ ___ ._. ... . /
+ _._. ___ _.. . /
+ .____ ..___ ...__
+ MORSE] ] unit-test
+
+[ [MORSE
+ -- --- .-. ... . /
+ -.-. --- -.. .
+ MORSE] ] [
+ "morse code" >morse morse>
+] unit-test
+
+[ "factor rocks!" ] [
+ [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, 2009 Alex Chapman, 2009 Diego Martinelli
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
+IN: morse
+
+<PRIVATE
+
+CONSTANT: dot-char CHAR: .
+CONSTANT: dash-char CHAR: -
+CONSTANT: char-gap-char CHAR: \s
+CONSTANT: word-gap-char CHAR: /
+CONSTANT: unknown-char CHAR: ?
+
+PRIVATE>
+
+CONSTANT: morse-code-table $[
+ H{
+ { 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 "/" }
+ } >biassoc
+]
+
+: ch>morse ( ch -- morse )
+ ch>lower morse-code-table at [ unknown-char ] unless* ;
+
+: morse>ch ( str -- ch )
+ morse-code-table value-at [ char-gap-char ] unless* ;
+
+<PRIVATE
+
+: word>morse ( str -- morse )
+ [ ch>morse ] { } map-as " " join ;
+
+: sentence>morse ( str -- morse )
+ " " split [ word>morse ] map " / " join ;
+
+: trim-blanks ( str -- newstr )
+ [ blank? ] trim ; inline
+
+: morse>word ( morse -- str )
+ " " split [ morse>ch ] "" map-as ;
+
+: morse>sentence ( morse -- sentence )
+ "/" split [ trim-blanks morse>word ] map " " join ;
+
+: replace-underscores ( str -- str' )
+ [ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
+
+PRIVATE>
+
+: >morse ( str -- newstr )
+ trim-blanks sentence>morse ;
+
+: morse> ( morse -- plain )
+ replace-underscores morse>sentence ;
+
+SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ;
+
+<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 ;
+
+CONSTANT: 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 ; 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
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences vectors classes classes.algebra
-combinators arrays words assocs parser namespaces make
-definitions prettyprint prettyprint.backend prettyprint.custom
-quotations generalizations debugger io compiler.units
-kernel.private effects accessors hashtables sorting shuffle
-math.order sets see effects.parser ;
-IN: multi-methods
-
-! PART I: Converting hook specializers
-: canonicalize-specializer-0 ( specializer -- specializer' )
- [ \ f or ] map ;
-
-SYMBOL: args
-
-SYMBOL: hooks
-
-SYMBOL: total
-
-: canonicalize-specializer-1 ( specializer -- specializer' )
- [
- [ class? ] filter
- [ length <reversed> [ 1+ neg ] map ] keep zip
- [ length args [ max ] change ] keep
- ]
- [
- [ pair? ] filter
- [ keys [ hooks get adjoin ] each ] keep
- ] bi append ;
-
-: canonicalize-specializer-2 ( specializer -- specializer' )
- [
- [
- {
- { [ dup integer? ] [ ] }
- { [ dup word? ] [ hooks get index ] }
- } cond args get +
- ] dip
- ] assoc-map ;
-
-: canonicalize-specializer-3 ( specializer -- specializer' )
- [ total get object <array> dup <enum> ] dip update ;
-
-: canonicalize-specializers ( methods -- methods' hooks )
- [
- [ [ canonicalize-specializer-0 ] dip ] assoc-map
-
- 0 args set
- V{ } clone hooks set
-
- [ [ canonicalize-specializer-1 ] dip ] assoc-map
-
- hooks [ natural-sort ] change
-
- [ [ canonicalize-specializer-2 ] dip ] assoc-map
-
- args get hooks get length + total set
-
- [ [ canonicalize-specializer-3 ] dip ] assoc-map
-
- hooks get
- ] with-scope ;
-
-: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
-
-: prepare-method ( method n -- quot )
- [ 1quotation ] [ drop-n-quot ] bi* prepend ;
-
-: prepare-methods ( methods -- methods' prologue )
- canonicalize-specializers
- [ length [ prepare-method ] curry assoc-map ] keep
- [ [ get ] curry ] map concat [ ] like ;
-
-! Part II: Topologically sorting specializers
-: maximal-element ( seq quot -- n elt )
- dupd [
- swapd [ call +lt+ = ] 2curry filter empty?
- ] 2curry find [ "Topological sort failed" throw ] unless* ;
- inline
-
-: topological-sort ( seq quot -- newseq )
- [ >vector [ dup empty? not ] ] dip
- [ dupd maximal-element [ over delete-nth ] dip ] curry
- produce nip ; inline
-
-: classes< ( seq1 seq2 -- lt/eq/gt )
- [
- {
- { [ 2dup eq? ] [ +eq+ ] }
- { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
- { [ 2dup class<= ] [ +lt+ ] }
- { [ 2dup swap class<= ] [ +gt+ ] }
- [ +eq+ ]
- } cond 2nip
- ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
-
-: sort-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
-! PART III: Creating dispatch quotation
-: picker ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- picker [ dip swap ] curry ]
- } case ;
-
-: (multi-predicate) ( class picker -- quot )
- swap "predicate" word-prop append ;
-
-: multi-predicate ( classes -- quot )
- dup length <reversed>
- [ picker 2array ] 2map
- [ drop object eq? not ] assoc-filter
- [ [ t ] ] [
- [ (multi-predicate) ] { } assoc>map
- unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
- ] if-empty ;
-
-: argument-count ( methods -- n )
- keys 0 [ length max ] reduce ;
-
-ERROR: no-method arguments generic ;
-
-: make-default-method ( methods generic -- quot )
- [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
-
-: multi-dispatch-quot ( methods generic -- quot )
- [ make-default-method ]
- [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
- 2bi alist>quot ;
-
-! Generic words
-PREDICATE: generic < word
- "multi-methods" word-prop >boolean ;
-
-: methods ( word -- alist )
- "multi-methods" word-prop >alist ;
-
-: make-generic ( generic -- quot )
- [
- [ methods prepare-methods % sort-methods ] keep
- multi-dispatch-quot %
- ] [ ] make ;
-
-: update-generic ( word -- )
- dup make-generic define ;
-
-! Methods
-PREDICATE: method-body < word
- "multi-method-generic" word-prop >boolean ;
-
-M: method-body stack-effect
- "multi-method-generic" word-prop stack-effect ;
-
-M: method-body crossref?
- "forgotten" word-prop not ;
-
-: method-word-name ( specializer generic -- string )
- [ name>> % "-" % unparse % ] "" make ;
-
-: method-word-props ( specializer generic -- assoc )
- [
- "multi-method-generic" set
- "multi-method-specializer" set
- ] H{ } make-assoc ;
-
-: <method> ( specializer generic -- word )
- [ method-word-props ] 2keep
- method-word-name f <word>
- swap >>props ;
-
-: with-methods ( word quot -- )
- over [
- [ "multi-methods" word-prop ] dip call
- ] dip update-generic ; inline
-
-: reveal-method ( method classes generic -- )
- [ set-at ] with-methods ;
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: create-method ( classes generic -- method )
- 2dup method dup [
- 2nip
- ] [
- drop [ <method> dup ] 2keep reveal-method
- ] if ;
-
-: niceify-method ( seq -- seq )
- [ dup \ f eq? [ drop f ] when ] map ;
-
-M: no-method error.
- "Type check error" print
- nl
- "Generic word " write dup generic>> pprint
- " does not have a method applicable to inputs:" print
- dup arguments>> short.
- nl
- "Inputs have signature:" print
- dup arguments>> [ class ] map niceify-method .
- nl
- "Available methods: " print
- generic>> methods canonicalize-specializers drop sort-methods
- keys [ niceify-method ] map stack. ;
-
-: forget-method ( specializer generic -- )
- [ delete-at ] with-methods ;
-
-: method>spec ( method -- spec )
- [ "multi-method-specializer" word-prop ]
- [ "multi-method-generic" word-prop ] bi prefix ;
-
-: define-generic ( word effect -- )
- over set-stack-effect
- dup "multi-methods" word-prop [ drop ] [
- [ H{ } clone "multi-methods" set-word-prop ]
- [ update-generic ]
- bi
- ] if ;
-
-! Syntax
-SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
-
-: parse-method ( -- quot classes generic )
- parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-
-: create-method-in ( specializer generic -- method )
- create-method dup save-location f set-word ;
-
-: CREATE-METHOD ( -- method )
- scan-word scan-object swap create-method-in ;
-
-: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
-
-SYNTAX: METHOD: (METHOD:) define ;
-
-! For compatibility
-SYNTAX: M:
- scan-word 1array scan-word create-method-in
- parse-definition
- define ;
-
-! Definition protocol. We qualify core generics here
-QUALIFIED: syntax
-
-syntax:M: generic definer drop \ GENERIC: f ;
-
-syntax:M: generic definition drop f ;
-
-PREDICATE: method-spec < array
- unclip generic? [ [ class? ] all? ] dip and ;
-
-syntax:M: method-spec where
- dup unclip method [ ] [ first ] ?if where ;
-
-syntax:M: method-spec set-where
- unclip method set-where ;
-
-syntax:M: method-spec definer
- unclip method definer ;
-
-syntax:M: method-spec definition
- unclip method definition ;
-
-syntax:M: method-spec synopsis*
- unclip method synopsis* ;
-
-syntax:M: method-spec forget*
- unclip method forget* ;
-
-syntax:M: method-body definer
- drop \ METHOD: \ ; ;
-
-syntax:M: method-body synopsis*
- dup definer.
- [ "multi-method-generic" word-prop pprint-word ]
- [ "multi-method-specializer" word-prop pprint* ] bi ;
+++ /dev/null
-Experimental multiple dispatch implementation
+++ /dev/null
-extensions
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings ;
-
-[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
-
-: setup-canon-test ( -- )
- 0 args set
- V{ } clone hooks set ;
-
-: canon-test-1 ( -- seq )
- { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
-
-[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- ] with-scope
-] unit-test
-
-[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- ] with-scope
-] unit-test
-
-[ { integer sequence x86 } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- args get hooks get length + total set
- canonicalize-specializer-3
- ] with-scope
-] unit-test
-
-CONSTANT: example-1
- {
- { { { cpu x86 } { os linux } } "a" }
- { { { cpu ppc } } "b" }
- { { string { os windows } } "c" }
- }
-
-[
- {
- { { object x86 linux } "a" }
- { { object ppc object } "b" }
- { { string object windows } "c" }
- }
- { cpu os }
-] [
- example-1 canonicalize-specializers
-] unit-test
-
-[
- {
- { { object x86 linux } [ drop drop "a" ] }
- { { object ppc object } [ drop drop "b" ] }
- { { string object windows } [ drop drop "c" ] }
- }
- [ \ cpu get \ os get ]
-] [
- example-1 prepare-methods
-] unit-test
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings words compiler.units quotations ;
-
-\ GENERIC: must-infer
-\ create-method-in must-infer
-
-DEFER: fake
-\ fake H{ } clone "multi-methods" set-word-prop
-
-[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
-
-[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
-[ { } \ fake method-word-props ] unit-test
-
-[ t ] [ { } \ fake <method> method-body? ] unit-test
-
-[
- [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
-
- [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
-
- [ t ] [ \ fake make-generic quotation? ] unit-test
-
- [ ] [ \ fake update-generic ] unit-test
-
- DEFER: testing
-
- [ ] [ \ testing (( -- )) define-generic ] unit-test
-
- [ t ] [ \ testing generic? ] unit-test
-] with-compilation-unit
+++ /dev/null
-IN: multi-methods.tests
-USING: math strings sequences tools.test ;
-
-GENERIC: legacy-test ( a -- b )
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs accessors see ;
-
-GENERIC: first-test ( -- )
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-SINGLETON: paper INSTANCE: paper thing
-SINGLETON: scissors INSTANCE: scissors thing
-SINGLETON: rock INSTANCE: rock thing
-
-GENERIC: beats? ( obj1 obj2 -- ? )
-
-METHOD: beats? { paper scissors } t ;
-METHOD: beats? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
-
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ { { } 3 } ] [ error get arguments>> ] unit-test
-[ t ] [ paper scissors play ] unit-test
-[ f ] [ scissors paper play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-SYMBOL: some-var
-
-GENERIC: hook-test ( -- obj )
-
-METHOD: hook-test { array { some-var array } } reverse ;
-METHOD: hook-test { { some-var array } } class ;
-METHOD: hook-test { hashtable { some-var number } } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-"error" some-var set
-[ H{ } hook-test ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ { H{ } "error" } ] [ error get arguments>> ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
+++ /dev/null
-USING: kernel multi-methods tools.test math arrays sequences
-math.order ;
-IN: multi-methods.tests
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ +lt+ ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ +eq+ ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ +gt+ ] [
- { object object } { number sequence } classes<
-] unit-test
+++ /dev/null
-
-USING: kernel sequences assocs circular sets fry ;
-
-USING: math multi-methods ;
-
-QUALIFIED: sequences
-QUALIFIED: assocs
-QUALIFIED: circular
-QUALIFIED: sets
-
-IN: newfx
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Now, we can see a new world coming into view.
-! A world in which there is the very real prospect of a new world order.
-!
-! - George Herbert Walker Bush
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: at ( col key -- val )
-GENERIC: of ( key col -- val )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: grab ( col key -- col val )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: is ( col key val -- col )
-GENERIC: as ( col val key -- col )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: is-of ( key val col -- col )
-GENERIC: as-of ( val key col -- col )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: mutate-at ( col key val -- )
-GENERIC: mutate-as ( col val key -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: at-mutate ( key val col -- )
-GENERIC: as-mutate ( val key col -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! sequence
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at { sequence number } swap nth ;
-METHOD: of { number sequence } nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: grab { sequence number } dupd swap nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is { sequence number object } swap pick set-nth ;
-METHOD: as { sequence object number } pick set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is-of { number object sequence } dup [ swapd set-nth ] dip ;
-METHOD: as-of { object number sequence } dup [ set-nth ] dip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: mutate-at { sequence number object } swap rot set-nth ;
-METHOD: mutate-as { sequence object number } rot set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at-mutate { number object sequence } swapd set-nth ;
-METHOD: as-mutate { object number sequence } set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! assoc
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at { assoc object } swap assocs:at ;
-METHOD: of { object assoc } assocs:at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: grab { assoc object } dupd swap assocs:at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is { assoc object object } swap pick set-at ;
-METHOD: as { assoc object object } pick set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is-of { object object assoc } dup [ swapd set-at ] dip ;
-METHOD: as-of { object object assoc } dup [ set-at ] dip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: mutate-at { assoc object object } swap rot set-at ;
-METHOD: mutate-as { assoc object object } rot set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at-mutate { object object assoc } swapd set-at ;
-METHOD: as-mutate { object object assoc } set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: push ( seq obj -- seq ) over sequences:push ;
-: push-on ( obj seq -- seq ) tuck sequences:push ;
-: pushed ( seq obj -- ) swap sequences:push ;
-: pushed-on ( obj seq -- ) sequences:push ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: member? ( seq obj -- ? ) swap sequences:member? ;
-: member-of? ( obj seq -- ? ) sequences:member? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: delete-at-key ( tbl key -- tbl ) over delete-at ;
-: delete-key-of ( key tbl -- tbl ) tuck delete-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: delete ( seq elt -- seq ) over sequences:delete ;
-: delete-from ( elt seq -- seq ) tuck sequences:delete ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: deleted ( seq elt -- ) swap sequences:delete ;
-: deleted-from ( elt seq -- ) sequences:delete ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remove ( seq obj -- seq ) swap sequences:remove ;
-: remove-from ( obj seq -- seq ) sequences:remove ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: filter-of ( quot seq -- seq ) swap filter ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: map-over ( quot seq -- seq ) swap map ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: push-circular ( seq elt -- seq ) over circular:push-circular ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prefix-on ( elt seq -- seq ) swap prefix ;
-: suffix-on ( elt seq -- seq ) swap suffix ;
-
-: suffix! ( seq elt -- seq ) over sequences:push ;
-: suffix-on! ( elt seq -- seq ) tuck sequences:push ;
-: suffixed! ( seq elt -- ) swap sequences:push ;
-: suffixed-on! ( elt seq -- ) sequences:push ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: subseq ( seq from to -- subseq ) rot sequences:subseq ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: key ( table val -- key ) swap assocs:value-at ;
-
-: key-of ( val table -- key ) assocs:value-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: index ( seq obj -- i ) swap sequences:index ;
-: index-of ( obj seq -- i ) sequences:index ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 1st ( seq -- obj ) 0 swap nth ;
-: 2nd ( seq -- obj ) 1 swap nth ;
-: 3rd ( seq -- obj ) 2 swap nth ;
-: 4th ( seq -- obj ) 3 swap nth ;
-: 5th ( seq -- obj ) 4 swap nth ;
-: 6th ( seq -- obj ) 5 swap nth ;
-: 7th ( seq -- obj ) 6 swap nth ;
-: 8th ( seq -- obj ) 7 swap nth ;
-: 9th ( seq -- obj ) 8 swap nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A note about the 'mutate' qualifier. Other words also technically mutate
-! their primary object. However, the 'mutate' qualifier is supposed to
-! indicate that this is the main objective of the word, as a side effect.
-
-: adjoin ( seq elt -- seq ) over sets:adjoin ;
-: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ;
-: adjoined ( set elt -- ) swap sets:adjoin ;
-: adjoined-on ( elt set -- ) sets:adjoin ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start ( seq subseq -- i ) swap sequences:start ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pluck ( seq i -- seq ) cut-slice rest-slice append ;
-: pluck-from ( i seq -- seq ) swap pluck ;
-: pluck! ( seq i -- seq ) over delete-nth ;
-: pluck-from! ( i seq -- seq ) tuck delete-nth ;
-: plucked! ( seq i -- ) swap delete-nth ;
-: plucked-from! ( i seq -- ) delete-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: snip ( seq a b -- seq ) [ over ] dip [ head ] [ tail ] 2bi* append ;
-: snip-this ( a b seq -- seq ) -rot snip ;
-: snip! ( seq a b -- seq ) pick delete-slice ;
-: snip-this! ( a b seq -- seq ) -rot pick delete-slice ;
-: snipped! ( seq a b -- ) rot delete-slice ;
-: snipped-from! ( a b seq -- ) delete-slice ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: invert-index ( seq i -- seq i ) [ dup length 1 - ] dip - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: append! ( a b -- ab ) over sequences:push-all ;
-: append-to! ( b a -- ab ) swap over sequences:push-all ;
-: appended! ( a b -- ) swap sequences:push-all ;
-: appended-to! ( b a -- ) sequences:push-all ;
-
-: prepend! ( a b -- ba ) over append 0 pick copy ;
-: prepended! ( a b -- ) over append 0 rot copy ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: insert ( seq i obj -- seq ) [ cut ] dip prefix append ;
-
-: splice ( seq i seq -- seq ) [ cut ] dip prepend append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: purge ( seq quot -- seq ) [ not ] compose filter ; inline
-
-: purge! ( seq quot -- seq )
- dupd '[ swap @ [ pluck! ] [ drop ] if ] each-index ; inline
--- /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
USING: kernel tools.test peg.javascript peg.javascript.ast accessors ;
IN: peg.javascript.tests
-\ parse-javascript must-infer
-
{ T{ ast-begin f V{ T{ ast-number f 123 } } } } [
"123;" parse-javascript
] unit-test
\ No newline at end of file
accessors multiline sequences math peg.ebnf ;
IN: peg.javascript.parser.tests
-\ javascript must-infer
-
{
T{
ast-begin
USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer accessors ;
IN: peg.javascript.tokenizer.tests
-\ tokenize-javascript must-infer
-
{
V{
T{ ast-number f 123 }
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 -
--- /dev/null
+Maxim Savchenko
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel accessors continuations lexer vocabs vocabs.parser
+ combinators.short-circuit sandbox tools.test ;
+
+IN: sandbox.tests
+
+<< "sandbox.syntax" load-vocab drop >>
+USE: sandbox.syntax.private
+
+: run-script ( x lines -- y )
+ H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } }
+ parse-sandbox call( x -- x! ) ;
+
+[ 120 ]
+[
+ 5
+ {
+ "! Simple factorial example"
+ "APPLYING: kernel math sequences ;"
+ "1 swap [ 1+ * ] each"
+ } run-script
+] unit-test
+
+[
+ 5
+ {
+ "! Jailbreak attempt with USE:"
+ "USE: io"
+ "\"Hello world!\" print"
+ } run-script
+]
+[
+ {
+ [ lexer-error? ]
+ [ error>> condition? ]
+ [ error>> error>> no-word-error? ]
+ [ error>> error>> name>> "USE:" = ]
+ } 1&&
+] must-fail-with
+
+[
+ 5
+ {
+ "! Jailbreak attempt with unauthorized APPLY:"
+ "APPLY: io"
+ "\"Hello world!\" print"
+ } run-script
+]
+[
+ {
+ [ lexer-error? ]
+ [ error>> sandbox-error? ]
+ [ error>> vocab>> "io" = ]
+ } 1&&
+] must-fail-with
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences vectors assocs namespaces parser lexer vocabs
+ combinators.short-circuit vocabs.parser ;
+
+IN: sandbox
+
+SYMBOL: whitelist
+
+: with-sandbox-vocabs ( quot -- )
+ "sandbox.syntax" load-vocab vocab-words 1vector
+ use [ auto-use? off call ] with-variable ; inline
+
+: parse-sandbox ( lines assoc -- quot )
+ whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ;
+
+: reveal-in ( name -- )
+ [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ;
+
+SYNTAX: REVEAL: scan reveal-in ;
+
+SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ;
--- /dev/null
+Basic sandboxing
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ;
+IN: sandbox.syntax
+
+<PRIVATE
+
+ERROR: sandbox-error vocab ;
+
+: sandbox-use+ ( alias -- )
+ dup whitelist get at [ use+ ] [ sandbox-error ] ?if ;
+
+PRIVATE>
+
+SYNTAX: APPLY: scan sandbox-use+ ;
+
+SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ;
+
+REVEALING:
+ ! #!
+ HEX: OCT: BIN: f t CHAR: "
+ [ { T{
+ ] } ;
+
+REVEAL: ;
-USING: tools.test sequence-parser ascii kernel accessors ;
+USING: tools.test sequence-parser unicode.categories kernel
+accessors ;
IN: sequence-parser.tests
[ "hello" ]
[ "123u" ]
[ "123u" <sequence-parser> take-c-integer ] unit-test
+
+[ 36 ]
+[
+ " //jofiejoe\n //eoieow\n/*asdf*/\n "
+ <sequence-parser> skip-whitespace/comments n>>
+] unit-test
+
+[ f ]
+[ "\n" <sequence-parser> take-integer ] unit-test
+
+[ "\n" ] [ "\n" <sequence-parser> [ ] take-while ] unit-test
+[ f ] [ "\n" <sequence-parser> [ not ] take-while ] unit-test
] [
[ drop n>> ]
[ skip-until ]
- [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
] if ; inline
: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
: skip-whitespace ( sequence-parser -- sequence-parser )
[ [ current blank? not ] take-until drop ] keep ;
+: skip-whitespace-eol ( sequence-parser -- sequence-parser )
+ [ [ current " \t\r" member? not ] take-until drop ] keep ;
+
+: take-c-comment ( sequence-parser -- seq/f )
+ [
+ dup "/*" take-sequence [
+ "*/" take-until-sequence*
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: take-c++-comment ( sequence-parser -- seq/f )
+ [
+ dup "//" take-sequence [
+ [
+ [
+ { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
+ ] take-until
+ ] [
+ advance drop
+ ] bi
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace-eol
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
+ [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
: take-rest-slice ( sequence-parser -- sequence/f )
[ sequence>> ] [ n>> ] bi
2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
sequence-parser [ n + ] change-n drop
] if ;
-: take-c-comment ( sequence-parser -- seq/f )
- [
- dup "/*" take-sequence [
- "*/" take-until-sequence*
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
-
-: take-c++-comment ( sequence-parser -- seq/f )
- [
- dup "//" take-sequence [
- [
- [
- { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
- ] take-until
- ] [
- advance drop
- ] bi
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
-
: c-identifier-begin? ( ch -- ? )
CHAR: a CHAR: z [a,b]
CHAR: A CHAR: Z [a,b]
CHAR: 0 CHAR: 9 [a,b]
{ CHAR: _ } 4 nappend member? ;
-: take-c-identifier ( state-parser -- string/f )
- [
- dup current c-identifier-begin? [
- [ current c-identifier-ch? ] take-while
- ] [
- drop f
- ] if
- ] with-sequence-parser ;
+: (take-c-identifier) ( sequence-parser -- string/f )
+ dup current c-identifier-begin? [
+ [ current c-identifier-ch? ] take-while
+ ] [
+ drop f
+ ] if ;
+
+: take-c-identifier ( sequence-parser -- string/f )
+ [ (take-c-identifier) ] with-sequence-parser ;
<< "length" [ length ] define-sorting >>
: sort-tokens ( seq -- seq' )
{ length>=< <=> } sort-by ;
-: take-first-matching ( state-parser seq -- seq )
+: take-first-matching ( sequence-parser seq -- seq )
swap
'[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
-: take-longest ( state-parser seq -- seq )
+: take-longest ( sequence-parser seq -- seq )
sort-tokens take-first-matching ;
-: take-c-integer ( state-parser -- string/f )
+: take-c-integer ( sequence-parser -- string/f )
[
dup take-integer [
swap
] if*
] with-sequence-parser ;
+CONSTANT: c-punctuators
+ {
+ "[" "]" "(" ")" "{" "}" "." "->"
+ "++" "--" "&" "*" "+" "-" "~" "!"
+ "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
+ "?" ":" ";" "..."
+ "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
+ "," "#" "##"
+ "<:" ":>" "<%" "%>" "%:" "%:%:"
+ }
+
+: take-c-punctuator ( sequence-parser -- string/f )
+ c-punctuators take-longest ;
+
: write-full ( sequence-parser -- ) sequence>> write ;
: write-rest ( sequence-parser -- ) take-rest write ;
+++ /dev/null
-
-USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
- newfx ;
-
-IN: shell.parser
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: basic-expr command stdin stdout background ;
-TUPLE: pipeline-expr commands stdin stdout background ;
-TUPLE: single-quoted-expr expr ;
-TUPLE: double-quoted-expr expr ;
-TUPLE: back-quoted-expr expr ;
-TUPLE: glob-expr expr ;
-TUPLE: variable-expr expr ;
-TUPLE: factor-expr expr ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
-
-: ast>pipeline-expr ( ast -- obj )
- pipeline-expr new
- over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
- over 2nd >>stdin
- over 6th >>stdout
- swap 7th >>background ;
-
-: ast>single-quoted-expr ( ast -- obj )
- 2nd >string single-quoted-expr boa ;
-
-: ast>double-quoted-expr ( ast -- obj )
- 2nd >string double-quoted-expr boa ;
-
-: ast>back-quoted-expr ( ast -- obj )
- 2nd >string back-quoted-expr boa ;
-
-: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
-
-: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
-
-: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-EBNF: expr
-
-space = " "
-
-tab = "\t"
-
-white = (space | tab)
-
-_ = (white)* => [[ drop ignore ]]
-
-sq = "'"
-dq = '"'
-bq = "`"
-
-single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]]
-double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]]
-back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]]
-
-factor = "$(" (!(")") .)* ")" => [[ ast>factor-expr ]]
-
-variable = "$" other => [[ ast>variable-expr ]]
-
-glob-char = ("*" | "?")
-
-non-glob-char = !(glob-char | white) .
-
-glob-beginning-string = (non-glob-char)* => [[ >string ]]
-
-glob-rest-string = (non-glob-char)+ => [[ >string ]]
-
-glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]]
-
-other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]]
-
-element = (single-quoted | double-quoted | back-quoted | factor | variable | glob | other)
-
-command = (element _)+
-
-to-file = ">" _ other => [[ second ]]
-in-file = "<" _ other => [[ second ]]
-ap-file = ">>" _ other => [[ second ]]
-
-basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]]
-
-pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]]
-
-submission = (pipeline | basic)
-
-;EBNF
\ No newline at end of file
+++ /dev/null
-USING: kernel parser words continuations namespaces debugger
-sequences combinators splitting prettyprint system io io.files
-io.pathnames io.launcher io.directories io.encodings.utf8 io.pipes
-sequences.deep accessors multi-methods newfx shell.parser
-combinators.short-circuit eval environment ;
-IN: shell
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cd ( args -- )
- dup empty?
- [ drop home set-current-directory ]
- [ first set-current-directory ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pwd ( args -- )
- drop
- current-directory get
- print ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: swords ( -- seq ) { "cd" "pwd" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: expand ( expr -- expr )
-
-METHOD: expand { single-quoted-expr } expr>> ;
-
-METHOD: expand { double-quoted-expr } expr>> ;
-
-METHOD: expand { variable-expr } expr>> os-env ;
-
-METHOD: expand { glob-expr }
- expr>>
- dup "*" =
- [ drop current-directory get directory-files ]
- [ ]
- if ;
-
-METHOD: expand { factor-expr } expr>> eval>string ;
-
-DEFER: expansion
-
-METHOD: expand { back-quoted-expr }
- expr>>
- expr
- command>>
- expansion
- utf8 <process-stream>
- contents
- " \n" split
- "" remove ;
-
-METHOD: expand { object } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: expansion ( command -- command ) [ expand ] map flatten ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-sword ( basic-expr -- )
- command>> expansion unclip "shell" lookup execute( arguments -- ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-foreground ( process -- )
- [ try-process ] [ print-error drop ] recover ;
-
-: run-background ( process -- ) run-detached drop ;
-
-: run-basic-expr ( basic-expr -- )
- <process>
- over command>> expansion >>command
- over stdin>> >>stdin
- over stdout>> >>stdout
- swap background>>
- [ run-background ]
- [ run-foreground ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: basic-chant ( basic-expr -- )
- dup command>> first swords member-of?
- [ run-sword ]
- [ run-basic-expr ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chant ( obj -- )
- dup basic-expr?
- [ basic-chant ]
- [ pipeline-chant ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prompt ( -- )
- current-directory get write
- " $ " write
- flush ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: shell
-
-: handle ( input -- )
- {
- { [ dup f = ] [ drop ] }
- { [ dup "exit" = ] [ drop ] }
- { [ dup "" = ] [ drop shell ] }
- { [ dup expr ] [ expr chant shell ] }
- { [ t ] [ drop "ix: ignoring input" print shell ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: shell ( -- )
- prompt
- readln
- handle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ix ( -- ) shell ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: ix
--- /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 ;
+
+CONSTANT: telephone-sample-freq 8000
+CONSTANT: half-sample-freq 22050
+CONSTANT: cd-sample-freq 44100
+CONSTANT: digital-sample-freq 48000
+CONSTANT: 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 ;
+
-Copyright (C) 2003, 2009 Slava Pestov and friends.
-
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
(fuel-con--send-string/wait buffer
fuel-con--init-stanza
'fuel-con--establish-connection-cont
- 60000)
+ 3000000)
conn))
(defun fuel-con--establish-connection-cont (ignore)
--- /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
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays classes kernel sequences sets
+io prettyprint multi-methods ;
+IN: boolean-expr
+
+! Demonstrates the use of Unicode symbols in source files, and
+! multi-method dispatch.
+
+TUPLE: ⋀ x y ;
+TUPLE: ⋁ x y ;
+TUPLE: ¬ x ;
+
+SINGLETONS: ⊤ ⊥ ;
+
+SINGLETONS: P Q R S T U V W X Y Z ;
+
+UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ;
+
+GENERIC: ⋀ ( x y -- expr )
+
+METHOD: ⋀ { ⊤ □ } nip ;
+METHOD: ⋀ { □ ⊤ } drop ;
+METHOD: ⋀ { ⊥ □ } drop ;
+METHOD: ⋀ { □ ⊥ } nip ;
+
+METHOD: ⋀ { ⋁ □ } [ [ x>> ] dip ⋀ ] [ [ y>> ] dip ⋀ ] 2bi ⋁ ;
+METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
+
+METHOD: ⋀ { □ □ } \ ⋀ boa ;
+
+GENERIC: ⋁ ( x y -- expr )
+
+METHOD: ⋁ { ⊤ □ } drop ;
+METHOD: ⋁ { □ ⊤ } nip ;
+METHOD: ⋁ { ⊥ □ } nip ;
+METHOD: ⋁ { □ ⊥ } drop ;
+
+METHOD: ⋁ { □ □ } \ ⋁ boa ;
+
+GENERIC: ¬ ( x -- expr )
+
+METHOD: ¬ { ⊤ } drop ⊥ ;
+METHOD: ¬ { ⊥ } drop ⊤ ;
+
+METHOD: ¬ { ⋀ } [ x>> ¬ ] [ y>> ¬ ] bi ⋁ ;
+METHOD: ¬ { ⋁ } [ x>> ¬ ] [ y>> ¬ ] bi ⋀ ;
+
+METHOD: ¬ { □ } \ ¬ boa ;
+
+: → ( x y -- expr ) ¬ ⋀ ;
+: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ;
+: ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ;
+
+GENERIC: (cnf) ( expr -- cnf )
+
+METHOD: (cnf) { ⋀ } [ x>> (cnf) ] [ y>> (cnf) ] bi append ;
+METHOD: (cnf) { □ } 1array ;
+
+GENERIC: cnf ( expr -- cnf )
+
+METHOD: cnf { ⋁ } [ x>> cnf ] [ y>> cnf ] bi append ;
+METHOD: cnf { □ } (cnf) 1array ;
+
+GENERIC: satisfiable? ( expr -- ? )
+
+METHOD: satisfiable? { ⊤ } drop t ;
+METHOD: satisfiable? { ⊥ } drop f ;
+
+: partition ( seq quot -- left right )
+ [ [ not ] compose filter ] [ filter ] 2bi ; inline
+
+: (satisfiable?) ( seq -- ? )
+ [ \ ¬ instance? ] partition [ x>> ] map intersect empty? ;
+
+METHOD: satisfiable? { □ }
+ cnf [ (satisfiable?) ] any? ;
+
+GENERIC: (expr.) ( expr -- )
+
+METHOD: (expr.) { □ } pprint ;
+
+: op. ( expr -- )
+ "(" write
+ [ x>> (expr.) ]
+ [ bl class pprint bl ]
+ [ y>> (expr.) ]
+ tri
+ ")" write ;
+
+METHOD: (expr.) { ⋀ } op. ;
+METHOD: (expr.) { ⋁ } op. ;
+METHOD: (expr.) { ¬ } [ class pprint ] [ x>> (expr.) ] bi ;
+
+: expr. ( expr -- ) (expr.) nl ;
--- /dev/null
+Simple boolean expression evaluator and simplifier
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io lint kernel math tools.test ;
+IN: lint.tests
+
+! Don't write code like this
+: lint1 ( obj -- ) [ "hi" print ] [ ] if ; ! when
+
+[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
+
+: lint2 ( n -- n' ) 1 + ; ! 1+
+[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
+
+: lint3 ( a b -- b a b ) dup -rot ; ! tuck
+
+[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.accessors arrays assocs
+combinators.short-circuit fry hashtables io
+kernel math namespaces prettyprint quotations sequences
+sequences.deep sets slots.private vectors vocabs words
+kernel.private ;
+IN: lint
+
+SYMBOL: def-hash
+SYMBOL: def-hash-keys
+
+: set-hash-vector ( val key hash -- )
+ 2dup at -rot [ ?push ] 2dip set-at ;
+
+: more-defs ( hash -- )
+ {
+ { -rot [ swap [ swap ] dip ] }
+ { -rot [ swap swapd ] }
+ { rot [ [ swap ] dip swap ] }
+ { rot [ swapd swap ] }
+ { over [ dup swap ] }
+ { tuck [ dup -rot ] }
+ { swapd [ [ swap ] dip ] }
+ { 2nip [ nip nip ] }
+ { 2drop [ drop drop ] }
+ { 3drop [ drop drop drop ] }
+ { pop* [ pop drop ] }
+ { when [ [ ] if ] }
+ { >boolean [ f = not ] }
+ } swap '[ first2 _ set-hash-vector ] each ;
+
+: accessor-words ( -- seq )
+{
+ alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
+ alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
+ <displaced-alien> alien-unsigned-cell set-alien-signed-cell
+ set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
+ set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
+ set-alien-unsigned-8 set-alien-signed-8
+ alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
+ set-alien-float alien-float
+} ;
+
+: trivial-defs ( -- seq )
+ {
+ [ drop ] [ 2array ]
+ [ bitand ]
+
+ [ . ]
+ [ get ]
+ [ t ] [ f ]
+ [ { } ]
+ [ drop f ]
+ [ "cdecl" ]
+ [ first ] [ second ] [ third ] [ fourth ]
+ [ ">" write ] [ "/>" write ]
+ } ;
+
+! ! Add definitions
+H{ } clone def-hash set-global
+
+all-words [
+ dup def>> dup callable?
+ [ def-hash get-global set-hash-vector ] [ drop ] if
+] each
+
+! ! Remove definitions
+
+! Remove empty word defs
+def-hash get-global [ drop empty? not ] assoc-filter
+
+! Remove constants [ 1 ]
+[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
+
+! Remove words that are their own definition
+[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
+
+! Remove set-alien-cell, etc.
+[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
+
+! Remove trivial defs
+[ drop trivial-defs member? not ] assoc-filter
+
+! Remove numbers only defs
+[ drop [ number? ] all? not ] assoc-filter
+
+! Remove curry only defs
+[ drop [ \ curry = ] all? not ] assoc-filter
+
+! Remove tag defs
+[
+ drop {
+ [ length 3 = ]
+ [ first \ tag = ] [ second number? ] [ third \ eq? = ]
+ } 1&& not
+] assoc-filter
+
+[
+ drop {
+ [ [ wrapper? ] deep-any? ]
+ [ [ hashtable? ] deep-any? ]
+ } 1|| not
+] assoc-filter
+
+! Remove n m shift defs
+[
+ drop dup length 3 = [
+ [ first2 [ number? ] both? ]
+ [ third \ shift = ] bi and not
+ ] [ drop t ] if
+] assoc-filter
+
+! Remove [ n slot ]
+[
+ drop dup length 2 =
+ [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
+] assoc-filter
+
+
+dup more-defs
+
+[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
+
+: find-duplicates ( -- seq )
+ def-hash get-global [ nip length 1 > ] assoc-filter ;
+
+GENERIC: lint ( obj -- seq )
+
+M: object lint ( obj -- seq ) drop f ;
+
+: subseq/member? ( subseq/member seq -- ? )
+ { [ start ] [ member? ] } 2|| ;
+
+M: callable lint ( quot -- seq )
+ [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
+
+M: word lint ( word -- seq )
+ def>> dup callable? [ lint ] [ drop f ] if ;
+
+: word-path. ( word -- )
+ [ vocabulary>> ] [ unparse ] bi ":" glue print ;
+
+: 4bl ( -- ) bl bl bl bl ;
+
+: (lint.) ( pair -- )
+ first2 [ word-path. ] dip [
+ [ 4bl . "-----------------------------------" print ]
+ [ def-hash get-global at [ 4bl word-path. ] each nl ] bi
+ ] each nl nl ;
+
+: lint. ( alist -- ) [ (lint.) ] each ;
+
+GENERIC: run-lint ( obj -- obj )
+
+: (trim-self) ( val key -- obj ? )
+ def-hash get-global at*
+ [ dupd remove empty? not ] [ drop f ] if ;
+
+: trim-self ( seq -- newseq )
+ [ [ (trim-self) ] filter ] assoc-map ;
+
+: filter-symbols ( alist -- alist )
+ [
+ nip first dup def-hash get-global at
+ [ first ] bi@ literalize = not
+ ] assoc-filter ;
+
+M: sequence run-lint ( seq -- seq )
+ [ dup lint ] { } map>assoc trim-self
+ [ second empty? not ] filter filter-symbols ;
+
+M: word run-lint ( word -- seq ) 1array run-lint ;
+
+: lint-all ( -- seq ) all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
+
+: lint-word ( word -- seq ) 1array run-lint dup lint. ;
--- /dev/null
+Finds potential mistakes in code
+++ /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
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences vectors classes classes.algebra
+combinators arrays words assocs parser namespaces make
+definitions prettyprint prettyprint.backend prettyprint.custom
+quotations generalizations debugger io compiler.units
+kernel.private effects accessors hashtables sorting shuffle
+math.order sets see effects.parser ;
+IN: multi-methods
+
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
+
+SYMBOL: args
+
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] filter
+ [ length <reversed> [ 1+ neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] filter
+ [ keys [ hooks get adjoin ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ [
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get +
+ ] dip
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ [ total get object <array> dup <enum> ] dip update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ [ canonicalize-specializer-0 ] dip ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ [ canonicalize-specializer-1 ] dip ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ [ canonicalize-specializer-2 ] dip ] assoc-map
+
+ args get hooks get length + total set
+
+ [ [ canonicalize-specializer-3 ] dip ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
+: maximal-element ( seq quot -- n elt )
+ dupd [
+ swapd [ call +lt+ = ] 2curry filter empty?
+ ] 2curry find [ "Topological sort failed" throw ] unless* ;
+ inline
+
+: topological-sort ( seq quot -- newseq )
+ [ >vector [ dup empty? not ] ] dip
+ [ dupd maximal-element [ over delete-nth ] dip ] curry
+ produce nip ; inline
+
+: classes< ( seq1 seq2 -- lt/eq/gt )
+ [
+ {
+ { [ 2dup eq? ] [ +eq+ ] }
+ { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
+ { [ 2dup class<= ] [ +lt+ ] }
+ { [ 2dup swap class<= ] [ +gt+ ] }
+ [ +eq+ ]
+ } cond 2nip
+ ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
+
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
+: picker ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1- picker [ dip swap ] curry ]
+ } case ;
+
+: (multi-predicate) ( class picker -- quot )
+ swap "predicate" word-prop append ;
+
+: multi-predicate ( classes -- quot )
+ dup length <reversed>
+ [ picker 2array ] 2map
+ [ drop object eq? not ] assoc-filter
+ [ [ t ] ] [
+ [ (multi-predicate) ] { } assoc>map
+ unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ ] if-empty ;
+
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
+ 2bi alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
+: methods ( word -- alist )
+ "multi-methods" word-prop >alist ;
+
+: make-generic ( generic -- quot )
+ [
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
+ ] [ ] make ;
+
+: update-generic ( word -- )
+ dup make-generic define ;
+
+! Methods
+PREDICATE: method-body < word
+ "multi-method-generic" word-prop >boolean ;
+
+M: method-body stack-effect
+ "multi-method-generic" word-prop stack-effect ;
+
+M: method-body crossref?
+ "forgotten" word-prop not ;
+
+: method-word-name ( specializer generic -- string )
+ [ name>> % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
+ [
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
+ method-word-name f <word>
+ swap >>props ;
+
+: with-methods ( word quot -- )
+ over [
+ [ "multi-methods" word-prop ] dip call
+ ] dip update-generic ; inline
+
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
+
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
+
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
+ ] if ;
+
+: niceify-method ( seq -- seq )
+ [ dup \ f eq? [ drop f ] when ] map ;
+
+M: no-method error.
+ "Type check error" print
+ nl
+ "Generic word " write dup generic>> pprint
+ " does not have a method applicable to inputs:" print
+ dup arguments>> short.
+ nl
+ "Inputs have signature:" print
+ dup arguments>> [ class ] map niceify-method .
+ nl
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
+
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
+
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
+
+: define-generic ( word effect -- )
+ over set-stack-effect
+ dup "multi-methods" word-prop [ drop ] [
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
+ ] if ;
+
+! Syntax
+SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
+
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
+
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-object swap create-method-in ;
+
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
+
+SYNTAX: METHOD: (METHOD:) define ;
+
+! For compatibility
+SYNTAX: M:
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ;
+
+! Definition protocol. We qualify core generics here
+QUALIFIED: syntax
+
+syntax:M: generic definer drop \ GENERIC: f ;
+
+syntax:M: generic definition drop f ;
+
+PREDICATE: method-spec < array
+ unclip generic? [ [ class? ] all? ] dip and ;
+
+syntax:M: method-spec where
+ dup unclip method [ ] [ first ] ?if where ;
+
+syntax:M: method-spec set-where
+ unclip method set-where ;
+
+syntax:M: method-spec definer
+ unclip method definer ;
+
+syntax:M: method-spec definition
+ unclip method definition ;
+
+syntax:M: method-spec synopsis*
+ unclip method synopsis* ;
+
+syntax:M: method-spec forget*
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
--- /dev/null
+Experimental multiple dispatch implementation
--- /dev/null
+extensions
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test ( -- )
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1 ( -- seq )
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+CONSTANT: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ }
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ { cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+
+[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+[ { } \ fake method-word-props ] unit-test
+
+[ t ] [ { } \ fake <method> method-body? ] unit-test
+
+[
+ [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing (( -- )) define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+] with-compilation-unit
--- /dev/null
+IN: multi-methods.tests
+USING: math strings sequences tools.test ;
+
+GENERIC: legacy-test ( a -- b )
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs accessors see ;
+
+GENERIC: first-test ( -- )
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+GENERIC: beats? ( obj1 obj2 -- ? )
+
+METHOD: beats? { paper scissors } t ;
+METHOD: beats? { scissors rock } t ;
+METHOD: beats? { rock paper } t ;
+METHOD: beats? { thing thing } f ;
+
+: play ( obj1 obj2 -- ? ) beats? 2nip ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+GENERIC: hook-test ( -- obj )
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+USING: kernel multi-methods tools.test math arrays sequences
+math.order ;
+IN: multi-methods.tests
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ +lt+ ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ +eq+ ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ +gt+ ] [
+ { object object } { number sequence } classes<
+] unit-test
--- /dev/null
+
+USING: kernel sequences assocs circular sets fry ;
+
+USING: math multi-methods ;
+
+QUALIFIED: sequences
+QUALIFIED: assocs
+QUALIFIED: circular
+QUALIFIED: sets
+
+IN: newfx
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Now, we can see a new world coming into view.
+! A world in which there is the very real prospect of a new world order.
+!
+! - George Herbert Walker Bush
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: at ( col key -- val )
+GENERIC: of ( key col -- val )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: grab ( col key -- col val )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: is ( col key val -- col )
+GENERIC: as ( col val key -- col )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: is-of ( key val col -- col )
+GENERIC: as-of ( val key col -- col )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: mutate-at ( col key val -- )
+GENERIC: mutate-as ( col val key -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: at-mutate ( key val col -- )
+GENERIC: as-mutate ( val key col -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! sequence
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at { sequence number } swap nth ;
+METHOD: of { number sequence } nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: grab { sequence number } dupd swap nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is { sequence number object } swap pick set-nth ;
+METHOD: as { sequence object number } pick set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is-of { number object sequence } dup [ swapd set-nth ] dip ;
+METHOD: as-of { object number sequence } dup [ set-nth ] dip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { sequence number object } swap rot set-nth ;
+METHOD: mutate-as { sequence object number } rot set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at-mutate { number object sequence } swapd set-nth ;
+METHOD: as-mutate { object number sequence } set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! assoc
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at { assoc object } swap assocs:at ;
+METHOD: of { object assoc } assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: grab { assoc object } dupd swap assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is { assoc object object } swap pick set-at ;
+METHOD: as { assoc object object } pick set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is-of { object object assoc } dup [ swapd set-at ] dip ;
+METHOD: as-of { object object assoc } dup [ set-at ] dip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { assoc object object } swap rot set-at ;
+METHOD: mutate-as { assoc object object } rot set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at-mutate { object object assoc } swapd set-at ;
+METHOD: as-mutate { object object assoc } set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push ( seq obj -- seq ) over sequences:push ;
+: push-on ( obj seq -- seq ) tuck sequences:push ;
+: pushed ( seq obj -- ) swap sequences:push ;
+: pushed-on ( obj seq -- ) sequences:push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: member? ( seq obj -- ? ) swap sequences:member? ;
+: member-of? ( obj seq -- ? ) sequences:member? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete-at-key ( tbl key -- tbl ) over delete-at ;
+: delete-key-of ( key tbl -- tbl ) tuck delete-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete ( seq elt -- seq ) over sequences:delete ;
+: delete-from ( elt seq -- seq ) tuck sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: deleted ( seq elt -- ) swap sequences:delete ;
+: deleted-from ( elt seq -- ) sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remove ( seq obj -- seq ) swap sequences:remove ;
+: remove-from ( obj seq -- seq ) sequences:remove ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: filter-of ( quot seq -- seq ) swap filter ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: map-over ( quot seq -- seq ) swap map ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push-circular ( seq elt -- seq ) over circular:push-circular ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prefix-on ( elt seq -- seq ) swap prefix ;
+: suffix-on ( elt seq -- seq ) swap suffix ;
+
+: suffix! ( seq elt -- seq ) over sequences:push ;
+: suffix-on! ( elt seq -- seq ) tuck sequences:push ;
+: suffixed! ( seq elt -- ) swap sequences:push ;
+: suffixed-on! ( elt seq -- ) sequences:push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: subseq ( seq from to -- subseq ) rot sequences:subseq ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key ( table val -- key ) swap assocs:value-at ;
+
+: key-of ( val table -- key ) assocs:value-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: index ( seq obj -- i ) swap sequences:index ;
+: index-of ( obj seq -- i ) sequences:index ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 1st ( seq -- obj ) 0 swap nth ;
+: 2nd ( seq -- obj ) 1 swap nth ;
+: 3rd ( seq -- obj ) 2 swap nth ;
+: 4th ( seq -- obj ) 3 swap nth ;
+: 5th ( seq -- obj ) 4 swap nth ;
+: 6th ( seq -- obj ) 5 swap nth ;
+: 7th ( seq -- obj ) 6 swap nth ;
+: 8th ( seq -- obj ) 7 swap nth ;
+: 9th ( seq -- obj ) 8 swap nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A note about the 'mutate' qualifier. Other words also technically mutate
+! their primary object. However, the 'mutate' qualifier is supposed to
+! indicate that this is the main objective of the word, as a side effect.
+
+: adjoin ( seq elt -- seq ) over sets:adjoin ;
+: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ;
+: adjoined ( set elt -- ) swap sets:adjoin ;
+: adjoined-on ( elt set -- ) sets:adjoin ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start ( seq subseq -- i ) swap sequences:start ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pluck ( seq i -- seq ) cut-slice rest-slice append ;
+: pluck-from ( i seq -- seq ) swap pluck ;
+: pluck! ( seq i -- seq ) over delete-nth ;
+: pluck-from! ( i seq -- seq ) tuck delete-nth ;
+: plucked! ( seq i -- ) swap delete-nth ;
+: plucked-from! ( i seq -- ) delete-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: snip ( seq a b -- seq ) [ over ] dip [ head ] [ tail ] 2bi* append ;
+: snip-this ( a b seq -- seq ) -rot snip ;
+: snip! ( seq a b -- seq ) pick delete-slice ;
+: snip-this! ( a b seq -- seq ) -rot pick delete-slice ;
+: snipped! ( seq a b -- ) rot delete-slice ;
+: snipped-from! ( a b seq -- ) delete-slice ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: invert-index ( seq i -- seq i ) [ dup length 1 - ] dip - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: append! ( a b -- ab ) over sequences:push-all ;
+: append-to! ( b a -- ab ) swap over sequences:push-all ;
+: appended! ( a b -- ) swap sequences:push-all ;
+: appended-to! ( b a -- ) sequences:push-all ;
+
+: prepend! ( a b -- ba ) over append 0 pick copy ;
+: prepended! ( a b -- ) over append 0 rot copy ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: insert ( seq i obj -- seq ) [ cut ] dip prefix append ;
+
+: splice ( seq i seq -- seq ) [ cut ] dip prepend append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: purge ( seq quot -- seq ) [ not ] compose filter ; inline
+
+: purge! ( seq quot -- seq )
+ dupd '[ swap @ [ pluck! ] [ drop ] if ] each-index ; inline
+++ /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
+
+USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
+ newfx ;
+
+IN: shell.parser
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: basic-expr command stdin stdout background ;
+TUPLE: pipeline-expr commands stdin stdout background ;
+TUPLE: single-quoted-expr expr ;
+TUPLE: double-quoted-expr expr ;
+TUPLE: back-quoted-expr expr ;
+TUPLE: glob-expr expr ;
+TUPLE: variable-expr expr ;
+TUPLE: factor-expr expr ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
+
+: ast>pipeline-expr ( ast -- obj )
+ pipeline-expr new
+ over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
+ over 2nd >>stdin
+ over 6th >>stdout
+ swap 7th >>background ;
+
+: ast>single-quoted-expr ( ast -- obj )
+ 2nd >string single-quoted-expr boa ;
+
+: ast>double-quoted-expr ( ast -- obj )
+ 2nd >string double-quoted-expr boa ;
+
+: ast>back-quoted-expr ( ast -- obj )
+ 2nd >string back-quoted-expr boa ;
+
+: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
+
+: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
+
+: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+EBNF: expr
+
+space = " "
+
+tab = "\t"
+
+white = (space | tab)
+
+_ = (white)* => [[ drop ignore ]]
+
+sq = "'"
+dq = '"'
+bq = "`"
+
+single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]]
+double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]]
+back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]]
+
+factor = "$(" (!(")") .)* ")" => [[ ast>factor-expr ]]
+
+variable = "$" other => [[ ast>variable-expr ]]
+
+glob-char = ("*" | "?")
+
+non-glob-char = !(glob-char | white) .
+
+glob-beginning-string = (non-glob-char)* => [[ >string ]]
+
+glob-rest-string = (non-glob-char)+ => [[ >string ]]
+
+glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]]
+
+other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]]
+
+element = (single-quoted | double-quoted | back-quoted | factor | variable | glob | other)
+
+command = (element _)+
+
+to-file = ">" _ other => [[ second ]]
+in-file = "<" _ other => [[ second ]]
+ap-file = ">>" _ other => [[ second ]]
+
+basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]]
+
+pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]]
+
+submission = (pipeline | basic)
+
+;EBNF
\ No newline at end of file
--- /dev/null
+USING: kernel parser words continuations namespaces debugger
+sequences combinators splitting prettyprint system io io.files
+io.pathnames io.launcher io.directories io.encodings.utf8 io.pipes
+sequences.deep accessors multi-methods newfx shell.parser
+combinators.short-circuit eval environment ;
+IN: shell
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cd ( args -- )
+ dup empty?
+ [ drop home set-current-directory ]
+ [ first set-current-directory ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pwd ( args -- )
+ drop
+ current-directory get
+ print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: swords ( -- seq ) { "cd" "pwd" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: expand ( expr -- expr )
+
+METHOD: expand { single-quoted-expr } expr>> ;
+
+METHOD: expand { double-quoted-expr } expr>> ;
+
+METHOD: expand { variable-expr } expr>> os-env ;
+
+METHOD: expand { glob-expr }
+ expr>>
+ dup "*" =
+ [ drop current-directory get directory-files ]
+ [ ]
+ if ;
+
+METHOD: expand { factor-expr } expr>> eval>string ;
+
+DEFER: expansion
+
+METHOD: expand { back-quoted-expr }
+ expr>>
+ expr
+ command>>
+ expansion
+ utf8 <process-stream>
+ contents
+ " \n" split
+ "" remove ;
+
+METHOD: expand { object } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: expansion ( command -- command ) [ expand ] map flatten ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-sword ( basic-expr -- )
+ command>> expansion unclip "shell" lookup execute( arguments -- ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-foreground ( process -- )
+ [ try-process ] [ print-error drop ] recover ;
+
+: run-background ( process -- ) run-detached drop ;
+
+: run-basic-expr ( basic-expr -- )
+ <process>
+ over command>> expansion >>command
+ over stdin>> >>stdin
+ over stdout>> >>stdout
+ swap background>>
+ [ run-background ]
+ [ run-foreground ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: basic-chant ( basic-expr -- )
+ dup command>> first swords member-of?
+ [ run-sword ]
+ [ run-basic-expr ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chant ( obj -- )
+ dup basic-expr?
+ [ basic-chant ]
+ [ pipeline-chant ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prompt ( -- )
+ current-directory get write
+ " $ " write
+ flush ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: shell
+
+: handle ( input -- )
+ {
+ { [ dup f = ] [ drop ] }
+ { [ dup "exit" = ] [ drop ] }
+ { [ dup "" = ] [ drop shell ] }
+ { [ dup expr ] [ expr chant shell ] }
+ { [ t ] [ drop "ix: ignoring input" print shell ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shell ( -- )
+ prompt
+ readln
+ handle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ix ( -- ) shell ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: ix
+++ /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 ;
-
{
if (BIGNUM_ZERO_P (denominator))
{
- divide_by_zero_error(NULL);
+ divide_by_zero_error();
return;
}
if (BIGNUM_ZERO_P (numerator))
{
if (BIGNUM_ZERO_P (denominator))
{
- divide_by_zero_error(NULL);
+ divide_by_zero_error();
return (BIGNUM_OUT_OF_BAND);
}
if (BIGNUM_ZERO_P (numerator))
{
if (BIGNUM_ZERO_P (denominator))
{
- divide_by_zero_error(NULL);
+ divide_by_zero_error();
return (BIGNUM_OUT_OF_BAND);
}
if (BIGNUM_ZERO_P (numerator))
word->optimizedp = T;
}
-/* Allocates memory */
-void default_word_code(F_WORD *word, bool relocate)
+/* Compile a word definition with the non-optimizing compiler. Allocates memory */
+void jit_compile_word(F_WORD *word, CELL def, bool relocate)
{
+ REGISTER_ROOT(def);
REGISTER_UNTAGGED(word);
- jit_compile(word->def,relocate);
+ jit_compile(def,relocate);
UNREGISTER_UNTAGGED(word);
+ UNREGISTER_ROOT(def);
- word->code = untag_quotation(word->def)->code;
+ word->code = untag_quotation(def)->code;
word->optimizedp = F;
}
CELL data = array_nth(pair,1);
- if(data == F)
+ if(type_of(data) == QUOTATION_TYPE)
{
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
- default_word_code(word,false);
+ jit_compile_word(word,data,false);
UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist);
}
- else
+ else if(type_of(data) == ARRAY_TYPE)
{
F_ARRAY *compiled_code = untag_array(data);
set_word_code(word,compiled);
}
+ else
+ critical_error("Expected a quotation or an array",data);
REGISTER_UNTAGGED(alist);
update_word_xt(word);
bool in_code_heap_p(CELL ptr);
-void default_word_code(F_WORD *word, bool relocate);
+void jit_compile_word(F_WORD *word, CELL def, bool relocate);
void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled);
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;
clear_gc_stats();
}
+/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
+ to coalesce equal but distinct quotations and wrappers. */
void primitive_become(void)
{
F_ARRAY *new_objects = untag_array(dpop());
gc();
+ /* If a word's definition quotation was in old_objects and the
+ quotation in new_objects is not compiled, we might leak memory
+ by referencing the old quotation unless we recompile all
+ unoptimized words. */
compile_all_words();
}
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
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
-void divide_by_zero_error(F_STACK_FRAME *native_stack)
+void divide_by_zero_error(void)
{
- general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack);
+ general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
void memory_signal_handler_impl(void)
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
-void divide_by_zero_signal_handler_impl(void)
-{
- divide_by_zero_error(signal_callstack_top);
-}
-
void misc_signal_handler_impl(void)
{
signal_error(signal_number,signal_callstack_top);
void throw_error(CELL error, F_STACK_FRAME *native_stack);
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack);
-void divide_by_zero_error(F_STACK_FRAME *native_stack);
+void divide_by_zero_error(void);
void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack);
void signal_error(int signal, F_STACK_FRAME *native_stack);
void type_error(CELL type, CELL tagged);
void *signal_callstack_top;
void memory_signal_handler_impl(void);
-void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);
void primitive_unimplemented(void);
userenv[i] = F;
/* do a full GC + code heap compaction */
+ performing_compaction = true;
compact_code_heap();
+ performing_compaction = false;
UNREGISTER_C_STRING(path);
signal_fault_addr = e->ExceptionInformation[1];
c->EIP = (CELL)memory_signal_handler_impl;
}
- else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO
- || e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO)
- {
- signal_number = ERROR_DIVIDE_BY_ZERO;
- c->EIP = (CELL)divide_by_zero_signal_handler_impl;
- }
/* If the Widcomm bluetooth stack is installed, the BTTray.exe process
injects code into running programs. For some reason this results in
random SEH exceptions with this (undocumented) exception code being
this exception means. */
else if(e->ExceptionCode != 0x40010006)
{
- signal_number = 11;
+ signal_number = e->ExceptionCode;
c->EIP = (CELL)misc_signal_handler_impl;
}
F_WORD *word = untag_word(array_nth(untag_array(words),i));
REGISTER_UNTAGGED(word);
if(word->optimizedp == F)
- default_word_code(word,false);
+ jit_compile_word(word,word->def,false);
UNREGISTER_UNTAGGED(word);
update_word_xt(word);
}
word->code = NULL;
REGISTER_UNTAGGED(word);
- default_word_code(word,true);
+ jit_compile_word(word,word->def,true);
UNREGISTER_UNTAGGED(word);
REGISTER_UNTAGGED(word);
projects / factor.git / commitdiff