* Contents
-- Platform support
- Compiling the Factor VM
- Libraries needed for compilation
- Bootstrapping the Factor image
- Source organization
- Community
-* Platform support
-
-Factor supports the following platforms:
-
- Linux/x86
- Linux/AMD64
- Linux/PowerPC
- Linux/ARM
- Mac OS X/x86
- Mac OS X/PowerPC
- FreeBSD/x86
- FreeBSD/AMD64
- OpenBSD/x86
- OpenBSD/AMD64
- Solaris/x86
- Solaris/AMD64
- MS Windows/x86 (XP and above)
- MS Windows CE/ARM
-
-Please donate time or hardware if you wish to see Factor running on
-other platforms. In particular, we are interested in:
-
- Windows/AMD64
- Mac OS X/AMD64
- Solaris/UltraSPARC
- Linux/MIPS
-
* Compiling the Factor VM
The Factor runtime is written in GNU C99, and is built with GNU make and
gcc.
-Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
-3.3 or earlier. If you are using gcc 4.3, you might get an unusable
-Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the
-command-line arguments for make.
+Factor supports various platforms. For an up-to-date list, see
+<http://factorcode.org/getfactor.fhtml>.
+
+Factor requires gcc 3.4 or later.
+
+On x86, Factor /will not/ build using gcc 3.3 or earlier.
+
+If you are using gcc 4.3, you might get an unusable Factor binary unless
+you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
+arguments for make.
-Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of
-targets and build options. Then run 'make' with the appropriate target
-for your platform.
+Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
Compilation will yield an executable named 'factor' on Unix,
-'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
+'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
* Libraries needed for compilation
-For X11 support, you need recent development libraries for libc, Freetype,
-X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu),
-you can use the line
+For X11 support, you need recent development libraries for libc,
+Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
+(like Ubuntu), you can use the line
-sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
+ sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
-to grab everything (if you're on a non-debian-derived distro please tell us
-what the equivalent command is on there and it can be added :)
+to grab everything (if you're on a non-debian-derived distro please tell
+us what the equivalent command is on there and it can be added).
* Bootstrapping the Factor image
-The boot images are no longer included with the Factor distribution
-due to size concerns. Instead, download a boot image from:
-
- http://factorcode.org/images/
-
Once you have compiled the Factor runtime, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
-Once you download the right image, bootstrap the system with the
+Boot images can be obtained from <http://factorcode.org/images/latest/>.
+
+Once you download the right image, bootstrap Factor with the
following command line:
./factor -i=boot.<cpu>.image
-Or this command for Mac OS X systems:
-
-./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
-
Bootstrap can take a while, depending on your system. When the process
completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between
* Running Factor on Mac OS X - Cocoa UI
-On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the
-terminal listener. If you are using Mac OS X 10.3, you can only run the
-X11 UI, as documented in the next section.
+On Mac OS X, a Cocoa UI is available in addition to the terminal
+listener.
The 'factor' executable runs the terminal listener:
* Running Factor on Mac OS X - X11 UI
-The X11 UI is available on Mac OS X, however its use is not recommended
-since it does not integrate with the host OS. However, if you are
-running Mac OS X 10.3, it is your only choice.
+The X11 UI is also available on Mac OS X, however its use is not
+recommended since it does not integrate with the host OS.
When compiling Factor, pass the X11=1 parameter:
- make macosx-ppc X11=1
+ make X11=1
Then bootstrap with the following switches:
- ./factor -i=boot.ppc.image -ui-backend=x11
+ ./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI.
If you did not download the binary package, you can bootstrap Factor in
the command prompt:
- factor-nt.exe -i=boot.x86.32.image
+ factor.exe -i=boot.<cpu>.image
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
To run the listener in the command prompt:
- factor-nt.exe -run=listener
+ factor.exe -run=listener
* The Factor FAQ
-The Factor FAQ lives online at http://factorcode.org/faq.fhtml
+The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
* Command line usage
-The Factor VM supports a number of command line switches. To read
-command line usage documentation, either enter the following in the UI
-listener:
+Factor supports a number of command line switches. To read command line
+usage documentation, enter the following in the UI listener:
"command-line" about
* Source organization
-The following two directories are managed by the module system; consult
-the documentation for details:
+The Factor source tree is organized as follows:
+ build-support/ - scripts used for compiling Factor
core/ - Factor core library and compiler
extra/ - more libraries
-
-The following directories contain additional files:
-
- misc/ - editor modes, icons, etc
- vm/ - sources for the Factor runtime, written in C
fonts/ - TrueType fonts used by UI
+ misc/ - editor modes, icons, etc
unmaintained/ - unmaintained contributions, please help!
+ vm/ - sources for the Factor VM, written in C
* Community
set_gcc() {
case $OS in
openbsd) ensure_program_installed egcc; CC=egcc;;
+ netbsd) if [[ $WORD -eq 64 ]] ; then
+ CC=/usr/pkg/gcc34/bin/gcc
+ else
+ CC=gcc
+ fi ;;
*) CC=gcc;;
esac
}
i386) ARCH=x86;;
i686) ARCH=x86;;
amd64) ARCH=x86;;
+ ppc64) ARCH=ppc;;
*86) ARCH=x86;;
*86_64) ARCH=x86;;
"Power Macintosh") ARCH=ppc;;
"<< \"freetype\" {"
" { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
- " { [ t ] [ drop ] }"
+ " [ drop ]"
"} cond >>"
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
: library ( name -- library ) libraries get at ;
: <library> ( path abi -- library )
- over dup [ dlopen ] when \ library construct-boa ;
+ over dup [ dlopen ] when \ library boa ;
: load-library ( name -- dll )
library dup [ library-dll ] when ;
getter setter
reg-class size align stack-align? ;
-: construct-c-type ( class -- type )
- construct-empty
+: new-c-type ( class -- type )
+ new
int-regs >>reg-class ;
: <c-type> ( -- type )
- \ c-type construct-c-type ;
+ \ c-type new-c-type ;
SYMBOL: c-types
TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- type )
- long-long-type construct-c-type ;
+ long-long-type new-c-type ;
M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ;
drop +linkage+ ;
: no-such-library ( name -- )
- \ no-such-library construct-boa
+ \ no-such-library boa
compiling-word get compiler-error ;
TUPLE: no-such-symbol name ;
drop +linkage+ ;
: no-such-symbol ( name -- )
- \ no-such-symbol construct-boa
+ \ no-such-symbol boa
compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- )
\ alien-invoke [
! Four literals
4 ensure-values
- #alien-invoke construct-empty
+ #alien-invoke new
! Compile-time parameters
pop-parameters >>parameters
pop-literal nip >>function
! Three literals and function pointer
4 ensure-values
4 reify-curries
- #alien-indirect construct-empty
+ #alien-indirect new
! Compile-time parameters
pop-literal nip >>abi
pop-parameters >>parameters
\ alien-callback [
4 ensure-values
- #alien-callback construct-empty dup node,
+ #alien-callback new dup node,
pop-literal nip >>quot
pop-literal nip >>abi
pop-parameters >>parameters
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
- { [ t ] [ c-type c-type-prep ] }
+ [ c-type c-type-prep ]
} cond ;
: wrap-callback-quot ( node -- quot )
[
[ quot>> ] [ prepare-callback-return ] bi append ,
- [ callback-context construct-empty do-callback ] %
+ [ callback-context new do-callback ] %
] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
{
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
- { [ t ] [ drop 0 ] }
+ [ drop 0 ]
} cond ;
: %callback-return ( node -- )
: (define-struct) ( name vocab size align fields -- )
>r [ align ] keep r>
- struct-type construct-boa
+ struct-type boa
-rot define-c-type ;
: make-field ( struct-name vocab type field-name -- spec )
{
{ [ dup expired? ] [ drop "( alien expired )" text ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
- { [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] }
+ [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
: >array ( seq -- array ) { } clone-like ;
-M: object new drop f <array> ;
+M: object new
-sequence drop f <array> ;
-M: f new drop dup zero? [ drop f ] [ f <array> ] if ;
+M: f new
-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
M: array like drop dup array? [ >array ] unless ;
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
{ $subsection subassoc? }
-{ $subsection intersect }
+{ $subsection assoc-intersect }
{ $subsection update }
-{ $subsection union }
-{ $subsection diff }
+{ $subsection assoc-union }
+{ $subsection assoc-diff }
{ $subsection remove-all }
{ $subsection substitute }
{ $subsection substitute-here }
-{ $see-also key? } ;
+{ $see-also key? assoc-contains? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-subset }
+{ $subsection assoc-contains? }
{ $subsection assoc-all? }
"Three additional combinators:"
{ $subsection cache }
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
+HELP: assoc-contains?
+{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
+{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
+
HELP: assoc-all?
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
-{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ;
+{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: subassoc?
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
{ keys values } related-words
-HELP: intersect
+HELP: assoc-intersect
{ $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
{ $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
{ $side-effects "assoc1" } ;
-HELP: union
+HELP: assoc-union
{ $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } }
{ $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ;
-HELP: diff
+HELP: assoc-diff
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
;
] [
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
- intersect
+ assoc-intersect
] unit-test
[
H{ { 1 2 } { 2 3 } { 6 5 } }
] [
H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
- union
+ assoc-union
] unit-test
[ H{ { 1 2 } { 2 3 } } t ] [
- f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd =
+ f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
] unit-test
[
H{ { 1 f } }
] [
- H{ { 1 f } } H{ { 1 f } } intersect
+ H{ { 1 f } } H{ { 1 f } } assoc-intersect
] unit-test
[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test
>r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
] { } assoc>map hashcode* ;
-: intersect ( assoc1 assoc2 -- intersection )
+: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-subset ;
: update ( assoc1 assoc2 -- )
swap [ swapd set-at ] curry assoc-each ;
-: union ( assoc1 assoc2 -- union )
+: assoc-union ( assoc1 assoc2 -- union )
2dup [ assoc-size ] bi@ + pick new-assoc
[ rot update ] keep [ swap update ] keep ;
-: diff ( assoc1 assoc2 -- diff )
+: assoc-diff ( assoc1 assoc2 -- diff )
swap [ nip key? not ] curry assoc-subset ;
: remove-all ( assoc seq -- subseq )
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
-M: bit-array new drop <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ;
M: bit-array equal?
over bit-array? [ sequence= ] [ 2drop f ] if ;
<PRIVATE\r
\r
: bit-array>vector ( bit-array length -- bit-vector )\r
- bit-vector construct-boa ; inline\r
+ bit-vector boa ; inline\r
\r
PRIVATE>\r
\r
[ dup length bit-array>vector ] [ >bit-vector ] if\r
] unless ;\r
\r
-M: bit-vector new\r
+M: bit-vector new-sequence\r
drop [ <bit-array> ] keep >fixnum bit-array>vector ;\r
\r
M: bit-vector equal?\r
--- /dev/null
+Growable bit arrays
--- /dev/null
+collections
"." write flush
{
- new nth push pop peek
+ new-sequence nth push pop peek
} compile
"." write flush
{ word 17 }
{ byte-array 18 }
{ tuple-layout 19 }
-} union type-numbers set
+} assoc-union type-numbers set
! Create special tombstone values
"tombstone" "hashtables.private" create
-"tuple" "kernel" lookup
+tuple
{ } define-tuple-class
"((empty))" "hashtables.private" create
! Some tuple classes
"hashtable" "hashtables" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "array-capacity" "sequences.private" }
} define-tuple-class
"sbuf" "sbufs" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "string" "strings" }
} define-tuple-class
"vector" "vectors" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "array" "arrays" }
} define-tuple-class
"byte-vector" "byte-vectors" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "byte-array" "byte-arrays" }
} define-tuple-class
"bit-vector" "bit-vectors" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "bit-array" "bit-arrays" }
} define-tuple-class
"float-vector" "float-vectors" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "float-array" "float-arrays" }
} define-tuple-class
"curry" "kernel" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "object" "kernel" }
[ tuple-layout [ <tuple-boa> ] curry ] tri define
"compose" "kernel" create
-"tuple" "kernel" lookup
+tuple
{
{
{ "object" "kernel" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
{ "(os-envs)" "system.private" }
+ { "set-os-env" "system" }
+ { "unset-os-env" "system" }
{ "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
{ "resize-bit-array" "bit-arrays" }
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
-math.parser generic ;
+math.parser generic sets ;
IN: bootstrap.stage2
SYMBOL: bootstrap-time
: load-components ( -- )
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] bi@
- seq-diff
+ diff
[ "bootstrap." prepend require ] each ;
! : compile-remaining ( -- )
\r
TUPLE: box value full? ;\r
\r
-: <box> ( -- box ) box construct-empty ;\r
+: <box> ( -- box ) box new ;\r
\r
: >box ( value box -- )\r
dup box-full? [ "Box already has a value" throw ] when\r
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
-M: byte-array new drop <byte-array> ;
+M: byte-array new-sequence drop <byte-array> ;
M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;
<PRIVATE\r
\r
: byte-array>vector ( byte-array length -- byte-vector )\r
- byte-vector construct-boa ; inline\r
+ byte-vector boa ; inline\r
\r
PRIVATE>\r
\r
[ dup length byte-array>vector ] [ >byte-vector ] if\r
] unless ;\r
\r
-M: byte-vector new\r
+M: byte-vector new-sequence\r
drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
\r
M: byte-vector equal?\r
--- /dev/null
+Growable byte arrays
--- /dev/null
+collections
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel classes classes.builtin combinators accessors\r
sequences arrays vectors assocs namespaces words sorting layouts\r
-math hashtables kernel.private ;\r
+math hashtables kernel.private sets ;\r
IN: classes.algebra\r
\r
: 2cache ( key1 key2 assoc quot -- value )\r
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
{ [ dup members ] [ right-union-class< ] }\r
{ [ over superclass ] [ superclass< ] }\r
- { [ t ] [ 2drop f ] }\r
+ [ 2drop f ]\r
} cond ;\r
\r
: anonymous-union-intersect? ( first second -- ? )\r
{ [ over tuple eq? ] [ 2drop t ] }\r
{ [ over builtin-class? ] [ 2drop f ] }\r
{ [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }\r
- { [ t ] [ swap classes-intersect? ] }\r
+ [ swap classes-intersect? ]\r
} cond ;\r
\r
: builtin-class-intersect? ( first second -- ? )\r
{\r
{ [ 2dup eq? ] [ 2drop t ] }\r
{ [ over builtin-class? ] [ 2drop f ] }\r
- { [ t ] [ swap classes-intersect? ] }\r
+ [ swap classes-intersect? ]\r
} cond ;\r
\r
: (classes-intersect?) ( first second -- ? )\r
{ [ over members ] [ left-union-and ] }\r
{ [ over anonymous-union? ] [ left-anonymous-union-and ] }\r
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }\r
- { [ t ] [ 2array <anonymous-intersection> ] }\r
+ [ 2array <anonymous-intersection> ]\r
} cond ;\r
\r
: left-anonymous-union-or ( first second -- class )\r
{ [ 2dup swap class< ] [ drop ] }\r
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }\r
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }\r
- { [ t ] [ 2array <anonymous-union> ] }\r
+ [ 2array <anonymous-union> ]\r
} cond ;\r
\r
: (class-not) ( class -- complement )\r
{ [ dup anonymous-complement? ] [ class>> ] }\r
{ [ dup object eq? ] [ drop null ] }\r
{ [ dup null eq? ] [ drop object ] }\r
- { [ t ] [ <anonymous-complement> ] }\r
+ [ <anonymous-complement> ]\r
} cond ;\r
\r
: largest-class ( seq -- n elt )\r
{ [ dup builtin-class? ] [ dup set ] }\r
{ [ dup members ] [ members [ (flatten-class) ] each ] }\r
{ [ dup superclass ] [ superclass (flatten-class) ] }\r
- { [ t ] [ drop ] }\r
+ [ drop ]\r
} cond ;\r
\r
: flatten-class ( class -- assoc )\r
dup reset-class
dup deferred? [ dup define-symbol ] when
dup word-props
- r> union over set-word-props
+ r> assoc-union over set-word-props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
- \ check-mixin-class construct-boa throw
+ \ check-mixin-class boa throw
] unless ;
: if-mixin-member? ( class mixin true false -- )
{ [ over mixin-instance? not ] [ f ] }
{ [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
{ [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
- { [ t ] [ t ] }
+ [ t ]
} cond 2nip ;
M: mixin-instance hashcode*
IN: classes.tuple
ARTICLE: "parametrized-constructors" "Parameterized constructors"
-"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
+"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
$nl
"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
{ $code
""
"TUPLE: car < vehicle engine ;"
": <car> ( max-speed engine -- car )"
- " car construct-empty"
+ " car new"
" V{ } clone >>occupants"
" swap >>engine"
" swap >>max-speed ;"
""
"TUPLE: aeroplane < vehicle max-altitude ;"
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
- " aeroplane construct-empty"
+ " aeroplane new"
" V{ } clone >>occupants"
" swap >>max-altitude"
" swap >>max-speed ;"
""
": add-occupant ( person vehicle -- ) occupants>> push ;"
""
- ": construct-vehicle ( class -- vehicle )"
- " construct-empty"
+ ": new-vehicle ( class -- vehicle )"
+ " new"
" V{ } clone >>occupants ;"
""
"TUPLE: car < vehicle engine ;"
": <car> ( max-speed engine -- car )"
- " car construct-vehicle"
+ " car new-vehicle"
" swap >>engine"
" swap >>max-speed ;"
""
"TUPLE: aeroplane < vehicle max-altitude ;"
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
- " aeroplane construct-vehicle"
+ " aeroplane new-vehicle"
" swap >>max-altitude"
" swap >>max-speed ;"
}
-"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ;
+"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ;
ARTICLE: "tuple-constructors" "Tuple constructors"
"Tuples are created by calling one of two constructor primitives:"
-{ $subsection construct-empty }
-{ $subsection construct-boa }
+{ $subsection new }
+{ $subsection boa }
"A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: }
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
{ $code
"TUPLE: color red green blue alpha ;"
""
+ "! The following two are equivalent"
"C: <rgba> rgba"
- ": <rgba> color construct-boa ; ! identical to above"
+ ": <rgba> color boa ;"
""
+ "! We can define constructors which call other constructors"
": <rgb> f <rgba> ;"
""
- ": <color> construct-empty ;"
- ": <color> f f f f <rgba> ; ! identical to above"
+ "! The following two are equivalent"
+ ": <color> color new ;"
+ ": <color> f f f f <rgba> ;"
}
{ $subsection "parametrized-constructors" } ;
$nl
"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
-"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link construct-empty } ", " { $link construct-boa } ", or a custom parametrized constructor."
+"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
{ $see-also "parametrized-constructors" } ;
ARTICLE: "tuple-subclassing" "Tuple subclassing"
}
"We can define a constructor which makes an empty employee:"
{ $code ": <employee> ( -- employee )"
- " employee construct-empty ;" }
+ " employee new ;" }
"Or we may wish the default constructor to always give employees a starting salary:"
{ $code
": <employee> ( -- employee )"
- " employee construct-empty"
+ " employee new"
" 40000 >>salary ;"
}
"We can define more refined constructors:"
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
": <employee> ( name position -- person )"
- " 40000 employee construct-boa ;"
+ " 40000 employee boa ;"
}
"Now we can define more specific constructors:"
{ $code
"SYMBOL: checks"
""
": <check> ( to amount -- check )"
- " checks counter check construct-boa ;"
+ " checks counter check boa ;"
""
": biweekly-paycheck ( employee -- check )"
" dup name>> swap salary>> 26 / <check> ;"
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }
-{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
+{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
-{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
+{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
-HELP: construct-empty
+HELP: new
{ $values { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
{ $examples
{ $example
"USING: kernel prettyprint ;"
"TUPLE: employee number name department ;"
- "employee construct-empty ."
+ "employee new ."
"T{ employee f f f f }"
}
} ;
" color construct ;"
}
"The last definition is actually equivalent to the following:"
- { $code ": <rgba> ( r g b a -- color ) rgba construct-boa ;" }
+ { $code ": <rgba> ( r g b a -- color ) rgba boa ;" }
"Which can be abbreviated further:"
{ $code "C: <rgba> color" }
} ;
-HELP: construct-boa
+HELP: boa
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
-{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
+{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
-: <rect> rect construct-boa ;
+: <rect> rect boa ;
: move ( x rect -- rect )
[ + ] change-x ;
] unit-test
! Missing check
-[ not-a-tuple-class construct-boa ] must-fail
-[ not-a-tuple-class construct-empty ] must-fail
+[ not-a-tuple-class boa ] must-fail
+[ not-a-tuple-class new ] must-fail
TUPLE: erg's-reshape-problem a b c d ;
! We want to make sure constructors are recompiled when
! tuples are reshaped
-: cons-test-1 \ erg's-reshape-problem construct-empty ;
-: cons-test-2 \ erg's-reshape-problem construct-boa ;
+: cons-test-1 \ erg's-reshape-problem new ;
+: cons-test-2 \ erg's-reshape-problem boa ;
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
] with-string-writer empty?
] with-variable
] unit-test
+
+! Missing error check
+[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
+ERROR: bad-superclass class ;
+
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
: tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
+: valid-superclass? ( class -- ? )
+ [ tuple-class? ] [ tuple eq? ] bi or ;
+
+: check-superclass ( superclass -- )
+ dup valid-superclass? [ bad-superclass ] unless drop ;
+
PRIVATE>
GENERIC# define-tuple-class 2 ( class superclass slots -- )
M: word define-tuple-class
+ over check-superclass
define-new-tuple-class ;
M: tuple-class define-tuple-class
3dup tuple-class-unchanged?
- [ 3dup redefine-tuple-class ] unless
+ [ over check-superclass 3dup redefine-tuple-class ] unless
3drop ;
: define-error-class ( class superclass slots -- )
[ define-tuple-class ] [ 2drop ] 3bi
- dup [ construct-boa throw ] curry define ;
+ dup [ boa throw ] curry define ;
M: tuple-class reset-class
[
{ $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ;
HELP: cond
-{ $values { "assoc" "a sequence of quotation pairs" } }
+{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
{ $description
- "Calls the second quotation in the first pair whose first quotation yields a true value."
+ "Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value."
$nl
"The following two phrases are equivalent:"
{ $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" }
"{"
" { [ dup 0 > ] [ \"positive\" ] }"
" { [ dup 0 < ] [ \"negative\" ] }"
- " { [ dup zero? ] [ \"zero\" ] }"
+ " [ \"zero\" ]"
"} cond"
}
} ;
{ $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ;
HELP: case
-{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } }
+{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } }
{ $description
- "Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
+ "Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
$nl
"If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
$nl
-IN: combinators.tests
USING: alien strings kernel math tools.test io prettyprint
-namespaces combinators words ;
+namespaces combinators words classes sequences ;
+IN: combinators.tests
+
+! Compiled
+: cond-test-1 ( obj -- str )
+ {
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ } cond ;
+
+\ cond-test-1 must-infer
+
+[ "even" ] [ 2 cond-test-1 ] unit-test
+[ "odd" ] [ 3 cond-test-1 ] unit-test
+
+: cond-test-2 ( obj -- str )
+ {
+ { [ dup t = ] [ drop "true" ] }
+ { [ dup f = ] [ drop "false" ] }
+ [ drop "something else" ]
+ } cond ;
+
+\ cond-test-2 must-infer
+
+[ "true" ] [ t cond-test-2 ] unit-test
+[ "false" ] [ f cond-test-2 ] unit-test
+[ "something else" ] [ "ohio" cond-test-2 ] unit-test
+
+: cond-test-3 ( obj -- str )
+ {
+ [ drop "something else" ]
+ { [ dup t = ] [ drop "true" ] }
+ { [ dup f = ] [ drop "false" ] }
+ } cond ;
+
+\ cond-test-3 must-infer
+
+[ "something else" ] [ t cond-test-3 ] unit-test
+[ "something else" ] [ f cond-test-3 ] unit-test
+[ "something else" ] [ "ohio" cond-test-3 ] unit-test
+
+: cond-test-4 ( -- )
+ {
+ } cond ;
+
+\ cond-test-4 must-infer
+
+[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
+! Interpreted
[ "even" ] [
2 {
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
- { [ t ] [ drop "neither" ] }
+ [ drop "neither" ]
+ } cond
+] unit-test
+
+[ "neither" ] [
+ 3 {
+ { [ dup string? ] [ drop "string" ] }
+ { [ dup float? ] [ drop "float" ] }
+ { [ dup alien? ] [ drop "alien" ] }
+ [ drop "neither" ]
+ } cond
+] unit-test
+
+[ "neither" ] [
+ 3 {
+ { [ dup string? ] [ drop "string" ] }
+ { [ dup float? ] [ drop "float" ] }
+ { [ dup alien? ] [ drop "alien" ] }
+ [ drop "neither" ]
+ } cond
+] unit-test
+
+[ "early" ] [
+ 2 {
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ [ drop "early" ]
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
} cond
] unit-test
-: case-test-1
+[ "really early" ] [
+ 2 {
+ [ drop "really early" ]
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond
+] unit-test
+
+[ { } cond ] [ class \ no-cond = ] must-fail-with
+
+[ "early" ] [
+ 2 {
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ [ drop "early" ]
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond
+] unit-test
+
+[ "really early" ] [
+ 2 {
+ [ drop "really early" ]
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond
+] unit-test
+
+[ { } cond ] [ class \ no-cond = ] must-fail-with
+
+! Compiled
+: case-test-1 ( obj -- obj' )
{
{ 1 [ "one" ] }
{ 2 [ "two" ] }
{ 4 [ "four" ] }
} case ;
+\ case-test-1 must-infer
+
[ "two" ] [ 2 case-test-1 ] unit-test
! Interpreted
[ "x" case-test-1 ] must-fail
-: case-test-2
+: case-test-2 ( obj -- obj' )
{
{ 1 [ "one" ] }
{ 2 [ "two" ] }
[ sq ]
} case ;
+\ case-test-2 must-infer
+
[ 25 ] [ 5 case-test-2 ] unit-test
! Interpreted
[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test
-: case-test-3
+: case-test-3 ( obj -- obj' )
{
{ 1 [ "one" ] }
{ 2 [ "two" ] }
[ sq ]
} case ;
+\ case-test-3 must-infer
+
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
+: case-const-1 1 ;
+: case-const-2 2 ; inline
+
+! Compiled
+: case-test-4 ( obj -- str )
+ {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case ;
+
+\ case-test-4 must-infer
+
+[ "uno" ] [ 1 case-test-4 ] unit-test
+[ "dos" ] [ 2 case-test-4 ] unit-test
+[ "tres" ] [ 3 case-test-4 ] unit-test
+[ "demasiado" ] [ 100 case-test-4 ] unit-test
+
+: case-test-5 ( obj -- )
+ {
+ { case-const-1 [ "uno" print ] }
+ { case-const-2 [ "dos" print ] }
+ { 3 [ "tres" print ] }
+ { 4 [ "cuatro" print ] }
+ { 5 [ "cinco" print ] }
+ [ drop "demasiado" print ]
+ } case ;
+
+\ case-test-5 must-infer
+
+[ ] [ 1 case-test-5 ] unit-test
+
+! Interpreted
+[ "uno" ] [
+ 1 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+[ "dos" ] [
+ 2 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+[ "tres" ] [
+ 3 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+[ "demasiado" ] [
+ 100 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+: do-not-call "do not call" throw ;
+
+: test-case-6
+ {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case ;
+
+[ "three" ] [ 3 test-case-6 ] unit-test
+[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
+
+[ "three" ] [
+ 3 {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case
+] unit-test
+
+[ "do-not-call" ] [
+ [ do-not-call ] first {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case
+] unit-test
+
+[ "do-not-call" ] [
+ \ do-not-call {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case
+] unit-test
+
! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
IN: combinators
USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
-hashtables sorting ;
+hashtables sorting words sets ;
: cleave ( x seq -- )
[ call ] with each ;
ERROR: no-cond ;
: cond ( assoc -- )
- [ first call ] find nip dup [ second call ] [ no-cond ] if ;
+ [ dup callable? [ drop t ] [ first call ] if ] find nip
+ [ dup callable? [ call ] [ second call ] if ]
+ [ no-cond ] if* ;
ERROR: no-case ;
+: case-find ( obj assoc -- obj' )
+ [
+ dup array? [
+ dupd first dup word? [
+ execute
+ ] [
+ dup wrapper? [ wrapped ] when
+ ] if =
+ ] [ quotation? ] if
+ ] find nip ;
: case ( obj assoc -- )
- [ dup array? [ dupd first = ] [ quotation? ] if ] find nip
- {
+ case-find {
{ [ dup array? ] [ nip second call ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ no-case ] }
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot )
+ [ dup callable? [ [ t ] swap 2array ] when ] map
reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- quot )
- [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
- alist>quot ;
+ [
+ [ 1quotation \ dup prefix \ = suffix ]
+ [ \ drop prefix ] bi*
+ ] assoc-map alist>quot ;
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
dup empty? [
drop
] [
- dup length 4 <= [
+ dup length 4 <=
+ over keys [ word? ] contains? or
+ [
linear-case-quot
] [
dup keys contiguous-range? [
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
- { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" }
- { { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } }
- { { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" }
+ { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
+ { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
+ { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
+ { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}
: finish-compile ( word effect dependencies -- )
>r dupd save-effect r>
over compiled-unxref
- over crossref? [ compiled-xref ] [ 2drop ] if ;
+ over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
- { [ t ] [ drop "neither" ] }
+ [ drop "neither" ]
} cond
] compile-call
] unit-test
[
3 {
{ [ dup fixnum? ] [ ] }
- { [ t ] [ drop t ] }
+ [ drop t ]
} cond
] compile-call
] unit-test
TUPLE: color red green blue ;
[ T{ color f 1 2 3 } ]
-[ 1 2 3 [ color construct-boa ] compile-call ] unit-test
+[ 1 2 3 [ color boa ] compile-call ] unit-test
[ 1 3 ] [
- 1 2 3 color construct-boa
+ 1 2 3 color boa
[ { color-red color-blue } get-slots ] compile-call
] unit-test
[ T{ color f 10 2 20 } ] [
10 20
- 1 2 3 color construct-boa [
+ 1 2 3 color boa [
[
{ set-color-red set-color-blue } set-slots
] compile-call
] unit-test
[ T{ color f f f f } ]
-[ [ color construct-empty ] compile-call ] unit-test
+[ [ color new ] compile-call ] unit-test
TUPLE: redefine-error def ;
: redefine-error ( definition -- )
- \ redefine-error construct-boa
+ \ redefine-error boa
{ { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- )
: compile ( words -- )
recompile-hook get call
- dup [ drop crossref? ] assoc-contains?
+ dup [ drop compiled-crossref? ] assoc-contains?
modify-code-heap ;
SYMBOL: outdated-tuples
: finish-compilation-unit ( -- )
call-recompile-hook
call-update-tuples-hook
- dup [ drop crossref? ] assoc-contains? modify-code-heap
+ dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
updated-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )
HELP: dispose
{ $values { "object" "a disposable object" } }
-{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
+{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
+$nl
+"No further operations can be performed on a disposable object after this call."
+$nl
+"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
HELP: with-disposal
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
-byte-arrays bit-arrays float-arrays combinators words ;
+byte-arrays bit-arrays float-arrays combinators words sets ;
IN: cpu.architecture
! A pseudo-register class for parameters spilled on the stack
} {
[ dup return>> large-struct? ]
[ drop EAX PUSH ]
- } {
- [ t ] [ drop ]
}
+ [ drop ]
} cond ;
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect )
- indirect construct-boa dup canonicalize ;
+ indirect boa dup canonicalize ;
: reg-code "register" word-prop 7 bitand ;
{
{ [ dup register-128? ] [ drop operand-64? ] }
{ [ dup not ] [ drop operand-64? ] }
- { [ t ] [ nip operand-64? ] }
+ [ nip operand-64? ]
} cond and ;
: rex.r
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
- { [ t ] [ second 0 15 between? ] }
+ [ second 0 15 between? ]
} cond ;
: kernel-errors
drop "Invalid parameters for create-method" ;
M: no-tuple-class summary
- drop "Invalid class for define-constructor" ;
+ drop "BOA constructors can only be defined for tuple classes" ;
+
+M: bad-superclass summary
+ drop "Tuple classes can only inherit from other tuple classes" ;
M: no-cond summary
drop "Fall-through in cond" ;
USING: tools.test generic kernel definitions sequences
compiler.units words ;
-TUPLE: combination-1 ;
-
-M: combination-1 perform-combination drop [ ] define ;
-
-M: combination-1 make-default-method 2drop [ "No method" throw ] ;
-
-SYMBOL: generic-1
-
-[
- generic-1 T{ combination-1 } define-generic
-
- object \ generic-1 create-method [ ] define
-] with-compilation-unit
-
-[ ] [
- [
- { combination-1 { object generic-1 } } forget-all
- ] with-compilation-unit
-] unit-test
-
GENERIC: some-generic ( a -- b )
USE: arrays
USING: dlists dlists.private kernel tools.test random assocs
-hashtables sequences namespaces sorting debugger io prettyprint
+sets sequences namespaces sorting debugger io prettyprint
math ;
IN: dlists.tests
[ dlist-push-all ] keep
[ dlist-delete-all ] keep
dlist>array
- ] 2keep seq-diff assert-same-elements
+ ] 2keep diff assert-same-elements
] unit-test
[ ] [
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
- dlist construct-empty
+ dlist new
0 >>length ;
: dlist-empty? ( dlist -- ? ) front>> not ;
{
{ [ over front>> over eq? ] [ drop pop-front* ] }
{ [ over back>> over eq? ] [ drop pop-back* ] }
- { [ t ] [ unlink-node dec-length ] }
+ [ unlink-node dec-length ]
} cond ;
: delete-node-if* ( dlist quot -- obj/f ? )
: <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if
- effect construct-boa ;
+ effect boa ;
: effect-height ( effect -- n )
dup effect-out length swap effect-in length - ;
{ [ dup effect-terminated? ] [ f ] }
{ [ 2dup [ effect-in length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
- { [ t ] [ t ] }
+ [ t ]
} cond 2nip ;
GENERIC: (stack-picture) ( obj -- str )
M: float-array like
drop dup float-array? [ >float-array ] unless ;
-M: float-array new drop 0.0 <float-array> ;
+M: float-array new-sequence drop 0.0 <float-array> ;
M: float-array equal?
over float-array? [ sequence= ] [ 2drop f ] if ;
<PRIVATE\r
\r
: float-array>vector ( float-array length -- float-vector )\r
- float-vector construct-boa ; inline\r
+ float-vector boa ; inline\r
\r
PRIVATE>\r
\r
[ dup length float-array>vector ] [ >float-vector ] if\r
] unless ;\r
\r
-M: float-vector new\r
+M: float-vector new-sequence\r
drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;\r
\r
M: float-vector equal?\r
--- /dev/null
+Growable float arrays
--- /dev/null
+collections
TUPLE: frame-required n ;
-: frame-required ( n -- ) \ frame-required construct-boa , ;
+: frame-required ( n -- ) \ frame-required boa , ;
: stack-frame-size ( code -- n )
no-stack-frame [
TUPLE: label offset ;
-: <label> ( -- label ) label construct-empty ;
+: <label> ( -- label ) label new ;
M: label fixup*
compiled-offset swap set-label-offset ;
M: word fixup*
{
- { %prologue-later [ dup [ %prologue ] if-stack-frame ] }
- { %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
+ { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
+ { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
} case ;
SYMBOL: relocation-table
TUPLE: label-fixup label class ;
-: label-fixup ( label class -- ) \ label-fixup construct-boa , ;
+: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
dup label-fixup-class rc-absolute?
TUPLE: rel-fixup arg class type ;
-: rel-fixup ( arg class type -- ) \ rel-fixup construct-boa , ;
+: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: (rel-fixup) ( arg class type offset -- pair )
pick rc-absolute-cell = cell 4 ? -
{ [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
- { [ t ] [ dup compile-queue get set-at ] }
+ [ dup compile-queue get set-at ]
} cond ;
: maybe-compile ( word -- )
: define-if>boolean-intrinsics ( word intrinsics -- )
[
>r [ if>boolean-intrinsic ] curry r>
- { { f "if-scratch" } } +scratch+ associate union
+ { { f "if-scratch" } } +scratch+ associate assoc-union
] assoc-map "intrinsics" set-word-prop ;
: define-if-intrinsics ( word intrinsics -- )
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays
-accessors ;
+accessors sets ;
IN: generator.registers
SYMBOL: +input+
! A data stack location.
TUPLE: ds-loc n class ;
-: <ds-loc> f ds-loc construct-boa ;
+: <ds-loc> f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
! A retain stack location.
TUPLE: rs-loc n class ;
-: <rs-loc> f rs-loc construct-boa ;
+: <rs-loc> f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
- f tagged construct-boa ;
+ f tagged boa ;
M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ;
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
- { [ t ] [ drop %unbox-any-c-ptr ] }
+ [ drop %unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
GENERIC: finalize-height ( stack -- )
-: construct-phantom-stack ( class -- stack )
- >r 0 V{ } clone r> construct-boa ; inline
+: new-phantom-stack ( class -- stack )
+ >r 0 V{ } clone r> boa ; inline
: (loc)
#! Utility for methods on <loc>
TUPLE: phantom-datastack < phantom-stack ;
: <phantom-datastack> ( -- stack )
- phantom-datastack construct-phantom-stack ;
+ phantom-datastack new-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
TUPLE: phantom-retainstack < phantom-stack ;
: <phantom-retainstack> ( -- stack )
- phantom-retainstack construct-phantom-stack ;
+ phantom-retainstack new-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
{ [ dup unboxed-c-ptr eq? ] [
over { unboxed-byte-array unboxed-alien } member?
] }
- { [ t ] [ f ] }
+ [ f ]
} cond 2nip ;
: allocation ( value spec -- reg-class )
{
{ [ dup quotation? ] [ 2drop f ] }
{ [ 2dup compatible? ] [ 2drop f ] }
- { [ t ] [ nip reg-spec>class ] }
+ [ nip reg-spec>class ]
} cond ;
: alloc-vreg-for ( value spec -- vreg )
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
- [ <vreg> ] curry map seq-diff
+ [ <vreg> ] curry map diff
>vector ;
: compute-free-vregs ( -- )
: check-method ( class generic -- class generic )
over class? over generic? and [
- \ check-method construct-boa throw
+ \ check-method boa throw
] unless ; inline
: with-methods ( generic quot -- )
{
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
- { [ t ] [ drop { 100 100 } ] }
+ [ drop { 100 100 } ]
} cond ;
: math-class-max ( class class -- class )
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
- { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
+ [ [ first second ] [ 1 tail-slice ] bi ]
} cond ;
: sort-methods ( assoc -- assoc' )
dupd <echelon-dispatch-engine>
] if
] assoc-map [ nip ] assoc-subset
- \ tuple-dispatch-engine construct-boa ;
+ \ tuple-dispatch-engine boa ;
: convert-tuple-methods ( assoc -- assoc' )
tuple bootstrap-word
] "" make ;
PREDICATE: tuple-dispatch-engine-word < word
- "tuple-dispatch-engine" word-prop ;
+ "tuple-dispatch-generic" word-prop generic? ;
M: tuple-dispatch-engine-word stack-effect
"tuple-dispatch-generic" word-prop
- [ extra-values ] [ stack-effect clone ] bi
- [ length + ] change-in ;
+ [ extra-values ] [ stack-effect ] bi
+ dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
-M: tuple-dispatch-engine-word crossref?
+M: tuple-dispatch-engine-word compiled-crossref?
drop t ;
: remember-engine ( word -- )
: <tuple-dispatch-engine-word> ( engine -- word )
tuple-dispatch-engine-word-name f <word>
- {
- [ t "tuple-dispatch-engine" set-word-prop ]
- [ generic get "tuple-dispatch-generic" set-word-prop ]
- [ remember-engine ]
- [ ]
- } cleave ;
+ [ generic get "tuple-dispatch-generic" set-word-prop ]
+ [ remember-engine ]
+ [ ]
+ tri ;
: define-tuple-dispatch-engine-word ( engine quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ;
USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces
-quotations inference vectors growable ;
+quotations inference vectors growable hashtables sbufs
+prettyprint ;
GENERIC: lo-tag-test
[ salary ] must-infer
-[ 24000 ] [ employee construct-boa salary ] unit-test
+[ 24000 ] [ employee boa salary ] unit-test
-[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
+[ 24000 ] [ tape-monkey boa salary ] unit-test
-[ 36000 ] [ junior-manager construct-boa salary ] unit-test
+[ 36000 ] [ junior-manager boa salary ] unit-test
-[ 41000 ] [ middle-manager construct-boa salary ] unit-test
+[ 41000 ] [ middle-manager boa salary ] unit-test
-[ 51000 ] [ senior-manager construct-boa salary ] unit-test
+[ 51000 ] [ senior-manager boa salary ] unit-test
-[ 102000 ] [ executive construct-boa salary ] unit-test
+[ 102000 ] [ executive boa salary ] unit-test
-[ ceo construct-boa salary ]
+[ ceo boa salary ]
[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
-[ intern construct-boa salary ]
+[ intern boa salary ]
[ T{ no-next-method f intern salary } = ] must-fail-with
! Weird shit
[ "vector growable sequence" ] [
V{ } my-var [ call-next-hooker ] with-variable
] unit-test
+
+GENERIC: no-stack-effect-decl
+
+M: hashtable no-stack-effect-decl ;
+M: vector no-stack-effect-decl ;
+M: sbuf no-stack-effect-decl ;
+
+[ ] [ \ no-stack-effect-decl see ] unit-test
+
+[ ] [ \ no-stack-effect-decl word-def . ] unit-test
\ if ,
] [ ] make ;
+: single-effective-method ( obj word -- method )
+ [ order [ instance? ] with find-last nip ] keep method ;
+
TUPLE: standard-combination # ;
C: <standard-combination> standard-combination
] with-standard ;
M: standard-generic effective-method
- [ dispatch# (picker) call ] keep
- [ order [ instance? ] with find-last nip ] keep method ;
+ [ dispatch# (picker) call ] keep single-effective-method ;
TUPLE: hook-combination var ;
M: hook-generic extra-values drop 1 ;
+M: hook-generic effective-method
+ [ "combination" word-prop var>> get ] keep
+ single-effective-method ;
+
M: hook-combination make-default-method
[ error-method ] with-hook ;
HELP: add-vertex
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
-{ $description "Adds a vertex to a directed graph, using the " { $snippet "edges" } " quotation to generate a sequence of edges leaving the vertex." }
+{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." }
{ $side-effects "graph" } ;
HELP: remove-vertex
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
-{ $description "Removes a vertex from a graph, using the quotation to generate a sequence of edges leaving the vertex." }
+{ $description "Removes a vertex from a graph, using the given edges sequence." }
{ $notes "The " { $snippet "edges" } " sequence must equal the value passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." }
{ $side-effects "graph" } ;
ARTICLE: "hashtables.utilities" "Hashtable utilities"
"Utility words to create a new hashtable from a single key/value pair:"
{ $subsection associate }
-{ $subsection ?set-at }
-"The final two words pertain to sequences but use a hashtable internally. Removing duplicate elements from a sequence in linear time, using a hashtable:"
-{ $subsection prune }
-"Test if a sequence contains duplicates in linear time:"
-{ $subsection all-unique? } ;
+{ $subsection ?set-at } ;
ABOUT: "hashtables"
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
{ $description "Constructs a hashtable from any assoc." } ;
-HELP: prune
-{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
-{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: hashtables prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
-} ;
-
-HELP: all-unique?
-{ $values { "seq" sequence } { "?" "a boolean" } }
-{ $description "Tests whether a sequence contains any repeated elements." }
-{ $example
- "USING: hashtables prettyprint ;"
- "{ 0 1 1 2 3 5 } all-unique? ."
- "f"
-} ;
-
HELP: rehash
{ $values { "hash" hashtable } }
{ $description "Rebuild the hashtable. This word should be called if the hashcodes of the hashtable's keys have changed, or if the hashing algorithms themselves have changed, neither of which should occur during normal operation." } ;
[ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test
-
-[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
-[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
PRIVATE>
: <hashtable> ( n -- hash )
- hashtable construct-empty [ reset-hash ] keep ;
+ hashtable new [ reset-hash ] keep ;
M: hashtable at* ( key hash -- value ? )
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
: ?set-at ( value key assoc/f -- assoc )
[ [ set-at ] keep ] [ associate ] if* ;
-: (prune) ( hash vec elt -- )
- rot 2dup key?
- [ 3drop ] [ dupd dupd set-at swap push ] if ; inline
-
-: prune ( seq -- newseq )
- [ length <hashtable> ]
- [ length <vector> ]
- [ ] tri
- [ >r 2dup r> (prune) ] each nip ;
-
-: all-unique? ( seq -- ? )
- [ length ]
- [ prune length ] bi = ;
-
INSTANCE: hashtable assoc
TUPLE: heap data ;
: <heap> ( class -- heap )
- >r V{ } clone r> construct-boa ; inline
+ >r V{ } clone r> boa ; inline
TUPLE: entry value key heap index ;
-: <entry> ( value key heap -- entry ) f entry construct-boa ;
+: <entry> ( value key heap -- entry ) f entry boa ;
PRIVATE>
--- /dev/null
+collections
USING: help.syntax help.markup words effects inference.dataflow
-inference.state inference.backend kernel sequences
+inference.state kernel sequences
kernel.private combinators sequences.private ;
+IN: inference.backend
HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
-{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
+{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
HELP: too-many->r
{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }
M: inference-error error-help error>> error-help ;
: (inference-error) ( ... class type -- * )
- >r construct-boa r>
+ >r boa r>
recursive-state get
- \ inference-error construct-boa throw ; inline
+ \ inference-error boa throw ; inline
: inference-error ( ... class -- * )
+error+ (inference-error) ; inline
{ [ dup [ curried? ] all? ] [ unify-curries ] }
{ [ dup [ composed? ] all? ] [ unify-composed ] }
{ [ dup [ special? ] contains? ] [ cannot-unify-specials ] }
- { [ t ] [ drop <computed> ] }
+ [ drop <computed> ]
} cond ;
: unify-stacks ( seq -- stack )
{ [ dup "infer" word-prop ] [ custom-infer ] }
{ [ dup "no-effect" word-prop ] [ no-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
- { [ t ] [ dup infer-word make-call-node ] }
+ [ dup infer-word make-call-node ]
} cond ;
TUPLE: recursive-declare-error word ;
TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value )
- <computed> recursive-state get value construct-boa ;
+ <computed> recursive-state get value boa ;
M: value hashcode* nip value-uid ;
[ in-d>> ] [ out-d>> ] bi <effect> ;
: param-node ( param class -- node )
- construct-empty swap >>param ; inline
+ new swap >>param ; inline
: in-node ( seq class -- node )
- construct-empty swap >>in-d ; inline
+ new swap >>in-d ; inline
: all-in-node ( class -- node )
flatten-meta-d swap in-node ; inline
: out-node ( seq class -- node )
- construct-empty swap >>out-d ; inline
+ new swap >>out-d ; inline
: all-out-node ( class -- node )
flatten-meta-d swap out-node ; inline
TUPLE: #push < node ;
-: #push ( -- node ) \ #push construct-empty ;
+: #push ( -- node ) \ #push new ;
TUPLE: #shuffle < node ;
-: #shuffle ( -- node ) \ #shuffle construct-empty ;
+: #shuffle ( -- node ) \ #shuffle new ;
TUPLE: #>r < node ;
-: #>r ( -- node ) \ #>r construct-empty ;
+: #>r ( -- node ) \ #>r new ;
TUPLE: #r> < node ;
-: #r> ( -- node ) \ #r> construct-empty ;
+: #r> ( -- node ) \ #r> new ;
TUPLE: #values < node ;
TUPLE: #terminate < node ;
-: #terminate ( -- node ) \ #terminate construct-empty ;
+: #terminate ( -- node ) \ #terminate new ;
TUPLE: #declare < node ;
"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
$nl ;
+ARTICLE: "inference-errors" "Inference errors"
+"Main wrapper for all inference errors:"
+{ $subsection inference-error }
+"Specific inference errors:"
+{ $subsection no-effect }
+{ $subsection literal-expected }
+{ $subsection too-many->r }
+{ $subsection too-many-r> }
+{ $subsection unbalanced-branches-error }
+{ $subsection effect-error }
+{ $subsection recursive-declare-error } ;
+
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
$nl
{ $subsection "inference-combinators" }
{ $subsection "inference-branches" }
{ $subsection "inference-recursive" }
-{ $subsection "inference-limitations" }
+{ $subsection "inference-limitations" }
+{ $subsection "inference-errors" }
{ $subsection "dataflow-graphs" }
{ $subsection "compiler-transforms" } ;
{ $error-description
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
$nl
- "The " { $snippet "error" } " slot contains one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
- { $list
- { $link no-effect }
- { $link literal-expected }
- { $link too-many->r }
- { $link too-many-r> }
- { $link unbalanced-branches-error }
- { $link effect-error }
- { $link recursive-declare-error }
- }
+ "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
} ;
\ (os-envs) { } { array } <effect> set-primitive-effect
+\ set-os-env { string string } { } <effect> set-primitive-effect
+
+\ unset-os-env { string } { } <effect> set-primitive-effect
+
\ (set-os-envs) { array } { } <effect> set-primitive-effect
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
-\ construct-empty must-infer
+\ new must-infer
TUPLE: a-tuple x y z ;
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables classes generic ;
+inspector hashtables classes generic sets ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
] 1 define-transform
-\ construct-boa [
+\ boa [
dup +inlined+ depends-on
tuple-layout [ <tuple-boa> ] curry
] 1 define-transform
-\ construct-empty [
+\ new [
1 ensure-values
peek-d value? [
pop-literal
tuple-layout [ <tuple> ] curry
swap infer-quot
] [
- \ construct-empty 1 1 <effect> make-call-node
+ \ new 1 1 <effect> make-call-node
] if
] "infer" set-word-prop
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables io kernel assocs math
namespaces prettyprint sequences strings io.styles vectors words
-quotations mirrors splitting math.parser classes vocabs refs ;
+quotations mirrors splitting math.parser classes vocabs refs
+sets ;
IN: inspector
GENERIC: summary ( object -- string )
<PRIVATE
-M: tuple-class <decoder> construct-empty <decoder> ;
-M: tuple <decoder> f decoder construct-boa ;
+M: tuple-class <decoder> new <decoder> ;
+M: tuple <decoder> f decoder boa ;
: >decoder< ( decoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
M: decoder dispose decoder-stream dispose ;
! Encoding
-M: tuple-class <encoder> construct-empty <encoder> ;
-M: tuple <encoder> encoder construct-boa ;
+M: tuple-class <encoder> new <encoder> ;
+M: tuple <encoder> encoder boa ;
: >encoder< ( encoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
{ [ dup -5 shift BIN: 110 number= ] [ double ] }
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
- { [ t ] [ drop replacement-char ] }
+ [ drop replacement-char ]
} cond ;
: decode-utf8 ( stream -- char/f )
2dup -6 shift encoded
encoded
] }
- { [ t ] [
+ [
2dup -18 shift BIN: 11110000 bitor swap stream-write1
2dup -12 shift encoded
2dup -6 shift encoded
encoded
- ] }
+ ]
} cond ;
M: utf8 encode-char
"Not all operating systems support symbolic links."
{ $see-also link-info } ;
-ARTICLE: "directories" "Directories"
-"Current directory:"
+ARTICLE: "current-directory" "Current working directory"
+"File system I/O operations use the value of a variable to resolve relative pathnames:"
{ $subsection current-directory }
+"This variable can be changed with a pair of words:"
{ $subsection set-current-directory }
{ $subsection with-directory }
+"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
+{ $subsection (normalize-path) }
+"The second is to change the working directory of the current process:"
+{ $subsection cd }
+{ $subsection cwd } ;
+
+ARTICLE: "directories" "Directories"
"Home directory:"
{ $subsection home }
"Directory listing:"
{ $subsection directory* }
"Creating directories:"
{ $subsection make-directory }
-{ $subsection make-directories } ;
+{ $subsection make-directories }
+{ $subsection "current-directory" } ;
ARTICLE: "file-types" "File Types"
"Platform-independent types:"
{ $subsection "file-streams" }
{ $subsection "fs-meta" }
{ $subsection "directories" }
-{ $subsection "delete-move-copy" }
-{ $see-also "os" } ;
+{ $subsection "delete-move-copy" } ;
ABOUT: "io.files"
{ cd cwd current-directory set-current-directory with-directory } related-words
HELP: current-directory
-{ $description "A variable holding the current directory. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ;
+{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable."
+$nl
+"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ;
+
+HELP: set-current-directory
+{ $values { "path" "a pathname string" } }
+{ $description "Changes the " { $link current-directory } " variable."
+$nl
+"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
-{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
+{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound."
+$nl
+"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
-{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
+{ $description "Resolve a path relative to the Factor source code location." } ;
HELP: pathname
{ $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;
1 tail left-trim-separators append-path-empty
] }
{ [ dup head..? ] [ drop no-parent-directory ] }
- { [ t ] [ nip ] }
+ [ nip ]
} cond ;
PRIVATE>
{ [ dup "\\\\?\\" head? ] [ t ] }
{ [ dup length 2 < ] [ f ] }
{ [ dup second CHAR: : = ] [ t ] }
- { [ t ] [ f ] }
+ [ f ]
} cond ;
: absolute-path? ( path -- ? )
{ [ dup "resource:" head? ] [ t ] }
{ [ os windows? ] [ windows-absolute-path? ] }
{ [ dup first path-separator? ] [ t ] }
- { [ t ] [ f ] }
+ [ f ]
} cond nip ;
: append-path ( str1 str2 -- str )
{ [ over absolute-path? over first path-separator? and ] [
>r 2 head r> append
] }
- { [ t ] [
+ [
>r right-trim-separators "/" r>
left-trim-separators 3append
- ] }
+ ]
} cond ;
: prepend-path ( str1 str2 -- str )
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
{ [ dup exists? ] [ ] }
- { [ t ] [
+ [
dup parent-directory make-directories
dup make-directory
- ] }
+ ]
} cond drop ;
! Directory listings
M: pathname <=> [ pathname-string ] compare ;
! Home directory
-: home ( -- dir )
- {
- { [ os winnt? ] [ "USERPROFILE" os-env ] }
- { [ os wince? ] [ "" resource-path ] }
- { [ os unix? ] [ "HOME" os-env ] }
- } cond ;
+HOOK: home os ( -- dir )
+
+M: winnt home "USERPROFILE" os-env ;
+
+M: wince home "" resource-path ;
+
+M: unix home "HOME" os-env ;
ARTICLE: "io.streams.duplex" "Duplex streams"
"Duplex streams combine an input stream and an output stream into a bidirectional stream."
{ $subsection duplex-stream }
-{ $subsection <duplex-stream> }
-{ $subsection check-closed } ;
+{ $subsection <duplex-stream> } ;
ABOUT: "io.streams.duplex"
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
-HELP: check-closed
-{ $values { "stream" "a duplex stream" } }
-{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
+HELP: stream-closed-twice
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
! Test duplex stream close behavior
TUPLE: closing-stream closed? ;
-: <closing-stream> closing-stream construct-empty ;
+: <closing-stream> closing-stream new ;
M: closing-stream dispose
dup closing-stream-closed? [
TUPLE: unclosable-stream ;
-: <unclosable-stream> unclosable-stream construct-empty ;
+: <unclosable-stream> unclosable-stream new ;
M: unclosable-stream dispose
"Can't close me!" throw ;
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations io accessors ;
IN: io.streams.duplex
-USING: kernel continuations io ;
! We ensure that the stream can only be closed once, to preserve
! integrity of duplex I/O ports.
-TUPLE: duplex-stream in out closed? ;
+TUPLE: duplex-stream in out closed ;
: <duplex-stream> ( in out -- stream )
- f duplex-stream construct-boa ;
+ f duplex-stream boa ;
ERROR: stream-closed-twice ;
-: check-closed ( stream -- )
- duplex-stream-closed? [ stream-closed-twice ] when ;
+<PRIVATE
-: duplex-stream-in+ ( duplex -- stream )
- dup check-closed duplex-stream-in ;
+: check-closed ( stream -- stream )
+ dup closed>> [ stream-closed-twice ] when ; inline
-: duplex-stream-out+ ( duplex -- stream )
- dup check-closed duplex-stream-out ;
+: in ( duplex -- stream ) check-closed in>> ;
+
+: out ( duplex -- stream ) check-closed out>> ;
+
+PRIVATE>
M: duplex-stream stream-flush
- duplex-stream-out+ stream-flush ;
+ out stream-flush ;
M: duplex-stream stream-readln
- duplex-stream-in+ stream-readln ;
+ in stream-readln ;
M: duplex-stream stream-read1
- duplex-stream-in+ stream-read1 ;
+ in stream-read1 ;
M: duplex-stream stream-read-until
- duplex-stream-in+ stream-read-until ;
+ in stream-read-until ;
M: duplex-stream stream-read-partial
- duplex-stream-in+ stream-read-partial ;
+ in stream-read-partial ;
M: duplex-stream stream-read
- duplex-stream-in+ stream-read ;
+ in stream-read ;
M: duplex-stream stream-write1
- duplex-stream-out+ stream-write1 ;
+ out stream-write1 ;
M: duplex-stream stream-write
- duplex-stream-out+ stream-write ;
+ out stream-write ;
M: duplex-stream stream-nl
- duplex-stream-out+ stream-nl ;
+ out stream-nl ;
M: duplex-stream stream-format
- duplex-stream-out+ stream-format ;
+ out stream-format ;
M: duplex-stream make-span-stream
- duplex-stream-out+ make-span-stream ;
+ out make-span-stream ;
M: duplex-stream make-block-stream
- duplex-stream-out+ make-block-stream ;
+ out make-block-stream ;
M: duplex-stream make-cell-stream
- duplex-stream-out+ make-cell-stream ;
+ out make-cell-stream ;
M: duplex-stream stream-write-table
- duplex-stream-out+ stream-write-table ;
+ out stream-write-table ;
M: duplex-stream dispose
#! The output stream is closed first, in case both streams
#! are attached to the same file descriptor, the output
#! buffer needs to be flushed before we close the fd.
- dup duplex-stream-closed? [
- t over set-duplex-stream-closed?
- [ dup duplex-stream-out dispose ]
- [ dup duplex-stream-in dispose ] [ ] cleanup
+ dup closed>> [
+ t >>closed
+ [ dup out>> dispose ]
+ [ dup in>> dispose ] [ ] cleanup
] unless drop ;
TUPLE: style-stream < filter-writer style ;
: do-nested-style ( style style-stream -- style stream )
- [ style>> swap union ] [ stream>> ] bi ; inline
+ [ style>> swap assoc-union ] [ stream>> ] bi ; inline
C: <style-stream> style-stream
M: callstack clone (clone) ;
! Tuple construction
-: construct-empty ( class -- tuple )
+: new ( class -- tuple )
tuple-layout <tuple> ;
-: construct-boa ( ... class -- tuple )
+: boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
! Quotation building
GENERIC# set-slots 1 ( ... tuple slots -- )
: construct ( ... slots class -- tuple )
- construct-empty [ swap set-slots ] keep ; inline
+ new [ swap set-slots ] keep ; inline
: construct-delegate ( delegate class -- tuple )
>r { set-delegate } r> construct ; inline
2drop over second over second and
[ <interval> ] [ 2drop f ] if
] }
- { [ t ] [ 2drop <interval> ] }
+ [ 2drop <interval> ]
} cond ;
: interval-intersect ( i1 i2 -- i3 )
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup left-endpoint-< ] [ f ] }
{ [ 2dup right-endpoint-< ] [ f ] }
- { [ t ] [ incomparable ] }
+ [ incomparable ]
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
{
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup right-endpoint-<= ] [ t ] }
- { [ t ] [ incomparable ] }
+ [ incomparable ]
} cond 2nip ;
: interval> ( i1 i2 -- ? )
: neg ( x -- -x ) 0 swap - ; foldable
: recip ( x -- y ) 1 swap / ; foldable
+: ?1+ [ 1+ ] [ 0 ] if* ; inline
+
: /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; foldable
{
{ [ dup empty? ] [ drop f ] }
{ [ f over memq? ] [ drop f ] }
- { [ t ] [ radix get [ < ] curry all? ] }
+ [ radix get [ < ] curry all? ]
} cond ;
: string>integer ( str -- n/f )
{
{ [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] }
- { [ t ] [ string>integer ] }
+ [ string>integer ]
} cond
r> [ dup [ neg ] when ] when
] with-radix ;
} {
[ CHAR: . over member? ]
[ ]
- } {
- [ t ]
- [ ".0" append ]
}
+ [ ".0" append ]
} cond ;
M: float >base
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
- { [ t ] [ float>string fix-float ] }
+ [ float>string fix-float ]
} cond ;
: number>string ( n -- str ) 10 >base ;
TUPLE: mirror object slots ;
: <mirror> ( object -- mirror )
- dup object-slots mirror construct-boa ;
+ dup object-slots mirror boa ;
: >mirror< ( mirror -- obj slots )
dup mirror-object swap mirror-slots ;
GENERIC: optimize-node* ( node -- node/t changed? )
: ?union ( assoc/f assoc -- hash )
- over [ union ] [ nip ] if ;
+ over [ assoc-union ] [ nip ] if ;
: add-node-literals ( assoc node -- )
over assoc-empty? [
2dup at* [ swap follow nip ] [ 2drop ] if ;
: union* ( assoc1 assoc2 -- assoc )
- union [ keys ] keep
+ assoc-union [ keys ] keep
[ dupd follow ] curry
H{ } map>assoc ;
{ [ over #label? not ] [ 2drop f ] }
{ [ over #label-word over eq? not ] [ 2drop f ] }
{ [ over #label-loop? not ] [ 2drop f ] }
- { [ t ] [ 2drop t ] }
+ [ 2drop t ]
} cond
] curry node-exists? ;
: label-is-not-loop? ( node word -- ? )
[
{
- { [ over #label? not ] [ 2drop f ] }
- { [ over #label-word over eq? not ] [ 2drop f ] }
- { [ over #label-loop? ] [ 2drop f ] }
- { [ t ] [ 2drop t ] }
- } cond
+ { [ over #label? not ] [ f ] }
+ { [ over #label-word over eq? not ] [ f ] }
+ { [ over #label-loop? ] [ f ] }
+ [ t ]
+ } cond 2nip
] curry node-exists? ;
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
-
+
[ t ] [
[ loop-test-1 ] dataflow dup detect-loops
\ loop-test-1 label-is-loop?
{ [ dup null class< ] [ drop f f ] }
{ [ dup \ f class-not class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
- { [ t ] [ drop f f ] }
+ [ drop f f ]
} cond
] if ;
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! inline
- { [ t ] [ dup dup set word-def (flat-length) ] }
+ [ dup dup set word-def (flat-length) ]
} cond ;
: (flat-length) ( seq -- n )
{ [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
- { [ t ] [ drop 1 ] }
+ [ drop 1 ]
} cond
] map sum ;
dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
- { [ t ] [ 2drop t ] }
+ [ 2drop t ]
} cond ;
! Resolve type checks at compile time where possible
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ dup method-body-inline? ] [ optimistic-inline ] }
- { [ t ] [ inline-method ] }
+ [ inline-method ]
} cond dup not ;
] "output-classes" set-word-prop
] each
-\ construct-empty [
+\ new [
dup node-in-d peek node-literal
dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
-[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
+[ ] [ [ new ] dataflow optimize drop ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
{ [ dup @ eq? ] [ drop match-@ ] }
{ [ dup class? ] [ match-class ] }
{ [ over value? not ] [ 2drop f ] }
- { [ t ] [ swap value-literal = ] }
+ [ swap value-literal = ]
} cond ;
: node-match? ( node values pattern -- ? )
[ dup "specializer" word-prop ]\r
[ "specializer" word-prop specialize-quot ]\r
}\r
- { [ t ] [ drop ] }\r
+ [ drop ]\r
} cond ;\r
\r
: specialized-length ( specializer -- n )\r
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
$parsing-note ;
+HELP: invalid-slot-name
+{ $values { "name" string } }
+{ $description "Throws an " { $link invalid-slot-name } " error." }
+{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
+{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
+ { $code
+ "TUPLE: my-mistaken-tuple slot-a slot-b"
+ ""
+ ": some-word ( a b c -- ) ... ;"
+ }
+} ;
+
HELP: unexpected
{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
{ $description "Throws an " { $link unexpected } " error." }
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.streams.string vocabs
io.encodings.utf8 source-files classes classes.tuple hashtables
-compiler.errors compiler.units accessors ;
+compiler.errors compiler.units accessors sets ;
IN: parser
TUPLE: lexer text line line-text line-length column ;
0 >>column
drop ;
+: new-lexer ( text class -- lexer )
+ new
+ 0 >>line
+ swap >>text
+ dup next-line ; inline
+
: <lexer> ( text -- lexer )
- 0 { set-lexer-text set-lexer-line } lexer construct
- dup next-line ;
+ lexer new-lexer ;
: location ( -- loc )
file get lexer get lexer-line 2dup and
TUPLE: parse-error file line column line-text error ;
: <parse-error> ( msg -- error )
- \ parse-error construct-empty
+ \ parse-error new
file get >>file
lexer get line>> >>line
lexer get column>> >>column
M: parse-error compute-restarts
error>> compute-restarts ;
+M: parse-error error-help
+ error>> error-help ;
+
SYMBOL: use
SYMBOL: in
drop "Word not found in current vocabulary search path" ;
: no-word ( name -- newword )
- dup no-word-error construct-boa
+ dup no-word-error boa
swap words-named [ forward-reference? not ] subset
word-restarts throw-restarts
dup word-vocabulary (use+) ;
scan-word bootstrap-word scan-word create-method-in ;
: shadowed-slots ( superclass slots -- shadowed )
- >r all-slot-names r> seq-intersect ;
+ >r all-slot-names r> intersect ;
: check-slot-shadowing ( class superclass slots -- )
shadowed-slots [
] "" make note.
] with each ;
+ERROR: invalid-slot-name name ;
+
+M: invalid-slot-name summary
+ drop
+ "Invalid slot name" ;
+
+: (parse-tuple-slots) ( -- )
+ #! This isn't meant to enforce any kind of policy, just
+ #! to check for mistakes of this form:
+ #!
+ #! TUPLE: blahblah foo bing
+ #!
+ #! : ...
+ scan {
+ { [ dup not ] [ unexpected-eof ] }
+ { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
+ { [ dup ";" = ] [ drop ] }
+ [ , (parse-tuple-slots) ]
+ } cond ;
+
+: parse-tuple-slots ( -- seq )
+ [ (parse-tuple-slots) ] { } make ;
+
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
- { "<" [ scan-word ";" parse-tokens ] }
- [ >r tuple ";" parse-tokens r> prefix ]
+ { "<" [ scan-word parse-tuple-slots ] }
+ [ >r tuple parse-tuple-slots r> prefix ]
} case 3dup check-slot-shadowing ;
ERROR: staging-violation word ;
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
{ [ dup parsing? ] [ nip execute-parsing t ] }
- { [ t ] [ pick push drop t ] }
+ [ pick push drop t ]
} cond ;
: (parse-until) ( accum end -- accum )
] if ;
: filter-moved ( assoc1 assoc2 -- seq )
- diff [
+ assoc-diff [
drop where dup [ first ] when
file get source-file-path =
] assoc-subset keys ;
: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
- [ get first2 union ] bi@ ;
+ [ get first2 assoc-union ] bi@ ;
: removed-classes ( -- assoc1 assoc2 )
new-definitions old-definitions
{ $subsection short-section }
{ $subsection long-section }
"Utilities to use when implementing sections:"
-{ $subsection construct-section }
-{ $subsection construct-block }
+{ $subsection new-section }
+{ $subsection new-block }
{ $subsection add-section } ;
ARTICLE: "prettyprint-sections" "Prettyprinter sections"
prettyprint.config sorting splitting math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
-classes.predicate classes.singleton combinators quotations ;
+classes.predicate classes.singleton combinators quotations
+sets ;
: make-pprint ( obj quot -- block in use )
[
{ [ dup word? not ] [ , ] }
{ [ dup "break?" word-prop ] [ drop ] }
{ [ dup "step-into?" word-prop ] [ remove-step-into ] }
- { [ t ] [ , ] }
+ [ , ]
} cond
] each
] [ ] make ;
{ { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
} } ;
-HELP: construct-section
+HELP: new-section
{ $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } }
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
TUPLE: pprinter last-newline line-count end-printing indent ;
-: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter construct-boa ;
+: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter boa ;
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
start-group? end-group?
style overhang ;
-: construct-section ( length class -- section )
- construct-empty
+: new-section ( length class -- section )
+ new
position get >>start
swap position [ + ] change
position get >>end
TUPLE: line-break < section type ;
: <line-break> ( type -- section )
- 0 \ line-break construct-section
+ 0 \ line-break new-section
swap >>type ;
M: line-break short-section drop ;
! Block sections
TUPLE: block < section sections ;
-: construct-block ( style class -- block )
- 0 swap construct-section
+: new-block ( style class -- block )
+ 0 swap new-section
V{ } clone >>sections
swap >>style ; inline
: <block> ( style -- block )
- block construct-block ;
+ block new-block ;
: pprinter-block ( -- block ) pprinter-stack get peek ;
TUPLE: text < section string ;
: <text> ( string style -- text )
- over length 1+ \ text construct-section
+ over length 1+ \ text new-section
swap >>style
swap >>string ;
TUPLE: inset < block narrow? ;
: <inset> ( narrow? -- block )
- H{ } inset construct-block
+ H{ } inset new-block
2 >>overhang
swap >>narrow? ;
TUPLE: flow < block ;
: <flow> ( -- block )
- H{ } flow construct-block ;
+ H{ } flow new-block ;
M: flow short-section? ( section -- ? )
#! If we can make room for this entire block by inserting
TUPLE: colon < block ;
: <colon> ( -- block )
- H{ } colon construct-block ;
+ H{ } colon new-block ;
M: colon long-section short-section ;
[ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test
-[ fixnum ] [ 1 >bignum SBUF" " new length class ] unit-test
+[ fixnum ] [ 1 >bignum SBUF" " new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test
<PRIVATE
: string>sbuf ( string length -- sbuf )
- sbuf construct-boa ; inline
+ sbuf boa ; inline
PRIVATE>
M: sbuf set-nth-unsafe
underlying >r >r >fixnum r> >fixnum r> set-string-nth ;
-M: sbuf new drop [ 0 <string> ] keep >fixnum string>sbuf ;
+M: sbuf new-sequence drop [ 0 <string> ] keep >fixnum string>sbuf ;
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
"An optional generic word for creating sequences of the same class as a given sequence:"
{ $subsection like }
"Optional generic words for optimization purposes:"
-{ $subsection new }
+{ $subsection new-sequence }
{ $subsection new-resizable }
{ $see-also "sequences-unsafe" } ;
{ $subsection prefix }
{ $subsection suffix }
"Removing elements:"
-{ $subsection remove }
-{ $subsection seq-diff } ;
+{ $subsection remove } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
{ $subsection "sequences-split" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
+{ $subsection "sequences-sorting" }
+{ $subsection "sets" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
{ $description "Throws an " { $link immutable } " error." }
{ $error-description "Thrown if an attempt is made to modify an immutable sequence." } ;
-HELP: new
+HELP: new-sequence
{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
HELP: all?
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." }
-{ $notes
- "The implementation makes use of a well-known logical identity:"
- $nl
- { $snippet "P[x] for all x <==> not ((not P[x]) for some x)" }
-} ;
+{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
HELP: push-if
{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
} ;
-HELP: seq-diff
-{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
-{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality." } ;
-
HELP: sum-lengths
{ $values { "seq" "a sequence of sequences" } { "n" integer } }
{ $description "Outputs the sum of the lengths of all sequences in " { $snippet "seq" } "." } ;
[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test
-[ V{ f f f } ] [ 3 V{ } new ] unit-test
-[ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test
+[ V{ f f f } ] [ 3 V{ } new-sequence ] unit-test
+[ SBUF" \0\0\0" ] [ 3 SBUF" " new-sequence ] unit-test
[ 0 ] [ f length ] unit-test
[ f first ] must-fail
GENERIC: set-length ( n seq -- )
GENERIC: nth ( n seq -- elt ) flushable
GENERIC: set-nth ( elt n seq -- )
-GENERIC: new ( len seq -- newseq ) flushable
+GENERIC: new-sequence ( len seq -- newseq ) flushable
GENERIC: new-resizable ( len seq -- newseq ) flushable
GENERIC: like ( seq exemplar -- newseq ) flushable
GENERIC: clone-like ( seq exemplar -- newseq ) flushable
: new-like ( len exemplar quot -- seq )
- over >r >r new r> call r> like ; inline
+ over >r >r new-sequence r> call r> like ; inline
M: sequence like drop ;
M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
M: virtual-sequence like virtual-seq like ;
-M: virtual-sequence new virtual-seq new ;
+M: virtual-sequence new-sequence virtual-seq new-sequence ;
INSTANCE: virtual-sequence sequence
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
check-slice
- slice construct-boa ; inline
+ slice boa ; inline
M: slice virtual-seq slice-seq ;
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
: prepare-subseq ( from to seq -- dst i src j n )
- [ >r swap - r> new dup 0 ] 3keep
+ [ >r swap - r> new-sequence dup 0 ] 3keep
-rot drop roll length ; inline
: check-copy ( src n dst -- )
(copy) drop ; inline
M: sequence clone-like
- >r dup length r> new [ 0 swap copy ] keep ;
+ >r dup length r> new-sequence [ 0 swap copy ] keep ;
M: immutable-sequence clone-like like ;
: memq? ( obj seq -- ? )
[ eq? ] with contains? ;
-: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
- swap [ member? ] curry subset ;
-
: remove ( obj seq -- newseq )
[ = not ] with subset ;
[ 0 swap copy ] keep
] new-like ;
-: seq-diff ( seq1 seq2 -- newseq )
- swap [ member? not ] curry subset ;
-
: peek ( seq -- elt ) dup length 1- swap nth ;
: pop* ( seq -- ) dup length 1- swap set-length ;
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+USING: kernel help.markup help.syntax sequences ;
+IN: sets
+
+ARTICLE: "sets" "Set-theoretic operations on sequences"
+"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time."
+$nl
+"Remove duplicates:"
+{ $subsection prune }
+"Test for duplicates:"
+{ $subsection all-unique? }
+"Set operations on sequences:"
+{ $subsection diff }
+{ $subsection intersect }
+{ $subsection union }
+{ $see-also member? memq? contains? all? "assocs-sets" } ;
+
+HELP: unique
+{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
+{ $description "Outputs a new assoc where the keys and values are equal." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }
+} ;
+
+HELP: prune
+{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
+{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
+} ;
+
+HELP: all-unique?
+{ $values { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests whether a sequence contains any repeated elements." }
+{ $example
+ "USING: sets prettyprint ;"
+ "{ 0 1 1 2 3 5 } all-unique? ."
+ "f"
+} ;
+
+HELP: diff
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality."
+} { $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
+} ;
+
+HELP: intersect
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a sequence consisting of elements present in both " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
+} ;
+
+HELP: union
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " and " { $snippet "seq2" } " which does not contain duplicate values." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "V{ 1 2 3 4 }" }
+} ;
+
+{ diff intersect union } related-words
--- /dev/null
+USING: kernel sets tools.test ;
+IN: sets.tests
+
+[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
+[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
+
+[ V{ 1 2 3 } ] [ { 1 2 2 3 3 } prune ] unit-test
+[ V{ 3 2 1 } ] [ { 3 3 2 2 1 } prune ] unit-test
+
+[ { } ] [ { } { } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
+
+[ { } ] [ { } { } diff ] unit-test
+[ { 4 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
+
+[ V{ } ] [ { } { } union ] unit-test
+[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs hashtables kernel sequences vectors ;
+IN: sets
+
+: (prune) ( elt hash vec -- )
+ 3dup drop key?
+ [ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
+ 3drop ; inline
+
+: prune ( seq -- newseq )
+ [ ] [ length <hashtable> ] [ length <vector> ] tri
+ [ [ (prune) ] 2curry each ] keep ;
+
+: unique ( seq -- assoc )
+ [ dup ] H{ } map>assoc ;
+
+: (all-unique?) ( elt hash -- ? )
+ 2dup key? [ 2drop f ] [ dupd set-at t ] if ;
+
+: all-unique? ( seq -- ? )
+ dup length <hashtable> [ (all-unique?) ] curry all? ;
+
+: intersect ( seq1 seq2 -- newseq )
+ unique [ key? ] curry subset ;
+
+: diff ( seq1 seq2 -- newseq )
+ swap unique [ key? not ] curry subset ;
+
+: union ( seq1 seq2 -- newseq )
+ append prune ;
--- /dev/null
+Set-theoretic operations on sequences
--- /dev/null
+collections
pathname-string forget-source ;
: rollback-source-file ( file -- )
- dup source-file-definitions new-definitions get [ union ] 2map
+ dup source-file-definitions new-definitions get [ assoc-union ] 2map
swap set-source-file-definitions ;
SYMBOL: file
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces strings arrays vectors sequences ;
+USING: kernel math namespaces strings arrays vectors sequences
+sets ;
IN: splitting
TUPLE: groups seq n sliced? ;
: check-groups 0 <= [ "Invalid group count" throw ] when ;
: <groups> ( seq n -- groups )
- dup check-groups f groups construct-boa ; inline
+ dup check-groups f groups boa ; inline
: <sliced-groups> ( seq n -- groups )
<groups> t over set-groups-sliced? ;
: split ( seq separators -- pieces ) [ split, ] { } make ;
: string-lines ( str -- seq )
- dup "\r\n" seq-intersect empty? [
+ dup "\r\n" intersect empty? [
1array
] [
"\n" split [
-USING: continuations kernel math namespaces strings sbufs
-tools.test sequences vectors arrays ;
+USING: continuations kernel math namespaces strings
+strings.private sbufs tools.test sequences vectors arrays memory
+prettyprint io.streams.null ;
IN: strings.tests
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test
"\udeadbe" clone
CHAR: \u123456 over clone set-first
] unit-test
+
+! Regressions
+[ ] [
+ [
+ 4 [
+ 100 [ drop "obdurak" clone ] map
+ gc
+ dup [
+ 1234 0 rot set-string-nth
+ ] each
+ 1000 [
+ 1000 f <array> drop
+ ] times
+ .
+ ] times
+ ] with-null-stream
+] unit-test
+
+[ t ] [
+ 10000 [
+ drop
+ 300 100 CHAR: \u123456
+ [ <string> clone resize-string first ] keep =
+ ] all?
+] unit-test
: >string ( seq -- str ) "" clone-like ;
-M: string new drop 0 <string> ;
+M: string new-sequence drop 0 <string> ;
INSTANCE: string sequence
""
"TUPLE: invalid-values x y ;"
": invalid-values ( x y -- * )"
- " \\ invalid-values construct-boa throw ;"
+ " \\ invalid-values boa throw ;"
}
} ;
HELP: C:
{ $syntax "C: constructor class" }
{ $values { "constructor" "a new word to define" } { "class" tuple-class } }
-{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link construct-boa } "." }
+{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link boa } "." }
{ $examples
"Suppose the following tuple has been defined:"
{ $code "TUPLE: color red green blue ;" }
"The following two lines are equivalent:"
{ $code
"C: <color> color"
- ": <color> color construct-boa ;"
+ ": <color> color boa ;"
}
"In both cases, a word " { $snippet "<color>" } " is defined, which reads three values from the stack and creates a " { $snippet "color" } " instance having these values in the " { $snippet "red" } ", " { $snippet "green" } " and " { $snippet "blue" } " slots, respectively."
} ;
scan {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape drop ] }
- { [ t ] [ name>char-hook get call ] }
+ [ name>char-hook get call ]
} cond parsed
] define-syntax
"C:" [
CREATE-WORD
scan-word dup check-tuple
- [ construct-boa ] curry define-inline
+ [ boa ] curry define-inline
] define-syntax
"ERROR:" [
ARTICLE: "system" "System interface"
{ $subsection "cpu" }
{ $subsection "os" }
-"Reading environment variables:"
-{ $subsection os-env }
-{ $subsection os-envs }
+{ $subsection "environment-variables" }
"Getting the path to the Factor VM and image:"
{ $subsection vm }
{ $subsection image }
{ $subsection exit }
{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
-ARTICLE: "cpu" "Processor Detection"
+ARTICLE: "environment-variables" "Environment variables"
+"Reading environment variables:"
+{ $subsection os-env }
+{ $subsection os-envs }
+"Writing environment variables:"
+{ $subsection set-os-env }
+{ $subsection unset-os-env }
+{ $subsection set-os-envs } ;
+
+ARTICLE: "cpu" "Processor detection"
"Processor detection:"
{ $subsection cpu }
"Supported processors:"
"Processor families:"
{ $subsection x86 } ;
-ARTICLE: "os" "Operating System Detection"
+ARTICLE: "os" "Operating system detection"
"Operating system detection:"
{ $subsection os }
"Supported operating systems:"
HELP: set-os-envs
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Replaces the current set of environment variables." }
+{ $notes
+ "Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+HELP: set-os-env ( value key -- )
+{ $values { "value" string } { "key" string } }
+{ $description "Set an environment variable." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+HELP: unset-os-env ( key -- )
+{ $values { "key" string } }
+{ $description "Unset an environment variable." }
{ $notes
"Names and values of environment variables are operating system-specific."
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-{ os-env os-envs set-os-envs } related-words
+{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
HELP: image
{ $values { "path" "a pathname string" } }
-USING: math tools.test system prettyprint namespaces kernel ;
+USING: math tools.test system prettyprint namespaces kernel
+strings sequences ;
IN: system.tests
os wince? [
[ ] [ "envs" get set-os-envs ] unit-test
[ t ] [ os-envs "envs" get = ] unit-test
] when
+
+[ ] [ "factor-test-key-1" unset-os-env ] unit-test
+[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
+[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
+[ ] [ "factor-test-key-1" unset-os-env ] unit-test
+[ f ] [ "factor-test-key-1" os-env ] unit-test
+
+[ ] [
+ 32766 CHAR: a <string> "factor-test-key-long" set-os-env
+] unit-test
+[ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
+[ ] [ "factor-test-key-long" unset-os-env ] unit-test
IN: threads
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators init boxes ;
+dlists assocs system combinators init boxes accessors ;
SYMBOL: initial-thread
! Thread-local storage
: tnamespace ( -- assoc )
- self dup thread-variables
- [ ] [ H{ } clone dup rot set-thread-variables ] ?if ;
+ self variables>> [ H{ } clone dup self (>>variables) ] unless* ;
: tget ( key -- value )
- self thread-variables at ;
+ self variables>> at ;
: tset ( value key -- )
tnamespace set-at ;
: thread ( id -- thread ) threads at ;
: thread-registered? ( thread -- ? )
- thread-id threads key? ;
+ id>> threads key? ;
: check-unregistered
dup thread-registered?
<PRIVATE
: register-thread ( thread -- )
- check-unregistered dup thread-id threads set-at ;
+ check-unregistered dup id>> threads set-at ;
: unregister-thread ( thread -- )
- check-registered thread-id threads delete-at ;
+ check-registered id>> threads delete-at ;
: set-self ( thread -- ) 40 setenv ; inline
PRIVATE>
+: new-thread ( quot name class -- thread )
+ new
+ swap >>name
+ swap >>quot
+ \ thread counter >>id
+ <box> >>continuation
+ [ ] >>exit-handler ; inline
+
: <thread> ( quot name -- thread )
- \ thread counter <box> [ ] {
- set-thread-quot
- set-thread-name
- set-thread-id
- set-thread-continuation
- set-thread-exit-handler
- } \ thread construct ;
+ \ thread new-thread ;
: run-queue 42 getenv ;
: sleep-queue 43 getenv ;
: resume ( thread -- )
- f over set-thread-state
+ f >>state
check-registered run-queue push-front ;
: resume-now ( thread -- )
- f over set-thread-state
+ f >>state
check-registered run-queue push-back ;
: resume-with ( obj thread -- )
- f over set-thread-state
+ f >>state
check-registered 2array run-queue push-front ;
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
- { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
+ [ sleep-queue heap-peek nip millis [-] ]
} cond ;
<PRIVATE
: schedule-sleep ( thread ms -- )
>r check-registered dup r> sleep-queue heap-push*
- swap set-thread-sleep-entry ;
+ >>sleep-entry drop ;
: expire-sleep? ( heap -- ? )
dup heap-empty?
[ drop f ] [ heap-peek nip millis <= ] if ;
: expire-sleep ( thread -- )
- f over set-thread-sleep-entry resume ;
+ f >>sleep-entry resume ;
: expire-sleep-loop ( -- )
sleep-queue
] [
pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
- f over set-thread-state
- thread-continuation box>
+ f >>state
+ continuation>> box>
continue-with
] if ;
PRIVATE>
: stop ( -- )
- self dup thread-exit-handler call
+ self dup exit-handler>> call
unregister-thread next ;
: suspend ( quot state -- obj )
[
- self thread-continuation >box
- self set-thread-state
+ self continuation>> >box
+ self (>>state)
self swap call next
] callcc1 2nip ; inline
millis + >integer sleep-until ;
: interrupt ( thread -- )
- dup thread-state [
- dup thread-sleep-entry [ sleep-queue heap-delete ] when*
- f over set-thread-sleep-entry
+ dup state>> [
+ dup sleep-entry>> [ sleep-queue heap-delete ] when*
+ f >>sleep-entry
dup resume
] when drop ;
V{ } set-catchstack
{ } set-retainstack
>r { } set-datastack r>
- thread-quot [ call stop ] call-clear
+ quot>> [ call stop ] call-clear
] 1 (throw)
] "spawn" suspend 2drop ;
<min-heap> 43 setenv
initial-thread global
[ drop f "Initial" <thread> ] cache
- <box> over set-thread-continuation
- f over set-thread-state
+ <box> >>continuation
+ f >>state
dup register-thread
set-self ;
100 >array dup >vector <reversed> >array >r reverse r> =
] unit-test
-[ fixnum ] [ 1 >bignum V{ } new length class ] unit-test
+[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
<PRIVATE
: array>vector ( array length -- vector )
- vector construct-boa ; inline
+ vector boa ; inline
PRIVATE>
dup array? [ dup length array>vector ] [ >vector ] if
] unless ;
-M: vector new drop [ f <array> ] keep >fixnum array>vector ;
+M: vector new
-sequence drop [ f <array> ] keep >fixnum array>vector ;
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
] with-compilation-unit
] unit-test
+[ ] [ "vocabs.loader.test.b" changed-vocab ] unit-test
+
[ ] [ "vocabs.loader.test.b" refresh ] unit-test
[ 3 ] [ "count-me" get-global ] unit-test
TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link )
- vocab-link construct-boa ;
+ vocab-link boa ;
M: vocab-link hashcode*
vocab-link-name hashcode* ;
HELP: gensym
{ $values { "word" word } }
-{ $description "Creates an uninterned word that is not equal to any other word in the system. Gensyms have an automatically-generated name based on a prefix and an incrementing counter." }
+{ $description "Creates an uninterned word that is not equal to any other word in the system." }
{ $examples { $unchecked-example "gensym ." "G:260561" } }
{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs
-quotations assocs hashtables sorting math.parser words.private
-vocabs combinators ;
+quotations assocs hashtables sorting words.private vocabs ;
IN: words
: word ( -- word ) \ word get-global ;
GENERIC: crossref? ( word -- ? )
M: word crossref?
- {
- { [ dup "forgotten" word-prop ] [ f ] }
- { [ dup word-vocabulary ] [ t ] }
- { [ t ] [ f ] }
- } cond nip ;
+ dup "forgotten" word-prop [
+ drop f
+ ] [
+ word-vocabulary >boolean
+ ] if ;
+
+GENERIC: compiled-crossref? ( word -- ? )
+
+M: word compiled-crossref? crossref? ;
GENERIC# (quot-uses) 1 ( obj assoc -- )
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
- [ drop crossref? ] assoc-subset
+ [ drop compiled-crossref? ] assoc-subset
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
{ "methods" "combination" "default-method" } reset-props ;
: gensym ( -- word )
- "G:" \ gensym counter number>string append f <word> ;
+ "( gensym )" f <word> ;
: define-temp ( quot -- word )
gensym dup rot define ;
pick callable? [ "Not a quotation" throw ] unless ; inline
: <alarm> ( quot time frequency -- alarm )
- check-alarm <box> alarm construct-boa ;
+ check-alarm <box> alarm boa ;
: register-alarm ( alarm -- )
dup dup alarm-time alarms get-global heap-push*
--- /dev/null
+Non-core array words
--- /dev/null
+collections
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
-: <element> element construct-empty ;
+: <element> element new ;
: set-id ( -- boolean )
read1 dup elements get set-element-id ;
TUPLE: tag value ;
-: <tag> ( -- <tag> ) 4 tag construct-boa ;
+: <tag> ( -- <tag> ) 4 tag boa ;
: with-ber ( quot -- )
[
"benchmark.dispatch1" words [ tuple-class? ] subset ;
: a-bunch-of-objects ( -- seq )
- my-classes [ construct-empty ] map ;
+ my-classes [ new ] map ;
: dispatch-benchmark ( -- )
1000000 a-bunch-of-objects
"benchmark.dispatch5" words [ tuple-class? ] subset ;\r
\r
: a-bunch-of-objects ( -- seq )\r
- my-classes [ construct-empty ] map ;\r
+ my-classes [ new ] map ;\r
\r
: dispatch-benchmark ( -- )\r
1000000 a-bunch-of-objects\r
: foo 0 100000000 [ over hello-n + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
M: check< summary drop "Number exceeds upper bound" ;
: check< ( num cmp -- num )
- 2dup < [ drop ] [ \ check< construct-boa throw ] if ;
+ 2dup < [ drop ] [ \ check< boa throw ] if ;
: ?check ( length -- )
safe-bitfields? get [ 2^ , \ check< , ] [ drop ] if ;
{ [ os unix? ] [ "random.unix" require ] }
} cond
-! [ [ 32 random-bits ] with-secure-random <mersenne-twister> random-generator set-global ]
-[ millis <mersenne-twister> random-generator set-global ]
-"generator.random" add-init-hook
+[
+ [ 32 random-bits ] with-system-random
+ <mersenne-twister> random-generator set-global
+] "generator.random" add-init-hook
--- /dev/null
+
+USING: help.syntax help.markup ;
+
+USING: bubble-chamber.particle.muon
+ bubble-chamber.particle.quark
+ bubble-chamber.particle.hadron
+ bubble-chamber.particle.axion ;
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: muon
+
+ { $class-description
+ "The muon is a colorful particle with an entangled friend."
+ "It draws both itself and its horizontally symmetric partner."
+ "A high range of speed and almost no speed decay allow the"
+ "muon to reach the extents of the window, often forming rings"
+ "where theta has decayed but speed remains stable. The result"
+ "is color almost everywhere in the general direction of collision,"
+ "stabilized into fuzzy rings." } ;
+
+HELP: quark
+
+ { $class-description
+ "The quark draws as a translucent black. Their large numbers"
+ "create fields of blackness overwritten only by the glowing shadows of "
+ "Hadrons. "
+ "quarks are allowed to accelerate away with speed decay values above 1.0. "
+ "Each quark has an entangled friend. Both particles are drawn identically,"
+ "mirrored along the y-axis." } ;
+
+HELP: hadron
+
+ { $class-description
+ "Hadrons collide from totally random directions. "
+ "Those hadrons that do not exit the drawing area, "
+ "tend to stabilize into perfect circular orbits. "
+ "Each hadron draws with a slight glowing emboss. "
+ "The hadron itself is not drawn." } ;
+
+HELP: axion
+
+ { $class-description
+ "The axion particle draws a bold black path. Axions exist "
+ "in a slightly higher dimension and as such are drawn with "
+ "elevated embossed shadows. Axions are quick to stabilize "
+ "and fall into single pixel orbits axions automatically "
+ "recollide themselves after stabilizing." } ;
+
+{ muon quark hadron axion } related-words
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber" "Bubble Chamber"
+
+ { $subsection "bubble-chamber-introduction" }
+ { $subsection "bubble-chamber-particles" }
+ { $subsection "bubble-chamber-author" }
+ { $subsection "bubble-chamber-running" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-introduction" "Introduction"
+
+"The Bubble Chamber is a generative painting system of imaginary "
+"colliding particles. A single super-massive collision produces a "
+"discrete universe of four particle types. Particles draw their "
+"positions over time as pixel exposures. " ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-particles" "Particles"
+
+"Four types of particles exist. The behavior and graphic appearance of "
+"each particle type is unique."
+
+ { $subsection muon }
+ { $subsection quark }
+ { $subsection hadron }
+ { $subsection axion } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-author" "Author"
+
+ "Bubble Chamber was created by Jared Tarbell. "
+ "It was originally implemented in Processing. "
+ "It was ported to Factor by Eduardo Cavazos. "
+ "The original work is on display here: "
+ { $url
+ "http://www.complexification.net/gallery/machines/bubblechamber/" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-running" "How to use"
+
+ "After you run the vocabulary, a window will appear. Click the "
+ "mouse in a random area to fire 11 particles of each type. "
+ "Another way to fire particles is to press the "
+ "spacebar. This fires all the particles." ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces sequences random math math.constants math.libm vars
+ ui
+ processing
+ processing.gadget
+ bubble-chamber.common
+ bubble-chamber.particle
+ bubble-chamber.particle.muon
+ bubble-chamber.particle.quark
+ bubble-chamber.particle.hadron
+ bubble-chamber.particle.axion ;
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VARS: particles muons quarks hadrons axions ;
+
+VAR: boom
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-all ( -- )
+
+ 2 pi * 1random >collision-theta
+
+ particles> [ collide ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-one ( -- )
+
+ dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
+
+ hadrons> random collide
+ quarks> random collide
+ muons> random collide ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-pressed ( -- )
+ boom on
+ 1 background ! kludge
+ 11 [ drop collide-one ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key-released ( -- )
+ key " " =
+ [
+ boom on
+ 1 background
+ collide-all
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber ( -- )
+
+ 1000 1000 size*
+
+ [
+ 1 background
+ no-stroke
+
+ 1789 [ drop <muon> ] map >muons
+ 1300 [ drop <quark> ] map >quarks
+ 1000 [ drop <hadron> ] map >hadrons
+ 111 [ drop <axion> ] map >axions
+
+ muons> quarks> hadrons> axions> 3append append >particles
+
+ collide-one
+ ] setup
+
+ [
+ boom>
+ [ particles> [ move ] each ]
+ when
+ ] draw
+
+ [ mouse-pressed ] button-down
+ [ key-released ] key-up ;
+
+: go ( -- ) [ bubble-chamber run ] with-ui ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+
+USING: kernel math accessors combinators.cleave vars ;
+
+IN: bubble-chamber.common
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: collision-theta
+
+: dim ( -- dim ) 1000 ;
+
+: center ( -- point ) dim 2 / dup {2} ; foldable
--- /dev/null
+
+USING: kernel sequences random accessors multi-methods
+ math math.constants math.ranges math.points combinators.cleave
+ processing bubble-chamber.common bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.axion
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: axion < particle ;
+
+: <axion> ( -- axion ) axion new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { axion }
+
+ center >>pos
+ 2 pi * 1random >>theta
+ 1.0 6.0 2random >>speed
+ 0.998 1.000 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
+
+: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
+: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
+
+: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
+: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { axion }
+
+ { 0.06 0.59 } stroke
+ dup pos>> point
+
+ 1 4 [a,b] [ axion-white axion-point- ] each
+ 1 4 [a,b] [ axion-black axion-point+ ] each
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
+
+ 1000 random 996 >
+ [
+ dup speed>> neg >>speed
+ dup speed-d>> neg 2 + >>speed-d
+
+ 100 random 30 > [ collide ] [ drop ] if
+ ]
+ [ drop ]
+ if ;
--- /dev/null
+
+USING: kernel random math math.constants math.points accessors multi-methods
+ processing
+ processing.color
+ bubble-chamber.common
+ bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.hadron
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: hadron < particle ;
+
+: <hadron> ( -- hadron ) hadron new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { hadron }
+
+ center >>pos
+ 2 pi * 1random >>theta
+ 0.5 3.5 2random >>speed
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ 0 1 0 <rgb> >>myc
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { hadron }
+
+ { 1 0.11 } stroke
+ dup pos>> 1 v-y point
+
+ { 0 0.11 } stroke
+ dup pos>> 1 v+y point
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ 1.0 >>speed-d
+ 0.00001 >>theta-dd
+
+ 100 random 70 > [ dup collide ] when
+ ]
+ when
+
+ out-of-bounds? [ collide ] [ drop ] if ;
--- /dev/null
+
+USING: kernel sequences math math.constants accessors
+ processing
+ processing.color ;
+
+IN: bubble-chamber.particle.muon.colors
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: good-colors ( -- seq )
+ {
+ T{ rgba f 0.23 0.14 0.17 1 }
+ T{ rgba f 0.23 0.14 0.15 1 }
+ T{ rgba f 0.21 0.14 0.15 1 }
+ T{ rgba f 0.51 0.39 0.33 1 }
+ T{ rgba f 0.49 0.33 0.20 1 }
+ T{ rgba f 0.55 0.45 0.32 1 }
+ T{ rgba f 0.69 0.63 0.51 1 }
+ T{ rgba f 0.64 0.39 0.18 1 }
+ T{ rgba f 0.73 0.42 0.20 1 }
+ T{ rgba f 0.71 0.45 0.29 1 }
+ T{ rgba f 0.79 0.45 0.22 1 }
+ T{ rgba f 0.82 0.56 0.34 1 }
+ T{ rgba f 0.88 0.72 0.49 1 }
+ T{ rgba f 0.85 0.69 0.40 1 }
+ T{ rgba f 0.96 0.92 0.75 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.85 0.82 0.69 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.82 0.82 0.79 1 }
+ T{ rgba f 0.65 0.69 0.67 1 }
+ T{ rgba f 0.53 0.60 0.55 1 }
+ T{ rgba f 0.57 0.53 0.68 1 }
+ T{ rgba f 0.47 0.42 0.56 1 }
+ } ;
+
+: anti-colors ( -- seq ) good-colors <reversed> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
+
+: set-good-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ good-colors at-fraction-of >>myc ]
+ [ drop ]
+ if ;
+
+: set-anti-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ anti-colors at-fraction-of >>mya ]
+ [ drop ]
+ if ;
--- /dev/null
+
+USING: kernel arrays sequences random
+ math
+ math.ranges
+ math.functions
+ math.vectors
+ multi-methods accessors
+ combinators.cleave
+ processing
+ bubble-chamber.common
+ bubble-chamber.particle
+ bubble-chamber.particle.muon.colors ;
+
+IN: bubble-chamber.particle.muon
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: muon < particle ;
+
+: <muon> ( -- muon ) muon new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { muon }
+
+ center >>pos
+ 2 32 [a,b] random >>speed
+ 0.0001 0.001 2random >>speed-d
+
+ collision-theta> -0.1 0.1 2random + >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
+
+ set-good-color
+ set-anti-color
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { muon }
+
+ dup myc>> 0.16 >>alpha stroke
+ dup pos>> point
+
+ dup mya>> 0.16 >>alpha stroke
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ move-by
+
+ step-theta
+ step-theta-d
+ step-speed-sub
+
+ out-of-bounds? [ collide ] [ drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel sequences combinators
+ math math.vectors math.functions multi-methods
+ accessors combinators.cleave processing processing.color
+ bubble-chamber.common ;
+
+IN: bubble-chamber.particle
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: collide ( particle -- )
+GENERIC: move ( particle -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: initialize-particle ( particle -- particle )
+
+ 0 0 {2} >>pos
+ 0 0 {2} >>vel
+
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ 0 0 0 1 <rgba> >>myc
+ 0 0 0 1 <rgba> >>mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
+
+: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: turn ( particle -- particle )
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
+: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
+: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
+: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x ( particle -- x ) pos>> first ;
+: y ( particle -- x ) pos>> second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: out-of-bounds? ( particle -- particle ? )
+ dup
+ { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
+ or or or ;
--- /dev/null
+
+USING: kernel arrays sequences random math accessors multi-methods
+ processing
+ bubble-chamber.common
+ bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.quark
+
+TUPLE: quark < particle ;
+
+: <quark> ( -- quark ) quark new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { quark }
+
+ center >>pos
+ collision-theta> -0.11 0.11 2random + >>theta
+ 0.5 3.0 2random >>speed
+
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { quark }
+
+ dup myc>> 0.13 >>alpha stroke
+ dup pos>> point
+
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ [ ] [ vel>> ] bi move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ dup speed>> neg >>speed
+ 2 over speed-d>> - >>speed-d
+ ]
+ when
+
+ out-of-bounds? [ collide ] [ drop ] if ;
--- /dev/null
+
+USING: io.files io.launcher io.encodings.utf8 prettyprint
+ builder.util builder.common builder.child builder.release
+ builder.report builder.email builder.cleanup ;
+
+IN: builder.build
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: create-build-dir ( -- )
+ datestamp >stamp
+ build-dir make-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: enter-build-dir ( -- ) build-dir set-current-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clone-builds-factor ( -- )
+ { "git" "clone" builds/factor } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: record-id ( -- )
+ "factor"
+ [ git-id "../git-id" utf8 [ . ] with-file-writer ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: build ( -- )
+ reset-status
+ create-build-dir
+ enter-build-dir
+ clone-builds-factor
+ record-id
+ build-child
+ release
+ report
+ email-report
+ cleanup ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: build
\ No newline at end of file
-USING: kernel namespaces sequences splitting system combinators continuations
- parser io io.files io.launcher io.sockets prettyprint threads
- bootstrap.image benchmark vars bake smtp builder.util accessors
- debugger io.encodings.utf8
- calendar
- tools.test
+USING: kernel debugger io.files threads calendar
builder.common
- builder.benchmark
- builder.release ;
+ builder.updates
+ builder.build ;
IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cd ( path -- ) set-current-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds/factor ( -- path ) builds "factor" append-path ;
-: build-dir ( -- path ) builds stamp> append-path ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prepare-build-machine ( -- )
- builds make-directory
- builds
- [
- { "git" "clone" "git://factorcode.org/git/factor.git" } try-process
- ]
- with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: enter-build-dir ( -- )
- datestamp >stamp
- builds cd
- stamp> make-directory
- stamp> cd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-id ( -- id )
- { "git" "show" } utf8 <process-stream>
- [ readln ] with-stream " " split second ;
-
-: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gnu-make ( -- string )
- os { freebsd openbsd netbsd } member?
- [ "gmake" ]
- [ "make" ]
- if ;
-
-: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-vm ( -- desc )
- <process>
- { gnu-make } to-strings >>command
- "../compile-log" >>stdout
- +stdout+ >>stderr ;
-
-: do-make-vm ( -- )
- make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: copy-image ( -- )
- builds/factor my-boot-image-name append-path ".." copy-file-into
- builds/factor my-boot-image-name append-path "." copy-file-into ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bootstrap-cmd ( -- cmd )
- { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
-
-: bootstrap ( -- desc )
- <process>
- bootstrap-cmd >>command
- +closed+ >>stdin
- "../boot-log" >>stdout
- +stdout+ >>stderr
- 60 minutes >>timeout ;
-
-: do-bootstrap ( -- )
- bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
-
-: builder-test-cmd ( -- cmd )
- { "./factor" "-run=builder.test" } to-strings ;
-
-: builder-test ( -- desc )
- <process>
- builder-test-cmd >>command
- +closed+ >>stdin
- "../test-log" >>stdout
- +stdout+ >>stderr
- 240 minutes >>timeout ;
-
-: do-builder-test ( -- )
- builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: build-status
-
-: (build) ( -- )
-
- builds-check
-
- build-status off
-
- enter-build-dir
-
- "report" utf8
- [
- "Build machine: " write host-name print
- "CPU: " write cpu .
- "OS: " write os .
- "Build directory: " write current-directory get print
-
- git-clone [ "git clone failed" print ] run-or-bail
-
- "factor"
- [
- record-git-id
- do-make-clean
- do-make-vm
- copy-image
- do-bootstrap
- do-builder-test
- ]
- with-directory
-
- "test-log" delete-file
-
- "git id: " write "git-id" eval-file print nl
-
- "Boot time: " write "boot-time" eval-file milli-seconds>time print
- "Load time: " write "load-time" eval-file milli-seconds>time print
- "Test time: " write "test-time" eval-file milli-seconds>time print nl
-
- "Did not pass load-everything: " print "load-everything-vocabs" cat
-
- "Did not pass test-all: " print "test-all-vocabs" cat
- "test-failures" cat
-
- "help-lint results:" print "help-lint" cat
-
- "Benchmarks: " print "benchmarks" eval-file benchmarks.
-
- nl
-
- show-benchmark-deltas
-
- "benchmarks" ".." copy-file-into
-
- maybe-release
- ]
- with-file-writer
-
- build-status on ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-from
-
-SYMBOL: builder-recipients
-
-: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
-
-: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
-
-: send-builder-email ( -- )
- <email>
- builder-from get >>from
- builder-recipients get >>to
- subject >>subject
- "./report" file>string >>body
- send-email ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
-
-! : build ( -- )
-! [ (build) ] try
-! builds cd stamp> cd
-! [ send-builder-email ] try
-! { "rm" "-rf" "factor" } [ ] run-or-bail
-! [ compress-image ] try ;
-
-: build ( -- )
- [
- (build)
- build-dir
- [
- { "rm" "-rf" "factor" } try-process
- compress-image
- ]
- with-directory
- ]
- try
- send-builder-email ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: bootstrap.image.download
-
-: git-pull ( -- desc )
- {
- "git"
- "pull"
- "--no-summary"
- "git://factorcode.org/git/factor.git"
- "master"
- } ;
-
-: updates-available? ( -- ? )
- git-id
- git-pull try-process
- git-id
- = not ;
-
-: new-image-available? ( -- ? )
- my-boot-image-name need-new-image?
- [ download-my-image t ]
- [ f ]
- if ;
-
: build-loop ( -- )
builds-check
[
- builds/factor
- [
- updates-available? new-image-available? or
- [ build ]
- when
- ]
- with-directory
+ builds/factor set-current-directory
+ new-code-available? [ build ] when
]
try
5 minutes sleep
build-loop ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: build-loop
+MAIN: build-loop
\ No newline at end of file
--- /dev/null
+
+USING: namespaces debugger io.files io.launcher accessors bootstrap.image
+ calendar builder.util builder.common ;
+
+IN: builder.child
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-vm ( -- )
+ <process>
+ gnu-make >>command
+ "../compile-log" >>stdout
+ +stdout+ >>stderr
+ try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
+
+: copy-image ( -- )
+ builds-factor-image ".." copy-file-into
+ builds-factor-image "." copy-file-into ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boot-cmd ( -- cmd )
+ { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
+
+: boot ( -- )
+ <process>
+ boot-cmd >>command
+ +closed+ >>stdin
+ "../boot-log" >>stdout
+ +stdout+ >>stderr
+ 60 minutes >>timeout
+ try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
+
+: test ( -- )
+ <process>
+ test-cmd >>command
+ +closed+ >>stdin
+ "../test-log" >>stdout
+ +stdout+ >>stderr
+ 240 minutes >>timeout
+ try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (build-child) ( -- )
+ make-clean
+ make-vm status-vm on
+ copy-image
+ boot status-boot on
+ test status-test on
+ status on ;
+
+: build-child ( -- )
+ "factor" set-current-directory
+ [ (build-child) ] try
+ ".." set-current-directory ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces io.files io.launcher bootstrap.image
+ builder.util builder.common ;
+
+IN: builder.cleanup
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-debug
+
+: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
+
+: delete-child-factor ( -- )
+ build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
+
+: cleanup ( -- )
+ builder-debug get f =
+ [
+ "test-log" delete-file
+ delete-child-factor
+ compress-image
+ ]
+ when ;
+
-USING: kernel namespaces io.files sequences vars ;
+USING: kernel namespaces sequences splitting
+ io io.files io.launcher io.encodings.utf8 prettyprint
+ vars builder.util ;
IN: builder.common
VAR: stamp
+: builds/factor ( -- path ) builds "factor" append-path ;
+: build-dir ( -- path ) builds stamp> append-path ;
+
+: create-build-dir ( -- )
+ datestamp >stamp
+ build-dir make-directory ;
+
+: enter-build-dir ( -- ) build-dir set-current-directory ;
+
+: clone-builds-factor ( -- )
+ { "git" "clone" builds/factor } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prepare-build-machine ( -- )
+ builds make-directory
+ builds
+ [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: status-vm
+SYMBOL: status-boot
+SYMBOL: status-test
+SYMBOL: status-build
+SYMBOL: status-release
+SYMBOL: status
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: reset-status ( -- )
+ { status-vm status-boot status-test status-build status-release status }
+ [ off ]
+ each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: upload-to-factorcode
+
--- /dev/null
+
+USING: kernel namespaces accessors smtp builder.util builder.common ;
+
+IN: builder.email
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-from
+SYMBOL: builder-recipients
+
+: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
+
+: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
+
+: email-report ( -- )
+ <email>
+ builder-from get >>from
+ builder-recipients get >>to
+ subject >>subject
+ "report" file>string >>body
+ send-email ;
+
--- /dev/null
+
+USING: kernel combinators system sequences io.files io.launcher prettyprint
+ builder.util
+ builder.common ;
+
+IN: builder.release.archive
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: base-name ( -- string )
+ { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
+
+: extension ( -- extension )
+ {
+ { [ os winnt? ] [ ".zip" ] }
+ { [ os macosx? ] [ ".dmg" ] }
+ { [ os unix? ] [ ".tar.gz" ] }
+ }
+ cond ;
+
+: archive-name ( -- string ) base-name extension append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
+
+: macosx-archive-cmd ( -- cmd )
+ { "hdiutil" "create"
+ "-srcfolder" "factor"
+ "-fs" "HFS+"
+ "-volname" "factor"
+ archive-name } ;
+
+: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: archive-cmd ( -- cmd )
+ {
+ { [ os windows? ] [ windows-archive-cmd ] }
+ { [ os macosx? ] [ macosx-archive-cmd ] }
+ { [ os unix? ] [ unix-archive-cmd ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-archive ( -- ) archive-cmd to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: releases ( -- path )
+ builds "releases" append-path
+ dup exists? not
+ [ dup make-directory ]
+ when ;
+
+: save-archive ( -- ) archive-name releases move-file-into ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel system namespaces sequences prettyprint io.files io.launcher
+ bootstrap.image
+ builder.util
+ builder.common ;
+
+IN: builder.release.branch
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: branch-name ( -- string ) "clean-" platform append ;
+
+: refspec ( -- string ) "master:" branch-name append ;
+
+: push-to-clean-branch ( -- )
+ { "git" "push" "factorcode.org:/git/factor.git" refspec }
+ to-strings
+ try-process ;
+
+: upload-clean-image ( -- )
+ {
+ "scp"
+ my-boot-image-name
+ "factorcode.org:/var/www/factorcode.org/newsite/images/clean"
+ }
+ to-strings
+ try-process ;
+
+: (update-clean-branch) ( -- )
+ "factor"
+ [
+ push-to-clean-branch
+ upload-clean-image
+ ]
+ with-directory ;
+
+: update-clean-branch ( -- )
+ upload-to-factorcode get
+ [ (update-clean-branch) ]
+ when ;
-USING: kernel system namespaces sequences splitting combinators
- io io.files io.launcher prettyprint
- bake combinators.cleave builder.common builder.util ;
+USING: kernel debugger system namespaces sequences splitting combinators
+ io io.files io.launcher prettyprint bootstrap.image
+ bake combinators.cleave
+ builder.util
+ builder.common
+ builder.release.branch
+ builder.release.tidy
+ builder.release.archive
+ builder.release.upload ;
IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: releases ( -- path )
- builds "releases" append-path
- dup exists? not
- [ dup make-directory ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: common-files ( -- seq )
- {
- "boot.x86.32.image"
- "boot.x86.64.image"
- "boot.macosx-ppc.image"
- "boot.linux-ppc.image"
- "vm"
- "temp"
- "logs"
- ".git"
- ".gitignore"
- "Makefile"
- "unmaintained"
- "build-support"
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: base-name ( -- string )
- { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: extension ( -- extension )
- {
- { [ os winnt? ] [ ".zip" ] }
- { [ os macosx? ] [ ".dmg" ] }
- { [ os unix? ] [ ".tar.gz" ] }
- }
- cond ;
-
-: archive-name ( -- string ) base-name extension append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
-
-: macosx-archive-cmd ( -- cmd )
- { "hdiutil" "create"
- "-srcfolder" "factor"
- "-fs" "HFS+"
- "-volname" "factor"
- archive-name } ;
-
-: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: archive-cmd ( -- cmd )
- {
- { [ os windows? ] [ windows-archive-cmd ] }
- { [ os macosx? ] [ macosx-archive-cmd ] }
- { [ os unix? ] [ unix-archive-cmd ] }
- }
- cond ;
-
-: make-archive ( -- ) archive-cmd to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remove-common-files ( -- )
- { "rm" "-rf" common-files } to-strings try-process ;
-
-: remove-factor-app ( -- )
- os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: upload-to-factorcode
-
-: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
-
-: remote-location ( -- dest )
- "factorcode.org:/var/www/factorcode.org/newsite/downloads"
- platform
- append-path ;
-
-: upload ( -- )
- { "scp" archive-name remote-location } to-strings
- [ "Error uploading binary to factorcode" print ]
- run-or-bail ;
-
-: maybe-upload ( -- )
- upload-to-factorcode get
- [ upload ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : release ( -- )
-! "factor"
-! [
-! remove-factor-app
-! remove-common-files
-! ]
-! with-directory
-! make-archive
-! archive-name releases move-file-into ;
-
-: release ( -- )
- "factor"
- [
- remove-factor-app
- remove-common-files
- ]
- with-directory
+: (release) ( -- )
+ update-clean-branch
+ tidy
make-archive
- maybe-upload
- archive-name releases move-file-into ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ upload
+ save-archive
+ status-release on ;
-: release? ( -- ? )
- {
- "./load-everything-vocabs"
- "./test-all-vocabs"
- }
- [ eval-file empty? ]
- all? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: clean-build? ( -- ? )
+ { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
-: maybe-release ( -- ) release? [ release ] when ;
\ No newline at end of file
+: release ( -- ) [ clean-build? [ (release) ] when ] try ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel system io.files io.launcher builder.util ;
+
+IN: builder.release.tidy
+
+: common-files ( -- seq )
+ {
+ "boot.x86.32.image"
+ "boot.x86.64.image"
+ "boot.macosx-ppc.image"
+ "boot.linux-ppc.image"
+ "vm"
+ "temp"
+ "logs"
+ ".git"
+ ".gitignore"
+ "Makefile"
+ "unmaintained"
+ "build-support"
+ } ;
+
+: remove-common-files ( -- )
+ { "rm" "-rf" common-files } to-strings try-process ;
+
+: remove-factor-app ( -- )
+ os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
+
+: tidy ( -- )
+ "factor" [ remove-factor-app remove-common-files ] with-directory ;
--- /dev/null
+
+USING: kernel namespaces io io.files
+ builder.util
+ builder.common
+ builder.release.archive ;
+
+IN: builder.release.upload
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-location ( -- dest )
+ "factorcode.org:/var/www/factorcode.org/newsite/downloads"
+ platform
+ append-path ;
+
+: (upload) ( -- )
+ { "scp" archive-name remote-location } to-strings
+ [ "Error uploading binary to factorcode" print ]
+ run-or-bail ;
+
+: upload ( -- )
+ upload-to-factorcode get
+ [ (upload) ]
+ when ;
--- /dev/null
+
+USING: kernel namespaces debugger system io io.files io.sockets
+ io.encodings.utf8 prettyprint benchmark
+ builder.util builder.common ;
+
+IN: builder.report
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (report) ( -- )
+
+ "Build machine: " write host-name print
+ "CPU: " write cpu .
+ "OS: " write os .
+ "Build directory: " write build-dir print
+ "git id: " write "git-id" eval-file print nl
+
+ status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
+ status-boot get f = [ "boot-log" cat "Boot error" throw ] when
+ status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
+
+ "Boot time: " write "boot-time" eval-file milli-seconds>time print
+ "Load time: " write "load-time" eval-file milli-seconds>time print
+ "Test time: " write "test-time" eval-file milli-seconds>time print nl
+
+ "Did not pass load-everything: " print "load-everything-vocabs" cat
+
+ "Did not pass test-all: " print "test-all-vocabs" cat
+ "test-failures" cat
+
+ "help-lint results:" print "help-lint" cat
+
+ "Benchmarks: " print "benchmarks" eval-file benchmarks. ;
+
+: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;
\ No newline at end of file
-! USING: kernel namespaces sequences assocs continuations
-! vocabs vocabs.loader
-! io
-! io.files
-! prettyprint
-! tools.vocabs
-! tools.test
-! io.encodings.utf8
-! combinators.cleave
-! help.lint
-! bootstrap.stage2 benchmark builder.util ;
-
USING: kernel namespaces assocs
io.files io.encodings.utf8 prettyprint
help.lint
--- /dev/null
+
+USING: kernel io.launcher bootstrap.image bootstrap.image.download
+ builder.util builder.common ;
+
+IN: builder.updates
+
+: git-pull-cmd ( -- cmd )
+ {
+ "git"
+ "pull"
+ "--no-summary"
+ "git://factorcode.org/git/factor.git"
+ "master"
+ } ;
+
+: updates-available? ( -- ? )
+ git-id
+ git-pull-cmd try-process
+ git-id
+ = not ;
+
+: new-image-available? ( -- ? )
+ my-boot-image-name need-new-image?
+ [ download-my-image t ]
+ [ f ]
+ if ;
+
+: new-code-available? ( -- ? )
+ updates-available?
+ new-image-available?
+ or ;
\ No newline at end of file
USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
+ system
combinators sequences splitting quotations arrays strings tools.time
sequences.deep accessors assocs.lib
io.encodings.utf8
: to-string ( obj -- str )
dup class
{
- { string [ ] }
- { quotation [ call ] }
- { word [ execute ] }
- { fixnum [ number>string ] }
- { array [ to-strings concat ] }
+ { \ string [ ] }
+ { \ quotation [ call ] }
+ { \ word [ execute ] }
+ { \ fixnum [ number>string ] }
+ { \ array [ to-strings concat ] }
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! TUPLE: process* arguments stdin stdout stderr timeout ;
-
-! : <process*> process* construct-empty ;
-
-! : >desc ( process* -- desc )
-! H{ } clone
-! over arguments>> [ +arguments+ swap put-at ] when*
-! over stdin>> [ +stdin+ swap put-at ] when*
-! over stdout>> [ +stdout+ swap put-at ] when*
-! over stderr>> [ +stderr+ swap put-at ] when*
-! over timeout>> [ +timeout+ swap put-at ] when*
-! nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: host-name* ( -- name ) host-name "." split first ;
: datestamp ( -- string )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: failsafe ( quot -- ) [ drop ] recover ;
+: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
+
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gnu-make ( -- string )
+ os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-id ( -- id )
+ { "git" "show" } utf8 <process-stream> [ readln ] with-stream
+ " " split second ;
numbers {
{ [ dup length 5 = ] [ 3 head pick push ] }
{ [ dup first 3 = ] [ 1 tail over push ] }
- { [ t ] [ drop ] }
+ [ drop ]
} cond (parse-model)
] when* ;
: <bunny-dlist> ( model -- geom )
GL_COMPILE [ first3 draw-triangles ] make-dlist
- bunny-dlist construct-boa ;
+ bunny-dlist boa ;
: <bunny-buffers> ( model -- geom )
{
]
[ first length 3 * ]
[ third length 3 * ]
- } cleave bunny-buffers construct-boa ;
+ } cleave bunny-buffers boa ;
GENERIC: bunny-geom ( geom -- )
GENERIC: draw-bunny ( geom draw -- )
ERROR: cairo-error string ;
-: check-zero
+: check-zero ( n -- n )
dup zero? [
"PNG dimension is 0" cairo-error
] when ;
: cairo-png-error ( n -- )
{
- { [ dup CAIRO_STATUS_NO_MEMORY = ] [ "Cairo: no memory" cairo-error ] }
- { [ dup CAIRO_STATUS_FILE_NOT_FOUND = ] [ "Cairo: file not found" cairo-error ] }
- { [ dup CAIRO_STATUS_READ_ERROR = ] [ "Cairo: read error" cairo-error ] }
- { [ t ] [ drop ] }
+ { CAIRO_STATUS_NO_MEMORY [ "Cairo: no memory" cairo-error ] }
+ { CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
+ { CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
+ [ drop ]
} cond ;
: <png> ( path -- png )
dup cairo_surface_status cairo-png-error
dup [ cairo_image_surface_get_width check-zero ]
[ cairo_image_surface_get_height check-zero ] [ ] tri
- cairo-surface>array png construct-boa ;
+ cairo-surface>array png boa ;
: write-png ( png path -- )
>r png-surface r>
M: windows gmt-offset ( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
dup GetTimeZoneInformation {
- { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }
- { [ dup [ TIME_ZONE_ID_UNKNOWN = ] [ TIME_ZONE_ID_STANDARD = ] bi or ] [
- drop TIME_ZONE_INFORMATION-Bias ] }
- { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
- drop
+ { TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
+ { TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
+ { TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
+ { TIME_ZONE_ID_DAYLIGHT [
[ TIME_ZONE_INFORMATION-Bias ]
[ TIME_ZONE_INFORMATION-DaylightBias ] bi +
] }
- } cond neg 60 /mod 0 ;
+ } case neg 60 /mod 0 ;
TUPLE: channel receivers senders ;
: <channel> ( -- channel )
- V{ } clone V{ } clone channel construct-boa ;
+ V{ } clone V{ } clone channel boa ;
GENERIC: to ( value channel -- )
GENERIC: from ( channel -- value )
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http;//factorcode.org/license.txt for BSD license
-USING: kernel sequences math sequences.private strings ;
+USING: kernel sequences math sequences.private strings
+accessors ;
IN: circular
! a circular sequence wraps another sequence, but begins at an
TUPLE: circular seq start ;
: <circular> ( seq -- circular )
- 0 circular construct-boa ;
+ 0 circular boa ;
: circular-wrap ( n circular -- n circular )
- [ circular-start + ] keep
- [ circular-seq length rem ] keep ; inline
+ [ start>> + ] keep
+ [ seq>> length rem ] keep ; inline
-M: circular length circular-seq length ;
+M: circular length seq>> length ;
-M: circular virtual@ circular-wrap circular-seq ;
+M: circular virtual@ circular-wrap seq>> ;
M: circular nth virtual@ nth ;
M: circular set-nth virtual@ set-nth ;
+M: circular virtual-seq seq>> ;
+
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
- circular-wrap set-circular-start ;
+ circular-wrap (>>start) ;
: push-circular ( elt circular -- )
- [ set-first ] keep 1 swap change-circular-start ;
+ [ set-first ] [ 1 swap change-circular-start ] bi ;
: <circular-string> ( n -- circular )
0 <string> <circular> ;
-M: circular virtual-seq circular-seq ;
-
INSTANCE: circular virtual-sequence
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"TUPLE: foo a b c ;"
- "1 2 3 \\ foo construct-boa \\ foo >tuple< .s"
+ "1 2 3 \\ foo boa \\ foo >tuple< .s"
"1\n2\n3"
}
{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"TUPLE: foo a bb* ccc dddd* ;"
- "1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s"
+ "1 2 3 4 \\ foo boa \\ foo >tuple*< .s"
"2\n4"
}
{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
TUPLE: foo a b* c d* e f* ;
-[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple< ] unit-test
-[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple*< ] unit-test
+[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple< ] unit-test
+[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple*< ] unit-test
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien io kernel namespaces core-foundation cocoa.messages
-cocoa cocoa.classes cocoa.runtime sequences threads
-debugger init inspector kernel.private ;
+USING: alien io kernel namespaces core-foundation
+core-foundation.run-loop cocoa.messages cocoa cocoa.classes
+cocoa.runtime sequences threads debugger init inspector
+kernel.private ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ;
-: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" <NSString> ;
-
: next-event ( app -- event )
0 f CFRunLoopDefaultMode 1
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
TUPLE: objc-error alien reason ;
: objc-error ( alien -- * )
- dup -> reason CF>string \ objc-error construct-boa throw ;
+ dup -> reason CF>string \ objc-error boa throw ;
M: objc-error summary ( error -- )
drop "Objective C exception" ;
TUPLE: selector name object ;
-MEMO: <selector> ( name -- sel ) f \ selector construct-boa ;
+MEMO: <selector> ( name -- sel ) f \ selector boa ;
: selector ( selector -- alien )
dup selector-object expired? [
{ "NSRect" "{_NSRect=ffff}" }
{ "NSSize" "{_NSSize=ff}" }
{ "NSRange" "{_NSRange=II}" }
-} union alien>objc-types set-global
+} assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype )
2dup CHAR: = -rot index* swap subseq
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
- { [ t ] [ 2nip 1string objc>alien-types get at ] }
+ [ 2nip 1string objc>alien-types get at ]
} cond ;
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
[ 1quotation ] map [ map-call-with ] curry ;
MACRO: construct-slots ( assoc tuple-class -- tuple )
- [ construct-empty ] curry swap [
+ [ new ] curry swap [
[ dip ] curry swap 1quotation [ keep ] curry compose
] { } assoc>map concat compose ;
IN: concurrency.combinators.tests\r
USING: concurrency.combinators tools.test random kernel math \r
-concurrency.mailboxes threads sequences ;\r
+concurrency.mailboxes threads sequences accessors ;\r
\r
[ [ drop ] parallel-each ] must-infer\r
[ [ ] parallel-map ] must-infer\r
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test\r
\r
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]\r
-[ delegate "Even" = ] must-fail-with\r
+[ error>> "Even" = ] must-fail-with\r
\r
[ V{ 0 3 6 9 } ]\r
[ 10 [ 3 mod zero? ] parallel-subset ] unit-test\r
\r
: <count-down> ( n -- count-down )\r
dup 0 < [ "Invalid count for count down" throw ] when\r
- <promise> \ count-down construct-boa\r
+ <promise> \ count-down boa\r
dup count-down-check ;\r
\r
: count-down ( count-down -- )\r
TUPLE: exchanger thread object ;\r
\r
: <exchanger> ( -- exchanger )\r
- <box> <box> exchanger construct-boa ;\r
+ <box> <box> exchanger boa ;\r
\r
: exchange ( obj exchanger -- newobj )\r
dup exchanger-thread box-full? [\r
TUPLE: flag value? thread ;
-: <flag> ( -- flag ) f <box> flag construct-boa ;
+: <flag> ( -- flag ) f <box> flag boa ;
: raise-flag ( flag -- )
dup flag-value? [
TUPLE: lock threads owner reentrant? ;\r
\r
: <lock> ( -- lock )\r
- <dlist> f f lock construct-boa ;\r
+ <dlist> f f lock boa ;\r
\r
: <reentrant-lock> ( -- lock )\r
- <dlist> f t lock construct-boa ;\r
+ <dlist> f t lock boa ;\r
\r
<PRIVATE\r
\r
TUPLE: rw-lock readers writers reader# writer ;\r
\r
: <rw-lock> ( -- lock )\r
- <dlist> <dlist> 0 f rw-lock construct-boa ;\r
+ <dlist> <dlist> 0 f rw-lock boa ;\r
\r
<PRIVATE\r
\r
\r
\r
ARTICLE: "concurrency.mailboxes" "Mailboxes"\r
-"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."\r
+"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."\r
{ $subsection mailbox }\r
{ $subsection <mailbox> }\r
"Removing the first element:"\r
"Testing if a mailbox is empty:"\r
{ $subsection mailbox-empty? }\r
{ $subsection while-mailbox-empty } ;\r
+\r
+ABOUT: "concurrency.mailboxes"\r
IN: concurrency.mailboxes.tests\r
-USING: concurrency.mailboxes vectors sequences threads\r
-tools.test math kernel strings ;\r
+USING: concurrency.mailboxes concurrency.count-downs vectors\r
+sequences threads tools.test math kernel strings namespaces\r
+continuations calendar ;\r
\r
[ V{ 1 2 3 } ] [\r
0 <vector>\r
"junk2" over mailbox-put\r
mailbox-get\r
] unit-test\r
+\r
+<mailbox> "m" set\r
+\r
+1 <count-down> "c" set\r
+1 <count-down> "d" set\r
+\r
+[\r
+ "c" get await\r
+ [ "m" get mailbox-get drop ]\r
+ [ drop "d" get count-down ] recover\r
+] "Mailbox close test" spawn drop\r
+\r
+[ ] [ "c" get count-down ] unit-test\r
+[ ] [ "m" get dispose ] unit-test\r
+[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
+\r
+[ ] [ "m" get dispose ] unit-test\r
+\r
+<mailbox> "m" set\r
+\r
+1 <count-down> "c" set\r
+1 <count-down> "d" set\r
+\r
+[\r
+ "c" get await\r
+ "m" get wait-for-close\r
+ "d" get count-down\r
+] "Mailbox close test" spawn drop\r
+\r
+[ ] [ "c" get count-down ] unit-test\r
+[ ] [ "m" get dispose ] unit-test\r
+[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
+\r
+[ ] [ "m" get dispose ] unit-test\r
IN: concurrency.mailboxes\r
USING: dlists threads sequences continuations\r
namespaces random math quotations words kernel arrays assocs\r
-init system concurrency.conditions ;\r
+init system concurrency.conditions accessors ;\r
\r
-TUPLE: mailbox threads data ;\r
+TUPLE: mailbox threads data closed ;\r
+\r
+: check-closed ( mailbox -- )\r
+ closed>> [ "Mailbox closed" throw ] when ; inline\r
+\r
+M: mailbox dispose\r
+ t >>closed threads>> notify-all ;\r
\r
: <mailbox> ( -- mailbox )\r
- <dlist> <dlist> mailbox construct-boa ;\r
+ <dlist> <dlist> f mailbox boa ;\r
\r
: mailbox-empty? ( mailbox -- bool )\r
- mailbox-data dlist-empty? ;\r
+ data>> dlist-empty? ;\r
\r
: mailbox-put ( obj mailbox -- )\r
- [ mailbox-data push-front ] keep\r
- mailbox-threads notify-all yield ;\r
+ [ data>> push-front ]\r
+ [ threads>> notify-all ] bi yield ;\r
+\r
+: wait-for-mailbox ( mailbox timeout -- )\r
+ >r threads>> r> "mailbox" wait ;\r
\r
: block-unless-pred ( mailbox timeout pred -- )\r
- pick mailbox-data over dlist-contains? [\r
+ pick check-closed\r
+ pick data>> over dlist-contains? [\r
3drop\r
] [\r
- >r over mailbox-threads over "mailbox" wait r>\r
- block-unless-pred\r
+ >r 2dup wait-for-mailbox r> block-unless-pred\r
] if ; inline\r
\r
: block-if-empty ( mailbox timeout -- mailbox )\r
+ over check-closed\r
over mailbox-empty? [\r
- over mailbox-threads over "mailbox" wait\r
- block-if-empty\r
+ 2dup wait-for-mailbox block-if-empty\r
] [\r
drop\r
] if ;\r
\r
: mailbox-peek ( mailbox -- obj )\r
- mailbox-data peek-back ;\r
+ data>> peek-back ;\r
\r
: mailbox-get-timeout ( mailbox timeout -- obj )\r
- block-if-empty mailbox-data pop-back ;\r
+ block-if-empty data>> pop-back ;\r
\r
: mailbox-get ( mailbox -- obj )\r
f mailbox-get-timeout ;\r
: mailbox-get-all-timeout ( mailbox timeout -- array )\r
block-if-empty\r
[ dup mailbox-empty? ]\r
- [ dup mailbox-data pop-back ]\r
+ [ dup data>> pop-back ]\r
[ ] unfold nip ;\r
\r
: mailbox-get-all ( mailbox -- array )\r
\r
: mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
3dup block-unless-pred\r
- nip >r mailbox-data r> delete-node-if ; inline\r
+ nip >r data>> r> delete-node-if ; inline\r
\r
: mailbox-get? ( mailbox pred -- obj )\r
f swap mailbox-get-timeout? ; inline\r
\r
-TUPLE: linked-error thread ;\r
+: wait-for-close-timeout ( mailbox timeout -- )\r
+ over closed>>\r
+ [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;\r
+\r
+: wait-for-close ( mailbox -- )\r
+ f wait-for-close-timeout ;\r
+\r
+TUPLE: linked-error error thread ;\r
\r
-: <linked-error> ( error thread -- linked )\r
- { set-delegate set-linked-error-thread }\r
- linked-error construct ;\r
+C: <linked-error> linked-error\r
\r
: ?linked dup linked-error? [ rethrow ] when ;\r
\r
-TUPLE: linked-thread supervisor ;\r
+TUPLE: linked-thread < thread supervisor ;\r
\r
M: linked-thread error-in-thread\r
- [ <linked-error> ] keep\r
- linked-thread-supervisor mailbox-put ;\r
+ [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;\r
\r
: <linked-thread> ( quot name mailbox -- thread' )\r
- >r <thread> linked-thread construct-delegate r>\r
- over set-linked-thread-supervisor ;\r
+ >r linked-thread new-thread r> >>supervisor ;\r
\r
: spawn-linked-to ( quot name mailbox -- thread )\r
<linked-thread> [ (spawn) ] keep ;\r
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
{ $see-also spawn } ;
-ARTICLE: { "concurrency" "messaging" } "Mailboxes"
+ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
$nl
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
{ $subsection receive }
{ $subsection receive-timeout }
{ $subsection receive-if }
-{ $subsection receive-if-timeout } ;
+{ $subsection receive-if-timeout }
+{ $see-also "concurrency.mailboxes" } ;
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
!
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words
-match quotations concurrency.messaging concurrency.mailboxes ;
+match quotations concurrency.messaging concurrency.mailboxes
+concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
"crash" throw
] "Linked test" spawn-linked drop
receive
-] [ delegate "crash" = ] must-fail-with
+] [ error>> "crash" = ] must-fail-with
MATCH-VARS: ?from ?to ?value ;
SYMBOL: increment
[ value , self , ] { } make "counter" get send
receive
exit "counter" get send
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Not yet
+
+! 1 <count-down> "c" set
+
+! [
+! "c" get count-down
+! receive drop
+! ] "Bad synchronous send" spawn "t" set
+
+! [ 3 "t" get send-synchronous ] must-fail
\ No newline at end of file
TUPLE: synchronous data sender tag ;\r
\r
: <synchronous> ( data -- sync )\r
- self 256 random-bits synchronous construct-boa ;\r
+ self 256 random-bits synchronous boa ;\r
\r
TUPLE: reply data tag ;\r
\r
: <reply> ( data synchronous -- reply )\r
- synchronous-tag \ reply construct-boa ;\r
+ synchronous-tag \ reply boa ;\r
\r
: synchronous-reply? ( response synchronous -- ? )\r
over reply?\r
TUPLE: promise mailbox ;\r
\r
: <promise> ( -- promise )\r
- <mailbox> promise construct-boa ;\r
+ <mailbox> promise boa ;\r
\r
: promise-fulfilled? ( promise -- ? )\r
promise-mailbox mailbox-empty? not ;\r
\r
: <semaphore> ( n -- semaphore )\r
dup 0 < [ "Cannot have semaphore with negative count" throw ] when\r
- <dlist> semaphore construct-boa ;\r
+ <dlist> semaphore boa ;\r
\r
: wait-to-acquire ( semaphore timeout -- )\r
>r semaphore-threads r> "semaphore" wait ;\r
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.styles io hashtables kernel
-sequences sequences.lib assocs system sorting math.parser ;
+sequences sequences.lib assocs system sorting math.parser
+sets ;
IN: contributors
: changelog ( -- authors )
TYPEDEF: void* CFStringRef
TYPEDEF: void* CFURLRef
TYPEDEF: void* CFUUIDRef
-TYPEDEF: void* CFRunLoopRef
TYPEDEF: bool Boolean
TYPEDEF: int CFIndex
+TYPEDEF: int SInt32
TYPEDEF: double CFTimeInterval
TYPEDEF: double CFAbsoluteTime
] [
"Cannot load bundled named " prepend throw
] ?if ;
-
-FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel math sequences
-namespaces assocs init continuations core-foundation ;
+namespaces assocs init accessors continuations combinators
+core-foundation core-foundation.run-loop ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
[
event-stream-callbacks global
- [ [ drop expired? not ] assoc-subset ] change-at
- 1 \ event-stream-counter set-global
+ [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
] "core-foundation" add-init-hook
-event-stream-callbacks global [ H{ } assoc-like ] change-at
-
: add-event-source-callback ( quot -- id )
event-stream-counter <alien>
[ event-stream-callbacks get set-at ] keep ;
}
"cdecl" [
[ >event-triple ] 3curry map
- swap event-stream-callbacks get at call
- drop
+ swap event-stream-callbacks get at
+ dup [ call drop ] [ 3drop ] if
] alien-callback ;
-TUPLE: event-stream info handle ;
+TUPLE: event-stream info handle closed ;
: <event-stream> ( quot paths latency flags -- event-stream )
>r >r >r
>r master-event-source-callback r>
r> r> r> <FSEventStream>
dup enable-event-stream
- event-stream construct-boa ;
+ f event-stream boa ;
M: event-stream dispose
- dup event-stream-info remove-event-source-callback
- event-stream-handle dup disable-event-stream
- FSEventStreamRelease ;
+ dup closed>> [ drop ] [
+ t >>closed
+ {
+ [ info>> remove-event-source-callback ]
+ [ handle>> disable-event-stream ]
+ [ handle>> FSEventStreamInvalidate ]
+ [ handle>> FSEventStreamRelease ]
+ } cleave
+ ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel threads init namespaces alien
+core-foundation ;
+IN: core-foundation.run-loop
+
+: kCFRunLoopRunFinished 1 ; inline
+: kCFRunLoopRunStopped 2 ; inline
+: kCFRunLoopRunTimedOut 3 ; inline
+: kCFRunLoopRunHandledSource 4 ; inline
+
+TYPEDEF: void* CFRunLoopRef
+
+FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
+
+FUNCTION: SInt32 CFRunLoopRunInMode (
+ CFStringRef mode,
+ CFTimeInterval seconds,
+ Boolean returnAfterSourceHandled
+) ;
+
+: CFRunLoopDefaultMode ( -- alien )
+ #! Ugly, but we don't have static NSStrings
+ \ CFRunLoopDefaultMode get-global dup expired? [
+ drop
+ "kCFRunLoopDefaultMode" <CFString>
+ dup \ CFRunLoopDefaultMode set-global
+ ] when ;
+
+: run-loop-thread ( -- )
+ CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
+ kCFRunLoopRunHandledSource = [ 1000 sleep ] unless
+ run-loop-thread ;
+
+: start-run-loop-thread ( -- )
+ [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
+
+[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook
TUPLE: coroutine resumecc exitcc ;
: cocreate ( quot -- co )
- coroutine construct-empty
+ coroutine new
dup current-coro associate
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
[ HEX: 10 swap set-cpu-last-interrupt ] keep
0 swap set-cpu-cycles ;
-: <cpu> ( -- cpu ) cpu construct-empty dup reset ;
+: <cpu> ( -- cpu ) cpu new dup reset ;
: (load-rom) ( n ram -- )
read1 [ ! n ram ch
+++ /dev/null
-USING: kernel math test namespaces crypto crypto-internals ;
-
-[ 6 ] [ 5 T{ bbs f 590695557939 811977232793 } random-bbs-bits* ] unit-test
-[ 792723710536787233474130382522 ] [ 100 T{ bbs f 200352954495 846054538649 } [ random-bbs-bits* drop ] 2keep random-bbs-bits* ] unit-test
-
delete-statements ;
: construct-db ( class -- obj )
- construct-empty
+ new
H{ } clone >>insert-statements
H{ } clone >>update-statements
H{ } clone >>delete-statements ;
TUPLE: result-set sql in-params out-params handle n max ;
: construct-statement ( sql in out class -- statement )
- construct-empty
+ new
swap >>out-params
swap >>in-params
swap >>sql ;
0 >>n drop ;
: construct-result-set ( query handle class -- result-set )
- construct-empty
+ new
swap >>handle
>r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
swap >>out-params
: mysql-error ( mysql -- )
[ mysql_error throw ] when* ;
-: mysql-connect ( mysql-connection -- )
- new-mysql over set-mysql-db-handle
- dup {
- mysql-db-handle
- mysql-db-host
- mysql-db-user
- mysql-db-password
- mysql-db-db
- mysql-db-port
- } get-slots f 0 mysql_real_connect mysql-error ;
+! : mysql-connect ( mysql-connection -- )
+ ! new-mysql over set-mysql-db-handle
+ ! dup {
+ ! mysql-db-handle
+ ! mysql-db-host
+ ! mysql-db-user
+ ! mysql-db-password
+ ! mysql-db-db
+ ! mysql-db-port
+ ! } get-slots f 0 mysql_real_connect mysql-error ;
! =========================================================
! Low level mysql utility definitions
TUPLE: mysql-result-set ;
M: mysql-db db-open ( mysql-db -- )
- drop ;
+ ;
M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ;
<< "postgresql" {
{ [ os winnt? ] [ "libpq.dll" ] }
- { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] }
- ! { [ os macosx? ] [ "libpq.dylib" ] }
+ { [ os macosx? ] [ "libpq.dylib" ] }
{ [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
{ offset 40 }
{ limit 20 }
} ;
-
-
{ [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] }
{ [ dup word? ] [ unparse sql% ] }
- { [ t ] [ T{ no-sql-match } throw ] }
+ [ T{ no-sql-match } throw ]
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
{
{ [ dup SQLITE_OK = ] [ drop ] }
{ [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
- { [ t ] [ sqlite-error ] }
+ [ sqlite-error ]
} cond ;
: sqlite-open ( filename -- db )
HOOK: insert-tuple* db ( tuple statement -- )
: resulting-tuple ( row out-params -- tuple )
- dup first sql-spec-class construct-empty [
+ dup first sql-spec-class new [
[
>r sql-spec-slot-name r> set-slot-named
] curry 2each
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
-vectors definitions prettyprint combinators.lib math ;
+vectors definitions prettyprint combinators.lib math sets ;
IN: delegate
! Protocols
: forget-old-definitions ( protocol new-wordlist -- )
>r users-and-words r>
- seq-diff forget-all-methods ;
+ diff forget-all-methods ;
: define-protocol ( protocol wordlist -- )
! 2dup forget-old-definitions
IN: delegate.protocols
PROTOCOL: sequence-protocol
- clone clone-like like new new-resizable nth nth-unsafe
+ clone clone-like like new-sequence new-resizable nth nth-unsafe
set-nth set-nth-unsafe length set-length lengthen ;
PROTOCOL: assoc-protocol
TUPLE: dummy-obj destroyed? ;
-: <dummy-obj> dummy-obj construct-empty ;
+: <dummy-obj> dummy-obj new ;
TUPLE: dummy-destructor obj ;
] if ;
: <destructor> ( obj -- newobj )
- f destructor construct-boa ;
+ f destructor boa ;
: add-error-destructor ( obj -- )
<destructor> error-destructors get push ;
TUPLE: vertex value edges ;
: <digraph> ( -- digraph )
- digraph construct-empty H{ } clone over set-delegate ;
+ digraph new H{ } clone over set-delegate ;
: <vertex> ( value -- vertex )
- V{ } clone vertex construct-boa ;
+ V{ } clone vertex boa ;
: add-vertex ( key value digraph -- )
>r <vertex> swap r> set-at ;
--- /dev/null
+collections
--- /dev/null
+Eric Mertens
--- /dev/null
+USING: accessors arrays hints kernel locals math sequences ;
+
+IN: disjoint-set
+
+<PRIVATE
+
+TUPLE: disjoint-set parents ranks counts ;
+
+: count ( a disjoint-set -- n )
+ counts>> nth ; inline
+
+: add-count ( p a disjoint-set -- )
+ [ count [ + ] curry ] keep counts>> swap change-nth ; inline
+
+: parent ( a disjoint-set -- p )
+ parents>> nth ; inline
+
+: set-parent ( p a disjoint-set -- )
+ parents>> set-nth ; inline
+
+: link-sets ( p a disjoint-set -- )
+ [ set-parent ]
+ [ add-count ] 3bi ; inline
+
+: rank ( a disjoint-set -- r )
+ ranks>> nth ; inline
+
+: inc-rank ( a disjoint-set -- )
+ ranks>> [ 1+ ] change-nth ; inline
+
+: representative? ( a disjoint-set -- ? )
+ dupd parent = ; inline
+
+: representative ( a disjoint-set -- p )
+ 2dup representative? [ drop ] [
+ [ [ parent ] keep representative dup ] 2keep set-parent
+ ] if ;
+
+: representatives ( a b disjoint-set -- r r )
+ [ representative ] curry bi@ ; inline
+
+: ranks ( a b disjoint-set -- r r )
+ [ rank ] curry bi@ ; inline
+
+:: branch ( a b neg zero pos -- )
+ a b = zero [ a b < neg pos if ] if ; inline
+
+PRIVATE>
+
+: <disjoint-set> ( n -- disjoint-set )
+ [ >array ]
+ [ 0 <array> ]
+ [ 1 <array> ] tri
+ disjoint-set boa ;
+
+: equiv-set-size ( a disjoint-set -- n )
+ [ representative ] keep count ;
+
+: equiv? ( a b disjoint-set -- ? )
+ representatives = ; inline
+
+:: equate ( a b disjoint-set -- )
+ a b disjoint-set representatives
+ 2dup = [ 2drop ] [
+ 2dup disjoint-set ranks
+ [ swap ] [ over disjoint-set inc-rank ] [ ] branch
+ disjoint-set link-sets
+ ] if ;
+
+HINTS: equate disjoint-set ;
+HINTS: representative disjoint-set ;
+HINTS: equiv-set-size disjoint-set ;
--- /dev/null
+An efficient implementation of the disjoint-set data structure
--- /dev/null
+collections
-rot {
{ [ over { 0 0 } = ] [ drop ] }
{ [ over second zero? ] [ >r first 1- r> line-end ] }
- { [ t ] [ pick call ] }
+ [ pick call ]
} cond nip ; inline
: (next-char) ( loc document quot -- loc )
-rot {
{ [ 2dup doc-end = ] [ drop ] }
{ [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
- { [ t ] [ pick call ] }
+ [ pick call ]
} cond nip ; inline
M: char-elt prev-elt
[ >r blank? r> xor ] curry ; inline
: (prev-word) ( ? col str -- col )
- rot break-detector find-last*
- drop [ 1+ ] [ 0 ] if* ;
+ rot break-detector find-last* drop ?1+ ;
: (next-word) ( ? col str -- col )
[ rot break-detector find* drop ] keep
[ [ "Load " prepend ] keep ] { } map>assoc ;
: no-edit-hook ( -- )
- \ no-edit-hook construct-empty
+ \ no-edit-hook new
editor-restarts throw-restarts
require ;
unicode.categories ;
IN: farkup
+<PRIVATE
+
: delimiters ( -- string )
"*_^~%[-=|\\\n" ; inline
[ "<p>" swap "</p>" 3array ] unless
] action ;
+PRIVATE>
+
PEG: parse-farkup ( -- parser )
[
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
drop 1quotation
] [
unclip {
- { , [ [ curry ] ((fry)) ] }
- { @ [ [ compose ] ((fry)) ] }
+ { \ , [ [ curry ] ((fry)) ] }
+ { \ @ [ [ compose ] ((fry)) ] }
! to avoid confusion, remove if fry goes core
- { namespaces:, [ [ curry ] ((fry)) ] }
+ { \ namespaces:, [ [ curry ] ((fry)) ] }
[ swap >r suffix r> (fry) ]
} case
TUPLE: cursortree cursors ;
: <cursortree> ( seq -- cursortree )
- <gb> cursortree
construct-empty tuck set-delegate <avl>
+ <gb> cursortree
new tuck set-delegate <avl>
over set-cursortree-cursors ;
GENERIC: cursortree-gb ( cursortree -- gb )
M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
: <cursor> ( cursortree -- cursor )
- cursor construct-empty tuck set-cursor-tree ;
+ cursor new tuck set-cursor-tree ;
: make-cursor ( cursortree pos cursor -- cursor )
>r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
: <left-cursor> ( cursortree pos -- left-cursor )
- left-cursor construct-empty make-cursor ;
+ left-cursor new make-cursor ;
: <right-cursor> ( cursortree pos -- right-cursor )
- right-cursor construct-empty make-cursor ;
+ right-cursor new make-cursor ;
: cursors ( cursortree -- seq )
cursortree-cursors values concat ;
tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
: <gb> ( seq -- gb )
- gb construct-empty
+ gb new
5 over set-gb-min-size
1.5 over set-gb-expand-factor
[ >r length r> set-gb-gap-start ] 2keep
+collections
collections sequences
{ [ os windows? ] [ "hardware-info.windows" ] }
{ [ os linux? ] [ "hardware-info.linux" ] }
{ [ os macosx? ] [ "hardware-info.macosx" ] }
- { [ t ] [ f ] }
+ [ f ]
} cond [ require ] when* >>
: hardware-report. ( -- )
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
- "\"mydata.dat\" dup file-info file-info-length ["
+ "\"mydata.dat\" dup file-info size>> ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}
":errors - print 2 compiler errors."
":warnings - print 50 compiler warnings."
}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erronous stack effect declarations."
+"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
{ $references
"To learn more about the compiler and static stack effect inference, read these articles:"
"compiler"
{ $code "#! /usr/bin/env factor -script" }
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
$nl
-"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch supresses compiler messages, and exits Factor when the script finishes."
+"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes."
{ $references
{ }
"cli"
$nl
"Keep the following guidelines in mind to avoid losing your sense of balance:"
{ $list
- "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
+ "Simplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
"In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code."
"If your code looks repetitive, factor it some more."
"If after factoring, your code still looks repetitive, introduce combinators."
"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
{ "Learn to use the " { $link "inference" } " tool." }
{ "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
- "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution."
+ "Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution."
{ "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
{ "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." }
{ "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." }
$nl
"Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
{ $code "\"inference\" test" }
- "In general, you should strive to write code with inferrable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
+ "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
quotations io.streams.byte-array io.encodings.string
-classes.builtin ;
+classes.builtin parser ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
{ { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } }
{ { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } }
{ { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link <array> } } }
+ { { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } }
{ { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } }
{ { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } }
{ { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }
{
{ [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] }
- { [ t ] [ (:help-multi) ] }
+ [ (:help-multi) ]
} cond (:help-debugger) ;
: remove-article ( name -- )
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
-macros combinators.lib sequences.lib math ;
+macros combinators.lib sequences.lib math sets ;
IN: help.lint
: check-example ( element -- )
[ strong-style get print-element* ] ($heading) ;
: ($code-style) ( presentation -- hash )
- presented associate code-style get union ;
+ presented associate code-style get assoc-union ;
: ($code) ( presentation quot -- )
[
GENERIC: >link ( obj -- obj )
M: link >link ;
M: vocab-spec >link ;
-M: object >link link construct-boa ;
+M: object >link link boa ;
PREDICATE: word-link < link link-name word? ;
TUPLE: article title content loc ;
: <article> ( title content -- article )
- f \ article construct-boa ;
+ f \ article boa ;
M: article article-name article-title ;
TUPLE: no-article name ;
-: no-article ( name -- * ) \ no-article construct-boa throw ;
+: no-article ( name -- * ) \ no-article boa throw ;
M: no-article summary
drop "Help article does not exist" ;
IN: html.tests
: make-html-string
- [ with-html-stream ] with-string-writer ;
+ [ with-html-stream ] with-string-writer ; inline
+
+[ [ ] make-html-string ] must-infer
[ ] [
512 <sbuf> <html-stream> drop
[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
[
- "<" "austin" funky construct-boa write-object
+ "<" "austin" funky boa write-object
] make-html-string
] unit-test
TUPLE: html-sub-stream style stream ;
: (html-sub-stream) ( style stream -- stream )
- html-sub-stream construct-boa
+ html-sub-stream boa
512 <sbuf> <html-stream> over set-delegate ;
: <html-sub-stream> ( style stream class -- stream )
! Utilities
: with-html-stream ( quot -- )
- stdio get <html-stream> swap with-stream* ;
+ stdio get <html-stream> swap with-stream* ; inline
: xhtml-preamble
"<?xml version=\"1.0\"?>" write-html
[ print-closing-named-tag ] }
{ [ dup tag-name string? ]
[ print-opening-named-tag ] }
- { [ t ] [ <unknown-tag-error> throw ] }
+ [ <unknown-tag-error> throw ]
} cond ;
SYMBOL: tablestack
USING: http tools.test multiline tuple-syntax
-io.streams.string kernel arrays splitting sequences ;
+io.streams.string kernel arrays splitting sequences
+assocs io.sockets ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ ] [
[
<dispatcher>
- <action>
- [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
- "quit" add-responder
- "extra/http/test" resource-path <static> >>default
+ <action>
+ [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
+ "quit" add-responder
+ <dispatcher>
+ "extra/http/test" resource-path <static> >>default
+ "nested" add-responder
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
[ t ] [
"extra/http/test/foo.html" resource-path ascii file-contents
- "http://localhost:1237/foo.html" http-get =
+ "http://localhost:1237/nested/foo.html" http-get =
+] unit-test
+
+! Try with a slightly malformed request
+[ t ] [
+ "localhost" 1237 <inet> ascii <client> [
+ "GET nested HTTP/1.0\r\n" write flush
+ "\r\n" write flush
+ readln drop
+ read-header USE: prettyprint
+ ] with-stream dup . "location" swap at "/" head?
] unit-test
[ "Goodbye" ] [
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry hashtables io io.streams.string kernel math
+USING: fry hashtables io io.streams.string kernel math sets
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
combinators vectors sorting accessors calendar
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
- dup "\r\n" seq-intersect empty?
+ dup "\r\n" intersect empty?
[ "Header injection attack" throw ] unless ;
: write-header ( assoc -- )
TUPLE: cookie name value path domain expires http-only ;
: <cookie> ( value name -- cookie )
- cookie construct-empty
+ cookie new
swap >>name swap >>value ;
: parse-cookies ( string -- seq )
: (unparse-cookie) ( key value -- )
{
- { [ dup f eq? ] [ 2drop ] }
- { [ dup t eq? ] [ drop , ] }
- { [ t ] [ "=" swap 3append , ] }
- } cond ;
+ { f [ drop ] }
+ { t [ , ] }
+ [ "=" swap 3append , ]
+ } case ;
: unparse-cookie ( cookie -- strings )
[
cookies ;
: <request>
- request construct-empty
+ request new
"1.1" >>version
http-port >>port
H{ } clone >>header
body ;
: <response>
- response construct-empty
+ response new
"1.1" >>version
H{ } clone >>header
"close" "connection" set-header
{ [ dup not ] [ drop ] }
{ [ dup string? ] [ write ] }
{ [ dup callable? ] [ call ] }
- { [ t ] [ stdio get stream-copy ] }
+ [ stdio get stream-copy ]
} cond ;
M: response write-response ( respose -- )
body ;
: <raw-response> ( -- response )
- raw-response construct-empty
+ raw-response new
"1.1" >>version ;
M: raw-response write-response ( respose -- )
TUPLE: action init display submit get-params post-params ;\r
\r
: <action>\r
- action construct-empty\r
+ action new\r
[ ] >>init\r
[ <400> ] >>display\r
[ <400> ] >>submit ;\r
M: action call-responder ( path action -- response )\r
'[\r
, ,\r
- [ +append-path associate request-params union params set ]\r
+ [ +append-path associate request-params assoc-union params set ]\r
[ action set ] bi*\r
request get method>> {\r
{ "GET" [ handle-get ] }\r
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors quotations assocs kernel splitting\r
-base64 html.elements io combinators http.server\r
-http.server.auth.providers http.server.auth.providers.null\r
-http.server.actions http.server.components http.server.sessions\r
-http.server.templating.fhtml http.server.validators\r
-http.server.auth http sequences io.files namespaces hashtables\r
+base64 io combinators sequences io.files namespaces hashtables\r
fry io.sockets arrays threads locals qualified continuations\r
-destructors ;\r
+destructors\r
+\r
+html.elements\r
+http\r
+http.server\r
+http.server.auth\r
+http.server.auth.providers\r
+http.server.auth.providers.null\r
+http.server.actions\r
+http.server.components\r
+http.server.forms\r
+http.server.sessions\r
+http.server.templating.fhtml\r
+http.server.validators ;\r
IN: http.server.auth.login\r
QUALIFIED: smtp\r
\r
SYMBOL: post-login-url\r
SYMBOL: login-failed?\r
\r
-TUPLE: login users ;\r
+TUPLE: login < dispatcher users ;\r
\r
: users login get users>> ;\r
\r
\r
successful-login\r
\r
- login get responder>> init-user-profile\r
+ login get default>> responder>> init-user-profile\r
] >>submit\r
] ;\r
\r
"password" value uid users check-login\r
[ login-failed? on validation-failed ] unless\r
\r
- "new-password" value set-password\r
+ "new-password" value >>password\r
] unless\r
\r
"realname" value >>realname\r
: <recover-form-3>\r
"new-password" <form>\r
"resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template\r
- "username" <username> <hidden>\r
+ "username" <username>\r
+ hidden >>renderer\r
t >>required\r
add-field\r
"new-password" <password>\r
"verify-password" <password>\r
t >>required\r
add-field\r
- "ticket" <string> <hidden>\r
+ "ticket" <string>\r
+ hidden >>renderer\r
t >>required\r
add-field ;\r
\r
"login" f <permanent-redirect> ;\r
\r
M: protected call-responder ( path responder -- response )\r
- logged-in-user sget [\r
- dup save-user-after\r
+ logged-in-user sget dup [\r
+ save-user-after\r
request get request-url previous-page sset\r
responder>> call-responder\r
] [\r
- 2drop\r
+ 3drop\r
request get method>> { "GET" "HEAD" } member?\r
[ show-login-page ] [ <400> ] if\r
] if ;\r
\r
M: login call-responder ( path responder -- response )\r
dup login set\r
- delegate call-responder ;\r
+ call-next-method ;\r
\r
: <login> ( responder -- auth )\r
- login <webapp>\r
+ login new-dispatcher\r
swap <protected> >>default\r
<login-action> "login" add-responder\r
<logout-action> "logout" add-responder\r
\r
[ t ] [ "user" get >boolean ] unit-test\r
\r
-[ ] [ "user" get "fdasf" set-password drop ] unit-test\r
+[ ] [ "user" get "fdasf" >>password drop ] unit-test\r
\r
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
\r
TUPLE: users-in-memory assoc ;\r
\r
: <users-in-memory> ( -- provider )\r
- H{ } clone users-in-memory construct-boa ;\r
+ H{ } clone users-in-memory boa ;\r
\r
M: users-in-memory get-user ( username provider -- user/f )\r
assoc>> at ;\r
\r
[ t ] [ "user" get >boolean ] unit-test\r
\r
- [ ] [ "user" get "fdasf" set-password drop ] unit-test\r
+ [ ] [ "user" get "fdasf" >>password drop ] unit-test\r
\r
[ ] [ "user" get "provider" get update-user ] unit-test\r
\r
\r
TUPLE: user username realname password email ticket profile ;\r
\r
-: <user> user construct-empty H{ } clone >>profile ;\r
+: <user> user new H{ } clone >>profile ;\r
\r
GENERIC: get-user ( username provider -- user/f )\r
\r
: check-login ( password username provider -- user/f )\r
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;\r
\r
-: set-password ( user password -- user ) >>password ;\r
-\r
! Password recovery support\r
\r
:: issue-ticket ( email username provider -- user/f )\r
#! A continuation responder is a special type of session\r
#! manager. However it works entirely differently from\r
#! the URL and cookie session managers.\r
- H{ } clone callback-responder construct-boa ;\r
+ H{ } clone callback-responder boa ;\r
\r
TUPLE: callback cont quot expires alarm responder ;\r
\r
] when drop ;\r
\r
: <callback> ( cont quot expires? -- callback )\r
- f callback-responder get callback construct-boa\r
+ f callback-responder get callback boa\r
dup touch-callback ;\r
\r
: invoke-callback ( callback -- response )\r
IN: http.server.components.tests\r
-USING: http.server.components http.server.validators\r
-namespaces tools.test kernel accessors\r
-tuple-syntax mirrors http.server.actions ;\r
+USING: http.server.components http.server.forms\r
+http.server.validators namespaces tools.test kernel accessors\r
+tuple-syntax mirrors http.server.actions\r
+io.streams.string io.streams.null ;\r
+\r
+\ render-edit must-infer\r
\r
validation-failed? off\r
\r
\r
TUPLE: test-tuple text number more-text ;\r
\r
-: <test-tuple> test-tuple construct-empty ;\r
+: <test-tuple> test-tuple new ;\r
\r
: <test-form> ( -- form )\r
"test" <form>\r
"123" "n" get validate value>>\r
] unit-test\r
\r
- [ ] [ "n" get t >>integer drop ] unit-test\r
+ [ ] [ "i" <integer> "i" set ] unit-test\r
\r
[ 3 ] [\r
- "3" "n" get validate\r
+ "3" "i" get validate\r
+ ] unit-test\r
+ \r
+ [ t ] [\r
+ "3.9" "i" get validate validation-error?\r
] unit-test\r
+\r
+ H{ } clone values set\r
+\r
+ [ ] [ 3 "i" set-value ] unit-test\r
+\r
+ [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test\r
+\r
+ [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test\r
+\r
+ [ ] [ "t" <text> "t" set ] unit-test\r
+\r
+ [ ] [ "hello world" "t" set-value ] unit-test\r
+\r
+ [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test\r
] with-scope\r
\r
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test\r
+\r
+[ ] [ "password" <password> "p" set ] unit-test\r
! See http://factorcode.org/license.txt for BSD license.
USING: html.elements http.server.validators accessors namespaces
kernel io math.parser assocs classes words classes.tuple arrays
-sequences io.files http.server.templating.fhtml
-http.server.actions splitting mirrors hashtables fry
+sequences splitting mirrors hashtables fry combinators
continuations math ;
IN: http.server.components
+! Renderer protocol
+GENERIC: render-view* ( value renderer -- )
+GENERIC: render-edit* ( value id renderer -- )
+
+TUPLE: field type ;
+
+C: <field> field
+
+M: field render-view* drop write ;
+
+M: field render-edit*
+ <input type>> =type [ =id ] [ =name ] bi =value input/> ;
+
+: render-error ( message -- )
+ <span "error" =class span> write </span> ;
+
+TUPLE: hidden < field ;
+
+: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
+
+M: hidden render-view* 2drop ;
+
+! Component protocol
SYMBOL: components
-TUPLE: component id required default ;
+TUPLE: component id required default renderer ;
: component ( name -- component )
dup components get at
[ ] [ "No such component: " prepend throw ] ?if ;
+GENERIC: init ( component -- component )
+
+M: component init ;
+
GENERIC: validate* ( value component -- result )
-GENERIC: render-view* ( value component -- )
-GENERIC: render-edit* ( value component -- )
-GENERIC: render-error* ( reason value component -- )
+GENERIC: component-string ( value component -- string )
SYMBOL: values
: set-value values get set-at ;
-: validate ( value component -- result )
- '[
- ,
- over empty? [
- [ default>> [ v-default ] when* ]
- [ required>> [ v-required ] when ]
- bi
- ] [ validate* ] if
- ] with-validator ;
+: blank-values H{ } clone values set ;
-: render-view ( component -- )
- [ id>> value ] [ render-view* ] bi ;
+: from-tuple <mirror> values set ;
-: render-error ( error -- )
- <span "error" =class span> write </span> ;
+: values-tuple values get mirror-object ;
-: render-edit ( component -- )
- dup id>> value dup validation-error? [
- [ reason>> ] [ value>> ] bi rot render-error*
- ] [
- swap [ default>> or ] keep render-edit*
- ] if ;
-
-: <component> ( id class -- component )
- \ component construct-empty
- swap construct-delegate
- swap >>id ; inline
-
-! Forms
-TUPLE: form view-template edit-template components ;
-
-: <form> ( id -- form )
- form <component>
- V{ } clone >>components ;
-
-: add-field ( form component -- form )
- dup id>> pick components>> set-at ;
-
-: with-form ( form quot -- )
- >r components>> components r> with-variable ; inline
-
-: set-defaults ( form -- )
- [
- components get [
- swap values get [
- swap default>> or
- ] change-at
- ] assoc-each
- ] with-form ;
-
-: view-form ( form -- )
- dup view-template>> '[ , run-template ] with-form ;
-
-: edit-form ( form -- )
- dup edit-template>> '[ , run-template ] with-form ;
-
-: validate-param ( id component -- )
- [ [ params get at ] [ validate ] bi* ]
- [ drop set-value ] 2bi ;
-
-: (validate-form) ( form -- error? )
- [
- validation-failed? off
- components get [ validate-param ] assoc-each
- validation-failed? get
- ] with-form ;
-
-: validate-form ( form -- )
- (validate-form) [ validation-failed ] when ;
+: render-view ( component -- )
+ [ id>> value ] [ component-string ] [ renderer>> ] tri
+ render-view* ;
-: blank-values H{ } clone values set ;
+<PRIVATE
-: from-tuple <mirror> values set ;
+: render-edit-string ( string component -- )
+ [ id>> ] [ renderer>> ] bi render-edit* ;
-: values-tuple values get mirror-object ;
+: render-edit-error ( component -- )
+ [ id>> value ] keep
+ [ [ value>> ] dip render-edit-string ]
+ [ drop reason>> render-error ] 2bi ;
-! ! !
-! Canned components: for simple applications and prototyping
-! ! !
+: value-or-default ( component -- value )
+ [ id>> value ] [ default>> ] bi or ;
-: render-input ( value component type -- )
- <input
- =type
- id>> [ =id ] [ =name ] bi
- =value
- input/> ;
+: render-edit-value ( component -- )
+ [ value-or-default ]
+ [ component-string ]
+ [ render-edit-string ]
+ tri ;
-! Hidden fields
-TUPLE: hidden ;
+PRIVATE>
-: <hidden> ( component -- component )
- hidden construct-delegate ;
+: render-edit ( component -- )
+ dup id>> value validation-error?
+ [ render-edit-error ] [ render-edit-value ] if ;
-M: hidden render-view*
- 2drop ;
+: validate ( value component -- result )
+ '[
+ ,
+ over empty? [
+ [ default>> [ v-default ] when* ]
+ [ required>> [ v-required ] when ]
+ bi
+ ] [ validate* ] if
+ ] with-validator ;
-M: hidden render-edit*
- >r dup number? [ number>string ] when r>
- "hidden" render-input ;
+: new-component ( id class renderer -- component )
+ swap new
+ swap >>renderer
+ swap >>id
+ init ; inline
! String input fields
-TUPLE: string min-length max-length ;
-
-: <string> ( id -- component ) string <component> ;
+TUPLE: string < component one-line min-length max-length ;
-M: string validate*
- [ v-one-line ] [
- [ min-length>> [ v-min-length ] when* ]
- [ max-length>> [ v-max-length ] when* ]
- bi
- ] bi* ;
+: new-string ( id class -- component )
+ "text" <field> new-component
+ t >>one-line ; inline
-M: string render-view*
- drop write ;
+: <string> ( id -- component )
+ string new-string ;
-M: string render-edit*
- "text" render-input ;
+M: string validate*
+ [ one-line>> [ v-one-line ] when ]
+ [ min-length>> [ v-min-length ] when* ]
+ [ max-length>> [ v-max-length ] when* ]
+ tri ;
-M: string render-error*
- "text" render-input render-error ;
+M: string component-string
+ drop ;
! Username fields
-TUPLE: username ;
+TUPLE: username < string ;
+
+M: username init
+ 2 >>min-length
+ 20 >>max-length ;
: <username> ( id -- component )
- <string> username construct-delegate
- 2 >>min-length
- 20 >>max-length ;
+ username new-string ;
M: username validate*
- delegate validate* v-one-word ;
+ call-next-method v-one-word ;
! E-mail fields
-TUPLE: email ;
+TUPLE: email < string ;
: <email> ( id -- component )
- <string> email construct-delegate
+ email new-string
5 >>min-length
60 >>max-length ;
M: email validate*
- delegate validate* dup empty? [ v-email ] unless ;
+ call-next-method dup empty? [ v-email ] unless ;
+
+! Don't send passwords back to the user
+TUPLE: password-renderer < field ;
+
+: password-renderer T{ password-renderer f "password" } ;
+
+: blank-password >r >r drop "" r> r> ;
+
+M: password-renderer render-edit*
+ blank-password call-next-method ;
! Password fields
-TUPLE: password ;
+TUPLE: password < string ;
+
+M: password init
+ 6 >>min-length
+ 60 >>max-length ;
: <password> ( id -- component )
- <string> password construct-delegate
- 6 >>min-length
- 60 >>max-length ;
+ password new-string
+ password-renderer >>renderer ;
M: password validate*
- delegate validate* v-one-word ;
-
-M: password render-edit*
- >r drop f r> "password" render-input ;
-
-M: password render-error*
- render-edit* render-error ;
+ call-next-method v-one-word ;
! Number fields
-TUPLE: number min-value max-value integer ;
+TUPLE: number < string min-value max-value ;
-: <number> ( id -- component ) number <component> ;
+: <number> ( id -- component )
+ number new-string ;
M: number validate*
[ v-number ] [
- [ integer>> [ v-integer ] when ]
[ min-value>> [ v-min-value ] when* ]
[ max-value>> [ v-max-value ] when* ]
- tri
+ bi
] bi* ;
-M: number render-view*
- drop number>string write ;
+M: number component-string
+ drop dup [ number>string ] when ;
-M: number render-edit*
- >r number>string r> "text" render-input ;
+! Integer fields
+TUPLE: integer < number ;
-M: number render-error*
- "text" render-input render-error ;
+: <integer> ( id -- component )
+ integer new-string ;
-! Text areas
-TUPLE: text ;
+M: integer validate*
+ call-next-method v-integer ;
-: <text> ( id -- component ) text <component> ;
+! Simple captchas
+TUPLE: captcha < string ;
-M: text validate* drop ;
+: <captcha> ( id -- component )
+ captcha new-string ;
-M: text render-view*
- drop write ;
+M: captcha validate*
+ drop v-captcha ;
-: render-textarea
- <textarea
- id>> [ =id ] [ =name ] bi
- textarea>
- write
- </textarea> ;
+! Text areas
+TUPLE: textarea-renderer ;
-M: text render-edit*
- render-textarea ;
+: textarea-renderer T{ textarea-renderer } ;
-M: text render-error*
- render-textarea render-error ;
+M: textarea-renderer render-view*
+ drop write ;
-! Simple captchas
-TUPLE: captcha ;
+M: textarea-renderer render-edit*
+ drop <textarea [ =id ] [ =name ] bi textarea> write </textarea> ;
-: <captcha> ( id -- component )
- <string> captcha construct-delegate ;
+TUPLE: text < string ;
-M: captcha validate*
- drop v-captcha ;
+: new-text ( id class -- component )
+ new-string
+ f >>one-line
+ textarea-renderer >>renderer ;
+
+: <text> ( id -- component )
+ text new-text ;
! Copyright (C) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: splitting http.server.components kernel io sequences\r
-farkup ;\r
+USING: splitting kernel io sequences farkup accessors\r
+http.server.components ;\r
IN: http.server.components.farkup\r
\r
-TUPLE: farkup ;\r
+TUPLE: farkup-renderer < textarea-renderer ;\r
\r
-: <farkup> ( id -- component )\r
- <text> farkup construct-delegate ;\r
+: farkup-renderer T{ farkup-renderer } ;\r
\r
-M: farkup render-view*\r
+M: farkup-renderer render-view*\r
drop string-lines "\n" join convert-farkup write ;\r
+\r
+: <farkup> ( id -- component )\r
+ <text>\r
+ farkup-renderer >>renderer ;\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces db.tuples math.parser
+accessors fry locals hashtables
+http.server
+http.server.actions
+http.server.components
+http.server.forms
+http.server.validators ;
IN: http.server.crud
-USING: kernel namespaces db.tuples math.parser http.server
-http.server.actions http.server.components
-http.server.validators accessors fry locals hashtables ;
:: <view-action> ( form ctor -- action )
<action>
C: <db-persistence> db-persistence\r
\r
: connect-db ( db-persistence -- )\r
- [ db>> ] [ params>> ] bi make-db\r
- [ db set ] [ db-open ] [ add-always-destructor ] tri ;\r
+ [ db>> ] [ params>> ] bi make-db db-open\r
+ [ db set ] [ add-always-destructor ] bi ;\r
\r
M: db-persistence call-responder\r
[ connect-db ] [ responder>> call-responder ] bi ;\r
--- /dev/null
+USING: kernel accessors assocs namespaces io.files fry
+http.server.actions
+http.server.components
+http.server.validators
+http.server.templating.fhtml ;
+IN: http.server.forms
+
+TUPLE: form < component view-template edit-template components ;
+
+M: form init V{ } clone >>components ;
+
+: <form> ( id -- form )
+ form f new-component ;
+
+: add-field ( form component -- form )
+ dup id>> pick components>> set-at ;
+
+: with-form ( form quot -- )
+ >r components>> components r> with-variable ; inline
+
+: set-defaults ( form -- )
+ [
+ components get [
+ swap values get [
+ swap default>> or
+ ] change-at
+ ] assoc-each
+ ] with-form ;
+
+: view-form ( form -- )
+ dup view-template>> '[ , run-template ] with-form ;
+
+: edit-form ( form -- )
+ dup edit-template>> '[ , run-template ] with-form ;
+
+: validate-param ( id component -- )
+ [ [ params get at ] [ validate ] bi* ]
+ [ drop set-value ] 2bi ;
+
+: (validate-form) ( form -- error? )
+ [
+ validation-failed? off
+ components get [ validate-param ] assoc-each
+ validation-failed? get
+ ] with-form ;
+
+: validate-form ( form -- )
+ (validate-form) [ validation-failed ] when ;
{
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
- { [ t ] [ relative-redirect ] }
+ [ relative-redirect ]
} cond ;
: <redirect> ( to query code message -- response )
TUPLE: dispatcher default responders ;
+: new-dispatcher ( class -- dispatcher )
+ new
+ 404-responder get >>default
+ H{ } clone >>responders ; inline
+
: <dispatcher> ( -- dispatcher )
- 404-responder get H{ } clone dispatcher construct-boa ;
+ dispatcher new-dispatcher ;
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
2drop redirect-with-/
] if ;
-: <webapp> ( class -- dispatcher )
- <dispatcher> swap construct-delegate ; inline
-
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
- 404-responder get H{ } clone vhost-dispatcher construct-boa ;
+ 404-responder get H{ } clone vhost-dispatcher boa ;
: find-vhost ( dispatcher -- responder )
request get host>> over responders>> at*
TUPLE: session-manager responder sessions ;
-: <session-manager> ( responder class -- responder' )
- >r <sessions-in-memory> session-manager construct-boa
- r> construct-delegate ; inline
+: new-session-manager ( responder class -- responder' )
+ new
+ <sessions-in-memory> >>sessions
+ swap >>responder ; inline
SYMBOLS: session session-id session-changed? ;
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ;
-TUPLE: null-sessions ;
+TUPLE: null-sessions < session-manager ;
: <null-sessions>
- null-sessions <session-manager> ;
+ null-sessions new-session-manager ;
M: null-sessions call-responder ( path responder -- response )
H{ } clone f call-responder/session ;
-TUPLE: url-sessions ;
+TUPLE: url-sessions < session-manager ;
: <url-sessions> ( responder -- responder' )
- url-sessions <session-manager> ;
+ url-sessions new-session-manager ;
: session-id-key "factorsessid" ;
[ drop ] [ get-session ] 2bi ;
: add-session-id ( query -- query' )
- session-id get [ session-id-key associate union ] when* ;
+ session-id get [ session-id-key associate assoc-union ] when* ;
: session-form-field ( -- )
<input
2drop nip new-url-session
] if ;
-TUPLE: cookie-sessions ;
+TUPLE: cookie-sessions < session-manager ;
: <cookie-sessions> ( responder -- responder' )
- cookie-sessions <session-manager> ;
+ cookie-sessions new-session-manager ;
: current-cookie-session ( responder -- id namespace/f )
request get session-id-key get-cookie dup
TUPLE: sessions-in-memory sessions alarms ;\r
\r
: <sessions-in-memory> ( -- storage )\r
- H{ } clone H{ } clone sessions-in-memory construct-boa ;\r
+ H{ } clone H{ } clone sessions-in-memory boa ;\r
\r
: cancel-session-timeout ( id storage -- )\r
alarms>> at [ cancel-alarm ] when* ;\r
: init-sessions-table session ensure-table ;
: <session> ( id -- session )
- session construct-empty
+ session new
swap dup [ string>number ] when >>id ;
M: sessions-in-db get-session ( id storage -- namespace/f )
TUPLE: file-responder root hook special ;\r
\r
: file-http-date ( filename -- string )\r
- file-info file-info-modified timestamp>http-string ;\r
+ file-info modified>> timestamp>http-string ;\r
\r
: last-modified-matches? ( filename -- ? )\r
file-http-date dup [\r
304 "Not modified" <trivial-response> ;\r
\r
: <file-responder> ( root hook -- responder )\r
- H{ } clone file-responder construct-boa ;\r
+ H{ } clone file-responder boa ;\r
\r
: <static> ( root -- responder )\r
[\r
<content>\r
swap\r
- [ file-info file-info-size "content-length" set-header ]\r
+ [ file-info size>> "content-length" set-header ]\r
[ file-http-date "last-modified" set-header ]\r
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]\r
tri\r
! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel parser namespaces io
io.files io.streams.string html html.elements source-files
debugger combinators math quotations generic strings splitting
accessors http.server.static http.server assocs
-io.encodings.utf8 fry ;
+io.encodings.utf8 fry accessors ;
IN: http.server.templating.fhtml
: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
-! See apps/http-server/test/ or libs/furnace/ for template usage
-! examples
-
! We use a custom lexer so that %> ends a token even if not
! followed by whitespace
-TUPLE: template-lexer ;
+TUPLE: template-lexer < lexer ;
: <template-lexer> ( lines -- lexer )
- <lexer> template-lexer construct-delegate ;
+ template-lexer new-lexer ;
M: template-lexer skip-word
[
{
{ [ 2dup nth CHAR: " = ] [ drop 1+ ] }
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
- { [ t ] [ f skip ] }
+ [ f skip ]
} cond
] change-lexer-column ;
DEFER: <% delimiter
: check-<% ( lexer -- col )
- "<%" over lexer-line-text rot lexer-column start* ;
+ "<%" over line-text>> rot column>> start* ;
: found-<% ( accum lexer col -- accum )
[
- over lexer-line-text
- >r >r lexer-column r> r> subseq parsed
+ over line-text>>
+ >r >r column>> r> r> subseq parsed
\ write-html parsed
- ] 2keep 2 + swap set-lexer-column ;
+ ] 2keep 2 + >>column drop ;
: still-looking ( accum lexer -- accum )
[
- dup lexer-line-text swap lexer-column tail
+ [ line-text>> ] [ column>> ] bi tail
parsed \ print-html parsed
] keep next-line ;
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces
+USING: kernel continuations sequences math namespaces sets
math.parser assocs regexp fry unicode.categories sequences ;
IN: http.server.validators
dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
- dup "\r\n" seq-intersect empty?
+ dup "\r\n" intersect empty?
[ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
USING: inverse tools.test arrays math kernel sequences
-math.functions math.constants ;
+math.functions math.constants continuations ;
IN: inverse-tests
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
{
{ [ <cons> ] [ list-sum + ] }
{ [ <nil> ] [ 0 ] }
- { [ ] [ "Malformed list" throw ] }
+ [ "Malformed list" throw ]
} switch ;
[ 10 ] [ 1 2 3 4 <nil> <cons> <cons> <cons> <cons> list-sum ] unit-test
[ 1 2 ] [ 1 2 <cons> [ <cons> ] undo ] unit-test
[ t ] [ 1 2 <cons> [ <cons> ] matches? ] unit-test
[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
+[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
-: empty-cons ( -- cons ) cons construct-empty ;
+: empty-cons ( -- cons ) cons new ;
: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
[ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
[ t ] [ pi [ pi ] matches? ] unit-test
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
+[ ] [ 3 [ _ ] undo ] unit-test
IN: inverse
TUPLE: fail ;
-: fail ( -- * ) \ fail construct-empty throw ;
+: fail ( -- * ) \ fail new throw ;
M: fail summary drop "Unification failed" ;
: assure ( ? -- ) [ fail ] unless ;
"pop-inverse" set-word-prop ;
TUPLE: no-inverse word ;
-: no-inverse ( word -- * ) \ no-inverse construct-empty throw ;
+: no-inverse ( word -- * ) \ no-inverse new throw ;
M: no-inverse summary
drop "The word cannot be used in pattern matching" ;
PREDICATE: pop-inverse < word "pop-length" word-prop ;
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
-: enough? ( stack quot -- ? )
- [ >r length r> 1quotation infer effect-in >= ] [ 3drop f ]
- recover ;
+: enough? ( stack word -- ? )
+ dup deferred? [ 2drop f ] [
+ [ >r length r> 1quotation infer effect-in >= ]
+ [ 3drop f ] recover
+ ] if ;
-: fold-word ( stack quot -- stack )
+: fold-word ( stack word -- stack )
2dup enough?
[ 1quotation with-datastack ] [ >r % r> , { } ] if ;
[ { } swap [ fold-word ] each % ] [ ] make ;
: flattenable? ( object -- ? )
- [ [ word? ] [ primitive? not ] and? ] [
+ { [ word? ] [ primitive? not ] [
{ "inverse" "math-inverse" "pop-inverse" }
[ word-prop ] with contains? not
- ] and? ;
+ ] } <-&& ;
: (flatten) ( quot -- )
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
2curry
] define-pop-inverse
-: _ f ;
+DEFER: _
\ _ [ drop ] define-inverse
: both ( object object -- object )
\ first3 [ 3array ] define-inverse
\ first4 [ 4array ] define-inverse
+\ prefix [ unclip ] define-inverse
+\ unclip [ prefix ] define-inverse
+\ suffix [ dup 1 head* swap peek ] define-inverse
+
! Constructor inverse
: deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ;
: boa-inverse ( class -- quot )
[ deconstruct-pred ] keep slot-readers compose ;
-\ construct-boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
+\ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
: empty-inverse ( class -- quot )
deconstruct-pred
[ tuple>array 1 tail [ ] contains? [ fail ] when ]
compose ;
-\ construct-empty 1 [ ?wrapped empty-inverse ] define-pop-inverse
+\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
: writer>reader ( word -- word' )
[ "writing" word-prop "slots" word-prop ] keep
MACRO: matches? ( quot -- ? ) [matches?] ;
TUPLE: no-match ;
-: no-match ( -- * ) \ no-match construct-empty throw ;
+: no-match ( -- * ) \ no-match new throw ;
M: no-match summary drop "Fall through in switch" ;
: recover-chain ( seq -- quot )
[ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
: [switch] ( quot-alist -- quot )
+ [ dup quotation? [ [ ] swap 2array ] when ] map
reverse [ >r [undo] r> compose ] { } assoc>map
recover-chain ;
TUPLE: buffer size ptr fill pos ;
: <buffer> ( n -- buffer )
- dup malloc 0 0 buffer construct-boa ;
+ dup malloc 0 0 buffer boa ;
: buffer-free ( buffer -- )
dup buffer-ptr free f swap set-buffer-ptr ;
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup io.encodings.8-bit.private ;
+USING: help.syntax help.markup io.encodings.8-bit.private
+strings ;
IN: io.encodings.8-bit
ARTICLE: "io.encodings.8-bit" "8-bit encodings"
{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ;
HELP: define-8-bit-encoding
-{ $values { "name" "a string" } { "path" "a path" } }
-{ $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
+{ $values { "name" string } { "stream" "an input stream" } }
+{ $description "Creates a new encoding. The stream should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
HELP: latin1
{ $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." }
{ "mac-roman" "ROMAN" }
} ;
-: full-path ( file-name -- path )
+: encoding-file ( file-name -- stream )
"extra/io/encodings/8-bit/" ".TXT"
- swapd 3append resource-path ;
+ swapd 3append resource-path
+ ascii <file-reader> ;
: tail-if ( seq n -- newseq )
2dup swap length <= [ tail ] [ drop ] if ;
: ch>byte ( assoc -- newassoc )
[ swap ] assoc-map >hashtable ;
-: parse-file ( file-name -- byte>ch ch>byte )
- ascii file-lines process-contents
+: parse-file ( path -- byte>ch ch>byte )
+ lines process-contents
[ byte>ch ] [ ch>byte ] bi ;
TUPLE: 8-bit name decode encode ;
decode>> decode-8-bit ;
: make-8-bit ( word byte>ch ch>byte -- )
- [ 8-bit construct-boa ] 2curry dupd curry define ;
+ [ 8-bit boa ] 2curry dupd curry define ;
-: define-8-bit-encoding ( name path -- )
+: define-8-bit-encoding ( name stream -- )
>r in get create r> parse-file make-8-bit ;
PRIVATE>
[
"io.encodings.8-bit" in [
- mappings [ full-path define-8-bit-encoding ] assoc-each
+ mappings [ encoding-file define-8-bit-encoding ] assoc-each
] with-variable
] with-compilation-unit
C: strict strict
TUPLE: decode-error ;
-: decode-error ( -- * ) \ decode-error construct-empty throw ;
+: decode-error ( -- * ) \ decode-error new throw ;
M: decode-error summary
drop "Error in decoding input stream" ;
{ $values { "process" process } }
{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ;
-HELP: process-stream
-{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
-
HELP: <process-stream>
{ $values
{ "desc" "a launch descriptor" }
{ "desc" "a launch descriptor" }
{ "quot" quotation }
{ "status" "an exit code" } }
-{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
+{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a process stream. After the quotation returns, waits for the process to end and outputs the exit code." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" integer } }
SYMBOL: +realtime-priority+
: <process> ( -- process )
- process construct-empty
+ process new
H{ } clone >>environment
+append-environment+ >>environment-mode ;
: get-environment ( process -- env )
dup environment>>
swap environment-mode>> {
- { +prepend-environment+ [ os-envs union ] }
- { +append-environment+ [ os-envs swap union ] }
+ { +prepend-environment+ [ os-envs assoc-union ] }
+ { +append-environment+ [ os-envs swap assoc-union ] }
{ +replace-environment+ [ ] }
} case ;
TUPLE: process-failed code ;
: process-failed ( code -- * )
- \ process-failed construct-boa throw ;
+ \ process-failed boa throw ;
: try-process ( desc -- )
run-process wait-for-process dup zero?
HOOK: (process-stream) io-backend ( process -- handle in out )
-TUPLE: process-stream process ;
+: <process-stream*> ( desc encoding -- stream process )
+ >r >process dup dup (process-stream) <reader&writer>
+ r> <encoder-duplex> -roll
+ process-started ;
: <process-stream> ( desc encoding -- stream )
- >r >process dup dup (process-stream)
- >r >r process-started process-stream construct-boa
- r> r> <reader&writer> r> <encoder-duplex>
- over set-delegate ;
+ <process-stream*> drop ; inline
: with-process-stream ( desc quot -- status )
- swap <process-stream>
+ swap <process-stream*> >r
[ swap with-stream ] keep
- process>> wait-for-process ; inline
+ r> wait-for-process ; inline
: notify-exit ( process status -- )
>>status
USING: io io.mmap io.files kernel tools.test continuations
-sequences io.encodings.ascii ;
+sequences io.encodings.ascii accessors ;
IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
+[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
IN: io.monitors\r
-USING: help.markup help.syntax continuations ;\r
+USING: help.markup help.syntax continuations\r
+concurrency.mailboxes quotations ;\r
+\r
+HELP: with-monitors\r
+{ $values { "quot" quotation } }\r
+{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." }\r
+{ $errors "Throws an error if the platform does not support file system change monitors." } ;\r
\r
HELP: <monitor>\r
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } }\r
-{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."\r
-$nl\r
-"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;\r
+{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." }\r
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
+\r
+HELP: (monitor)\r
+{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } }\r
+{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }\r
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
\r
HELP: next-change\r
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }\r
-{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;\r
+{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }\r
+{ $errors "Throws an error if the monitor is closed from another thread." } ;\r
\r
HELP: with-monitor\r
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }\r
-{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;\r
+{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }\r
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
\r
HELP: +add-file+\r
-{ $description "Indicates that the file has been added to the directory." } ;\r
+{ $description "Indicates that a file has been added to its parent directory." } ;\r
\r
HELP: +remove-file+\r
-{ $description "Indicates that the file has been removed from the directory." } ;\r
+{ $description "Indicates that a file has been removed from its parent directory." } ;\r
\r
HELP: +modify-file+\r
-{ $description "Indicates that the file contents have changed." } ;\r
+{ $description "Indicates that a file's contents have changed." } ;\r
+\r
+HELP: +rename-file-old+\r
+{ $description "Indicates that a file has been renamed, and this is the old name." } ;\r
+\r
+HELP: +rename-file-new+\r
+{ $description "Indicates that a file has been renamed, and this is the new name." } ;\r
\r
HELP: +rename-file+\r
-{ $description "Indicates that file has been renamed." } ;\r
+{ $description "Indicates that a file has been renamed." } ;\r
\r
ARTICLE: "io.monitors.descriptors" "File system change descriptors"\r
"Change descriptors output by " { $link next-change } ":"\r
{ $subsection +add-file+ }\r
{ $subsection +remove-file+ }\r
{ $subsection +modify-file+ }\r
-{ $subsection +rename-file+ }\r
-{ $subsection +add-file+ } ;\r
+{ $subsection +rename-file-old+ }\r
+{ $subsection +rename-file-new+ }\r
+{ $subsection +rename-file+ } ;\r
+\r
+ARTICLE: "io.monitors.platforms" "Monitors on different platforms"\r
+"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is platform-specific. User code should not assume either case."\r
+{ $heading "Mac OS X" }\r
+"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."\r
+$nl\r
+{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."\r
+$nl\r
+"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."\r
+{ $heading "Windows" }\r
+"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."\r
+$nl\r
+"Both recursive and non-recursive monitors are directly supported by the operating system."\r
+{ $heading "Linux" }\r
+"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."\r
+$nl\r
+"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code."\r
+$nl\r
+"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."\r
+{ $heading "BSD" }\r
+"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD."\r
+$nl\r
+"The " { $snippet "kqueue" } " system is limited to monitoring individual files and directories. Monitoring a directory only notifies of files being added and removed to the directory itself, not of changes to file contents."\r
+{ $heading "Windows CE" }\r
+"Windows CE does not support monitors." ;\r
\r
ARTICLE: "io.monitors" "File system change monitors"\r
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."\r
$nl\r
+"Monitoring operations must be wrapped in a combinator:"\r
+{ $subsection with-monitors }\r
"Creating a file system change monitor and listening for changes:"\r
{ $subsection <monitor> }\r
{ $subsection next-change }\r
+"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:"\r
+{ $subsection (monitor) }\r
{ $subsection "io.monitors.descriptors" }\r
-"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."\r
-$nl\r
-"A utility combinator which opens a monitor and cleans it up after:"\r
+{ $subsection "io.monitors.platforms" } \r
+"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:"\r
{ $subsection with-monitor }\r
-"An example which watches the Factor directory for changes:"\r
+"Monitors support the " { $link "io.timeouts" } "."\r
+$nl\r
+"An example which watches a directory for changes:"\r
{ $code\r
"USE: io.monitors"\r
": watch-loop ( monitor -- )"\r
" dup next-change . . nl nl flush watch-loop ;"\r
""\r
- "\"\" resource-path f [ watch-loop ] with-monitor"\r
+ ": watch-directory ( path -- )"\r
+ " [ t [ watch-loop ] with-monitor ] with-monitors"\r
} ;\r
\r
ABOUT: "io.monitors"\r
--- /dev/null
+IN: io.monitors.tests
+USING: io.monitors tools.test io.files system sequences
+continuations namespaces concurrency.count-downs kernel io
+threads calendar prettyprint ;
+
+os { winnt linux macosx } member? [
+ [
+ [ "monitor-test" temp-file delete-tree ] ignore-errors
+
+ [ ] [ "monitor-test" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
+
+ [ ] [ "monitor-test/a1" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test/a2" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test
+
+ [ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test
+
+ [ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test
+
+ [ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test
+
+ [ ] [ "monitor-test/a2/a1/a4.txt" temp-file touch-file ] unit-test
+ [ ] [ "monitor-test/a2/a1/a5.txt" temp-file touch-file ] unit-test
+ [ ] [ "monitor-test/a2/a1/a4.txt" temp-file delete-file ] unit-test
+ [ ] [ "monitor-test/a2/a1/a5.txt" temp-file "monitor-test/a2/a1/a4.txt" temp-file move-file ] unit-test
+
+ [ t ] [ "monitor-test/a2/a1/a4.txt" temp-file exists? ] unit-test
+
+ [ ] [ "m" get dispose ] unit-test
+ ] with-monitors
+
+
+ [
+ [ "monitor-test" temp-file delete-tree ] ignore-errors
+
+ [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
+
+ [ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
+
+ [ ] [ 1 <count-down> "b" set ] unit-test
+
+ [ ] [ 1 <count-down> "c1" set ] unit-test
+
+ [ ] [ 1 <count-down> "c2" set ] unit-test
+
+ [ ] [
+ [
+ "b" get count-down
+
+ [
+ "m" get next-change drop
+ dup print flush
+ dup parent-directory
+ [ right-trim-separators "xyz" tail? ] either? not
+ ] [ ] [ ] while
+
+ "c1" get count-down
+
+ [
+ "m" get next-change drop
+ dup print flush
+ dup parent-directory
+ [ right-trim-separators "yxy" tail? ] either? not
+ ] [ ] [ ] while
+
+ "c2" get count-down
+ ] "Monitor test thread" spawn drop
+ ] unit-test
+
+ [ ] [ "b" get await ] unit-test
+
+ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
+
+ [ ] [ "c1" get 1 minutes await-timeout ] unit-test
+
+ [ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
+
+ [ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
+
+ [ ] [ "c2" get 1 minutes await-timeout ] unit-test
+
+ ! Dispose twice
+ [ ] [ "m" get dispose ] unit-test
+
+ [ ] [ "m" get dispose ] unit-test
+ ] with-monitors
+] when
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: io.backend kernel continuations namespaces sequences\r
-assocs hashtables sorting arrays threads boxes io.timeouts ;\r
-IN: io.monitors\r
-\r
-<PRIVATE\r
-\r
-TUPLE: monitor queue closed? ;\r
-\r
-: check-monitor ( monitor -- )\r
- monitor-closed? [ "Monitor closed" throw ] when ;\r
-\r
-: (monitor) ( delegate -- monitor )\r
- H{ } clone {\r
- set-delegate\r
- set-monitor-queue\r
- } monitor construct ;\r
-\r
-GENERIC: fill-queue ( monitor -- )\r
-\r
-: changed-file ( changed path -- )\r
- namespace [ append ] change-at ;\r
-\r
-: dequeue-change ( assoc -- path changes )\r
- delete-any prune natural-sort >array ;\r
-\r
-M: monitor dispose\r
- dup check-monitor\r
- t over set-monitor-closed?\r
- delegate dispose ;\r
-\r
-! Simple monitor; used on Linux and Mac OS X. On Windows,\r
-! monitors are full-fledged ports.\r
-TUPLE: simple-monitor handle callback timeout ;\r
-\r
-M: simple-monitor timeout simple-monitor-timeout ;\r
-\r
-M: simple-monitor set-timeout set-simple-monitor-timeout ;\r
-\r
-: <simple-monitor> ( handle -- simple-monitor )\r
- f (monitor) <box> {\r
- set-simple-monitor-handle\r
- set-delegate\r
- set-simple-monitor-callback\r
- } simple-monitor construct ;\r
-\r
-: construct-simple-monitor ( handle class -- simple-monitor )\r
- >r <simple-monitor> r> construct-delegate ; inline\r
-\r
-: notify-callback ( simple-monitor -- )\r
- simple-monitor-callback [ resume ] if-box? ;\r
-\r
-M: simple-monitor timed-out\r
- notify-callback ;\r
-\r
-M: simple-monitor fill-queue ( monitor -- )\r
- [\r
- [ swap simple-monitor-callback >box ]\r
- "monitor" suspend drop\r
- ] with-timeout\r
- check-monitor ;\r
-\r
-M: simple-monitor dispose ( monitor -- )\r
- dup delegate dispose notify-callback ;\r
-\r
-PRIVATE>\r
-\r
-HOOK: <monitor> io-backend ( path recursive? -- monitor )\r
-\r
-: next-change ( monitor -- path changed )\r
- dup check-monitor\r
- dup monitor-queue dup assoc-empty? [\r
- drop dup fill-queue next-change\r
- ] [ nip dequeue-change ] if ;\r
-\r
-SYMBOL: +add-file+\r
-SYMBOL: +remove-file+\r
-SYMBOL: +modify-file+\r
-SYMBOL: +rename-file+\r
-\r
-: with-monitor ( path recursive? quot -- )\r
- >r <monitor> r> with-disposal ; inline\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend kernel continuations namespaces sequences
+assocs hashtables sorting arrays threads boxes io.timeouts
+accessors concurrency.mailboxes ;
+IN: io.monitors
+
+HOOK: init-monitors io-backend ( -- )
+
+M: object init-monitors ;
+
+HOOK: dispose-monitors io-backend ( -- )
+
+M: object dispose-monitors ;
+
+: with-monitors ( quot -- )
+ [
+ init-monitors
+ [ dispose-monitors ] [ ] cleanup
+ ] with-scope ; inline
+
+TUPLE: monitor < identity-tuple path queue timeout ;
+
+M: monitor hashcode* path>> hashcode* ;
+
+M: monitor timeout timeout>> ;
+
+M: monitor set-timeout (>>timeout) ;
+
+: new-monitor ( path mailbox class -- monitor )
+ new
+ swap >>queue
+ swap >>path ; inline
+
+: queue-change ( path changes monitor -- )
+ 3dup and and
+ [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
+
+HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
+
+: <monitor> ( path recursive? -- monitor )
+ <mailbox> (monitor) ;
+
+: next-change ( monitor -- path changed )
+ [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
+
+SYMBOL: +add-file+
+SYMBOL: +remove-file+
+SYMBOL: +modify-file+
+SYMBOL: +rename-file-old+
+SYMBOL: +rename-file-new+
+SYMBOL: +rename-file+
+
+: with-monitor ( path recursive? quot -- )
+ >r <monitor> r> with-disposal ; inline
--- /dev/null
+USING: accessors math kernel namespaces continuations
+io.files io.monitors io.monitors.recursive io.backend
+concurrency.mailboxes
+tools.test ;
+IN: io.monitors.recursive.tests
+
+\ pump-thread must-infer
+
+SINGLETON: mock-io-backend
+
+TUPLE: counter i ;
+
+SYMBOL: dummy-monitor-created
+SYMBOL: dummy-monitor-disposed
+
+TUPLE: dummy-monitor < monitor ;
+
+M: dummy-monitor dispose
+ drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
+
+M: mock-io-backend (monitor)
+ nip
+ over exists? [
+ dummy-monitor new-monitor
+ dummy-monitor-created get [ 1+ ] change-i drop
+ ] [
+ "Does not exist" throw
+ ] if ;
+
+M: mock-io-backend link-info
+ global [ link-info ] bind ;
+
+[ ] [ 0 counter boa dummy-monitor-created set ] unit-test
+[ ] [ 0 counter boa dummy-monitor-disposed set ] unit-test
+
+[ ] [
+ mock-io-backend io-backend [
+ "" resource-path <mailbox> <recursive-monitor> dispose
+ ] with-variable
+] unit-test
+
+[ t ] [ dummy-monitor-created get i>> 0 > ] unit-test
+
+[ t ] [ dummy-monitor-created get i>> dummy-monitor-disposed get i>> = ] unit-test
+
+[ "doesnotexist" temp-file delete-tree ] ignore-errors
+
+[
+ mock-io-backend io-backend [
+ "doesnotexist" temp-file <mailbox> <recursive-monitor> dispose
+ ] with-variable
+] must-fail
+
+[ ] [
+ mock-io-backend io-backend [
+ "" resource-path <mailbox> <recursive-monitor>
+ [ dispose ] [ dispose ] bi
+ ] with-variable
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences assocs arrays continuations combinators kernel
+threads concurrency.messaging concurrency.mailboxes
+concurrency.promises
+io.files io.monitors ;
+IN: io.monitors.recursive
+
+! Simulate recursive monitors on platforms that don't have them
+
+TUPLE: recursive-monitor < monitor children thread ready ;
+
+DEFER: add-child-monitor
+
+: qualify-path ( path -- path' )
+ monitor tget path>> prepend-path ;
+
+: add-child-monitors ( path -- )
+ #! We yield since this directory scan might take a while.
+ [
+ directory* [ first add-child-monitor yield ] each
+ ] curry ignore-errors ;
+
+: add-child-monitor ( path -- )
+ qualify-path dup link-info type>> +directory+ eq? [
+ [ add-child-monitors ]
+ [
+ [ f my-mailbox (monitor) ] keep
+ monitor tget children>> set-at
+ ] bi
+ ] [ drop ] if ;
+
+USE: io
+USE: prettyprint
+
+: remove-child-monitor ( monitor -- )
+ monitor tget children>> delete-at*
+ [ dispose ] [ drop ] if ;
+
+M: recursive-monitor dispose
+ dup queue>> closed>> [
+ drop
+ ] [
+ [ "stop" swap thread>> send-synchronous drop ]
+ [ queue>> dispose ] bi
+ ] if ;
+
+: stop-pump ( -- )
+ monitor tget children>> [ nip dispose ] assoc-each ;
+
+: pump-step ( msg -- )
+ first3 path>> swap >r prepend-path r> monitor tget 3array
+ monitor tget queue>>
+ mailbox-put ;
+
+: child-added ( path monitor -- )
+ path>> prepend-path add-child-monitor ;
+
+: child-removed ( path monitor -- )
+ path>> prepend-path remove-child-monitor ;
+
+: update-hierarchy ( msg -- )
+ first3 swap [
+ {
+ { +add-file+ [ child-added ] }
+ { +remove-file+ [ child-removed ] }
+ { +rename-file-old+ [ child-removed ] }
+ { +rename-file-new+ [ child-added ] }
+ [ 3drop ]
+ } case
+ ] with with each ;
+
+: pump-loop ( -- )
+ receive dup synchronous? [
+ >r stop-pump t r> reply-synchronous
+ ] [
+ [ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
+ pump-loop
+ ] if ;
+
+: monitor-ready ( error/t -- )
+ monitor tget ready>> fulfill ;
+
+: pump-thread ( monitor -- )
+ monitor tset
+ [ "" add-child-monitor t monitor-ready ]
+ [ [ self <linked-error> monitor-ready ] keep rethrow ]
+ recover
+ pump-loop ;
+
+: start-pump-thread ( monitor -- )
+ dup [ pump-thread ] curry
+ "Recursive monitor pump" spawn
+ >>thread drop ;
+
+: wait-for-ready ( monitor -- )
+ ready>> ?promise ?linked drop ;
+
+: <recursive-monitor> ( path mailbox -- monitor )
+ >r (normalize-path) r>
+ recursive-monitor new-monitor
+ H{ } clone >>children
+ <promise> >>ready
+ dup start-pump-thread
+ dup wait-for-ready ;
USING: io io.buffers io.backend help.markup help.syntax kernel
-byte-arrays sbufs words continuations byte-vectors ;
+byte-arrays sbufs words continuations byte-vectors classes ;
IN: io.nonblocking
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
$nl
"Ports have the following slots:"
{ $list
- { { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
- { { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
- { { $link port-type } " - a symbol identifying the port's intended purpose" }
- { { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
+ { { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" }
+ { { $snippet "error" } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
+ { { $snippet "type" } " - a symbol identifying the port's intended purpose" }
+ { { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" }
} } ;
HELP: input-port
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
HELP: <port>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
-{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
+{ $description "Creates a new " { $link port } " with no buffer." }
$low-level-note ;
HELP: <buffered-port>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
{ $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." }
$low-level-note ;
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
HELP: can-write?
-{ $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } }
+{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }
{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-IN: io.nonblocking
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.streams.duplex io.encodings
io.backend continuations debugger classes byte-arrays namespaces
-splitting dlists assocs io.encodings.binary ;
+splitting dlists assocs io.encodings.binary inspector accessors ;
+IN: io.nonblocking
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
-! Common delegate of native stream readers and writers
-TUPLE: port
-handle
-error
-timeout
-type eof? ;
-
-M: port timeout port-timeout ;
-
-M: port set-timeout set-port-timeout ;
+TUPLE: port handle buffer error timeout closed eof ;
-SYMBOL: closed
+M: port timeout timeout>> ;
-PREDICATE: input-port < port port-type input-port eq? ;
-PREDICATE: output-port < port port-type output-port eq? ;
+M: port set-timeout (>>timeout) ;
GENERIC: init-handle ( handle -- )
+
GENERIC: close-handle ( handle -- )
-: <port> ( handle buffer type -- port )
- pick init-handle {
- set-port-handle
- set-delegate
- set-port-type
- } port construct ;
+: <port> ( handle class -- port )
+ new
+ swap dup init-handle >>handle ; inline
+
+: <buffered-port> ( handle class -- port )
+ <port>
+ default-buffer-size get <buffer> >>buffer ; inline
-: <buffered-port> ( handle type -- port )
- default-buffer-size get <buffer> swap <port> ;
+TUPLE: input-port < port ;
: <reader> ( handle -- input-port )
input-port <buffered-port> ;
+TUPLE: output-port < port ;
+
: <writer> ( handle -- output-port )
output-port <buffered-port> ;
swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
: pending-error ( port -- )
- dup port-error f rot set-port-error [ throw ] when* ;
+ [ f ] change-error drop [ throw ] when* ;
+
+ERROR: port-closed-error port ;
+
+M: port-closed-error summary
+ drop "Port has been closed" ;
+
+: check-closed ( port -- port )
+ dup closed>> [ port-closed-error ] when ;
HOOK: cancel-io io-backend ( port -- )
GENERIC: (wait-to-read) ( port -- )
: wait-to-read ( count port -- )
- tuck buffer-length > [ (wait-to-read) ] [ drop ] if ;
+ tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
: wait-to-read1 ( port -- )
1 swap wait-to-read ;
: unless-eof ( port quot -- value )
- >r dup buffer-empty? over port-eof? and
- [ f swap set-port-eof? f ] r> if ; inline
+ >r dup buffer>> buffer-empty? over eof>> and
+ [ f >>eof drop f ] r> if ; inline
M: input-port stream-read1
- dup wait-to-read1 [ buffer-pop ] unless-eof ;
+ check-closed
+ dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
: read-step ( count port -- byte-array/f )
[ wait-to-read ] 2keep
- [ dupd buffer-read ] unless-eof nip ;
+ [ dupd buffer>> buffer-read ] unless-eof nip ;
: read-loop ( count port accum -- )
pick over length - dup 0 > [
] if ;
M: input-port stream-read
+ check-closed
>r 0 max >fixnum r>
2dup read-step dup [
pick over length > [
[ push-all ] keep
[ read-loop ] keep
B{ } like
- ] [
- 2nip
- ] if
- ] [
- 2nip
- ] if ;
+ ] [ 2nip ] if
+ ] [ 2nip ] if ;
M: input-port stream-read-partial ( max stream -- byte-array/f )
+ check-closed
>r 0 max >fixnum r> read-step ;
-: can-write? ( len writer -- ? )
+: can-write? ( len buffer -- ? )
[ buffer-fill + ] keep buffer-capacity <= ;
: wait-to-write ( len port -- )
- tuck can-write? [ drop ] [ stream-flush ] if ;
+ tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
- 1 over wait-to-write byte>buffer ;
+ check-closed
+ 1 over wait-to-write
+ buffer>> byte>buffer ;
M: output-port stream-write
- over length over buffer-size > [
- [ buffer-size <groups> ] keep
- [ stream-write ] curry each
+ check-closed
+ over length over buffer>> buffer-size > [
+ [ buffer>> buffer-size <groups> ]
+ [ [ stream-write ] curry ] bi
+ each
] [
- over length over wait-to-write >buffer
+ [ >r length r> wait-to-write ]
+ [ buffer>> >buffer ] 2bi
] if ;
GENERIC: port-flush ( port -- )
M: output-port stream-flush ( port -- )
- dup port-flush pending-error ;
+ check-closed
+ [ port-flush ] [ pending-error ] bi ;
+
+GENERIC: close-port ( port -- )
+
+M: output-port close-port
+ [ port-flush ] [ call-next-method ] bi ;
-: close-port ( port type -- )
- output-port eq? [ dup port-flush ] when
+M: port close-port
dup cancel-io
- dup port-handle close-handle
- dup delegate [ buffer-free ] when*
- f swap set-delegate ;
+ dup handle>> close-handle
+ [ [ buffer-free ] when* f ] change-buffer drop ;
M: port dispose
- dup port-type closed eq?
- [ drop ]
- [ dup port-type >r closed over set-port-type r> close-port ]
- if ;
+ dup closed>> [ drop ] [ t >>closed close-port ] if ;
-TUPLE: server-port addr client client-addr encoding ;
+TUPLE: server-port < port addr client client-addr encoding ;
: <server-port> ( handle addr encoding -- server )
- rot
f server-port <port>
- { set-server-port-addr set-server-port-encoding set-delegate }
- server-port construct ;
+ rot server-port <port>
+ swap >>encoding
+ swap >>addr ;
-: check-server-port ( port -- )
- port-type server-port assert= ;
+: check-server-port ( port -- port )
+ dup server-port? [ "Not a server port" throw ] unless ; inline
-TUPLE: datagram-port addr packet packet-addr ;
+TUPLE: datagram-port < port addr packet packet-addr ;
: <datagram-port> ( handle addr -- datagram )
- >r f datagram-port <port> r>
- { set-delegate set-datagram-port-addr }
- datagram-port construct ;
+ swap datagram-port <port>
+ swap >>addr ;
-: check-datagram-port ( port -- )
- port-type datagram-port assert= ;
+: check-datagram-port ( port -- port )
+ check-closed
+ dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
-: check-datagram-send ( packet addrspec port -- )
- dup check-datagram-port
- datagram-port-addr [ class ] bi@ assert=
- class byte-array assert= ;
+: check-datagram-send ( packet addrspec port -- packet addrspec port )
+ check-datagram-port
+ 2dup addr>> [ class ] bi@ assert=
+ pick class byte-array assert= ;
] curry each ;
: <directory-iterator> ( path bfs? -- iterator )
- <dlist> directory-iterator construct-boa
+ <dlist> directory-iterator boa
dup path>> over push-directory ;
: next-file ( iter -- file/f )
LOG: accepted-connection NOTICE
-: with-client ( client quot -- )
+: with-client ( client addrspec quot -- )
[
- over client-stream-addr accepted-connection
+ swap accepted-connection
with-stream*
- ] curry with-disposal ; inline
+ ] 2curry with-disposal ; inline
\ with-client DEBUG add-error-logging
: accept-loop ( server quot -- )
[
- >r accept r> [ with-client ] 2curry "Client" spawn drop
+ >r accept r> [ with-client ] 3curry "Client" spawn drop
] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- )
{ [ dup AF_INET = ] [ T{ inet4 } ] }
{ [ dup AF_INET6 = ] [ T{ inet6 } ] }
{ [ dup AF_UNIX = ] [ T{ local } ] }
- { [ t ] [ f ] }
+ [ f ]
} cond nip ;
M: f parse-sockaddr nip ;
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
{ $subsection <server> }
{ $subsection accept }
-"The stream returned by " { $link accept } " holds the address specifier of the remote client:"
-{ $subsection client-stream-addr }
"Server sockets are closed by calling " { $link dispose } "."
$nl
"Address specifiers have the following interpretation with connection-oriented networking words:"
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
HELP: accept
-{ $values { "server" "a handle" } { "client" "a bidirectional stream" } }
-{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor."
-$nl
-"The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." }
+{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } }
+{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." }
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
HELP: <datagram>
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations
-sequences arrays io.encodings io.nonblocking ;
+sequences arrays io.encodings io.nonblocking accessors ;
IN: io.sockets
TUPLE: local path ;
: <local> ( path -- addrspec )
- normalize-path local construct-boa ;
+ normalize-path local boa ;
TUPLE: inet4 host port ;
C: <inet> inet
-TUPLE: client-stream addr ;
+HOOK: ((client)) io-backend ( addrspec -- client-in client-out )
-: <client-stream> ( addrspec delegate -- stream )
- { set-client-stream-addr set-delegate }
- client-stream construct ;
-
-HOOK: (client) io-backend ( addrspec -- client-in client-out )
-
-GENERIC: client* ( addrspec -- client-in client-out )
-M: array client* [ (client) 2array ] attempt-all first2 ;
-M: object client* (client) ;
+GENERIC: (client) ( addrspec -- client-in client-out )
+M: array (client) [ ((client)) 2array ] attempt-all first2 ;
+M: object (client) ((client)) ;
: <client> ( addrspec encoding -- stream )
- >r client* r> <encoder-duplex> ;
+ >r (client) r> <encoder-duplex> ;
HOOK: (server) io-backend ( addrspec -- handle )
HOOK: (accept) io-backend ( server -- addrspec handle )
-: accept ( server -- client )
- [ (accept) dup <reader&writer> ] keep
- server-port-encoding <encoder-duplex>
- <client-stream> ;
+: accept ( server -- client addrspec )
+ [ (accept) dup <reader&writer> ] [ encoding>> ] bi
+ <encoder-duplex> swap ;
HOOK: <datagram> io-backend ( addrspec -- datagram )
HOOK: host-name io-backend ( -- string )
-M: inet client*
- dup inet-host swap inet-port f resolve-host
- dup empty? [ "Host name lookup failed" throw ] when
- client* ;
+M: inet (client)
+ [ host>> ] [ port>> ] bi f resolve-host
+ [ empty? [ "Host name lookup failed" throw ] when ]
+ [ (client) ]
+ bi ;
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;\r
\r
ARTICLE: "io.timeouts" "I/O timeout protocol"\r
-"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."\r
+"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."\r
{ $subsection timeout }\r
{ $subsection set-timeout }\r
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."\r
{ $subsection timed-out }\r
"A combinator to be used in operations which can time out:"\r
{ $subsection with-timeout }\r
-{ $see-also "stream-protocol" "io.launcher" } ;\r
+{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;\r
\r
ABOUT: "io.timeouts"\r
: io-task-fd port>> handle>> ;
: <io-task> ( port continuation/f class -- task )
- >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
- r> construct-delegate ; inline
+ new
+ swap [ 1vector ] [ V{ } clone ] if* >>callbacks
+ swap >>port ; inline
-TUPLE: input-task ;
+TUPLE: input-task < io-task ;
-: <input-task> ( port continuation class -- task )
- >r input-task <io-task> r> construct-delegate ; inline
-
-TUPLE: output-task ;
-
-: <output-task> ( port continuation class -- task )
- >r output-task <io-task> r> construct-delegate ; inline
+TUPLE: output-task < io-task ;
GENERIC: do-io-task ( task -- ? )
GENERIC: io-task-container ( mx task -- hashtable )
M: output-task io-task-container drop writes>> ;
-: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
-
-: construct-mx ( class -- obj ) <mx> swap construct-delegate ;
+: new-mx ( class -- obj )
+ new
+ H{ } clone >>reads
+ H{ } clone >>writes ; inline
GENERIC: register-io-task ( task mx -- )
GENERIC: unregister-io-task ( task mx -- )
! Readers
: reader-eof ( reader -- )
- dup buffer-empty? [ t >>eof? ] when drop ;
+ dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n )
- [ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ;
+ [ handle>> ]
+ [ buffer>> buffer-end ]
+ [ buffer>> buffer-capacity ] tri read ;
: refill ( port -- ? )
#! Return f if there is a recoverable error
- dup buffer-empty? [
+ dup buffer>> buffer-empty? [
dup (refill) dup 0 >= [
- swap n>buffer t
+ swap buffer>> n>buffer t
] [
drop defer-error
] if
drop t
] if ;
-TUPLE: read-task ;
+TUPLE: read-task < input-task ;
: <read-task> ( port continuation -- task )
- read-task <input-task> ;
+ read-task <io-task> ;
M: read-task do-io-task
io-task-port dup refill
! Writers
: write-step ( port -- ? )
- dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write
- dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ;
+ dup
+ [ handle>> ]
+ [ buffer>> buffer@ ]
+ [ buffer>> buffer-length ] tri
+ write dup 0 >=
+ [ swap buffer>> buffer-consume f ]
+ [ drop defer-error ] if ;
-TUPLE: write-task ;
+TUPLE: write-task < output-task ;
: <write-task> ( port continuation -- task )
- write-task <output-task> ;
+ write-task <io-task> ;
M: write-task do-io-task
- io-task-port dup [ buffer-empty? ] [ port-error ] bi or
- [ 0 swap buffer-reset t ] [ write-step ] if ;
+ io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
+ [ 0 swap buffer>> buffer-reset t ] [ write-step ] if ;
: add-write-io-task ( port continuation -- )
- over port-handle mx get-global mx-writes at*
+ over handle>> mx get-global writes>> at*
[ io-task-callbacks push drop ]
[ drop <write-task> add-io-task ] if ;
: (wait-to-write) ( port -- )
[ add-write-io-task ] with-port-continuation drop ;
-M: port port-flush ( port -- )
- dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
+M: output-port port-flush ( port -- )
+ dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
2 <writer> ;
! mx io-task for embedding an fd-based mx inside another mx
-TUPLE: mx-port mx ;
+TUPLE: mx-port < port mx ;
: <mx-port> ( mx -- port )
- dup fd>> f mx-port <port>
- { set-mx-port-mx set-delegate } mx-port construct ;
+ dup fd>> mx-port <port> swap >>mx ;
-TUPLE: mx-task ;
+TUPLE: mx-task < io-task ;
: <mx-task> ( port -- task )
f mx-task <io-task> ;
: multiplexer-error ( n -- )
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
+
+: ?flag ( n mask symbol -- n )
+ pick rot bitand 0 > [ , ] [ drop ] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.bsd
-USING: io.backend io.unix.backend io.unix.select
-namespaces system ;
+USING: namespaces system kernel accessors assocs continuations
+unix
+io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ;
M: bsd init-io ( -- )
- <select-mx> mx set-global ;
+ <select-mx> mx set-global
+ <kqueue-mx> kqueue-mx set-global
+ kqueue-mx get-global <mx-port> <mx-task>
+ dup io-task-fd
+ [ mx get-global reads>> set-at ]
+ [ mx get-global writes>> set-at ] 2bi ;
+
+M: bsd (monitor) ( path recursive? mailbox -- )
+ swap [ "Recursive kqueue monitors not supported" throw ] when
+ <vnode-monitor> ;
namespaces structs ;
IN: io.unix.epoll
-TUPLE: epoll-mx events ;
+TUPLE: epoll-mx < mx events ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
256 ; inline
: <epoll-mx> ( -- mx )
- epoll-mx construct-mx
+ epoll-mx new-mx
max-events epoll_create dup io-error over set-mx-fd
max-events "epoll-event" <c-array> over set-epoll-mx-events ;
epoll_ctl io-error ;
M: epoll-mx register-io-task ( task mx -- )
- 2dup EPOLL_CTL_ADD do-epoll-ctl
- delegate register-io-task ;
+ [ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ;
M: epoll-mx unregister-io-task ( task mx -- )
- 2dup delegate unregister-io-task
- EPOLL_CTL_DEL do-epoll-ctl ;
+ [ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ;
: wait-event ( mx timeout -- n )
>r { mx-fd epoll-mx-events } get-slots max-events
M: unix copy-file ( from to -- )
[ normalize-path ] bi@
[ (copy-file) ]
- [ swap file-info file-info-permissions chmod io-error ]
+ [ swap file-info permissions>> chmod io-error ]
2bi ;
: stat>type ( stat -- type )
- stat-st_mode {
- { [ dup S_ISREG ] [ +regular-file+ ] }
- { [ dup S_ISDIR ] [ +directory+ ] }
- { [ dup S_ISCHR ] [ +character-device+ ] }
- { [ dup S_ISBLK ] [ +block-device+ ] }
- { [ dup S_ISFIFO ] [ +fifo+ ] }
- { [ dup S_ISLNK ] [ +symbolic-link+ ] }
- { [ dup S_ISSOCK ] [ +socket+ ] }
- { [ t ] [ +unknown+ ] }
- } cond nip ;
+ stat-st_mode S_IFMT bitand {
+ { S_IFREG [ +regular-file+ ] }
+ { S_IFDIR [ +directory+ ] }
+ { S_IFCHR [ +character-device+ ] }
+ { S_IFBLK [ +block-device+ ] }
+ { S_IFIFO [ +fifo+ ] }
+ { S_IFLNK [ +symbolic-link+ ] }
+ { S_IFSOCK [ +socket+ ] }
+ [ drop +unknown+ ]
+ } case ;
: stat>file-info ( stat -- info )
{
[ stat-st_mode ]
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
M: unix file-info ( path -- info )
normalize-path stat* stat>file-info ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel io.nonblocking io.unix.backend
-sequences assocs unix unix.time unix.kqueue unix.process math namespaces
-combinators threads vectors io.launcher
-io.unix.launcher ;
+USING: alien.c-types kernel math math.bitfields namespaces
+locals accessors combinators threads vectors hashtables
+sequences assocs continuations sets
+unix unix.time unix.kqueue unix.process
+io.nonblocking io.unix.backend io.launcher io.unix.launcher
+io.monitors ;
IN: io.unix.kqueue
-TUPLE: kqueue-mx events ;
+TUPLE: kqueue-mx < mx events monitors ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
256 ; inline
: <kqueue-mx> ( -- mx )
- kqueue-mx construct-mx
- kqueue dup io-error over set-mx-fd
- max-events "kevent" <c-array> over set-kqueue-mx-events ;
+ kqueue-mx new-mx
+ H{ } clone >>monitors
+ kqueue dup io-error >>fd
+ max-events "kevent" <c-array> >>events ;
GENERIC: io-task-filter ( task -- n )
M: output-task io-task-filter drop EVFILT_WRITE ;
+GENERIC: io-task-fflags ( task -- n )
+
+M: io-task io-task-fflags drop 0 ;
+
: make-kevent ( task flags -- event )
"kevent" <c-object>
tuck set-kevent-flags
over io-task-fd over set-kevent-ident
+ over io-task-fflags over set-kevent-fflags
swap io-task-filter over set-kevent-filter ;
: register-kevent ( kevent mx -- )
- mx-fd swap 1 f 0 f kevent
+ fd>> swap 1 f 0 f kevent
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
M: kqueue-mx register-io-task ( task mx -- )
- over EV_ADD make-kevent over register-kevent
- delegate register-io-task ;
+ [ >r EV_ADD make-kevent r> register-kevent ]
+ [ call-next-method ]
+ 2bi ;
M: kqueue-mx unregister-io-task ( task mx -- )
- 2dup delegate unregister-io-task
- swap EV_DELETE make-kevent swap register-kevent ;
+ [ call-next-method ]
+ [ >r EV_DELETE make-kevent r> register-kevent ]
+ 2bi ;
: wait-kevent ( mx timespec -- n )
- >r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent
+ >r [ fd>> f 0 ] keep events>> max-events r> kevent
dup multiplexer-error ;
-: kevent-read-task ( mx fd -- )
- over mx-reads at handle-io-task ;
+:: kevent-read-task ( mx fd kevent -- )
+ mx fd mx reads>> at handle-io-task ;
-: kevent-write-task ( mx fd -- )
- over mx-reads at handle-io-task ;
+:: kevent-write-task ( mx fd kevent -- )
+ mx fd mx writes>> at handle-io-task ;
-: kevent-proc-task ( pid -- )
- dup wait-for-pid swap find-process
+:: kevent-proc-task ( mx pid kevent -- )
+ pid wait-for-pid
+ pid find-process
dup [ swap notify-exit ] [ 2drop ] if ;
+: parse-action ( mask -- changed )
+ [
+ NOTE_DELETE +remove-file+ ?flag
+ NOTE_WRITE +modify-file+ ?flag
+ NOTE_EXTEND +modify-file+ ?flag
+ NOTE_ATTRIB +modify-file+ ?flag
+ NOTE_RENAME +rename-file+ ?flag
+ NOTE_REVOKE +remove-file+ ?flag
+ drop
+ ] { } make prune ;
+
+:: kevent-vnode-task ( mx kevent fd -- )
+ ""
+ kevent kevent-fflags parse-action
+ fd mx monitors>> at queue-change ;
+
: handle-kevent ( mx kevent -- )
- dup kevent-ident swap kevent-filter {
+ [ ] [ kevent-ident ] [ kevent-filter ] tri {
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
- { [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] }
+ { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
+ { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
} cond ;
: handle-kevents ( mx n -- )
- [ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
+ [ over events>> kevent-nth handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( ms mx -- )
swap dup [ make-timespec ] when
dupd wait-kevent handle-kevents ;
+! Procs
: make-proc-kevent ( pid -- kevent )
"kevent" <c-object>
tuck set-kevent-ident
EVFILT_PROC over set-kevent-filter
NOTE_EXIT over set-kevent-fflags ;
-: add-pid-task ( pid mx -- )
+: register-pid-task ( pid mx -- )
swap make-proc-kevent swap register-kevent ;
+
+! VNodes
+TUPLE: vnode-monitor < monitor fd ;
+
+: vnode-fflags ( -- n )
+ {
+ NOTE_DELETE
+ NOTE_WRITE
+ NOTE_EXTEND
+ NOTE_ATTRIB
+ NOTE_LINK
+ NOTE_RENAME
+ NOTE_REVOKE
+ } flags ;
+
+: make-vnode-kevent ( fd flags -- kevent )
+ "kevent" <c-object>
+ tuck set-kevent-flags
+ tuck set-kevent-ident
+ EVFILT_VNODE over set-kevent-filter
+ vnode-fflags over set-kevent-fflags ;
+
+: register-monitor ( monitor mx -- )
+ >r dup fd>> r>
+ [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
+ [ monitors>> set-at ] 3bi ;
+
+: unregister-monitor ( monitor mx -- )
+ >r fd>> r>
+ [ monitors>> delete-at ]
+ [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
+
+: <vnode-monitor> ( path mailbox -- monitor )
+ >r [ O_RDONLY 0 open dup io-error ] keep r>
+ vnode-monitor new-monitor swap >>fd
+ [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
+
+M: vnode-monitor dispose
+ [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
{ [ pick string? ] [ redirect-file ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick +inherit+ eq? ] [ redirect-closed ] }
- { [ t ] [ redirect-stream ] }
+ [ redirect-stream ]
} cond ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.backend io.monitors io.monitors.private
-io.files io.buffers io.nonblocking io.timeouts io.unix.backend
-io.unix.select io.unix.launcher unix.linux.inotify assocs
-namespaces threads continuations init math alien.c-types alien
-vocabs.loader accessors system ;
+USING: kernel io.backend io.monitors io.unix.backend
+io.unix.select io.unix.linux.monitors system namespaces ;
IN: io.unix.linux
-TUPLE: linux-monitor ;
-
-: <linux-monitor> ( wd -- monitor )
- linux-monitor construct-simple-monitor ;
-
-TUPLE: inotify watches ;
-
-: watches ( -- assoc ) inotify get-global watches>> ;
-
-: wd>monitor ( wd -- monitor ) watches at ;
-
-: <inotify> ( -- port/f )
- H{ } clone
- inotify_init dup 0 < [ 2drop f ] [
- inotify <buffered-port>
- { set-inotify-watches set-delegate } inotify construct
- ] if ;
-
-: inotify-fd inotify get-global handle>> ;
-
-: (add-watch) ( path mask -- wd )
- inotify-fd -rot inotify_add_watch dup io-error ;
-
-: check-existing ( wd -- )
- watches key? [
- "Cannot open multiple monitors for the same file" throw
- ] when ;
-
-: add-watch ( path mask -- monitor )
- (add-watch) dup check-existing
- [ <linux-monitor> dup ] keep watches set-at ;
-
-: remove-watch ( monitor -- )
- dup simple-monitor-handle watches delete-at
- simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ;
-
-: check-inotify
- inotify get [
- "inotify is not supported by this Linux release" throw
- ] unless ;
-
-M: linux <monitor> ( path recursive? -- monitor )
- check-inotify
- drop IN_CHANGE_EVENTS add-watch ;
-
-M: linux-monitor dispose ( monitor -- )
- dup delegate dispose remove-watch ;
-
-: ?flag ( n mask symbol -- n )
- pick rot bitand 0 > [ , ] [ drop ] if ;
-
-: parse-action ( mask -- changed )
- [
- IN_CREATE +add-file+ ?flag
- IN_DELETE +remove-file+ ?flag
- IN_DELETE_SELF +remove-file+ ?flag
- IN_MODIFY +modify-file+ ?flag
- IN_ATTRIB +modify-file+ ?flag
- IN_MOVED_FROM +rename-file+ ?flag
- IN_MOVED_TO +rename-file+ ?flag
- IN_MOVE_SELF +rename-file+ ?flag
- drop
- ] { } make ;
-
-: parse-file-notify ( buffer -- changed path )
- { inotify-event-name inotify-event-mask } get-slots
- parse-action swap alien>char-string ;
-
-: events-exhausted? ( i buffer -- ? )
- fill>> >= ;
-
-: inotify-event@ ( i buffer -- alien )
- ptr>> <displaced-alien> ;
-
-: next-event ( i buffer -- i buffer )
- 2dup inotify-event@
- inotify-event-len "inotify-event" heap-size +
- swap >r + r> ;
-
-: parse-file-notifications ( i buffer -- )
- 2dup events-exhausted? [ 2drop ] [
- 2dup inotify-event@ dup inotify-event-wd wd>monitor [
- monitor-queue [
- parse-file-notify changed-file
- ] bind
- ] keep notify-callback
- next-event parse-file-notifications
- ] if ;
-
-: read-notifications ( port -- )
- dup refill drop
- 0 over parse-file-notifications
- 0 swap buffer-reset ;
-
-TUPLE: inotify-task ;
-
-: <inotify-task> ( port -- task )
- f inotify-task <input-task> ;
-
-: init-inotify ( mx -- )
- <inotify> dup [
- dup inotify set-global
- <inotify-task> swap register-io-task
- ] [
- 2drop
- ] if ;
-
-M: inotify-task do-io-task ( task -- )
- io-task-port read-notifications f ;
-
M: linux init-io ( -- )
- <select-mx>
- [ mx set-global ]
- [ init-inotify ] bi ;
+ <select-mx> mx set-global ;
linux set-io-backend
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io.backend io.monitors io.monitors.recursive
+io.files io.buffers io.monitors io.nonblocking io.timeouts
+io.unix.backend io.unix.select unix.linux.inotify assocs
+namespaces threads continuations init math math.bitfields sets
+alien.c-types alien vocabs.loader accessors system hashtables ;
+IN: io.unix.linux.monitors
+
+TUPLE: linux-monitor < monitor wd ;
+
+: <linux-monitor> ( wd path mailbox -- monitor )
+ linux-monitor new-monitor
+ swap >>wd ;
+
+SYMBOL: watches
+
+SYMBOL: inotify
+
+: wd>monitor ( wd -- monitor ) watches get at ;
+
+: <inotify> ( -- port/f )
+ inotify_init dup 0 < [ drop f ] [ <reader> ] if ;
+
+: inotify-fd inotify get handle>> ;
+
+: check-existing ( wd -- )
+ watches get key? [
+ "Cannot open multiple monitors for the same file" throw
+ ] when ;
+
+: (add-watch) ( path mask -- wd )
+ inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
+
+: add-watch ( path mask mailbox -- monitor )
+ >r
+ >r (normalize-path) r>
+ [ (add-watch) ] [ drop ] 2bi r>
+ <linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
+
+: check-inotify
+ inotify get [
+ "Calling <monitor> outside with-monitors" throw
+ ] unless ;
+
+M: linux (monitor) ( path recursive? mailbox -- monitor )
+ swap [
+ <recursive-monitor>
+ ] [
+ check-inotify
+ IN_CHANGE_EVENTS swap add-watch
+ ] if ;
+
+M: linux-monitor dispose ( monitor -- )
+ [ wd>> watches get delete-at ]
+ [ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ;
+
+: ignore-flags? ( mask -- ? )
+ {
+ IN_DELETE_SELF
+ IN_MOVE_SELF
+ IN_UNMOUNT
+ IN_Q_OVERFLOW
+ IN_IGNORED
+ } flags bitand 0 > ;
+
+: parse-action ( mask -- changed )
+ [
+ IN_CREATE +add-file+ ?flag
+ IN_DELETE +remove-file+ ?flag
+ IN_MODIFY +modify-file+ ?flag
+ IN_ATTRIB +modify-file+ ?flag
+ IN_MOVED_FROM +rename-file-old+ ?flag
+ IN_MOVED_TO +rename-file-new+ ?flag
+ drop
+ ] { } make prune ;
+
+: parse-file-notify ( buffer -- path changed )
+ dup inotify-event-mask ignore-flags? [
+ drop f f
+ ] [
+ [ inotify-event-name alien>char-string ]
+ [ inotify-event-mask parse-action ] bi
+ ] if ;
+
+: events-exhausted? ( i buffer -- ? )
+ fill>> >= ;
+
+: inotify-event@ ( i buffer -- alien )
+ ptr>> <displaced-alien> ;
+
+: next-event ( i buffer -- i buffer )
+ 2dup inotify-event@
+ inotify-event-len "inotify-event" heap-size +
+ swap >r + r> ;
+
+: parse-file-notifications ( i buffer -- )
+ 2dup events-exhausted? [ 2drop ] [
+ 2dup inotify-event@ dup inotify-event-wd wd>monitor
+ >r parse-file-notify r> queue-change
+ next-event parse-file-notifications
+ ] if ;
+
+: inotify-read-loop ( port -- )
+ dup wait-to-read1
+ 0 over buffer>> parse-file-notifications
+ 0 over buffer>> buffer-reset
+ inotify-read-loop ;
+
+: inotify-read-thread ( port -- )
+ [ inotify-read-loop ] curry ignore-errors ;
+
+M: linux init-monitors
+ H{ } clone watches set
+ <inotify> [
+ [ inotify set ]
+ [
+ [ inotify-read-thread ] curry
+ "Linux monitor thread" spawn drop
+ ] bi
+ ] [
+ "Linux kernel version is too old" throw
+ ] if* ;
+
+M: linux dispose-monitors
+ inotify get dispose ;
-USING: io.unix.bsd io.backend io.monitors io.monitors.private
-continuations kernel core-foundation.fsevents sequences
-namespaces arrays system ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents
+continuations kernel sequences namespaces arrays system locals
+accessors ;
IN: io.unix.macosx
-macosx set-io-backend
-
-TUPLE: macosx-monitor ;
+TUPLE: macosx-monitor < monitor handle ;
: enqueue-notifications ( triples monitor -- )
- tuck monitor-queue
- [ [ first { +modify-file+ } swap changed-file ] each ] bind
- notify-callback ;
+ [
+ >r first { +modify-file+ } r> queue-change
+ ] curry each ;
-M: macosx <monitor>
- drop
- f macosx-monitor construct-simple-monitor
+M:: macosx (monitor) ( path recursive? mailbox -- monitor )
+ path mailbox macosx-monitor new-monitor
dup [ enqueue-notifications ] curry
- rot 1array 0 0 <event-stream>
- over set-simple-monitor-handle ;
+ path 1array 0 0 <event-stream> >>handle ;
M: macosx-monitor dispose
- dup simple-monitor-handle dispose delegate dispose ;
+ handle>> dispose ;
+
+macosx set-io-backend
M: unix <mapped-file> ( path length -- obj )
swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
- r> mmap-open f mapped-file construct-boa ;
+ r> mmap-open f mapped-file boa ;
M: unix close-mapped-file ( mmap -- )
[ mapped-file-address ] keep
accessors ;
IN: io.unix.select
-TUPLE: select-mx read-fdset write-fdset ;
+TUPLE: select-mx < mx read-fdset write-fdset ;
! Factor's bit-arrays are an array of bytes, OS X expects
! FD_SET to be an array of cells, so we have to account for
little-endian? [ BIN: 11000 bitxor ] unless ; inline
: <select-mx> ( -- mx )
- select-mx construct-mx
- FD_SETSIZE 8 * <bit-array> >>read-fdset
- FD_SETSIZE 8 * <bit-array> >>write-fdset ;
+ select-mx new-mx
+ FD_SETSIZE 8 * <bit-array> >>read-fdset
+ FD_SETSIZE 8 * <bit-array> >>write-fdset ;
: clear-nth ( n seq -- ? )
[ nth ] [ f -rot set-nth ] 2bi ;
[ handle-fd ] 2curry assoc-each ;
: init-fdset ( tasks fdset -- )
- ! dup clear-bits
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
: read-fdset/tasks
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
: init-fdsets ( mx -- nfds read write except )
- [ num-fds ] keep
- [ read-fdset/tasks tuck init-fdset ] keep
- write-fdset/tasks tuck init-fdset
+ [ num-fds ]
+ [ read-fdset/tasks tuck init-fdset ]
+ [ write-fdset/tasks tuck init-fdset ] tri
f ;
M: select-mx wait-for-events ( ms mx -- )
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend io.files io.files.private system ;
+combinators io.backend io.files io.files.private system accessors ;
IN: io.unix.sockets
: pending-init-error ( port -- )
: init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE sockopt ;
-TUPLE: connect-task ;
+TUPLE: connect-task < output-task ;
: <connect-task> ( port continuation -- task )
- connect-task <output-task> ;
+ connect-task <io-task> ;
M: connect-task do-io-task
io-task-port dup port-handle f 0 write
: wait-to-connect ( port -- )
[ <connect-task> add-io-task ] with-port-continuation drop ;
-M: unix (client) ( addrspec -- client-in client-out )
+M: unix ((client)) ( addrspec -- client-in client-out )
dup make-sockaddr/size >r >r
protocol-family SOCK_STREAM socket-fd
dup r> r> connect
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
-TUPLE: accept-task ;
+TUPLE: accept-task < input-task ;
: <accept-task> ( port continuation -- task )
- accept-task <input-task> ;
+ accept-task <io-task> ;
: accept-sockaddr ( port -- fd sockaddr )
dup port-handle swap server-port-addr sockaddr-type
M: unix (accept) ( server -- addrspec handle )
#! Wait for a client connection.
- dup check-server-port
- dup wait-to-accept
- dup pending-error
- dup server-port-client-addr
- swap server-port-client ;
+ check-server-port
+ [ wait-to-accept ]
+ [ pending-error ]
+ [ [ client-addr>> ] [ client>> ] bi ] tri ;
! Datagram sockets - UDP and Unix domain
M: unix <datagram>
rot head
] if ;
-TUPLE: receive-task ;
+TUPLE: receive-task < input-task ;
: <receive-task> ( stream continuation -- task )
- receive-task <input-task> ;
+ receive-task <io-task> ;
M: receive-task do-io-task
io-task-port
[ <receive-task> add-io-task ] with-port-continuation drop ;
M: unix receive ( datagram -- packet addrspec )
- dup check-datagram-port
- dup wait-receive
- dup pending-error
- dup datagram-port-packet
- swap datagram-port-packet-addr ;
+ check-datagram-port
+ [ wait-receive ]
+ [ pending-error ]
+ [ [ packet>> ] [ packet-addr>> ] bi ] tri ;
: do-send ( socket data sockaddr len -- n )
>r >r dup length 0 r> r> sendto ;
-TUPLE: send-task packet sockaddr len ;
+TUPLE: send-task < output-task packet sockaddr len ;
: <send-task> ( packet sockaddr len stream continuation -- task )
- send-task <output-task> [
+ send-task <io-task> [
{
set-send-task-packet
set-send-task-sockaddr
2drop 2drop ;
M: unix send ( packet addrspec datagram -- )
- 3dup check-datagram-send
+ check-datagram-send
[ >r make-sockaddr/size r> wait-send ] keep
pending-error ;
socket-server <local>
ascii <server> [
- accept [
+ accept drop [
"Hello world" print flush
readln "XYZ" = "FOO" "BAR" ? print flush
] with-stream
[ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object> [
[ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
stdout-pipe stdin-pipe ;
: default-CreateProcess-args ( -- obj )
- CreateProcess-args construct-empty
+ CreateProcess-args new
"STARTUPINFO" <c-object>
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
PAGE_READWRITE SEC_COMMIT bitor
FILE_MAP_ALL_ACCESS mmap-open
-rot 2array
- f \ mapped-file construct-boa
+ f \ mapped-file boa
] with-destructors ;
M: windows close-mapped-file ( mapped-file -- )
io.windows libc kernel math namespaces sequences
threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii
-combinators.lib system ;
+combinators.lib system accessors ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ 2drop t ] }
- { [ dup eof? ] [ drop t swap set-port-eof? f ] }
- { [ t ] [ (win32-error-string) throw ] }
+ { [ dup eof? ] [ drop t >>eof drop f ] }
+ [ (win32-error-string) throw ]
} cond
] [
drop t
] if ;
: get-overlapped-result ( overlapped port -- bytes-transferred )
- dup port-handle win32-file-handle rot 0 <uint>
+ dup handle>> handle>> rot 0 <uint>
[ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ;
: save-callback ( overlapped port -- )
] [
dup eof? [
drop lookup-callback
- dup io-callback-port t swap set-port-eof?
+ dup port>> t >>eof drop
] [
(win32-error-string) swap lookup-callback
- [ io-callback-port set-port-error ] keep
- ] if io-callback-thread resume f
+ [ port>> set-port-error ] keep
+ ] if thread>> resume f
] if
] [
lookup-callback
handle-overlapped [ 0 drain-overlapped ] unless ;
M: winnt cancel-io
- port-handle win32-file-handle CancelIo drop ;
+ handle>> handle>> CancelIo drop ;
M: winnt io-multiplex ( ms -- )
drain-overlapped ;
kernel libc math threads windows windows.kernel32 system
alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs namespaces
-io.files.private ;
+io.files.private accessors ;
IN: io.windows.nt.files
M: winnt cwd
{ [ dup length 2 = ] [ dup second CHAR: : = ] } && nip ] [
t
] }
- { [ t ] [ f ] }
+ [ f ]
} cond nip ;
ERROR: not-absolute-path ;
dup pending-error
tuck get-overlapped-result
dup pick update-file-ptr
- swap buffer-consume ;
+ swap buffer>> buffer-consume ;
: (flush-output) ( port -- )
dup make-FileArgs
>r FileArgs-lpOverlapped r>
[ save-callback ] 2keep
[ finish-flush ] keep
- dup buffer-empty? [ drop ] [ (flush-output) ] if
+ dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
] [
2drop
] if ;
[ [ (flush-output) ] with-timeout ] with-destructors ;
M: port port-flush
- dup buffer-empty? [ dup flush-output ] unless drop ;
+ dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
: finish-read ( overlapped port -- )
dup pending-error
tuck get-overlapped-result dup zero? [
- drop t swap set-port-eof?
+ drop t >>eof drop
] [
- dup pick n>buffer
+ dup pick buffer>> n>buffer
swap update-file-ptr
] if ;
{ [ pick +inherit+ eq? ] [ redirect-inherit ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick string? ] [ redirect-file ] }
- { [ t ] [ redirect-stream ] }
+ [ redirect-stream ]
} cond ;
: default-stdout ( args -- handle )
--- /dev/null
+IN: io.windows.nt.monitors.tests\r
+USING: io.windows.nt.monitors tools.test ;\r
+\r
+\ fill-queue-thread must-infer\r
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types destructors io.windows
-io.windows.nt.backend kernel math windows windows.kernel32
-windows.types libc assocs alien namespaces continuations
-io.monitors io.monitors.private io.nonblocking io.buffers
-io.files io.timeouts io sequences hashtables sorting arrays
-combinators math.bitfields strings system ;
+USING: alien alien.c-types libc destructors locals
+kernel math assocs namespaces continuations sequences hashtables
+sorting arrays combinators math.bitfields strings system
+accessors threads
+io.backend io.windows io.windows.nt.backend io.monitors
+io.nonblocking io.buffers io.files io.timeouts io
+windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
+ normalize-path
FILE_LIST_DIRECTORY
share-mode
f
dup add-completion
f <win32-file> ;
-TUPLE: win32-monitor path recursive? ;
+TUPLE: win32-monitor-port < input-port recursive ;
-: <win32-monitor> ( path recursive? port -- monitor )
- (monitor) {
- set-win32-monitor-path
- set-win32-monitor-recursive?
- set-delegate
- } win32-monitor construct ;
+TUPLE: win32-monitor < monitor port ;
-M: winnt <monitor> ( path recursive? -- monitor )
- [
- over open-directory win32-monitor <buffered-port>
- <win32-monitor>
- ] with-destructors ;
-
-: begin-reading-changes ( monitor -- overlapped )
- dup port-handle win32-file-handle
- over buffer-ptr
- pick buffer-size
- roll win32-monitor-recursive? 1 0 ?
+: begin-reading-changes ( port -- overlapped )
+ {
+ [ handle>> handle>> ]
+ [ buffer>> ptr>> ]
+ [ buffer>> size>> ]
+ [ recursive>> 1 0 ? ]
+ } cleave
FILE_NOTIFY_CHANGE_ALL
0 <uint>
(make-overlapped)
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
-: read-changes ( monitor -- bytes )
+: read-changes ( port -- bytes )
[
- [
- dup begin-reading-changes
- swap [ save-callback ] 2keep
- dup check-monitor ! we may have closed it...
- get-overlapped-result
- ] with-timeout
+ dup begin-reading-changes
+ swap [ save-callback ] 2keep
+ check-closed ! we may have closed it...
+ dup eof>> [ "EOF??" throw ] when
+ get-overlapped-result
] with-destructors ;
: parse-action ( action -- changed )
{
- { [ dup FILE_ACTION_ADDED = ] [ +add-file+ ] }
- { [ dup FILE_ACTION_REMOVED = ] [ +remove-file+ ] }
- { [ dup FILE_ACTION_MODIFIED = ] [ +modify-file+ ] }
- { [ dup FILE_ACTION_RENAMED_OLD_NAME = ] [ +rename-file+ ] }
- { [ dup FILE_ACTION_RENAMED_NEW_NAME = ] [ +rename-file+ ] }
- { [ t ] [ +modify-file+ ] }
- } cond nip ;
+ { FILE_ACTION_ADDED [ +add-file+ ] }
+ { FILE_ACTION_REMOVED [ +remove-file+ ] }
+ { FILE_ACTION_MODIFIED [ +modify-file+ ] }
+ { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] }
+ { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] }
+ [ drop +modify-file+ ]
+ } case 1array ;
: memory>u16-string ( alien len -- string )
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
-: parse-file-notify ( buffer -- changed path )
- {
- FILE_NOTIFY_INFORMATION-FileName
- FILE_NOTIFY_INFORMATION-FileNameLength
- FILE_NOTIFY_INFORMATION-Action
- } get-slots parse-action 1array -rot memory>u16-string ;
-
-: (changed-files) ( buffer -- )
- dup parse-file-notify changed-file
- dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
- [ 2drop ] [ swap <displaced-alien> (changed-files) ] if ;
-
-M: win32-monitor fill-queue ( monitor -- )
- dup buffer-ptr over read-changes
- [ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc
- swap set-monitor-queue ;
+: parse-notify-record ( buffer -- path changed )
+ [
+ [ FILE_NOTIFY_INFORMATION-FileName ]
+ [ FILE_NOTIFY_INFORMATION-FileNameLength ]
+ bi memory>u16-string
+ ]
+ [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
+
+: (file-notify-records) ( buffer -- buffer )
+ dup ,
+ dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
+ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
+ (file-notify-records)
+ ] unless ;
+
+: file-notify-records ( buffer -- seq )
+ [ (file-notify-records) drop ] { } make ;
+
+: parse-notify-records ( monitor buffer -- )
+ file-notify-records
+ [ parse-notify-record rot queue-change ] with each ;
+
+: fill-queue ( monitor -- )
+ dup port>> check-closed
+ [ buffer>> ptr>> ] [ read-changes zero? ] bi
+ [ 2dup parse-notify-records ] unless
+ 2drop ;
+
+: (fill-queue-thread) ( monitor -- )
+ dup fill-queue (fill-queue-thread) ;
+
+: fill-queue-thread ( monitor -- )
+ [ dup fill-queue (fill-queue-thread) ]
+ [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ;
+
+M:: winnt (monitor) ( path recursive? mailbox -- monitor )
+ [
+ path mailbox win32-monitor new-monitor
+ path open-directory \ win32-monitor-port <buffered-port>
+ recursive? >>recursive
+ >>port
+ dup [ fill-queue-thread ] curry
+ "Windows monitor thread" spawn drop
+ ] with-destructors ;
+
+M: win32-monitor dispose
+ port>> dispose ;
[
>r over >r create-named-pipe dup close-later
r> r> open-other-end dup close-later
- pipe construct-boa
+ pipe boa
] with-destructors ;
: close-pipe ( pipe -- )
continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
-threads classes.tuple.lib system ;
+threads classes.tuple.lib system accessors ;
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
2dup save-callback
get-overlapped-result drop ;
-M: winnt (client) ( addrspec -- client-in client-out )
+M: winnt ((client)) ( addrspec -- client-in client-out )
[
- \ ConnectEx-args construct-empty
+ \ ConnectEx-args new
over make-sockaddr/size pick init-connect
over tcp-socket over set-ConnectEx-args-s*
dup ConnectEx-args-s* add-completion
M: winnt (accept) ( server -- addrspec handle )
[
[
- dup check-server-port
- \ AcceptEx-args construct-empty
+ check-server-port
+ \ AcceptEx-args new
[ init-accept ] keep
[ ((accept)) ] keep
[ accept-continuation ] keep
: init-WSARecvFrom ( datagram WSARecvFrom -- )
[ set-WSARecvFrom-args-port ] 2keep
[
- >r delegate port-handle delegate win32-file-handle r>
+ >r handle>> handle>> r>
set-WSARecvFrom-args-s*
] 2keep [
>r datagram-port-addr sockaddr-type heap-size r>
M: winnt receive ( datagram -- packet addrspec )
[
- dup check-datagram-port
- \ WSARecvFrom-args construct-empty
+ check-datagram-port
+ \ WSARecvFrom-args new
[ init-WSARecvFrom ] keep
[ call-WSARecvFrom ] keep
[ WSARecvFrom-continuation ] keep
M: winnt send ( packet addrspec datagram -- )
[
- 3dup check-datagram-send
- \ WSASendTo-args construct-empty
+ check-datagram-send
+ \ WSASendTo-args new
[ init-WSASendTo ] keep
[ call-WSASendTo ] keep
[ WSASendTo-continuation ] keep
io.sockets.impl windows.errors strings io.streams.duplex
kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
-continuations math.bitfields system ;
+continuations math.bitfields system accessors ;
IN: io.windows
M: windows destruct-handle CloseHandle drop ;
] when drop ;
: open-append ( path -- handle length )
- [ dup file-info file-info-size ] [ drop 0 ] recover
+ [ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
: make-FileArgs ( port -- <FileArgs> )
[ port-handle win32-file-handle ] keep
- [ delegate ] keep
+ [ buffer>> ] keep
[
- buffer-length
+ buffer>> buffer-length
"DWORD" <c-object>
] keep FileArgs-overlapped <FileArgs> ;
HOOK: WSASocket-flags io-backend ( -- DWORD )
-TUPLE: win32-socket ;
+TUPLE: win32-socket < win32-file ;
: <win32-socket> ( handle -- win32-socket )
- f <win32-file>
- \ win32-socket construct-delegate ;
+ f win32-file boa ;
: open-socket ( family type -- socket )
0 f 0 WSASocket-flags WSASocket dup socket-error ;
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar io io.sockets kernel match namespaces
-sequences splitting strings continuations threads ascii
-io.encodings.utf8 ;
+USING: arrays calendar combinators channels concurrency.messaging fry io
+ io.encodings.8-bit io.sockets kernel math namespaces sequences
+ sequences.lib splitting strings threads
+ continuations classes.tuple ascii accessors ;
IN: irc
+! utils
+: split-at-first ( seq separators -- before after )
+ dupd '[ , member? ] find
+ [ cut 1 tail ]
+ [ swap ]
+ if ;
+
+: spawn-server-linked ( quot name -- thread )
+ >r '[ , [ ] [ ] while ] r>
+ spawn-linked ;
+! ---
+
+! Default irc port
+: irc-port 6667 ;
+
+! Message used when the client isn't running anymore
+SINGLETON: irc-end
+
! "setup" objects
-TUPLE: profile server port nickname password default-channels ;
-C: <profile> profile
+TUPLE: irc-profile server port nickname password default-channels ;
+C: <irc-profile> irc-profile
-TUPLE: channel-profile name password auto-rejoin ;
-C: <channel-profile> channel-profile
+TUPLE: irc-channel-profile name password auto-rejoin ;
+C: <irc-channel-profile> irc-channel-profile
! "live" objects
-TUPLE: irc-client profile nick stream stream-process controller-process ;
-C: <irc-client> irc-client
-
TUPLE: nick name channels log ;
C: <nick> nick
-TUPLE: channel name topic members log attributes ;
-C: <channel> channel
+TUPLE: irc-client profile nick stream stream-channel controller-channel
+ listeners is-running ;
+: <irc-client> ( profile -- irc-client )
+ f V{ } clone V{ } clone <nick>
+ f <channel> <channel> V{ } clone f irc-client boa ;
+
+USE: prettyprint
+TUPLE: irc-listener channel ;
+! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
+! tener la opción de dejar de correr un client??
+: <irc-listener> ( quot -- irc-listener )
+ <channel> irc-listener boa swap
+ [
+ [ channel>> '[ , from ] ]
+ [ '[ , curry f spawn drop ] ]
+ bi* compose "irc-listener" spawn-server-linked drop
+ ] [ drop ] 2bi ;
+
+! TUPLE: irc-channel name topic members log attributes ;
+! C: <irc-channel> irc-channel
! the delegate of all irc messages
-TUPLE: irc-message timestamp ;
+TUPLE: irc-message line prefix command parameters trailing timestamp ;
C: <irc-message> irc-message
! "irc message" objects
-TUPLE: logged-in name text ;
+TUPLE: logged-in < irc-message name ;
C: <logged-in> logged-in
-TUPLE: ping name ;
+TUPLE: ping < irc-message ;
C: <ping> ping
-TUPLE: join name channel ;
-C: <join> join
+TUPLE: join_ < irc-message ;
+C: <join> join_
-TUPLE: part name channel text ;
+TUPLE: part < irc-message name channel ;
C: <part> part
-TUPLE: quit text ;
+TUPLE: quit ;
C: <quit> quit
-TUPLE: privmsg name text ;
+TUPLE: privmsg < irc-message name ;
C: <privmsg> privmsg
-TUPLE: kick channel er ee text ;
+TUPLE: kick < irc-message channel who ;
C: <kick> kick
-TUPLE: roomlist channel names ;
+TUPLE: roomlist < irc-message channel names ;
C: <roomlist> roomlist
-TUPLE: nick-in-use name ;
+TUPLE: nick-in-use < irc-message name ;
C: <nick-in-use> nick-in-use
-TUPLE: notice type text ;
+TUPLE: notice < irc-message type ;
C: <notice> notice
-TUPLE: mode name channel mode text ;
+TUPLE: mode < irc-message name channel mode ;
C: <mode> mode
-! TUPLE: members
-TUPLE: unhandled text ;
+TUPLE: unhandled < irc-message ;
C: <unhandled> unhandled
-! "control message" objects
-TUPLE: command sender ;
-TUPLE: service predicate quot enabled? ;
-TUPLE: chat-command from to text ;
-TUPLE: join-command channel password ;
-TUPLE: part-command channel text ;
-
SYMBOL: irc-client
-: irc-stream> ( -- stream ) irc-client get irc-client-stream ;
-: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ;
+: irc-client> ( -- irc-client ) irc-client get ;
+: irc-stream> ( -- stream ) irc-client> stream>> ;
+
+: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+
: parse-name ( string -- string )
- trim-: "!" split first ;
-: irc-split ( string -- seq )
- 1 swap [ [ CHAR: : = ] find* ] keep
- swap [ swap cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-:
- " " split r> [ 1array append ] when* ;
+ remove-heading-: "!" split-at-first drop ;
+
+: sender>> ( obj -- string )
+ prefix>> parse-name ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head?
+ [ remove-heading-: " " split1 ]
+ [ f swap ]
+ if ;
+
+: split-trailing ( string -- string string/f )
+ ":" split1 ;
+
+: string>irc-message ( string -- object )
+ dup split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip
+ now <irc-message> ;
+
: me? ( name -- ? )
- irc-client get irc-client-nick nick-name = ;
+ irc-client> nick>> name>> = ;
: irc-write ( s -- )
irc-stream> stream-write ;
: irc-print ( s -- )
irc-stream> [ stream-print ] keep stream-flush ;
-: nick ( nick -- )
+! Irc commands
+
+: NICK ( nick -- )
"NICK " irc-write irc-print ;
-: login ( nick -- )
- dup nick
+: LOGIN ( nick -- )
+ dup NICK
"USER " irc-write irc-write
" hostname servername :irc.factor" irc-print ;
-: connect* ( server port -- )
- <inet> utf8 <client> irc-client get set-irc-client-stream ;
-
-: connect ( server -- ) 6667 connect* ;
+: CONNECT ( server port -- stream )
+ <inet> latin1 <client> ;
-: join ( channel password -- )
+: JOIN ( channel password -- )
"JOIN " irc-write
- [ >r " :" r> 3append ] when* irc-print ;
+ [ " :" swap 3append ] when* irc-print ;
-: part ( channel text -- )
- >r "PART " irc-write irc-write r>
+: PART ( channel text -- )
+ [ "PART " irc-write irc-write ] dip
" :" irc-write irc-print ;
-: say ( line nick -- )
- "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
+: KICK ( channel who -- )
+ [ "KICK " irc-write irc-write ] dip
+ " " irc-write irc-print ;
+
+: PRIVMSG ( nick line -- )
+ [ "PRIVMSG " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
+
+: SAY ( nick line -- )
+ PRIVMSG ;
-: quit ( text -- )
+: ACTION ( nick line -- )
+ [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ;
+
+: QUIT ( text -- )
"QUIT :" irc-write irc-print ;
+: join-channel ( channel-profile -- )
+ [ name>> ] keep password>> JOIN ;
+: irc-connect ( irc-client -- )
+ [ profile>> [ server>> ] keep port>> CONNECT ] keep
+ swap >>stream t >>is-running drop ;
+
GENERIC: handle-irc ( obj -- )
M: object handle-irc ( obj -- )
- "Unhandled irc object" print drop ;
+ drop ;
M: logged-in handle-irc ( obj -- )
- logged-in-name irc-client get [ irc-client-nick set-nick-name ] keep
-
- irc-client-profile profile-default-channels
- [
- [ channel-profile-name ] keep
- channel-profile-password join
- ] each ;
+ name>>
+ irc-client> [ nick>> swap >>name drop ] keep
+ profile>> default-channels>> [ join-channel ] each ;
M: ping handle-irc ( obj -- )
"PONG " irc-write
- ping-name irc-print ;
+ trailing>> irc-print ;
M: nick-in-use handle-irc ( obj -- )
- nick-in-use-name "_" append nick ;
-
-: delegate-timestamp ( obj -- obj )
- now <irc-message> over set-delegate ;
-
-MATCH-VARS: ?name ?name2 ?channel ?text ?mode ;
-SYMBOL: line
-: match-irc ( string -- )
- dup line set
- dup print flush
- irc-split
- {
- { { "PING" ?name }
- [ ?name <ping> ] }
- { { ?name "001" ?name2 ?text }
- [ ?name2 ?text <logged-in> ] }
- { { ?name "433" _ ?name2 "Nickname is already in use." }
- [ ?name2 <nick-in-use> ] }
-
- { { ?name "JOIN" ?channel }
- [ ?name ?channel <join> ] }
- { { ?name "PART" ?channel ?text }
- [ ?name ?channel ?text <part> ] }
- { { ?name "PRIVMSG" ?channel ?text }
- [ ?name ?channel ?text <privmsg> ] }
- { { ?name "QUIT" ?text }
- [ ?name ?text <quit> ] }
-
- { { "NOTICE" ?name ?text }
- [ ?name ?text <notice> ] }
- { { ?name "MODE" ?channel ?mode ?text }
- [ ?name ?channel ?mode ?text <mode> ] }
- { { ?name "KICK" ?channel ?name2 ?text }
- [ ?channel ?name ?name2 ?text <kick> ] }
-
- ! { { ?name "353" ?name2 _ ?channel ?text }
- ! [ ?text ?channel ?name2 make-member-list ] }
- { _ [ line get <unhandled> ] }
- } match-cond
- delegate-timestamp handle-irc flush ;
-
-: irc-loop ( -- )
- irc-stream> stream-readln
- [ match-irc irc-loop ] when* ;
-
+ name>> "_" append NICK ;
+
+: parse-irc-line ( string -- message )
+ string>irc-message
+ dup command>> {
+ { "PING" [ \ ping ] }
+ { "NOTICE" [ \ notice ] }
+ { "001" [ \ logged-in ] }
+ { "433" [ \ nick-in-use ] }
+ { "JOIN" [ \ join_ ] }
+ { "PART" [ \ part ] }
+ { "PRIVMSG" [ \ privmsg ] }
+ { "QUIT" [ \ quit ] }
+ { "MODE" [ \ mode ] }
+ { "KICK" [ \ kick ] }
+ [ drop \ unhandled ]
+ } case
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
+
+! Reader
+: handle-reader-message ( irc-client irc-message -- )
+ dup handle-irc swap stream-channel>> to ;
+
+: reader-loop ( irc-client -- )
+ dup stream>> stream-readln [
+ dup print parse-irc-line handle-reader-message
+ ] [
+ f >>is-running
+ dup stream>> dispose
+ irc-end over controller-channel>> to
+ stream-channel>> irc-end swap to
+ ] if* ;
+
+! Controller commands
+GENERIC: handle-command ( obj -- )
+
+M: object handle-command ( obj -- )
+ . ;
+
+TUPLE: send-message to text ;
+C: <send-message> send-message
+M: send-message handle-command ( obj -- )
+ dup to>> swap text>> SAY ;
+
+TUPLE: send-action to text ;
+C: <send-action> send-action
+M: send-action handle-command ( obj -- )
+ dup to>> swap text>> ACTION ;
+
+TUPLE: send-quit text ;
+C: <send-quit> send-quit
+M: send-quit handle-command ( obj -- )
+ text>> QUIT ;
+
+: irc-listen ( irc-client quot -- )
+ [ listeners>> ] [ <irc-listener> ] bi* swap push ;
+
+! Controller loop
+: controller-loop ( irc-client -- )
+ controller-channel>> from handle-command ;
+
+! Multiplexer
+: multiplex-message ( irc-client message -- )
+ swap listeners>> [ channel>> ] map
+ [ '[ , , to ] "message" spawn drop ] each-with ;
+
+: multiplexer-loop ( irc-client -- )
+ dup stream-channel>> from multiplex-message ;
+
+! process looping and starting
+: (spawn-irc-loop) ( irc-client quot name -- )
+ [ over >r curry r> '[ @ , is-running>> ] ] dip
+ spawn-server-linked drop ;
+
+: spawn-irc-loop ( irc-client quot name -- )
+ '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ]
+ f spawn drop ;
+
+: spawn-irc ( irc-client -- )
+ [ [ reader-loop ] "reader-loop" spawn-irc-loop ]
+ [ [ controller-loop ] "controller-loop" spawn-irc-loop ]
+ [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ]
+ tri ;
+
: do-irc ( irc-client -- )
- dup irc-client set
- dup irc-client-profile profile-server
- over irc-client-profile profile-port connect*
- dup irc-client-profile profile-nickname login
- [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ;
-
-: with-infinite-loop ( quot timeout -- quot timeout )
- "looping" print flush
- over [ drop ] recover dup sleep with-infinite-loop ;
-
-: start-irc ( irc-client -- )
- ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ;
- [ do-irc ] curry 3000 with-infinite-loop ;
-
-
-! For testing
-: make-factorbot
- "irc.freenode.org" 6667 "factorbot" f
- [
- "#concatenative-flood" f f <channel-profile> ,
- ] { } make <profile>
- f V{ } clone V{ } clone <nick>
- f f f <irc-client> ;
-
-: test-factorbot
- make-factorbot start-irc ;
-
+ irc-client [
+ irc-client>
+ [ irc-connect ]
+ [ profile>> nickname>> LOGIN ]
+ [ spawn-irc ]
+ tri
+ ] with-variable ;
\ No newline at end of file
: <jamshred> ( -- jamshred )
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
- jamshred construct-boa ;
+ jamshred boa ;
: jamshred-player ( jamshred -- player )
! TODO: support more than one player
TUPLE: oint location forward up left ;
: <oint> ( location forward up left -- oint )
- oint construct-boa ;
+ oint boa ;
! : x-rotation ( theta -- matrix )
! #! construct this matrix:
TUPLE: player name tunnel nearest-segment ;
: <player> ( name -- player )
- f f player construct-boa
+ f f player boa
F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
: turn-player ( player x-radians y-radians -- )
TUPLE: segment number color radius ;
: <segment> ( number color radius location forward up left -- segment )
- <oint> >r segment construct-boa r> over set-delegate ;
+ <oint> >r segment boa r> over set-delegate ;
: segment-vertex ( theta segment -- vertex )
tuck 2dup oint-up swap sin v*n
USING: arrays assocs hashtables assocs io kernel math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
-splitting sorting shuffle symbols ;
+splitting sorting shuffle symbols sets ;
IN: koszul
! Utilities
{ [ dup number? ] [ { } associate ] }
{ [ dup array? ] [ 1 swap associate ] }
{ [ dup hashtable? ] [ ] }
- { [ t ] [ 1array >alt ] }
+ [ 1array >alt ]
} cond ;
: canonicalize
! Printing elements
: num-alt. ( n -- str )
{
- { [ dup 1 = ] [ drop " + " ] }
- { [ dup -1 = ] [ drop " - " ] }
- { [ t ] [ number>string " + " prepend ] }
- } cond ;
+ { 1 [ " + " ] }
+ { -1 [ " - " ] }
+ [ number>string " + " prepend ]
+ } case ;
: (alt.) ( basis n -- str )
over empty? [
TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
- [ promise ] bi@ \ lazy-cons construct-boa
+ [ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone
[ set-promise-value ] keep ;
: <memoized-cons> ( cons -- memoized-cons )
not-memoized not-memoized not-memoized
- memoized-cons construct-boa ;
+ memoized-cons boa ;
M: memoized-cons car ( memoized-cons -- car )
dup memoized-cons-car not-memoized? [
{
{ [ dup sequence? ] [ 0 swap seq>list ] }
{ [ dup list? ] [ ] }
- { [ t ] [ "Could not convert object to a list" throw ] }
+ [ "Could not convert object to a list" throw ]
} cond ;
TUPLE: lazy-concat car cdr ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: io lint kernel math tools.test ;
-IN: lint.tests
-
-! Don't write code like this
-: lint1
- [ "hi" print ] [ ] if ; ! when
-
-[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
-
-: lint2
- 1 + ; ! 1+
-[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
-
-: lint3
- dup -rot ; ! tuck
-
-[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays assocs combinators.lib io kernel
-macros math namespaces prettyprint quotations sequences
-vectors vocabs words html.elements slots.private tar ;
-IN: lint
-
-SYMBOL: def-hash
-SYMBOL: def-hash-keys
-
-: set-hash-vector ( val key hash -- )
- 2dup at -rot >r >r ?push r> r> set-at ;
-
-: add-word-def ( word quot -- )
- dup callable? [
- def-hash get-global set-hash-vector
- ] [
- 2drop
- ] if ;
-
-: more-defs
- {
- { [ swap >r swap r> ] -rot }
- { [ swap swapd ] -rot }
- { [ >r swap r> swap ] rot }
- { [ swapd swap ] rot }
- { [ dup swap ] over }
- { [ dup -rot ] tuck }
- { [ >r swap r> ] swapd }
- { [ nip nip ] 2nip }
- { [ drop drop ] 2drop }
- { [ drop drop drop ] 3drop }
- { [ 0 = ] zero? }
- { [ pop drop ] pop* }
- { [ [ ] if ] when }
- } [ first2 swap add-word-def ] 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
- {
- [ get ] [ t ] [ { } ] [ . ] [ drop f ]
- [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
- [ ">" write-html ] [ <unimplemented-typeflag> throw ]
- [ "/>" write-html ]
- } ;
-
-H{ } clone def-hash set-global
-all-words [ dup word-def add-word-def ] each
-more-defs
-
-! Remove empty word defs
-def-hash get-global [
- drop empty? not
-] assoc-subset
-
-! Remove constants [ 1 ]
-[
- drop dup length 1 = swap first number? and not
-] assoc-subset
-
-! Remove set-alien-cell, etc.
-[
- drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
-] assoc-subset
-
-! Remove trivial defs
-[
- drop trivial-defs member? not
-] assoc-subset
-
-! Remove n m shift defs
-[
- drop dup length 3 = [
- dup first2 [ number? ] both?
- swap third \ shift = and not
- ] [ drop t ] if
-] assoc-subset
-
-! Remove [ n slot ]
-[
- drop dup length 2 = [
- first2 \ slot = swap number? and not
- ] [ drop t ] if
-] assoc-subset def-hash set-global
-
-: find-duplicates
- def-hash get-global [
- nip length 1 >
- ] assoc-subset ;
-
-def-hash get-global keys def-hash-keys set-global
-
-GENERIC: lint ( obj -- seq )
-
-M: object lint ( obj -- seq )
- drop f ;
-
-: subseq/member? ( subseq/member seq -- ? )
- { [ 2dup start ] [ 2dup member? ] } || 2nip ;
-
-M: callable lint ( quot -- seq )
- def-hash-keys get [
- swap subseq/member?
- ] with subset ;
-
-M: word lint ( word -- seq )
- word-def dup callable? [ lint ] [ drop f ] if ;
-
-: word-path. ( word -- )
- [ word-vocabulary ":" ] keep unparse 3append write nl ;
-
-: (lint.) ( pair -- )
- first2 >r word-path. r> [
- bl bl bl bl
- dup .
- "-----------------------------------" print
- def-hash get at [ bl bl bl bl word-path. ] each
- nl
- ] each nl nl ;
-
-: lint. ( alist -- )
- [ (lint.) ] each ;
-
-
-GENERIC: run-lint ( obj -- obj )
-
-: (trim-self)
- def-hash get-global at* [
- dupd remove empty? not
- ] [
- drop f
- ] if ;
-
-: trim-self ( seq -- newseq )
- [ [ (trim-self) ] subset ] assoc-map ;
-
-: filter-symbols ( alist -- alist )
- [
- nip first dup def-hash get at
- [ first ] bi@ literalize = not
- ] assoc-subset ;
-
-M: sequence run-lint ( seq -- seq )
- [
- global [ dup . flush ] bind
- dup lint
- ] { } map>assoc
- trim-self
- [ second empty? not ] subset
- 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: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
-definitions prettyprint hashtables prettyprint.sections
+definitions prettyprint hashtables prettyprint.sections sets
sequences.private effects generic compiler.units accessors ;
IN: locals
M: quotation free-vars { } [ add-if-free ] reduce ;
M: lambda free-vars
- dup vars>> swap body>> free-vars seq-diff ;
+ dup vars>> swap body>> free-vars diff ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lambda-rewrite
parse-log-line {\r
{ [ dup malformed? ] [ malformed-line ] }\r
{ [ dup multiline? ] [ add-multiline ] }\r
- { [ t ] [ , ] }\r
+ [ , ]\r
} cond\r
] each\r
] { } make ;\r
rot [ empty? not ] subset {\r
{ [ dup empty? ] [ 3drop ] }\r
{ [ dup length 1 = ] [ first -rot f (write-message) ] }\r
- { [ t ] [\r
+ [\r
[ first -rot f (write-message) ] 3keep\r
1 tail -rot [ t (write-message) ] 2curry each\r
- ] }\r
+ ]\r
} cond ;\r
\r
: (log-message) ( msg -- )\r
-Utility for defining compiler transforms, and short-circuiting boolean operators
+Utility for defining compiler transforms
{ [ dup match-var? ] [ get ] }
{ [ dup sequence? ] [ [ replace-patterns ] map ] }
{ [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: match-replace ( object pattern1 pattern2 -- result )
[ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ;
: <erato> ( n -- erato )
- dup ind 1+ <bit-array> 1 over set-bits erato construct-boa ;
+ dup ind 1+ <bit-array> 1 over set-bits erato boa ;
: next-prime ( erato -- prime/f )
[ erato-latest 2 + ] keep [ set-erato-latest ] 2keep
{ [ pick fp-nan? pick fp-nan? or ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ ~rel ] }
- { [ t ] [ ~abs ] }
+ [ ~abs ]
} cond ;
: power-of-2? ( n -- ? )
USING: combinators combinators.lib io locals kernel math
math.functions math.ranges namespaces random sequences
-hashtables ;
+hashtables sets ;
IN: math.miller-rabin
SYMBOL: a
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
- { [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] }
+ [ [ drop trials set t (miller-rabin) ] with-scope ]
} cond ;
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
{ [ dup 2 < ] [ drop { } ] }
{ [ dup 1000003 < ]
[ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
- { [ t ]
- [ primes-under-million 1000003 lprimes-from
- rot [ <= ] curry lwhile list>array append ] }
+ [ primes-under-million 1000003 lprimes-from
+ rot [ <= ] curry lwhile list>array append ]
} cond ; foldable
: primes-between ( low high -- seq )
: <range> ( a b step -- range )
>r over - r>
[ / 1+ 0 max >integer ] keep
- range construct-boa ;
+ range boa ;
M: range length ( seq -- n )
range-length ;
TUPLE: model-tester hit? ;
-: <model-tester> model-tester construct-empty ;
+: <model-tester> model-tester new ;
M: model-tester model-changed nip t swap set-model-tester-hit? ;
value connections dependencies ref locked? ;
: <model> ( value -- model )
- V{ } clone V{ } clone 0 f model construct-boa ;
+ V{ } clone V{ } clone 0 f model boa ;
M: model hashcode* drop model hashcode* ;
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test kernel math arrays sequences
-prettyprint strings classes hashtables assocs namespaces
-debugger continuations ;
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ -1 ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ 0 ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ 1 ] [
- { object object } { number sequence } classes<
-] unit-test
-
-[
- {
- { { object integer } [ 1 ] }
- { { object object } [ 2 ] }
- { { POSTPONE: f POSTPONE: f } [ 3 ] }
- }
-] [
- {
- { { integer } [ 1 ] }
- { { } [ 2 ] }
- { { f f } [ 3 ] }
- } congruify-methods
-] unit-test
-
-GENERIC: first-test
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-TUPLE: paper ; INSTANCE: paper thing
-TUPLE: scissors ; INSTANCE: scissors thing
-TUPLE: rock ; INSTANCE: rock thing
-
-GENERIC: beats?
-
-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
-[ t ] [ T{ paper } T{ scissors } play ] unit-test
-[ f ] [ T{ scissors } T{ paper } play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-GENERIC: legacy-test
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
-
-SYMBOL: some-var
-
-HOOK: hook-test some-var
-
-[ t ] [ \ hook-test hook-generic? ] unit-test
-
-METHOD: hook-test { array array } reverse ;
-METHOD: hook-test { array } class ;
-METHOD: hook-test { hashtable 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
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
USING: kernel math sequences vectors classes classes.algebra
combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
-debugger io compiler.units kernel.private effects ;
+debugger io compiler.units kernel.private effects accessors
+hashtables sorting shuffle ;
IN: multi-methods
-GENERIC: generic-prologue ( combination -- quot )
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
-GENERIC: method-prologue ( combination -- quot )
+SYMBOL: args
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] subset
+ [ length <reversed> [ 1+ neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] subset
+ [ keys [ hooks get push-new ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ >r
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get + r>
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ >r total get object <array> dup <enum> r> update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ >r canonicalize-specializer-0 r> ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ >r canonicalize-specializer-1 r> ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ >r canonicalize-specializer-2 r> ] assoc-map
+
+ args get hooks get length + total set
+
+ [ >r canonicalize-specializer-3 r> ] 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 0 < ] 2curry subset empty?
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
{ [ 2dup class< ] [ -1 ] }
{ [ 2dup swap class< ] [ 1 ] }
- { [ t ] [ 0 ] }
+ [ 0 ]
} cond 2nip
] 2map [ zero? not ] find nip 0 or ;
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
: picker ( n -- quot )
{
{ 0 [ [ dup ] ] }
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ >r argument-count r> [ >r narray r> no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ >r multi-predicate r> ] 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-method-def ( quot classes generic -- quot )
+: make-generic ( generic -- quot )
[
- swap [ declare ] curry %
- "multi-combination" word-prop method-prologue %
- %
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
] [ ] make ;
-TUPLE: method word def classes generic loc ;
+: update-generic ( word -- )
+ dup make-generic define ;
+! Methods
PREDICATE: method-body < word
- "multi-method" word-prop >boolean ;
+ "multi-method-generic" word-prop >boolean ;
M: method-body stack-effect
- "multi-method" word-prop method-generic stack-effect ;
+ "multi-method-generic" word-prop stack-effect ;
M: method-body crossref?
drop t ;
-: method-word-name ( classes generic -- string )
+: method-word-name ( specializer generic -- string )
+ [ word-name % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
[
- word-name %
- "-(" % [ "," % ] [ word-name % ] interleave ")" %
- ] "" make ;
-
-: <method-word> ( quot classes generic -- word )
- #! We xref here because the "multi-method" word-prop isn't
- #! set yet so crossref? yields f.
- [ make-method-def ] 2keep
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
method-word-name f <word>
- dup rot define
- dup xref ;
+ [ set-word-props ] keep ;
-: <method> ( quot classes generic -- method )
- [ <method-word> ] 3keep f \ method construct-boa
- dup method-word over "multi-method" set-word-prop ;
+: with-methods ( word quot -- )
+ over >r >r "multi-methods" word-prop
+ r> call r> update-generic ; inline
-TUPLE: no-method arguments generic ;
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
-: no-method ( argument-count generic -- * )
- >r narray r> \ no-method construct-boa throw ; inline
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
-: argument-count ( methods -- n )
- dup assoc-empty? [ drop 0 ] [
- keys [ length ] map supremum
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
] if ;
-: multi-dispatch-quot ( methods generic -- quot )
- >r [
- [
- >r multi-predicate r> method-word 1quotation
- ] assoc-map
- ] keep argument-count
- r> [ no-method ] 2curry
- swap reverse alist>quot ;
-
-: congruify-methods ( alist -- alist' )
- dup argument-count [
- swap >r object pad-left [ \ f or ] map r>
- ] curry assoc-map ;
-
-: sorted-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error.
"Type check error" print
nl
- "Generic word " write dup no-method-generic pprint
+ "Generic word " write dup generic>> pprint
" does not have a method applicable to inputs:" print
- dup no-method-arguments short.
+ dup arguments>> short.
nl
"Inputs have signature:" print
- dup no-method-arguments [ class ] map niceify-method .
+ dup arguments>> [ class ] map niceify-method .
nl
- "Defined methods in topological order: " print
- no-method-generic
- methods congruify-methods sorted-methods keys
- [ niceify-method ] map stack. ;
-
-TUPLE: standard-combination ;
-
-M: standard-combination method-prologue drop [ ] ;
-
-M: standard-combination generic-prologue drop [ ] ;
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
-: make-generic ( generic -- quot )
- dup "multi-combination" word-prop generic-prologue swap
- [ methods congruify-methods sorted-methods ] keep
- multi-dispatch-quot append ;
-
-TUPLE: hook-combination var ;
-
-M: hook-combination method-prologue
- drop [ drop ] ;
-
-M: hook-combination generic-prologue
- hook-combination-var [ get ] curry ;
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
-: update-generic ( word -- )
- dup make-generic define ;
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
-: define-generic ( word combination -- )
- over "multi-combination" word-prop over = [
- 2drop
+: define-generic ( word -- )
+ dup "multi-methods" word-prop [
+ drop
] [
- dupd "multi-combination" set-word-prop
- dup H{ } clone "multi-methods" set-word-prop
- update-generic
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
] if ;
-: define-standard-generic ( word -- )
- T{ standard-combination } define-generic ;
-
+! Syntax
: GENERIC:
- CREATE define-standard-generic ; parsing
-
-: define-hook-generic ( word var -- )
- hook-combination construct-boa define-generic ;
-
-: HOOK:
- CREATE scan-word define-hook-generic ; parsing
+ CREATE define-generic ; parsing
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: with-methods ( word quot -- )
- over >r >r "multi-methods" word-prop
- r> call r> update-generic ; inline
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-: define-method ( quot classes generic -- )
- >r [ bootstrap-word ] map r>
- [ <method> ] 2keep
- [ set-at ] with-methods ;
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
-: forget-method ( classes generic -- )
- [ delete-at ] with-methods ;
+: CREATE-METHOD
+ scan-word scan-object swap create-method-in ;
-: method>spec ( method -- spec )
- dup method-classes swap method-generic prefix ;
+: (METHOD:) CREATE-METHOD parse-definition ;
-: parse-method ( -- quot classes generic )
- parse-definition dup 2 tail over second rot first ;
-
-: METHOD:
- location
- >r parse-method [ define-method ] 2keep prefix r>
- remember-definition ; parsing
+: METHOD: (METHOD:) define ; parsing
! For compatibility
: M:
- scan-word 1array scan-word parse-definition
- -rot define-method ; parsing
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ; parsing
! Definition protocol. We qualify core generics here
USE: qualified
QUALIFIED: syntax
-PREDICATE: generic < word
- "multi-combination" word-prop >boolean ;
-
-PREDICATE: standard-generic < word
- "multi-combination" word-prop standard-combination? ;
-
-PREDICATE: hook-generic < word
- "multi-combination" word-prop hook-combination? ;
-
-syntax:M: standard-generic definer drop \ GENERIC: f ;
+syntax:M: generic definer drop \ GENERIC: f ;
-syntax:M: standard-generic definition drop f ;
-
-syntax:M: hook-generic definer drop \ HOOK: f ;
-
-syntax:M: hook-generic definition drop f ;
-
-syntax:M: hook-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup "multi-combination" word-prop
- hook-combination-var pprint-word stack-effect. ;
+syntax:M: generic definition drop f ;
PREDICATE: method-spec < array
unclip generic? >r [ class? ] all? r> and ;
syntax:M: method-spec where
- dup unclip method [ method-loc ] [ second where ] ?if ;
+ dup unclip method [ ] [ first ] ?if where ;
syntax:M: method-spec set-where
- unclip method set-method-loc ;
+ unclip method set-where ;
syntax:M: method-spec definer
- drop \ METHOD: \ ; ;
+ unclip method definer ;
syntax:M: method-spec definition
- unclip method dup [ method-def ] when ;
+ unclip method definition ;
syntax:M: method-spec synopsis*
- dup definer.
- unclip pprint* pprint* ;
+ unclip method synopsis* ;
syntax:M: method-spec forget*
- unclip forget-method ;
+ 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
+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
+ { 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
+
+: 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" }
+ }
+ V{ 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 >r sort-methods r> ] 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
+
+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 ;
+
+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?
+
+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
+
+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
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+IN: multi-methods.tests
+USING: kernel multi-methods tools.test math arrays sequences ;
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ -1 ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ 0 ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ 1 ] [
+ { object object } { number sequence } classes<
+] unit-test
USING: kernel sequences assocs qualified circular ;
+USING: math multi-methods ;
+
QUALIFIED: sequences
+QUALIFIED: assocs
QUALIFIED: circular
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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-at ( seq i -- val ) swap nth ;
-: nth-of ( i seq -- val ) nth ;
+METHOD: at { sequence number } swap nth ;
+METHOD: of { number sequence } nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-is ( seq i val -- seq ) swap pick set-nth ;
-: is-nth ( seq val i -- seq ) pick set-nth ;
+METHOD: grab { sequence number } dupd swap nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ;
-: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ;
+METHOD: is { sequence number object } swap pick set-nth ;
+METHOD: as { sequence object number } pick set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: mutate-nth ( seq i val -- ) swap rot set-nth ;
-: mutate-nth-at ( seq val i -- ) rot set-nth ;
+METHOD: is-of { number object sequence } dup >r swapd set-nth r> ;
+METHOD: as-of { object number sequence } dup >r set-nth r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { sequence number object } swap rot set-nth ;
+METHOD: mutate-as { sequence object number } rot set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: mutate-nth-of ( i val seq -- ) swapd set-nth ;
-: mutate-nth-at-of ( val i seq -- ) set-nth ;
+METHOD: at-mutate { number object sequence } swapd set-nth ;
+METHOD: as-mutate { object number sequence } set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: at-key ( tbl key -- val ) swap at ;
-: key-of ( key tbl -- val ) at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! assoc
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: key-is ( tbl key val -- tbl ) swap pick set-at ;
-: is-key ( tbl val key -- tbl ) pick set-at ;
+METHOD: at { assoc object } swap assocs:at ;
+METHOD: of { object assoc } assocs:at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: mutate-key ( tbl key val -- ) swap rot set-at ;
-: mutate-at-key ( tbl val key -- ) rot set-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 >r swapd set-at r> ;
+METHOD: as-of { object object assoc } dup >r set-at r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { assoc object object } swap rot set-at ;
+METHOD: mutate-as { assoc object object } rot set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: mutate-key-of ( key val tbl -- ) swapd set-at ;
-: mutate-at-key-of ( val key tbl -- ) set-at ;
+METHOD: at-mutate { object object assoc } swapd set-at ;
+METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel alien alien.syntax combinators alien.c-types\r
- strings sequences namespaces words math threads ;\r
-IN: odbc\r
-\r
-"odbc" "odbc32.dll" "stdcall" add-library\r
-\r
-LIBRARY: odbc\r
-\r
-TYPEDEF: void* usb_dev_handle*\r
-TYPEDEF: short SQLRETURN\r
-TYPEDEF: short SQLSMALLINT\r
-TYPEDEF: short* SQLSMALLINT*\r
-TYPEDEF: ushort SQLUSMALLINT\r
-TYPEDEF: uint* SQLUINTEGER*\r
-TYPEDEF: int SQLINTEGER\r
-TYPEDEF: char SQLCHAR\r
-TYPEDEF: char* SQLCHAR*\r
-TYPEDEF: void* SQLHANDLE\r
-TYPEDEF: void* SQLHANDLE*\r
-TYPEDEF: void* SQLHENV\r
-TYPEDEF: void* SQLHDBC\r
-TYPEDEF: void* SQLHSTMT\r
-TYPEDEF: void* SQLHWND\r
-TYPEDEF: void* SQLPOINTER\r
-\r
-: SQL-HANDLE-ENV ( -- number ) 1 ; inline\r
-: SQL-HANDLE-DBC ( -- number ) 2 ; inline\r
-: SQL-HANDLE-STMT ( -- number ) 3 ; inline\r
-: SQL-HANDLE-DESC ( -- number ) 4 ; inline\r
-\r
-: SQL-NULL-HANDLE ( -- alien ) f ; inline\r
-\r
-: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline\r
-\r
-: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline\r
-: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline\r
-\r
-: SQL-SUCCESS ( -- number ) 0 ; inline\r
-: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline\r
-: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline\r
-\r
-: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline\r
-: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline\r
-\r
-: SQL-C-DEFAULT ( -- number ) 99 ; inline\r
-\r
-SYMBOL: SQL-CHAR\r
-SYMBOL: SQL-VARCHAR\r
-SYMBOL: SQL-LONGVARCHAR\r
-SYMBOL: SQL-WCHAR\r
-SYMBOL: SQL-WCHARVAR\r
-SYMBOL: SQL-WLONGCHARVAR\r
-SYMBOL: SQL-DECIMAL\r
-SYMBOL: SQL-SMALLINT\r
-SYMBOL: SQL-NUMERIC\r
-SYMBOL: SQL-INTEGER\r
-SYMBOL: SQL-REAL\r
-SYMBOL: SQL-FLOAT\r
-SYMBOL: SQL-DOUBLE\r
-SYMBOL: SQL-BIT\r
-SYMBOL: SQL-TINYINT\r
-SYMBOL: SQL-BIGINT\r
-SYMBOL: SQL-BINARY\r
-SYMBOL: SQL-VARBINARY\r
-SYMBOL: SQL-LONGVARBINARY\r
-SYMBOL: SQL-TYPE-DATE\r
-SYMBOL: SQL-TYPE-TIME\r
-SYMBOL: SQL-TYPE-TIMESTAMP\r
-SYMBOL: SQL-TYPE-UTCDATETIME\r
-SYMBOL: SQL-TYPE-UTCTIME\r
-SYMBOL: SQL-INTERVAL-MONTH\r
-SYMBOL: SQL-INTERVAL-YEAR\r
-SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH\r
-SYMBOL: SQL-INTERVAL-DAY\r
-SYMBOL: SQL-INTERVAL-HOUR\r
-SYMBOL: SQL-INTERVAL-MINUTE\r
-SYMBOL: SQL-INTERVAL-SECOND\r
-SYMBOL: SQL-INTERVAL-DAY-TO-HOUR\r
-SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE\r
-SYMBOL: SQL-INTERVAL-DAY-TO-SECOND\r
-SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE\r
-SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND\r
-SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND\r
-SYMBOL: SQL-GUID\r
-SYMBOL: SQL-TYPE-UNKNOWN\r
-\r
-: convert-sql-type ( number -- symbol )\r
- {\r
- { [ dup 1 = ] [ drop SQL-CHAR ] }\r
- { [ dup 12 = ] [ drop SQL-VARCHAR ] }\r
- { [ dup -1 = ] [ drop SQL-LONGVARCHAR ] }\r
- { [ dup -8 = ] [ drop SQL-WCHAR ] }\r
- { [ dup -9 = ] [ drop SQL-WCHARVAR ] }\r
- { [ dup -10 = ] [ drop SQL-WLONGCHARVAR ] }\r
- { [ dup 3 = ] [ drop SQL-DECIMAL ] }\r
- { [ dup 5 = ] [ drop SQL-SMALLINT ] }\r
- { [ dup 2 = ] [ drop SQL-NUMERIC ] }\r
- { [ dup 4 = ] [ drop SQL-INTEGER ] }\r
- { [ dup 7 = ] [ drop SQL-REAL ] }\r
- { [ dup 6 = ] [ drop SQL-FLOAT ] }\r
- { [ dup 8 = ] [ drop SQL-DOUBLE ] }\r
- { [ dup -7 = ] [ drop SQL-BIT ] }\r
- { [ dup -6 = ] [ drop SQL-TINYINT ] }\r
- { [ dup -5 = ] [ drop SQL-BIGINT ] }\r
- { [ dup -2 = ] [ drop SQL-BINARY ] }\r
- { [ dup -3 = ] [ drop SQL-VARBINARY ] } \r
- { [ dup -4 = ] [ drop SQL-LONGVARBINARY ] }\r
- { [ dup 91 = ] [ drop SQL-TYPE-DATE ] }\r
- { [ dup 92 = ] [ drop SQL-TYPE-TIME ] }\r
- { [ dup 93 = ] [ drop SQL-TYPE-TIMESTAMP ] }\r
- { [ t ] [ drop SQL-TYPE-UNKNOWN ] }\r
- } cond ;\r
-\r
-: succeeded? ( n -- bool )\r
- #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)\r
- {\r
- { [ dup SQL-SUCCESS = ] [ drop t ] }\r
- { [ dup SQL-SUCCESS-WITH-INFO = ] [ drop t ] }\r
- { [ t ] [ drop f ] }\r
- } cond ; \r
-\r
-FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;\r
-FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;\r
-FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ; \r
-FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;\r
-FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;\r
-FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;\r
-FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;\r
-FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;\r
-FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;\r
-FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;\r
-FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;\r
-\r
-: alloc-handle ( type parent -- handle )\r
- f <void*> [ SQLAllocHandle ] keep swap succeeded? [\r
- *void*\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-: alloc-env-handle ( -- handle )\r
- SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;\r
-\r
-: alloc-dbc-handle ( env -- handle )\r
- SQL-HANDLE-DBC swap alloc-handle ;\r
-\r
-: alloc-stmt-handle ( dbc -- handle )\r
- SQL-HANDLE-STMT swap alloc-handle ;\r
-\r
-: temp-string ( length -- byte-array length )\r
- [ CHAR: \space <string> string>char-alien ] keep ;\r
-\r
-: odbc-init ( -- env )\r
- alloc-env-handle\r
- [ \r
- SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr \r
- succeeded? [ "odbc-init failed" throw ] unless\r
- ] keep ;\r
-\r
-: odbc-connect ( env dsn -- dbc )\r
- >r alloc-dbc-handle dup r> \r
- f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT \r
- SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;\r
-\r
-: odbc-disconnect ( dbc -- )\r
- SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ; \r
-\r
-: odbc-prepare ( dbc string -- statement )\r
- >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;\r
-\r
-: odbc-free-statement ( statement -- )\r
- SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;\r
-\r
-: odbc-execute ( statement -- )\r
- SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;\r
-\r
-: odbc-next-row ( statement -- bool )\r
- SQLFetch succeeded? ;\r
-\r
-: odbc-number-of-columns ( statement -- number )\r
- 0 <short> [ SQLNumResultCols succeeded? ] keep swap [\r
- *short\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-TUPLE: column nullable digits size type name number ;\r
-\r
-C: <column> column\r
-\r
-: odbc-describe-column ( statement n -- column )\r
- dup >r\r
- 1024 CHAR: \space <string> string>char-alien dup >r\r
- 1024 \r
- 0 <short>\r
- 0 <short> dup >r\r
- 0 <uint> dup >r\r
- 0 <short> dup >r\r
- 0 <short> dup >r\r
- SQLDescribeCol succeeded? [\r
- r> *short \r
- r> *short \r
- r> *uint \r
- r> *short convert-sql-type \r
- r> alien>char-string \r
- r> <column> \r
- ] [\r
- r> drop r> drop r> drop r> drop r> drop r> drop\r
- "odbc-describe-column failed" throw\r
- ] if ;\r
-\r
-: dereference-type-pointer ( byte-array column -- object )\r
- column-type {\r
- { [ dup SQL-CHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-VARCHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-LONGVARCHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-WCHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-WCHARVAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-WLONGCHARVAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-SMALLINT = ] [ drop *short ] }\r
- { [ dup SQL-INTEGER = ] [ drop *long ] }\r
- { [ dup SQL-REAL = ] [ drop *float ] }\r
- { [ dup SQL-FLOAT = ] [ drop *double ] }\r
- { [ dup SQL-DOUBLE = ] [ drop *double ] }\r
- { [ dup SQL-TINYINT = ] [ drop *char ] }\r
- { [ dup SQL-BIGINT = ] [ drop *longlong ] }\r
- { [ t ] [ nip [ "Unknown SQL Type: " % word-name % ] "" make ] } \r
- } cond ;\r
-\r
-TUPLE: field value column ;\r
-\r
-C: <field> field\r
-\r
-: odbc-get-field ( statement column -- field )\r
- dup column? [ dupd odbc-describe-column ] unless dup >r column-number\r
- SQL-C-DEFAULT\r
- 8192 CHAR: \space <string> string>char-alien dup >r\r
- 8192 \r
- f SQLGetData succeeded? [\r
- r> r> [ dereference-type-pointer ] keep <field>\r
- ] [\r
- r> drop r> [ \r
- "SQLGetData Failed for Column: " % \r
- dup column-name % \r
- " of type: " % dup column-type word-name %\r
- ] "" make swap <field>\r
- ] if ;\r
-\r
-: odbc-get-row-fields ( statement -- seq )\r
- [\r
- dup odbc-number-of-columns [\r
- 1+ odbc-get-field field-value ,\r
- ] with each \r
- ] { } make ;\r
-\r
-: (odbc-get-all-rows) ( statement -- )\r
- dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ; \r
- \r
-: odbc-get-all-rows ( statement -- seq )\r
- [ (odbc-get-all-rows) ] { } make ;\r
- \r
-: odbc-query ( string dsn -- result )\r
- odbc-init swap odbc-connect [\r
- swap odbc-prepare\r
- dup odbc-execute\r
- dup odbc-get-all-rows\r
- swap odbc-free-statement\r
- ] keep odbc-disconnect ;
\ No newline at end of file
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien alien.syntax combinators alien.c-types
+ strings sequences namespaces words math threads ;
+IN: odbc
+
+"odbc" "odbc32.dll" "stdcall" add-library
+
+LIBRARY: odbc
+
+TYPEDEF: void* usb_dev_handle*
+TYPEDEF: short SQLRETURN
+TYPEDEF: short SQLSMALLINT
+TYPEDEF: short* SQLSMALLINT*
+TYPEDEF: ushort SQLUSMALLINT
+TYPEDEF: uint* SQLUINTEGER*
+TYPEDEF: int SQLINTEGER
+TYPEDEF: char SQLCHAR
+TYPEDEF: char* SQLCHAR*
+TYPEDEF: void* SQLHANDLE
+TYPEDEF: void* SQLHANDLE*
+TYPEDEF: void* SQLHENV
+TYPEDEF: void* SQLHDBC
+TYPEDEF: void* SQLHSTMT
+TYPEDEF: void* SQLHWND
+TYPEDEF: void* SQLPOINTER
+
+: SQL-HANDLE-ENV ( -- number ) 1 ; inline
+: SQL-HANDLE-DBC ( -- number ) 2 ; inline
+: SQL-HANDLE-STMT ( -- number ) 3 ; inline
+: SQL-HANDLE-DESC ( -- number ) 4 ; inline
+
+: SQL-NULL-HANDLE ( -- alien ) f ; inline
+
+: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline
+
+: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline
+: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline
+
+: SQL-SUCCESS ( -- number ) 0 ; inline
+: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline
+: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline
+
+: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline
+: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline
+
+: SQL-C-DEFAULT ( -- number ) 99 ; inline
+
+SYMBOL: SQL-CHAR
+SYMBOL: SQL-VARCHAR
+SYMBOL: SQL-LONGVARCHAR
+SYMBOL: SQL-WCHAR
+SYMBOL: SQL-WCHARVAR
+SYMBOL: SQL-WLONGCHARVAR
+SYMBOL: SQL-DECIMAL
+SYMBOL: SQL-SMALLINT
+SYMBOL: SQL-NUMERIC
+SYMBOL: SQL-INTEGER
+SYMBOL: SQL-REAL
+SYMBOL: SQL-FLOAT
+SYMBOL: SQL-DOUBLE
+SYMBOL: SQL-BIT
+SYMBOL: SQL-TINYINT
+SYMBOL: SQL-BIGINT
+SYMBOL: SQL-BINARY
+SYMBOL: SQL-VARBINARY
+SYMBOL: SQL-LONGVARBINARY
+SYMBOL: SQL-TYPE-DATE
+SYMBOL: SQL-TYPE-TIME
+SYMBOL: SQL-TYPE-TIMESTAMP
+SYMBOL: SQL-TYPE-UTCDATETIME
+SYMBOL: SQL-TYPE-UTCTIME
+SYMBOL: SQL-INTERVAL-MONTH
+SYMBOL: SQL-INTERVAL-YEAR
+SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH
+SYMBOL: SQL-INTERVAL-DAY
+SYMBOL: SQL-INTERVAL-HOUR
+SYMBOL: SQL-INTERVAL-MINUTE
+SYMBOL: SQL-INTERVAL-SECOND
+SYMBOL: SQL-INTERVAL-DAY-TO-HOUR
+SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE
+SYMBOL: SQL-INTERVAL-DAY-TO-SECOND
+SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE
+SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND
+SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND
+SYMBOL: SQL-GUID
+SYMBOL: SQL-TYPE-UNKNOWN
+
+: convert-sql-type ( number -- symbol )
+ {
+ { 1 [ SQL-CHAR ] }
+ { 12 [ SQL-VARCHAR ] }
+ { -1 [ SQL-LONGVARCHAR ] }
+ { -8 [ SQL-WCHAR ] }
+ { -9 [ SQL-WCHARVAR ] }
+ { -10 [ SQL-WLONGCHARVAR ] }
+ { 3 [ SQL-DECIMAL ] }
+ { 5 [ SQL-SMALLINT ] }
+ { 2 [ SQL-NUMERIC ] }
+ { 4 [ SQL-INTEGER ] }
+ { 7 [ SQL-REAL ] }
+ { 6 [ SQL-FLOAT ] }
+ { 8 [ SQL-DOUBLE ] }
+ { -7 [ SQL-BIT ] }
+ { -6 [ SQL-TINYINT ] }
+ { -5 [ SQL-BIGINT ] }
+ { -2 [ SQL-BINARY ] }
+ { -3 [ SQL-VARBINARY ] }
+ { -4 [ SQL-LONGVARBINARY ] }
+ { 91 [ SQL-TYPE-DATE ] }
+ { 92 [ SQL-TYPE-TIME ] }
+ { 93 [ SQL-TYPE-TIMESTAMP ] }
+ [ drop SQL-TYPE-UNKNOWN ]
+ } case ;
+
+: succeeded? ( n -- bool )
+ #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
+ {
+ { SQL-SUCCESS [ t ] }
+ { SQL-SUCCESS-WITH-INFO [ t ] }
+ [ drop f ]
+ } case ;
+
+FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;
+FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;
+FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ;
+FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;
+FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;
+FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;
+FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;
+FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;
+FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;
+
+: alloc-handle ( type parent -- handle )
+ f <void*> [ SQLAllocHandle ] keep swap succeeded? [
+ *void*
+ ] [
+ drop f
+ ] if ;
+
+: alloc-env-handle ( -- handle )
+ SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;
+
+: alloc-dbc-handle ( env -- handle )
+ SQL-HANDLE-DBC swap alloc-handle ;
+
+: alloc-stmt-handle ( dbc -- handle )
+ SQL-HANDLE-STMT swap alloc-handle ;
+
+: temp-string ( length -- byte-array length )
+ [ CHAR: \space <string> string>char-alien ] keep ;
+
+: odbc-init ( -- env )
+ alloc-env-handle
+ [
+ SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr
+ succeeded? [ "odbc-init failed" throw ] unless
+ ] keep ;
+
+: odbc-connect ( env dsn -- dbc )
+ >r alloc-dbc-handle dup r>
+ f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT
+ SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;
+
+: odbc-disconnect ( dbc -- )
+ SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ;
+
+: odbc-prepare ( dbc string -- statement )
+ >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;
+
+: odbc-free-statement ( statement -- )
+ SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;
+
+: odbc-execute ( statement -- )
+ SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;
+
+: odbc-next-row ( statement -- bool )
+ SQLFetch succeeded? ;
+
+: odbc-number-of-columns ( statement -- number )
+ 0 <short> [ SQLNumResultCols succeeded? ] keep swap [
+ *short
+ ] [
+ drop f
+ ] if ;
+
+TUPLE: column nullable digits size type name number ;
+
+C: <column> column
+
+: odbc-describe-column ( statement n -- column )
+ dup >r
+ 1024 CHAR: \space <string> string>char-alien dup >r
+ 1024
+ 0 <short>
+ 0 <short> dup >r
+ 0 <uint> dup >r
+ 0 <short> dup >r
+ 0 <short> dup >r
+ SQLDescribeCol succeeded? [
+ r> *short
+ r> *short
+ r> *uint
+ r> *short convert-sql-type
+ r> alien>char-string
+ r> <column>
+ ] [
+ r> drop r> drop r> drop r> drop r> drop r> drop
+ "odbc-describe-column failed" throw
+ ] if ;
+
+: dereference-type-pointer ( byte-array column -- object )
+ column-type {
+ { SQL-CHAR [ alien>char-string ] }
+ { SQL-VARCHAR [ alien>char-string ] }
+ { SQL-LONGVARCHAR [ alien>char-string ] }
+ { SQL-WCHAR [ alien>char-string ] }
+ { SQL-WCHARVAR [ alien>char-string ] }
+ { SQL-WLONGCHARVAR [ alien>char-string ] }
+ { SQL-SMALLINT [ *short ] }
+ { SQL-INTEGER [ *long ] }
+ { SQL-REAL [ *float ] }
+ { SQL-FLOAT [ *double ] }
+ { SQL-DOUBLE [ *double ] }
+ { SQL-TINYINT [ *char ] }
+ { SQL-BIGINT [ *longlong ] }
+ [ nip [ "Unknown SQL Type: " % word-name % ] "" make ]
+ } case ;
+
+TUPLE: field value column ;
+
+C: <field> field
+
+: odbc-get-field ( statement column -- field )
+ dup column? [ dupd odbc-describe-column ] unless dup >r column-number
+ SQL-C-DEFAULT
+ 8192 CHAR: \space <string> string>char-alien dup >r
+ 8192
+ f SQLGetData succeeded? [
+ r> r> [ dereference-type-pointer ] keep <field>
+ ] [
+ r> drop r> [
+ "SQLGetData Failed for Column: " %
+ dup column-name %
+ " of type: " % dup column-type word-name %
+ ] "" make swap <field>
+ ] if ;
+
+: odbc-get-row-fields ( statement -- seq )
+ [
+ dup odbc-number-of-columns [
+ 1+ odbc-get-field field-value ,
+ ] with each
+ ] { } make ;
+
+: (odbc-get-all-rows) ( statement -- )
+ dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ;
+
+: odbc-get-all-rows ( statement -- seq )
+ [ (odbc-get-all-rows) ] { } make ;
+
+: odbc-query ( string dsn -- result )
+ odbc-init swap odbc-connect [
+ swap odbc-prepare
+ dup odbc-execute
+ dup odbc-get-all-rows
+ swap odbc-free-statement
+ ] keep odbc-disconnect ;
num-audio-buffers-processed {\r
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }\r
{ [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }\r
- { [ t ] [ fill-processed-audio-buffer t ] }\r
+ [ fill-processed-audio-buffer t ]\r
} cond ;\r
\r
: start-audio ( player -- player bool )\r
decode-packet {\r
{ [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }\r
{ [ is-theora-packet? ] [ handle-initial-theora-header ] }\r
- { [ t ] [ handle-initial-unknown-header ] }\r
+ [ handle-initial-unknown-header ]\r
} cond t\r
] [\r
f\r
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting opengl.gl
-continuations math.parser math arrays ;
+continuations math.parser math arrays sets ;
IN: opengl.capabilities
: (require-gl) ( thing require-quot make-error-quot -- )
: has-gl-extensions? ( extensions -- ? )
gl-extensions swap [ over member? ] all? nip ;
: (make-gl-extensions-error) ( required-extensions -- )
- gl-extensions swap seq-diff
+ gl-extensions swap diff
"Required OpenGL extensions not supported:\n" %
[ " " % % "\n" % ] each ;
: require-gl-extensions ( extensions -- )
USING: alien alien.syntax combinators kernel parser sequences
system words namespaces hashtables init math arrays assocs
continuations ;
+IN: opengl.gl.extensions
ERROR: unknown-gl-platform ;
<< {
{ [ os windows? ] [ "opengl.gl.windows" ] }
{ [ os macosx? ] [ "opengl.gl.macosx" ] }
{ [ os unix? ] [ "opengl.gl.unix" ] }
- { [ t ] [ unknown-gl-platform ] }
+ [ unknown-gl-platform ]
} cond use+ >>
-IN: opengl.gl.extensions
SYMBOL: +gl-function-number-counter+
SYMBOL: +gl-function-pointers+
TUPLE: sprite loc dim dim2 dlist texture ;
: <sprite> ( loc dim dim2 -- sprite )
- f f sprite construct-boa ;
+ f f sprite boa ;
: sprite-size2 sprite-dim2 first2 ;
swap comment-node present-text ;
: comment, ( ? node text -- )
- rot [ \ comment construct-boa , ] [ 2drop ] if ;
+ rot [ \ comment boa , ] [ 2drop ] if ;
: values% ( prefix values -- )
swap [
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
- { [ t ] [ words-called ] }
+ [ words-called ]
} cond 1 -rot get at+
] [
drop
: check-result ( result -- )
{
- { [ dup OCI_SUCCESS = ] [ drop ] }
- { [ dup OCI_ERROR = ] [ err get get-oci-error ] }
- { [ dup OCI_INVALID_HANDLE = ] [ "invalid handle" throw ] }
- { [ t ] [ "operation failed" throw ] }
- } cond ;
+ { OCI_SUCCESS [ ] }
+ { OCI_ERROR [ err get get-oci-error ] }
+ { OCI_INVALID_HANDLE [ "invalid handle" throw ] }
+ [ "operation failed" throw ]
+ } case ;
: check-status ( status -- bool )
{
- { [ dup OCI_SUCCESS = ] [ drop t ] }
- { [ dup OCI_ERROR = ] [ err get get-oci-error ] }
- { [ dup OCI_INVALID_HANDLE = ] [ "invalid handle" throw ] }
- { [ dup OCI_NO_DATA = ] [ drop f ] }
- { [ t ] [ "operation failed" throw ] }
- } cond ;
+ { OCI_SUCCESS [ t ] }
+ { OCI_ERROR [ err get get-oci-error ] }
+ { OCI_INVALID_HANDLE [ "invalid handle" throw ] }
+ { OCI_NO_DATA [ f ] }
+ [ "operation failed" throw ]
+ } case ;
! =========================================================
! Initialization and handle-allocation routines
>r stm get err get r> dup length swap malloc-char-string swap
OCI_NTV_SYNTAX OCI_DEFAULT OCIStmtPrepare check-result ;
-: calculate-size ( type -- size object )
+: calculate-size ( type -- size )
{
- { [ dup SQLT_INT = ] [ "int" heap-size ] }
- { [ dup SQLT_FLT = ] [ "float" heap-size ] }
- { [ dup SQLT_CHR = ] [ "char" heap-size ] }
- { [ dup SQLT_NUM = ] [ "int" heap-size 10 * ] }
- { [ dup SQLT_STR = ] [ 64 ] }
- { [ dup SQLT_ODT = ] [ 256 ] }
- } cond ;
+ { SQLT_INT [ "int" heap-size ] }
+ { SQLT_FLT [ "float" heap-size ] }
+ { SQLT_CHR [ "char" heap-size ] }
+ { SQLT_NUM [ "int" heap-size 10 * ] }
+ { SQLT_STR [ 64 ] }
+ { SQLT_ODT [ 256 ] }
+ } case ;
: define-by-position ( position type -- )
>r >r stm get f <void*> err get
- r> r> calculate-size swap >r [ "char" malloc-array dup buf set ] keep 1+
+ r> r> dup calculate-size >r [ "char" malloc-array dup buf set ] keep 1+
r> f f f OCI_DEFAULT OCIDefineByPos check-result ;
: execute-statement ( -- bool )
TUPLE: ensure-parser test ;
: ensure ( parser -- ensure )
- ensure-parser construct-boa ;
+ ensure-parser boa ;
M: ensure-parser parse ( input parser -- list )
2dup ensure-parser-test parse nil?
TUPLE: ensure-not-parser test ;
: ensure-not ( parser -- ensure )
- ensure-not-parser construct-boa ;
+ ensure-not-parser boa ;
M: ensure-not-parser parse ( input parser -- list )
2dup ensure-not-parser-test parse nil?
>r and-parser-parsers r> suffix
] [
2array
- ] if and-parser construct-boa ;
+ ] if and-parser boa ;
: <and-parser> ( parsers -- parser )
- dup length 1 = [ first ] [ and-parser construct-boa ] if ;
+ dup length 1 = [ first ] [ and-parser boa ] if ;
: and-parser-parse ( list p1 -- list )
swap [
TUPLE: or-parser parsers ;
: <or-parser> ( parsers -- parser )
- dup length 1 = [ first ] [ or-parser construct-boa ] if ;
+ dup length 1 = [ first ] [ or-parser boa ] if ;
: <|> ( parser1 parser2 -- parser )
2array <or-parser> ;
TUPLE: only-first-parser p1 ;
LAZY: only-first ( parser -- parser )
- only-first-parser construct-boa ;
+ only-first-parser boa ;
M: only-first-parser parse ( input parser -- list )
#! Transform a parser into a parser that only yields
{ V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
"x[i][j].y" primary parse-result-ast
] unit-test
+
+'ebnf' compile must-infer
\r
M: ebnf-action (transform) ( ast -- parser )\r
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals \r
- string-lines [ parse-lines ] with-compilation-unit action ;\r
+ string-lines parse-lines action ;\r
\r
M: ebnf-semantic (transform) ( ast -- parser )\r
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals \r
- string-lines [ parse-lines ] with-compilation-unit semantic ;\r
+ string-lines parse-lines semantic ;\r
\r
M: ebnf-var (transform) ( ast -- parser )\r
parser>> (transform) ;\r
[ compiled-parse ] curry [ with-scope ] curry ;\r
\r
: replace-escapes ( string -- string )\r
- "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ;\r
+ [\r
+ "\\t" token [ drop "\t" ] action ,\r
+ "\\n" token [ drop "\n" ] action ,\r
+ "\\r" token [ drop "\r" ] action ,\r
+ ] choice* replace ;\r
\r
: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing\r
\r
just-parser-p1 compiled-parser just-pattern curry ;
MEMO: just ( parser -- parser )
- just-parser construct-boa init-parser ;
+ just-parser boa init-parser ;
: 1token ( ch -- parser ) 1string token ;
SYMBOL: ignore
: <parse-result> ( remaining ast -- parse-result )
- parse-result construct-boa ;
+ parse-result boa ;
SYMBOL: packrat
SYMBOL: pos
SYMBOL: lrstack
SYMBOL: heads
+: failed? ( obj -- ? )
+ fail = ;
+
: delegates ( -- cache )
\ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
#! that maps the position to the parser result.
id>> packrat get [ drop H{ } clone ] cache ;
+: process-rule-result ( p result -- result )
+ [
+ nip [ ast>> ] [ remaining>> ] bi input-from pos set
+ ] [
+ pos set fail
+ ] if* ;
+
: eval-rule ( rule -- ast )
#! Evaluate a rule, return an ast resulting from it.
#! Return fail if the rule failed. The rule has
#! stack effect ( input -- parse-result )
- pos get swap
- execute
-! drop f f <parse-result>
- [
- nip
- [ ast>> ] [ remaining>> ] bi
- input-from pos set
- ] [
- pos set
- fail
- ] if* ; inline
+ pos get swap execute process-rule-result ; inline
: memo ( pos rule -- memo-entry )
#! Return the result from the memo cache.
#! Store an entry in the cache
rule-parser input-cache set-at ;
-:: (grow-lr) ( r p m h -- )
- p pos set
- h involved-set>> clone h (>>eval-set)
- r eval-rule
- dup fail = pos get m pos>> <= or [
- drop
+: update-m ( ast m -- )
+ swap >>ans pos get >>pos drop ;
+
+: stop-growth? ( ast m -- ? )
+ [ failed? pos get ] dip
+ pos>> <= or ;
+
+: setup-growth ( h p -- )
+ pos set dup involved-set>> clone >>eval-set drop ;
+
+: (grow-lr) ( h p r m -- )
+ >r >r [ setup-growth ] 2keep r> r>
+ >r dup eval-rule r> swap
+ dup pick stop-growth? [
+ 4drop drop
] [
- m (>>ans)
- pos get m (>>pos)
- r p m h (grow-lr)
+ over update-m
+ (grow-lr)
] if ; inline
-:: grow-lr ( r p m h -- ast )
- h p heads get set-at
- r p m h (grow-lr)
- p heads get delete-at
- m pos>> pos set m ans>>
+: grow-lr ( h p r m -- ast )
+ >r >r [ heads get set-at ] 2keep r> r>
+ pick over >r >r (grow-lr) r> r>
+ swap heads get delete-at
+ dup pos>> pos set ans>>
; inline
:: (setup-lr) ( r l s -- )
|
h rule>> r eq? [
m ans>> seed>> m (>>ans)
- m ans>> fail = [
+ m ans>> failed? [
fail
] [
- r p m h grow-lr
+ h p r m grow-lr
] if
] [
m ans>> seed>>
r h eval-set>> member? [
h [ r swap remove ] change-eval-set drop
r eval-rule
- m (>>ans)
- pos get m (>>pos)
+ m update-m
m
] [
m
GENERIC: (compile) ( parser -- quot )
+: execute-parser ( word -- result )
+ pos get apply-rule dup failed? [
+ drop f
+ ] [
+ input-slice swap <parse-result>
+ ] if ; inline
-:: parser-body ( parser -- quot )
+: parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version
#! of the parser.
- [let* | rule [ gensym dup parser (compile) 0 1 <effect> define-declared dup parser "peg" set-word-prop ]
- |
- [
- rule pos get apply-rule dup fail = [
- drop f
- ] [
- input-slice swap <parse-result>
- ] if
- ]
- ] ;
+ gensym 2dup swap (compile) 0 1 <effect> define-declared swap dupd "peg" set-word-prop
+ [ execute-parser ] curry ;
: compiled-parser ( parser -- word )
#! Look to see if the given parser has been compiled.
gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
] if* ;
+SYMBOL: delayed
+
+: fixup-delayed ( -- )
+ #! Work through all delayed parsers and recompile their
+ #! words to have the correct bodies.
+ delayed get [
+ call compiled-parser 1quotation 0 1 <effect> define-declared
+ ] assoc-each ;
+
: compile ( parser -- word )
- [ compiled-parser ] with-compilation-unit ;
+ [
+ H{ } clone delayed [
+ compiled-parser fixup-delayed
+ ] with-variable
+ ] with-compilation-unit ;
: compiled-parse ( state word -- result )
swap [ execute ] with-packrat ; inline
#! For efficiency we memoize the quotation.
#! This way it is run only once and the
#! parser constructed once at run time.
- quot>> '[ @ compile ] { } { "word" } <effect> memoize-quot '[ @ execute ] ;
+ quot>> gensym [ delayed get set-at ] keep 1quotation ;
TUPLE: box-parser quot ;
PRIVATE>
: token ( string -- parser )
- token-parser construct-boa init-parser ;
+ token-parser boa init-parser ;
: satisfy ( quot -- parser )
- satisfy-parser construct-boa init-parser ;
+ satisfy-parser boa init-parser ;
: range ( min max -- parser )
- range-parser construct-boa init-parser ;
+ range-parser boa init-parser ;
: seq ( seq -- parser )
- seq-parser construct-boa init-parser ;
+ seq-parser boa init-parser ;
: 2seq ( parser1 parser2 -- parser )
2array seq ;
{ } make seq ; inline
: choice ( seq -- parser )
- choice-parser construct-boa init-parser ;
+ choice-parser boa init-parser ;
: 2choice ( parser1 parser2 -- parser )
2array choice ;
{ } make choice ; inline
: repeat0 ( parser -- parser )
- repeat0-parser construct-boa init-parser ;
+ repeat0-parser boa init-parser ;
: repeat1 ( parser -- parser )
- repeat1-parser construct-boa init-parser ;
+ repeat1-parser boa init-parser ;
: optional ( parser -- parser )
- optional-parser construct-boa init-parser ;
+ optional-parser boa init-parser ;
: semantic ( parser quot -- parser )
- semantic-parser construct-boa init-parser ;
+ semantic-parser boa init-parser ;
: ensure ( parser -- parser )
- ensure-parser construct-boa init-parser ;
+ ensure-parser boa init-parser ;
: ensure-not ( parser -- parser )
- ensure-not-parser construct-boa init-parser ;
+ ensure-not-parser boa init-parser ;
: action ( parser quot -- parser )
- action-parser construct-boa init-parser ;
+ action-parser boa init-parser ;
: sp ( parser -- parser )
- sp-parser construct-boa init-parser ;
+ sp-parser boa init-parser ;
: hide ( parser -- parser )
[ drop ignore ] action ;
: delay ( quot -- parser )
- delay-parser construct-boa init-parser ;
+ delay-parser boa init-parser ;
: box ( quot -- parser )
#! because a box has its quotation run at compile time
#! parse. The action adds an indirection with a parser type
#! that gets memoized and fixes this. Need to rethink how
#! to fix boxes so this isn't needed...
- box-parser
construct-boa next-id f <parser> over set-delegate [ ] action ;
+ box-parser boa next-id f <parser> over set-delegate [ ] action ;
: PEG:
(:) [
{ [ 1 over consonant-end? not ] [ drop f ] }
{ [ 2 over consonant-end? ] [ drop f ] }
{ [ 3 over consonant-end? not ] [ drop f ] }
- { [ t ] [ "wxy" last-is? not ] }
+ [ "wxy" last-is? not ]
} cond ;
: r ( str oldsuffix newsuffix -- str )
{ [ "ies" ?tail ] [ "i" append ] }
{ [ dup "ss" tail? ] [ ] }
{ [ "s" ?tail ] [ ] }
- { [ t ] [ ] }
+ [ ]
} cond
] when ;
{
{ [ "ed" ?tail ] [ -ed ] }
{ [ "ing" ?tail ] [ -ing ] }
- { [ t ] [ f ] }
+ [ f ]
} cond
] [ -ed/ing ]
}
- { [ t ] [ ] }
+ [ ]
} cond ;
: step1c ( str -- newstr )
{ [ "iviti" ?tail ] [ "iviti" "ive" r ] }
{ [ "biliti" ?tail ] [ "biliti" "ble" r ] }
{ [ "logi" ?tail ] [ "logi" "log" r ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: step3 ( str -- newstr )
{ [ "ical" ?tail ] [ "ical" "ic" r ] }
{ [ "ful" ?tail ] [ "ful" "" r ] }
{ [ "ness" ?tail ] [ "ness" "" r ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: -ion ( str -- newstr )
{ [ "ous" ?tail ] [ ] }
{ [ "ive" ?tail ] [ ] }
{ [ "ize" ?tail ] [ ] }
- { [ t ] [ ] }
+ [ ]
} cond dup consonant-seq 1 > [ nip ] [ drop ] if ;
: remove-e? ( str -- ? )
{ [ dup peek CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ butlast ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: step5 ( str -- newstr ) remove-e ll->l ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <processing-gadget> ( -- gadget )
- processing-gadget construct-empty
+ processing-gadget new
<frame-buffer> set-gadget-delegate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-
-USING: help.syntax help.markup ;
-
-IN: processing.gallery.bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: muon
-
- { $class-description
- "The muon is a colorful particle with an entangled friend."
- "It draws both itself and its horizontally symmetric partner."
- "A high range of speed and almost no speed decay allow the"
- "muon to reach the extents of the window, often forming rings"
- "where theta has decayed but speed remains stable. The result"
- "is color almost everywhere in the general direction of collision,"
- "stabilized into fuzzy rings." } ;
-
-HELP: quark
-
- { $class-description
- "The quark draws as a translucent black. Their large numbers"
- "create fields of blackness overwritten only by the glowing shadows of "
- "Hadrons. "
- "quarks are allowed to accelerate away with speed decay values above 1.0. "
- "Each quark has an entangled friend. Both particles are drawn identically,"
- "mirrored along the y-axis." } ;
-
-HELP: hadron
-
- { $class-description
- "Hadrons collide from totally random directions. "
- "Those hadrons that do not exit the drawing area, "
- "tend to stabilize into perfect circular orbits. "
- "Each hadron draws with a slight glowing emboss. "
- "The hadron itself is not drawn." } ;
-
-HELP: axion
-
- { $class-description
- "The axion particle draws a bold black path. Axions exist "
- "in a slightly higher dimension and as such are drawn with "
- "elevated embossed shadows. Axions are quick to stabilize "
- "and fall into single pixel orbits axions automatically "
- "recollide themselves after stabilizing." } ;
-
-{ muon quark hadron axion } related-words
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber" "Bubble Chamber"
-
- { $subsection "bubble-chamber-introduction" }
- { $subsection "bubble-chamber-particles" }
- { $subsection "bubble-chamber-author" }
- { $subsection "bubble-chamber-running" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-introduction" "Introduction"
-
-"The Bubble Chamber is a generative painting system of imaginary "
-"colliding particles. A single super-massive collision produces a "
-"discrete universe of four particle types. Particles draw their "
-"positions over time as pixel exposures. " ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-particles" "Particles"
-
-"Four types of particles exist. The behavior and graphic appearance of "
-"each particle type is unique."
-
- { $subsection muon }
- { $subsection quark }
- { $subsection hadron }
- { $subsection axion } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-author" "Author"
-
- "Bubble Chamber was created by Jared Tarbell. "
- "It was originally implemented in Processing. "
- "It was ported to Factor by Eduardo Cavazos. "
- "The original work is on display here: "
- { $url
- "http://www.complexification.net/gallery/machines/bubblechamber/" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-running" "How to use"
-
- "After you run the vocabulary, a window will appear. Click the "
- "mouse in a random area to fire 11 particles of each type. "
- "Another way to fire particles is to press the "
- "spacebar. This fires all the particles." ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel namespaces sequences combinators arrays threads
-
- math
- math.libm
- math.vectors
- math.ranges
- math.constants
- math.functions
- math.points
-
- ui
- ui.gadgets
-
- random accessors multi-methods
- combinators.cleave
- vars locals
-
- newfx
-
- processing
- processing.gadget
- processing.color ;
-
-IN: processing.gallery.bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dim ( -- dim ) 1000 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: collision-theta
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: boom
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VARS: particles muons quarks hadrons axions ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: good-colors ( -- seq )
- {
- T{ rgba f 0.23 0.14 0.17 1 }
- T{ rgba f 0.23 0.14 0.15 1 }
- T{ rgba f 0.21 0.14 0.15 1 }
- T{ rgba f 0.51 0.39 0.33 1 }
- T{ rgba f 0.49 0.33 0.20 1 }
- T{ rgba f 0.55 0.45 0.32 1 }
- T{ rgba f 0.69 0.63 0.51 1 }
- T{ rgba f 0.64 0.39 0.18 1 }
- T{ rgba f 0.73 0.42 0.20 1 }
- T{ rgba f 0.71 0.45 0.29 1 }
- T{ rgba f 0.79 0.45 0.22 1 }
- T{ rgba f 0.82 0.56 0.34 1 }
- T{ rgba f 0.88 0.72 0.49 1 }
- T{ rgba f 0.85 0.69 0.40 1 }
- T{ rgba f 0.96 0.92 0.75 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.85 0.82 0.69 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.82 0.82 0.79 1 }
- T{ rgba f 0.65 0.69 0.67 1 }
- T{ rgba f 0.53 0.60 0.55 1 }
- T{ rgba f 0.57 0.53 0.68 1 }
- T{ rgba f 0.47 0.42 0.56 1 }
- } ;
-
-: good-color ( i -- color ) good-colors nth-of ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x ( particle -- x ) pos>> first ;
-: y ( particle -- x ) pos>> second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: out-of-bounds? ( particle -- particle ? )
- dup
- { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
- or or or ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: initialize-particle ( particle -- particle )
-
- 0 0 {2} >>pos
- 0 0 {2} >>vel
-
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- 0 0 0 1 <rgba> >>myc
- 0 0 0 1 <rgba> >>mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: collide ( particle -- )
-GENERIC: move ( particle -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: muon < particle ;
-
-: <muon> ( -- muon ) muon construct-empty initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { muon }
-
- dim 2 / dup 2array >>pos
- 2 32 [a,b] random >>speed
- 0.0001 0.001 2random >>speed-d
-
- collision-theta> -0.1 0.1 2random + >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- [ dup theta-dd>> abs 0.001 < ]
- [ -0.1 0.1 2random >>theta-dd ]
- [ ]
- while
-
- dup theta>> pi +
- 2 pi * /
- good-colors length 1 - *
- [ ] [ good-colors length >= ] [ 0 < ] tri or
- [ drop ]
- [
- [ good-color >>myc ]
- [ good-colors length swap - 1 - good-color >>mya ]
- bi
- ]
- if
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { muon }
-
- dup myc>> 0.16 >>alpha stroke
- dup pos>> point
-
- dup mya>> 0.16 >>alpha stroke
- dup pos>> first2 >r dim swap - r> 2array point
-
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- move-by
-
- [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
- [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
- [ ] [ speed>> ] [ speed-d>> ] tri - >>speed
-
- out-of-bounds?
- [ collide ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: quark < particle ;
-
-: <quark> ( -- quark ) quark construct-empty initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { quark }
-
- dim 2 / dup 2array >>pos
- collision-theta> -0.11 0.11 2random + >>theta
- 0.5 3.0 2random >>speed
-
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ dup theta-dd>> abs 0.00001 < ]
- [ -0.001 0.001 2random >>theta-dd ]
- [ ]
- while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { quark }
-
- dup myc>> 0.13 >>alpha stroke
- dup pos>> point
-
- dup pos>> first2 >r dim swap - r> 2array point
-
- [ ] [ vel>> ] bi move-by
-
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel
-
- [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
- [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
- [ ] [ speed>> ] [ speed-d>> ] tri * >>speed
-
- ! 1000 random 997 >
- 3/1000 chance
- [
- dup speed>> neg >>speed
- 2 over speed-d>> - >>speed-d
- ]
- when
-
- out-of-bounds?
- [ collide ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: hadron < particle ;
-
-: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { hadron }
-
- dim 2 / dup 2array >>pos
- 2 pi * 1random >>theta
- 0.5 3.5 2random >>speed
-
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ dup theta-dd>> abs 0.00001 < ]
- [ -0.001 0.001 2random >>theta-dd ]
- [ ]
- while
-
- 0 1 0 <rgb> >>myc
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { hadron }
-
- { 1 0.11 } stroke
- dup pos>> 1 v-y point
-
- { 0 0.11 } stroke
- dup pos>> 1 v+y point
-
- dup vel>> move-by
-
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel
-
- [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
- [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
- [ ] [ speed>> ] [ speed-d>> ] tri * >>speed
-
- ! 1000 random 997 >
- 3/1000 chance
- [
- 1.0 >>speed-d
- 0.00001 >>theta-dd
-
- ! 100 random 70 >
- 30/100 chance
- [
- dim 2 / dup 2array >>pos
- dup collide
- ]
- when
- ]
- when
-
- out-of-bounds?
- [ collide ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: axion < particle ;
-
-: <axion> ( -- axion ) axion construct-empty initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { axion }
-
- dim 2 / dup 2array >>pos
- 2 pi * 1random >>theta
- 1.0 6.0 2random >>speed
-
- 0.998 1.000 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ dup theta-dd>> abs 0.00001 < ]
- [ -0.001 0.001 2random >>theta-dd ]
- [ ]
- while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { axion }
-
- { 0.06 0.59 } stroke
- dup pos>> point
-
- 1 4 [a,b]
- [| dy |
- 1 30 dy 6 * - 255.0 / 2array stroke
- dup pos>> 0 dy neg 2array v+ point
- ] with-locals
- each
-
- 1 4 [a,b]
- [| dy |
- 0 30 dy 6 * - 255.0 / 2array stroke
- dup pos>> dy v+y point
- ] with-locals
- each
-
- dup vel>> move-by
-
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel
-
- [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
- [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
- [ ] [ speed>> ] [ speed-d>> ] tri * >>speed
-
- [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
-
- ! 1000 random 996 >
- 4/1000 chance
- [
- dup speed>> neg >>speed
- dup speed-d>> neg 2 + >>speed-d
-
- ! 100 random 30 >
- 70/100 chance
- [
- dim 2 / dup 2array >>pos
- collide
- ]
- [ drop ]
- if
- ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : draw ( -- )
-
-! boom>
-! [ particles> [ move ] each ]
-! when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-all ( -- )
-
- 2 pi * 1random >collision-theta
-
- particles> [ collide ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-one ( -- )
-
- dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
-
- hadrons> random collide
- quarks> random collide
- muons> random collide ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse-pressed ( -- )
- boom on
- 1 background ! kludge
- 11 [ drop collide-one ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: key-released ( -- )
- key " " =
- [
- boom on
- 1 background
- collide-all
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bubble-chamber ( -- )
-
- 1000 1000 size*
-
- [
- 1 background
- no-stroke
-
- 1789 [ drop <muon> ] map >muons
- 1300 [ drop <quark> ] map >quarks
- 1000 [ drop <hadron> ] map >hadrons
- 111 [ drop <axion> ] map >axions
-
- muons> quarks> hadrons> axions> 3append append >particles
-
- collide-one
- ] setup
-
- [
- boom>
- [ particles> [ move ] each ]
- when
- ] draw
-
- [ mouse-pressed ] button-down
- [ key-released ] key-up
-
- ;
-
-: go ( -- ) [ bubble-chamber run ] with-ui ;
-
-MAIN: go
\ No newline at end of file
combinators
combinators.lib
combinators.cleave
- rewrite-closures fry accessors
+ rewrite-closures fry accessors newfx
processing.color
processing.gadget ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
+
+: at-fraction ( seq fraction -- val ) over length 1- * at ;
+
+: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
VAR: fill-color
VAR: stroke-color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-VAR: slate
+! VAR: slate
VAR: loop-flag
! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting ;
+ sorting sets ;
IN: project-euler.004
! http://projecteuler.net/index.php?section=problems&id=4
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting ;
+ sorting sets ;
IN: project-euler.023
! http://projecteuler.net/index.php?section=problems&id=23
PRIVATE>
: euler023 ( -- answer )
- 20161 abundants-upto possible-sums source-023 seq-diff sum ;
+ 20161 abundants-upto possible-sums source-023 diff sum ;
! TODO: solution is still too slow, although it takes under 1 minute
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math.functions math.ranges project-euler.common
- sequences ;
+ sequences sets ;
IN: project-euler.029
! http://projecteuler.net/index.php?section=problems&id=29
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.functions
- math.parser math.ranges project-euler.common sequences ;
+ math.parser math.ranges project-euler.common sequences sets ;
IN: project-euler.032
! http://projecteuler.net/index.php?section=problems&id=32
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.combinatorics math.parser math.primes
- project-euler.common sequences sequences.lib ;
+ project-euler.common sequences sequences.lib sets ;
IN: project-euler.035
! http://projecteuler.net/index.php?section=problems&id=35
: possible? ( seq -- ? )
dup length 1 > [
- dup { 0 2 4 5 6 8 } swap seq-diff =
+ dup { 0 2 4 5 6 8 } swap diff =
] [
drop t
] if ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser
- math.ranges project-euler.common sequences sequences.lib sorting ;
+ math.ranges project-euler.common sequences sequences.lib sorting sets ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
[ unclip 1 head prefix concat ] map [ all-unique? ] subset ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 seq-diff first prefix ;
+ dup natural-sort 10 diff first prefix ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
math.parser namespaces sequences sequences.lib sequences.private sorting
- splitting strings ;
+ splitting strings sets ;
IN: project-euler.059
! http://projecteuler.net/index.php?section=problems&id=59
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables io.files kernel math math.parser namespaces
-io.encodings.ascii sequences ;
+io.encodings.ascii sequences sets ;
IN: project-euler.079
! http://projecteuler.net/index.php?section=problems&id=79
] { } make ;
: find-source ( seq -- elt )
- dup values swap keys [ prune ] bi@ seq-diff
+ dup values swap keys [ prune ] bi@ diff
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq )
: topological-sort ( seq -- seq )
[ [ (topological-sort) ] { } make ] keep
- concat prune dupd seq-diff append ;
+ concat prune dupd diff append ;
: euler079 ( -- answer )
source-079 >edges topological-sort 10 digits>integer ;
! [ euler079 ] 100 ave-time
! 2 ms run / 0 ms GC ave time - 100 trials
-! TODO: prune and seq-diff are relatively slow; topological sort could be
+! TODO: prune and diff are relatively slow; topological sort could be
! cleaned up and generalized much better, but it works for this problem
MAIN: euler079
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
- { [ t ] [ 2/ [ fn ] [ 1- fn + ] bi + ] }
+ [ 2/ [ fn ] [ 1- fn ] bi + ]
} cond ;
: euler169 ( -- result )
{
{ [ dup integer? ] [ 1- 0 add-bits ] }
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
- { [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
+ [ [ 1 mod compute ] 2keep >integer 0 add-bits ]
} cond ;
PRIVATE>
--- /dev/null
+USING: circular disjoint-set kernel math math.ranges
+ sequences sequences.lib ;
+IN: project-euler.186
+
+: (generator) ( k -- n )
+ dup sq 300007 * 200003 - * 100003 + 1000000 rem ;
+
+: <generator> ( -- lag )
+ 55 [1,b] [ (generator) ] map <circular> ;
+
+: advance ( lag -- )
+ [ { 0 31 } nths sum 1000000 rem ] keep push-circular ;
+
+: next ( lag -- n )
+ [ first ] [ advance ] bi ;
+
+: 2unless? ( x y ?quot quot -- )
+ >r 2keep rot [ 2drop ] r> if ; inline
+
+: (p186) ( generator counter unionfind -- counter )
+ 524287 over equiv-set-size 990000 <
+ [
+ pick [ next ] [ next ] bi
+ [ = ] [
+ pick equate
+ [ 1+ ] dip
+ ] 2unless? (p186)
+ ] [
+ drop nip
+ ] if ;
+
+: euler186 ( -- n )
+ <generator> 0 1000000 <disjoint-set> (p186) ;
+
+MAIN: euler186
Aaron Schaefer
+Eric Mertens
TUPLE: promise quot forced? value ;
: promise ( quot -- promise )
- f f \ promise construct-boa ;
+ f f \ promise boa ;
: promise-with ( value quot -- promise )
curry promise ;
{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
{ $examples { $code
"QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ;
+
+HELP: QUALIFIED-WITH:
+{ $syntax "QUALIFIED-WITH: vocab prefix" }
+{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses the specified prefix." }
+{ $examples { $code
+ "QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ;
+
+HELP: FROM:
+{ $syntax "FROM: vocab => words ... ;" }
+{ $description "Imports the specified words from vocab." }
+{ $examples { $code
+ "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
+
+HELP: EXCLUDE:
+{ $syntax "EXCLUDE: vocab => words ... ;" }
+{ $description "Imports everything from vocab excluding the specified words" }
+{ $examples { $code
+ "EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
+
+HELP: RENAME:
+{ $syntax "RENAME: word vocab => newname " }
+{ $description "Imports word from vocab, but renamed to newname." }
+{ $examples { $code
+ "RENAME: + math => -"
+ "2 3 - ! => 5" } } ;
+
: x 1 ;
IN: bar
: x 2 ;
+IN: baz
+: x 3 ;
+
QUALIFIED: foo
QUALIFIED: bar
-[ 1 2 2 ] [ foo:x bar:x x ] unit-test
+[ 1 2 3 ] [ foo:x bar:x x ] unit-test
+
+QUALIFIED-WITH: bar p
+[ 2 ] [ p:x ] unit-test
+
+RENAME: x baz => y
+[ 3 ] [ y ] unit-test
+
+FROM: baz => x ;
+[ 3 ] [ x ] unit-test
+
+EXCLUDE: bar => x ;
+[ 3 ] [ x ] unit-test
+
-USING: kernel sequences assocs parser vocabs namespaces
-vocabs.loader ;
+USING: kernel sequences assocs hashtables parser vocabs words namespaces
+vocabs.loader debugger sets ;
IN: qualified
-: define-qualified ( vocab-name -- )
- dup require
- dup vocab-words swap CHAR: : suffix
+: define-qualified ( vocab-name prefix-name -- )
+ [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
[ -rot >r append r> ] curry assoc-map
use get push ;
-
: QUALIFIED:
- scan define-qualified ; parsing
+ #! Syntax: QUALIFIED: vocab
+ scan dup define-qualified ; parsing
+
+: QUALIFIED-WITH:
+ #! Syntax: QUALIFIED-WITH: vocab prefix
+ scan scan define-qualified ; parsing
+
+: expect=> scan "=>" assert= ;
+
+: partial-vocab ( words name -- assoc )
+ dupd [
+ lookup [ "No such word: " swap append throw ] unless*
+ ] curry map zip ;
+
+: partial-vocab-ignoring ( words name -- assoc )
+ [ vocab-words keys diff ] keep partial-vocab ;
+
+: EXCLUDE:
+ #! Syntax: EXCLUDE: vocab => words ... ;
+ scan expect=>
+ ";" parse-tokens swap partial-vocab-ignoring use get push ; parsing
+
+: FROM:
+ #! Syntax: FROM: vocab => words... ;
+ scan expect=>
+ ";" parse-tokens swap partial-vocab use get push ; parsing
+
+: RENAME:
+ #! Syntax: RENAME: word vocab => newname
+ scan scan lookup [ "No such word" throw ] unless*
+ expect=>
+ scan associate use get push ; parsing
+
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math.constants ;
-IN: random-tester.databank
-
-: databank ( -- array )
- {
- ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
- pi 1/0. -1/0. 0/0. [ ]
- f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
- C{ 2 2 } C{ 1/0. 1/0. }
- } ;
-
+++ /dev/null
-USING: compiler continuations io kernel math namespaces
-prettyprint quotations random sequences vectors
-compiler.units ;
-USING: random-tester.databank random-tester.safe-words ;
-IN: random-tester
-
-SYMBOL: errored
-SYMBOL: before
-SYMBOL: after
-SYMBOL: quot
-TUPLE: random-tester-error ;
-
-: setup-test ( #data #code -- data... quot )
- #! Variable stack effect
- >r [ databank random ] times r>
- [ drop \ safe-words get random ] map >quotation ;
-
-: test-compiler ! ( data... quot -- ... )
- errored off
- dup quot set
- datastack 1 head* before set
- [ call ] [ drop ] recover
- datastack after set
- clear
- before get [ ] each
- quot get [ compile-call ] [ errored on ] recover ;
-
-: do-test ! ( data... quot -- )
- .s flush test-compiler
- errored get [
- datastack after get 2dup = [
- 2drop
- ] [
- [ . ] each
- "--" print
- [ . ] each
- quot get .
- random-tester-error construct-empty throw
- ] if
- ] unless clear ;
-
-: random-test1 ( #data #code -- )
- setup-test do-test ;
-
-: random-test2 ( -- )
- 3 2 setup-test do-test ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math sequences namespaces hashtables words
-arrays parser compiler syntax io prettyprint optimizer
-random math.constants math.functions layouts random-tester.utils ;
-IN: random-tester
-
-! Tweak me
-: max-length 15 ; inline
-: max-value 1000000000 ; inline
-
-! varying bit-length random number
-: random-bits ( n -- int )
- random 2 swap ^ random ;
-
-: random-seq ( -- seq )
- { [ ] { } V{ } "" } random
- [ max-length random [ max-value random , ] times ] swap make ;
-
-: random-string
- [ max-length random [ max-value random , ] times ] "" make ;
-
-: special-integers ( -- seq ) \ special-integers get ;
-[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
-{ } make \ special-integers set-global
-: special-floats ( -- seq ) \ special-floats get ;
-[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
-{ } make \ special-floats set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
-[
- { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
- e , e neg , pi , pi neg ,
- 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
- pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
- e neg e neg rect> , e e rect> ,
-] { } make \ special-complexes set-global
-
-: random-fixnum ( -- fixnum )
- most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
-
-: random-bignum ( -- bignum )
- 400 random-bits first-bignum + 50% [ neg ] when ;
-
-: random-integer ( -- n )
- 50% [
- random-fixnum
- ] [
- 50% [ random-bignum ] [ special-integers get random ] if
- ] if ;
-
-: random-positive-integer ( -- int )
- random-integer dup 0 < [
- neg
- ] [
- dup 0 = [ 1 + ] when
- ] if ;
-
-: random-ratio ( -- ratio )
- 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
-
-: random-float ( -- float )
- 50% [ random-ratio ] [ special-floats get random ] if
- 50%
- [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
- >float ;
-
-: random-number ( -- number )
- {
- [ random-integer ]
- [ random-ratio ]
- [ random-float ]
- } do-one ;
-
-: random-complex ( -- C )
- random-number random-number rect> ;
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel namespaces sequences sorting vocabs ;
-USING: arrays assocs generic hashtables math math.intervals math.parser math.functions refs shuffle vectors words ;
-IN: random-tester.safe-words
-
-: ?-words
- {
- delegate
-
- /f
-
- bits>float bits>double
- float>bits double>bits
-
- >bignum >boolean >fixnum >float
-
- array? integer? complex? value-ref? ref? key-ref?
- interval? number?
- wrapper? tuple?
- [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
- 2^ not
- ! arrays
- resize-array <array>
- ! assocs
- (assoc-stack)
- new-assoc
- assoc-like
- <hashtable>
- all-integers? (all-integers?) ! hangs?
- assoc-push-if
-
- (clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
- } ;
-
-: bignum-words
- {
- next-power-of-2 (next-power-of-2)
- times
- hashcode hashcode*
- } ;
-
-: initialization-words
- {
- init-namespaces
- } ;
-
-: stack-words
- {
- dup
- drop 2drop 3drop
- roll -roll 2swap
-
- >r r>
- } ;
-
-: stateful-words
- {
- counter
- gensym
- } ;
-
-: foo-words
- {
- set-retainstack
- retainstack callstack
- datastack
- callstack>array
- } ;
-
-: exit-words
- {
- call-clear die
- } ;
-
-: bad-words ( -- array )
- [
- ?-words %
- bignum-words %
- initialization-words %
- stack-words %
- stateful-words %
- exit-words %
- foo-words %
- ] { } make ;
-
-: safe-words ( -- array )
- bad-words {
- "alists" "arrays" "assocs" ! "bit-arrays" "byte-arrays"
- ! "classes" "combinators" "compiler" "continuations"
- ! "core-foundation" "definitions" "documents"
- ! "float-arrays" "generic" "graphs" "growable"
- "hashtables" ! io.*
- "kernel" "math"
- "math.bitfields" "math.complex" "math.constants" "math.floats"
- "math.functions" "math.integers" "math.intervals" "math.libm"
- "math.parser" "math.ratios" "math.vectors"
- ! "namespaces" "quotations" "sbufs"
- ! "queues" "strings" "sequences"
- "vectors"
- ! "words"
- } [ words ] map concat seq-diff natural-sort ;
-
-safe-words \ safe-words set-global
-
-! foo dup (clone) = .
-! foo dup clone = .
-! f [ byte-array>bignum assoc-clone-like ] compile-1
-! 2 3.14 [ construct-empty number= ] compile-1
-! 3.14 [ <vector> assoc? ] compile-1
-! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: arrays assocs combinators.lib continuations kernel
-math math.functions memoize namespaces quotations random sequences
-sequences.private shuffle ;
-IN: random-tester.utils
-
-: %chance ( n -- ? )
- 100 random > ;
-
-: 10% ( -- ? ) 10 %chance ;
-: 20% ( -- ? ) 20 %chance ;
-: 30% ( -- ? ) 30 %chance ;
-: 40% ( -- ? ) 40 %chance ;
-: 50% ( -- ? ) 50 %chance ;
-: 60% ( -- ? ) 60 %chance ;
-: 70% ( -- ? ) 70 %chance ;
-: 80% ( -- ? ) 80 %chance ;
-: 90% ( -- ? ) 90 %chance ;
-
-: call-if ( quot ? -- ) swap when ; inline
-
-: with-10% ( quot -- ) 10% call-if ; inline
-: with-20% ( quot -- ) 20% call-if ; inline
-: with-30% ( quot -- ) 30% call-if ; inline
-: with-40% ( quot -- ) 40% call-if ; inline
-: with-50% ( quot -- ) 50% call-if ; inline
-: with-60% ( quot -- ) 60% call-if ; inline
-: with-70% ( quot -- ) 70% call-if ; inline
-: with-80% ( quot -- ) 80% call-if ; inline
-: with-90% ( quot -- ) 90% call-if ; inline
-
-: random-key keys random ;
-: random-value [ random-key ] keep at ;
-
-: do-one ( seq -- ) random call ; inline
--- /dev/null
+USING: kernel math tools.test namespaces random
+random.blum-blum-shub ;
+IN: blum-blum-shub.tests
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } random-32*
+] unit-test
+
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } [
+ 32 random-bits
+ ] with-random
+] unit-test
+
+[ 5726770047455156646 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } [
+ 64 random-bits
+ ] with-random
+] unit-test
+
+[ 3716213681 ]
+[
+ 100 T{ blum-blum-shub f 200352954495 846054538649 } tuck [
+ random-32* drop
+ ] curry times
+ random-32*
+] unit-test
math.functions accessors random ;
IN: random.blum-blum-shub
-! TODO: take (log log M) bits instead of 1 bit
-! Blum Blum Shub, M = pq
+! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
+! return low bit of x+1
TUPLE: blum-blum-shub x n ;
-C: <blum-blum-shub> blum-blum-shub
+<PRIVATE
: generate-bbs-primes ( numbits -- p q )
- #! two primes congruent to 3 (mod 4)
[ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
-IN: crypto
: <blum-blum-shub> ( numbits -- blum-blum-shub )
- #! returns a Blum-Blum-Shub tuple
generate-bbs-primes *
[ find-relative-prime ] keep
- blum-blum-shub construct-boa ;
-
-! 256 make-bbs blum-blum-shub set-global
+ blum-blum-shub boa ;
: next-bbs-bit ( bbs -- bit )
- #! x = x^2 mod n, return low bit of calculated x
- [ [ x>> 2 ] [ n>> ] bi ^mod ]
- [ [ >>x ] keep x>> 1 bitand ] bi ;
+ [ [ x>> 2 ] [ n>> ] bi ^mod ] keep
+ over >>x drop 1 bitand ;
-IN: crypto
-! : random ( n -- n )
- ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256
- ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
+PRIVATE>
M: blum-blum-shub random-32* ( bbs -- r )
- ;
+ 0 32 rot
+ [ next-bbs-bit swap 1 shift bitor ] curry times ;
PRIVATE>
: <mersenne-twister> ( seed -- obj )
- init-mt-seq 0 mersenne-twister construct-boa
+ init-mt-seq 0 mersenne-twister boa
dup mt-generate ;
M: mersenne-twister seed-random ( mt seed -- )
inspector ;
IN: random
-SYMBOL: insecure-random-generator
+SYMBOL: system-random-generator
SYMBOL: secure-random-generator
SYMBOL: random-generator
: with-random ( tuple quot -- )
random-generator swap with-variable ; inline
+: with-system-random ( quot -- )
+ system-random-generator get swap with-random ; inline
+
: with-secure-random ( quot -- )
- >r secure-random-generator get r> with-random ; inline
+ secure-random-generator get swap with-random ; inline
os openbsd? [
[
"/dev/srandom" <unix-random> secure-random-generator set-global
- "/dev/prandom" <unix-random> insecure-random-generator set-global
+ "/dev/arandom" <unix-random> system-random-generator set-global
] "random.unix" add-init-hook
] [
[
"/dev/random" <unix-random> secure-random-generator set-global
- "/dev/urandom" <unix-random> insecure-random-generator set-global
+ "/dev/urandom" <unix-random> system-random-generator set-global
] "random.unix" add-init-hook
] if
[
MS_DEF_PROV
- PROV_RSA_FULL <windows-rng> insecure-random-generator set-global
+ PROV_RSA_FULL <windows-rng> system-random-generator set-global
MS_STRONG_PROV
PROV_RSA_FULL <windows-rng> secure-random-generator set-global
ignore-case? [
dup 'regexp' just parse-1
] with-variable
- ] keep regexp construct-boa ;
+ ] keep regexp boa ;
: do-ignore-case ( string regexp -- string regexp )
dup regexp-ignore-case? [ >r >upper r> ] when ;
noise first2 {\r
{ [ over 4 <= ] [ >r drop 0 r> ] }\r
{ [ over 15 >= ] [ >r 2 * r> ] }\r
- { [ t ] [ ] }\r
+ [ ]\r
} cond\r
{\r
! short words are easier to read\r
{ [ dup 25 >= ] [ >r 2 * r> 20 max ] }\r
{ [ dup 20 >= ] [ >r 5/3 * r> ] }\r
{ [ dup 15 >= ] [ >r 3/2 * r> ] }\r
- { [ t ] [ ] }\r
+ [ ]\r
} cond noise-factor ;\r
\r
GENERIC: word-noise-factor ( word -- factor )\r
dup 1 3999 between? [
drop
] [
- roman-range-error construct-boa throw
+ roman-range-error boa throw
] if ;
: roman<= ( ch1 ch2 -- ? )
{
{ [ dup letter? ] [ CHAR: a rotate ] }
{ [ dup LETTER? ] [ CHAR: A rotate ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: rot13 ( string -- string ) [ rot-letter ] map ;
arc construct-empty swap >>relation swap >>object swap >>subject ;
: <id-arc> ( id -- arc )
- arc construct-empty swap >>id ;
+ arc new swap >>id ;
: delete-arc ( arc -- ) delete-tuple ;
: ?nth* ( n seq -- elt/f ? )
2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
-: nths ( indices seq -- seq' )
- [ swap nth ] with map ;
+: nths ( seq indices -- seq' )
+ swap [ nth ] curry map ;
: replace ( str oldseq newseq -- str' )
zip >hashtable substitute ;
--- /dev/null
+Non-core sequence words
: map-next ( seq quot -- newseq )
! quot: next-elt elt -- newelt
- over dup length swap new >r
+ over dup length swap new-sequence >r
iterate-seq [ (map-next) ] 2curry
r> [ collect ] keep ; inline
--- /dev/null
+Iteration with access to next element
read1 {
{ [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
{ [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
- { [ t ] [ read be> ] }
+ [ read be> ]
} cond ;
: serialize-shared ( obj quot -- )
{
{ [ dup t eq? ] [ serialize-true ] }
{ [ dup word-vocabulary not ] [ serialize-gensym ] }
- { [ t ] [ serialize-word ] }
+ [ serialize-word ]
} cond ;
M: wrapper (serialize) ( obj -- )
(deserialize) <wrapper> ;
:: (deserialize-seq) ( exemplar quot -- seq )
- deserialize-cell exemplar new
+ deserialize-cell exemplar new-sequence
[ intern-object ]
[ dup [ drop quot call ] change-each ] bi ; inline
: deserialize-tuple ( -- array )
#! Ugly because we have to intern the tuple before reading
#! slots
- (deserialize) construct-empty
+ (deserialize) new
[ intern-object ]
[
[ (deserialize) ]
"220 OK\r\n" write flush t
] }
{ [ data-mode get ] [ dup global [ print ] bind t ] }
- { [ t ] [
+ [
"500 ERROR\r\n" write flush t
- ] }
+ ]
} cond nip [ process ] when ;
: mock-smtp-server ( port -- )
"Starting SMTP server on port " write dup . flush
"127.0.0.1" swap <inet4> ascii <server> [
- accept [
+ accept drop [
1 minutes stdio get set-timeout
"220 hello\r\n" write flush
process
USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
math.parser random system calendar io.encodings.ascii
-calendar.format accessors ;
+calendar.format accessors sets ;
IN: smtp
SYMBOL: smtp-domain
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
- dup "\r\n>" seq-intersect empty?
+ dup "\r\n>" intersect empty?
[ "Bad e-mail address: " prepend throw ] unless ;
: mail-from ( fromaddr -- )
{ [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
{ [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
{ [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
- { [ t ] [ "unknown error" throw ] }
+ [ "unknown error" throw ]
} cond ;
: multiline? ( response -- boolean )
: get-ok ( -- ) receive-response check-response ;
: validate-header ( string -- string' )
- dup "\r\n" seq-intersect empty?
+ dup "\r\n" intersect empty?
[ "Invalid header string: " prepend throw ] unless ;
: write-header ( key value -- )
message-id "Message-Id" set-header ;
: <email> ( -- email )
- email construct-empty
+ email new
H{ } clone >>headers ;
: send-email ( email -- )
{ [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] }
{ [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] }
{ [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] }
- { [ t ] [ 2drop white ] }
+ [ 2drop white ]
} cond ;
: plot-bitmap-bits ( bitmap point byte bit -- )
TUPLE: state place data ;
TUPLE: missing-state ;
-: missing-state \ missing-state construct-empty throw ;
+: missing-state \ missing-state new throw ;
M: missing-state error.
drop "Missing state" print ;
! * Errors\r
TUPLE: parsing-error line column ;\r
: <parsing-error> ( -- parsing-error )\r
- get-line get-column parsing-error construct-boa ;\r
+ get-line get-column parsing-error boa ;\r
\r
: construct-parsing-error ( ... slots class -- error )\r
construct <parsing-error> over set-delegate ; inline\r
#! advance spot to after the substring.\r
[ [\r
dup slip swap dup [ get-char , ] unless\r
- ] skip-until ] "" make nip ;\r
+ ] skip-until ] "" make nip ; inline\r
\r
: rest ( -- string )\r
[ f ] take-until ;\r
{ [ 3dup nip row-contains? ] [ 3drop ] }
{ [ 3dup drop col-contains? ] [ 3drop ] }
{ [ 3dup box-contains? ] [ 3drop ] }
- { [ t ] [ assume ] }
+ [ assume ]
} cond ;
: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
{ [ over 9 = ] [ >r drop 0 r> 1+ search ] }
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
{ [ 2dup board> ] [ >r 1+ r> search ] }
- { [ t ] [ solve ] }
+ [ solve ]
} cond ;
: sudoku ( board -- )
USING: combinators io io.files io.streams.duplex
io.streams.string kernel math math.parser continuations
namespaces pack prettyprint sequences strings system
-hexdump io.encodings.binary ;
+hexdump io.encodings.binary inspector accessors ;
IN: tar
: zero-checksum 256 ;
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-: <tar-header> ( -- obj ) tar-header construct-empty ;
+: <tar-header> ( -- obj ) tar-header new ;
: tar-trim ( seq -- newseq )
[ "\0 " member? ] trim ;
: parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [
2drop
- \ tar-header construct-empty
+ \ tar-header new
0 over set-tar-header-size
0 over set-tar-header-checksum
] [
[ read-tar-header ] with-string-reader
[ tar-header-checksum = [
- \ checksum-error construct-empty throw
+ \ checksum-error new throw
] unless
] keep
] if ;
-TUPLE: unknown-typeflag str ;
-: <unknown-typeflag> ( ch -- obj )
- 1string \ unknown-typeflag construct-boa ;
-
-TUPLE: unimplemented-typeflag header ;
-: <unimplemented-typeflag> ( header -- obj )
- global [ "Unimplemented typeflag: " print dup . flush ] bind
- tar-header-typeflag
- 1string \ unimplemented-typeflag construct-boa ;
+ERROR: unknown-typeflag ch ;
+M: unknown-typeflag summary ( obj -- str )
+ ch>> 1string
+ "Unknown typeflag: " prepend ;
: tar-append-path ( path -- newpath )
base-dir get prepend-path ;
! Normal file
: typeflag-0
- tar-header-name tar-append-path binary <file-writer>
+ name>> tar-append-path binary <file-writer>
[ read-data-blocks ] keep dispose ;
! Hard link
-: typeflag-1 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-1 ( header -- ) unknown-typeflag ;
! Symlink
-: typeflag-2 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-2 ( header -- ) unknown-typeflag ;
! character special
-: typeflag-3 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-3 ( header -- ) unknown-typeflag ;
! Block special
-: typeflag-4 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-4 ( header -- ) unknown-typeflag ;
! Directory
: typeflag-5 ( header -- )
tar-header-name tar-append-path make-directories ;
! FIFO
-: typeflag-6 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-6 ( header -- ) unknown-typeflag ;
! Contiguous file
-: typeflag-7 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-7 ( header -- ) unknown-typeflag ;
! Global extended header
-: typeflag-8 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-8 ( header -- ) unknown-typeflag ;
! Extended header
-: typeflag-9 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-9 ( header -- ) unknown-typeflag ;
! Global POSIX header
-: typeflag-g ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-g ( header -- ) unknown-typeflag ;
! Extended POSIX header
-: typeflag-x ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-x ( header -- ) unknown-typeflag ;
! Solaris access control list
-: typeflag-A ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-A ( header -- ) unknown-typeflag ;
! GNU dumpdir
-: typeflag-D ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-D ( header -- ) unknown-typeflag ;
! Solaris extended attribute file
-: typeflag-E ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-E ( header -- ) unknown-typeflag ;
! Inode metadata
-: typeflag-I ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-I ( header -- ) unknown-typeflag ;
! Long link name
-: typeflag-K ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-K ( header -- ) unknown-typeflag ;
! Long file name
: typeflag-L ( header -- )
filename get tar-append-path make-directories ;
! Multi volume continuation entry
-: typeflag-M ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-M ( header -- ) unknown-typeflag ;
! GNU long file name
-: typeflag-N ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-N ( header -- ) unknown-typeflag ;
! Sparse file
-: typeflag-S ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-S ( header -- ) unknown-typeflag ;
! Volume header
-: typeflag-V ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-V ( header -- ) unknown-typeflag ;
! Vendor extended header type
-: typeflag-X ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- )
512 read
{ CHAR: S [ typeflag-S ] }
{ CHAR: V [ typeflag-V ] }
{ CHAR: X [ typeflag-X ] }
- [ <unknown-typeflag> throw ]
+ [ unknown-typeflag ]
} case
! dup tar-header-size zero? [
! out-stream get [ dispose ] when
: parse-tar ( path -- obj )
binary [
- "tar-test" resource-path base-dir set
+ "resource:tar-test" base-dir set
global [ nl nl nl "Starting to parse .tar..." print flush ] bind
global [ "Expanding to: " write base-dir get . flush ] bind
(parse-tar)
TUPLE: tax-table single married ;
: <tax-table> ( single married class -- obj )
- >r tax-table construct-boa r> construct-delegate ;
+ >r tax-table boa r> construct-delegate ;
: tax-bracket-range dup second swap first - ;
[ drop f <array> ] with map ;
: <board> ( width height -- board )
- 2dup make-rows board construct-boa ;
+ 2dup make-rows board boa ;
#! A block is simply an array of form { x y } where { 0 0 } is the top-left of
#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board.
{ [ 2dup length 1- number= ] [ 2drop 4 ] }
{ [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] }
{ [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] }
- { [ t ] [ 2drop 1 ] }
+ [ 2drop 1 ]
} cond ;
: score ( full fuzzy -- n )
+stdout+ >>stderr
+closed+ >>stdin
+low-priority+ >>priority
- utf8 <process-stream>
- dup copy-lines
- process>> wait-for-process zero? [
+ utf8 <process-stream*>
+ >r copy-lines r> wait-for-process zero? [
"Deployment failed" throw
] unless ;
{ deploy-c-types? f }
! default value for deploy.macosx
{ "stop-after-last-window?" t }
- } union ;
+ } assoc-union ;
: deploy-config-path ( vocab -- string )
vocab-dir "deploy.factor" append-path ;
: deploy-config ( vocab -- assoc )
dup default-config swap
dup deploy-config-path vocab-file-contents
- parse-fresh dup empty? [ drop ] [ first union ] if ;
+ parse-fresh dup empty? [ drop ] [ first assoc-union ] if ;
: set-deploy-config ( assoc vocab -- )
>r unparse-use string-lines r>
IN: tools.deploy.tests\r
USING: tools.test system io.files kernel tools.deploy.config\r
tools.deploy.backend math sequences io.launcher arrays\r
-namespaces continuations layouts ;\r
+namespaces continuations layouts accessors ;\r
\r
: shake-and-bake ( vocab -- )\r
[ "test.image" temp-file delete-file ] ignore-errors\r
] with-directory ;\r
\r
: small-enough? ( n -- ? )\r
- >r "test.image" temp-file file-info file-info-size r> <= ;\r
+ >r "test.image" temp-file file-info size>> r> <= ;\r
\r
[ ] [ "hello-world" shake-and-bake ] unit-test\r
\r
USING: qualified io.streams.c init fry namespaces assocs kernel
parser tools.deploy.config vocabs sequences words words.private
memory kernel.private continuations io prettyprint
-vocabs.loader debugger system strings ;
+vocabs.loader debugger system strings sets ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
set-global ;
: strip-vocab-globals ( except names -- words )
- [ child-vocabs [ words ] map concat ] map concat seq-diff ;
+ [ child-vocabs [ words ] map concat ] map concat diff ;
: stripped-globals ( -- seq )
[
[ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
! Only keeps those methods that we actually call
- sent-messages get super-sent-messages get union
- objc-methods [ intersect ] change
+ sent-messages get super-sent-messages get assoc-union
+ objc-methods [ assoc-intersect ] change
sent-messages get
super-sent-messages get
[ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
- super-message-senders [ intersect ] change
- message-senders [ intersect ] change
+ super-message-senders [ assoc-intersect ] change
+ message-senders [ assoc-intersect ] change
sent-messages off
super-sent-messages off
: threads. ( -- )\r
standard-table-style [\r
[\r
- { "ID" "Name" "Waiting on" "Remaining sleep" }\r
+ { "ID:" "Name:" "Waiting on:" "Remaining sleep:" }\r
[ [ write ] with-cell ] each\r
] with-row\r
\r
{
{ [ dup not ] [ drop "" ] }
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
- { [ t ] [ drop "[Loaded]" ] }
+ [ drop "[Loaded]" ]
} cond ;
: write-status ( vocab -- )
--- /dev/null
+USING: tools.test tools.vocabs.monitor io.files ;
+IN: tools.vocabs.monitor.tests
+
+[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test
+[ "kernel" ] [ "core/kernel/" path>vocab ] unit-test
+[ "kernel" ] [ "core/kernel/" resource-path path>vocab ] unit-test
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: threads io.files io.monitors init kernel\r
-vocabs.loader tools.vocabs namespaces continuations ;\r
+vocabs vocabs.loader tools.vocabs namespaces continuations\r
+sequences splitting assocs command-line ;\r
IN: tools.vocabs.monitor\r
\r
-! Use file system change monitoring to flush the tags/authors\r
-! cache\r
-SYMBOL: vocab-monitor\r
+: vocab-dir>vocab-name ( path -- vocab )\r
+ left-trim-separators right-trim-separators\r
+ { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;\r
+\r
+: path>vocab-name ( path -- vocab )\r
+ dup ".factor" tail? [ parent-directory ] when ;\r
+\r
+: chop-vocab-root ( path -- path' )\r
+ "resource:" prepend-path (normalize-path)\r
+ dup vocab-roots get\r
+ [ (normalize-path) ] map\r
+ [ head? ] with find nip\r
+ ?head drop ;\r
+\r
+: path>vocab ( path -- vocab )\r
+ chop-vocab-root path>vocab-name vocab-dir>vocab-name ;\r
+\r
+: monitor-loop ( monitor -- )\r
+ #! On OS X, monitors give us the full path, so we chop it\r
+ #! off if its there.\r
+ dup next-change drop path>vocab changed-vocab\r
+ reset-cache\r
+ monitor-loop ;\r
\r
: monitor-thread ( -- )\r
- vocab-monitor get-global\r
- next-change 2drop\r
- t sources-changed? set-global reset-cache ;\r
+ [\r
+ [\r
+ "" resource-path t <monitor>\r
+ \r
+ H{ } clone changed-vocabs set-global\r
+ vocabs [ changed-vocab ] each\r
+ \r
+ monitor-loop\r
+ ] with-monitors\r
+ ] ignore-errors ;\r
\r
-: start-monitor-thread\r
+: start-monitor-thread ( -- )\r
#! Silently ignore errors during monitor creation since\r
#! monitors are not supported on all platforms.\r
- [\r
- "" resource-path t <monitor> vocab-monitor set-global\r
- [ monitor-thread t ] "Vocabulary monitor" spawn-server drop\r
- ] ignore-errors ;\r
+ [ monitor-thread ] "Vocabulary monitor" spawn drop ;\r
\r
-[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook\r
+[\r
+ "-no-monitors" cli-args member? [\r
+ start-monitor-thread\r
+ ] unless\r
+] "tools.vocabs.monitor" add-init-hook\r
--- /dev/null
+IN: tools.vocabs.tests
+USING: tools.test tools.vocabs namespaces continuations ;
+
+[ ] [
+ changed-vocabs get-global
+ f changed-vocabs set-global
+ [ t ] [ "kernel" changed-vocab? ] unit-test
+ [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
+] unit-test
USING: io.files kernel io.encodings.utf8 vocabs.loader vocabs\r
sequences namespaces math.parser arrays hashtables assocs\r
memoize inspector sorting splitting combinators source-files\r
-io debugger continuations compiler.errors init io.crc32 ;\r
+io debugger continuations compiler.errors init io.crc32 \r
+sets ;\r
IN: tools.vocabs\r
\r
: vocab-tests-file ( vocab -- path )\r
\r
: vocab-tests ( vocab -- tests )\r
[\r
- dup vocab-tests-file [ , ] when*\r
- vocab-tests-dir [ % ] when*\r
+ [ vocab-tests-file [ , ] when* ]\r
+ [ vocab-tests-dir [ % ] when* ] bi\r
] { } make ;\r
\r
: vocab-files ( vocab -- seq )\r
[\r
- dup vocab-source-path [ , ] when*\r
- dup vocab-docs-path [ , ] when*\r
- vocab-tests %\r
+ [ vocab-source-path [ , ] when* ]\r
+ [ vocab-docs-path [ , ] when* ]\r
+ [ vocab-tests % ] tri\r
] { } make ;\r
\r
-: source-modified? ( path -- ? )\r
- dup source-files get at [\r
- dup source-file-path\r
- dup exists? [\r
- utf8 file-lines lines-crc32\r
- swap source-file-checksum = not\r
- ] [\r
- 2drop f\r
- ] if\r
- ] [\r
- exists?\r
- ] ?if ;\r
-\r
-: modified ( seq quot -- seq )\r
- [ dup ] swap compose { } map>assoc\r
- [ nip ] assoc-subset\r
- [ nip source-modified? ] assoc-subset keys ; inline\r
-\r
-: modified-sources ( vocabs -- seq )\r
- [ vocab-source-path ] modified ;\r
-\r
-: modified-docs ( vocabs -- seq )\r
- [ vocab-docs-path ] modified ;\r
-\r
-: to-refresh ( prefix -- modified-sources modified-docs )\r
- child-vocabs\r
- dup modified-sources swap modified-docs ;\r
-\r
: vocab-heading. ( vocab -- )\r
nl\r
"==== " write\r
- dup vocab-name swap vocab write-object ":" print\r
+ [ vocab-name ] [ vocab write-object ] bi ":" print\r
nl ;\r
\r
: load-error. ( triple -- )\r
- dup first vocab-heading.\r
- dup second print-error\r
- drop ;\r
+ [ first vocab-heading. ] [ second print-error ] bi ;\r
\r
: load-failures. ( failures -- )\r
[ load-error. nl ] each ;\r
failures get\r
] with-compiler-errors ;\r
\r
-: do-refresh ( modified-sources modified-docs -- )\r
- 2dup\r
- [ f swap set-vocab-docs-loaded? ] each\r
- [ f swap set-vocab-source-loaded? ] each\r
- append prune require-all load-failures. ;\r
+: source-modified? ( path -- ? )\r
+ dup source-files get at [\r
+ dup source-file-path\r
+ dup exists? [\r
+ utf8 file-lines lines-crc32\r
+ swap source-file-checksum = not\r
+ ] [\r
+ 2drop f\r
+ ] if\r
+ ] [\r
+ exists?\r
+ ] ?if ;\r
\r
-: refresh ( prefix -- ) to-refresh do-refresh ;\r
+SYMBOL: changed-vocabs\r
+\r
+[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook\r
\r
-SYMBOL: sources-changed?\r
+: changed-vocab ( vocab -- )\r
+ dup vocab changed-vocabs get and\r
+ [ dup changed-vocabs get set-at ] [ drop ] if ;\r
\r
-[ t sources-changed? set-global ] "tools.vocabs" add-init-hook\r
+: unchanged-vocab ( vocab -- )\r
+ changed-vocabs get delete-at ;\r
\r
-: refresh-all ( -- )\r
- "" refresh f sources-changed? set-global ;\r
+: unchanged-vocabs ( vocabs -- )\r
+ [ unchanged-vocab ] each ;\r
+\r
+: changed-vocab? ( vocab -- ? )\r
+ changed-vocabs get dup [ key? ] [ 2drop t ] if ;\r
+\r
+: filter-changed ( vocabs -- vocabs' )\r
+ [ changed-vocab? ] subset ;\r
+\r
+SYMBOL: modified-sources\r
+SYMBOL: modified-docs\r
+\r
+: (to-refresh) ( vocab variable loaded? path -- )\r
+ dup [\r
+ swap [\r
+ pick changed-vocab? [\r
+ source-modified? [ get push ] [ 2drop ] if\r
+ ] [ 3drop ] if\r
+ ] [ drop get push ] if\r
+ ] [ 2drop 2drop ] if ;\r
+\r
+: to-refresh ( prefix -- modified-sources modified-docs unchanged )\r
+ [\r
+ V{ } clone modified-sources set\r
+ V{ } clone modified-docs set\r
+\r
+ child-vocabs [\r
+ [\r
+ [\r
+ [ modified-sources ]\r
+ [ vocab-source-loaded? ]\r
+ [ vocab-source-path ]\r
+ tri (to-refresh)\r
+ ] [\r
+ [ modified-docs ]\r
+ [ vocab-docs-loaded? ]\r
+ [ vocab-docs-path ]\r
+ tri (to-refresh)\r
+ ] bi\r
+ ] each\r
+\r
+ modified-sources get\r
+ modified-docs get\r
+ ]\r
+ [ modified-sources get modified-docs get append swap diff ] bi\r
+ ] with-scope ;\r
+\r
+: do-refresh ( modified-sources modified-docs unchanged -- )\r
+ unchanged-vocabs\r
+ [\r
+ [ [ f swap set-vocab-source-loaded? ] each ]\r
+ [ [ f swap set-vocab-docs-loaded? ] each ] bi*\r
+ ]\r
+ [\r
+ append prune\r
+ [ unchanged-vocabs ]\r
+ [ require-all load-failures. ] bi\r
+ ] 2bi ;\r
+\r
+: refresh ( prefix -- ) to-refresh do-refresh ;\r
\r
-MEMO: (vocab-file-contents) ( path -- lines )\r
- dup exists? [ utf8 file-lines ] [ drop f ] if ;\r
+: refresh-all ( -- ) "" refresh ;\r
\r
-: vocab-file-contents ( vocab name -- seq )\r
- vocab-append-path dup [ (vocab-file-contents) ] when ;\r
+MEMO: vocab-file-contents ( vocab name -- seq )\r
+ vocab-append-path dup\r
+ [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;\r
\r
: set-vocab-file-contents ( seq vocab name -- )\r
dupd vocab-append-path [\r
utf8 set-file-lines\r
- \ (vocab-file-contents) reset-memoized\r
+ \ vocab-file-contents reset-memoized\r
] [\r
"The " swap vocab-name\r
" vocabulary was not loaded from the file system"\r
{ [ ".test" ?tail ] [ t ] }\r
{ [ "raptor" ?head ] [ t ] }\r
{ [ dup "tools.deploy.app" = ] [ t ] }\r
- { [ t ] [ f ] }\r
+ [ f ]\r
} cond nip ;\r
\r
: filter-dangerous ( seq -- seq' )\r
\r
: reset-cache ( -- )\r
root-cache get-global clear-assoc\r
- \ (vocab-file-contents) reset-memoized\r
+ \ vocab-file-contents reset-memoized\r
\ all-vocabs-seq reset-memoized\r
\ all-authors reset-memoized\r
\ all-tags reset-memoized ;\r
{
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
{ [ dup primitive? ] [ execute break ] }
- { [ t ] [ word-def (step-into-quot) ] }
+ [ word-def (step-into-quot) ]
} cond ;
\ (step-into-execute) t "step-into?" set-word-prop
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
{ [ dup array? ] [ add-breakpoint , \ break , ] }
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
- { [ t ] [ , \ break , ] }
+ [ , \ break , ]
} cond %
] [ ] make
] change-frame ;
TUPLE: avl-node balance ;
: <avl-node> ( key value -- node )
- swap <node> 0 avl-node construct-boa tuck set-delegate ;
+ swap <node> 0 avl-node boa tuck set-delegate ;
: change-balance ( node amount -- )
over avl-node-balance + swap set-avl-node-balance ;
avl-node-balance {
{ [ dup zero? ] [ 2drop 0 0 ] }
{ [ over = ] [ neg 0 ] }
- { [ t ] [ 0 swap ] }
+ [ 0 swap ]
} cond ;
: double-rotate ( node -- node )
current-side get over avl-node-balance {
{ [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
{ [ dupd = ] [ drop 0 over set-avl-node-balance t ] }
- { [ t ] [ dupd neg change-balance rebalance-delete ] }
+ [ dupd neg change-balance rebalance-delete ]
} cond ;
: avl-replace-with-extremity ( to-replace node -- node shorter? )
--- /dev/null
+collections
2dup get-splay [ 2nip set-node-value ] [
drop dup inc-count
2dup splay-split rot
- >r >r swapd r> node construct-boa r> set-tree-root
+ >r >r swapd r> node boa r> set-tree-root
] if ;
: new-root ( value key tree -- )
-Splay Trees
+Splay trees
TUPLE: tree root count ;
: <tree> ( -- tree )
- f 0 tree construct-boa ;
+ f 0 tree boa ;
: construct-tree ( class -- tree )
- construct-empty <tree> over set-delegate ; inline
+ new <tree> over set-delegate ; inline
INSTANCE: tree tree-mixin
TUPLE: node key value left right ;
: <node> ( key value -- node )
- f f node construct-boa ;
+ f f node boa ;
SYMBOL: current-side
[ 2drop t ] }
{ [ >r 2nip r> [ tree-call ] 2keep rot ]
[ drop [ node-key ] keep node-value t ] }
- { [ t ] [ >r node-right r> find-node ] }
+ [ >r node-right r> find-node ]
} cond ; inline
M: tree-mixin assoc-find ( tree quot -- key value ? )
swap tuple>array length over length - ;
: <tuple-array> ( length example -- tuple-array )
- prepare-example [ rot * { } new ] keep
+ prepare-example [ rot * { } new-sequence ] keep
<sliced-groups> tuple-array construct-delegate
[ set-tuple-array-example ] keep ;
tuck >r >r tuple-array-example deconstruct r> r>
delegate set-nth ;
-M: tuple-array new tuple-array-example >tuple <tuple-array> ;
+M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ;
: >tuple-array ( seq -- tuple-array/seq )
dup empty? [
[ scan-object pick rot set-slot parse-slots ] when* ;
: TUPLE{
- scan-word construct-empty parse-slots parsed ; parsing
+ scan-word new parse-slots parsed ; parsing
TUPLE: turtle ;
: <turtle> ( -- turtle )
-turtle construct-empty
+turtle new
{ 0 0 0 } clone <pos>
3 identity-matrix <ori>
rot
! Two text transfer buffers
TUPLE: clipboard contents ;
-: <clipboard> "" clipboard construct-boa ;
+: <clipboard> "" clipboard boa ;
GENERIC: paste-clipboard ( gadget clipboard -- )
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs cocoa kernel math cocoa.messages
cocoa.subclassing cocoa.classes cocoa.views cocoa.application
cocoa.pasteboard cocoa.types cocoa.windows sequences ui
ui.gadgets ui.gadgets.worlds ui.gestures core-foundation
-threads ;
+threads combinators ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
[ [ nip T{ select-all-action } send-action$ ] ui-try ]
}
+! Multi-touch gestures: this is undocumented.
+! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
+{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaZ sgn {
+ { 1 [ T{ zoom-in-action } send-action$ ] }
+ { -1 [ T{ zoom-out-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+}
+
+{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaX sgn {
+ { 1 [ T{ left-action } send-action$ ] }
+ { -1 [ T{ right-action } send-action$ ] }
+ { 0
+ [
+ dup -> deltaY sgn {
+ { 1 [ T{ up-action } send-action$ ] }
+ { -1 [ T{ down-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+ }
+ } case
+ ]
+}
+
+! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
+
{ "acceptsFirstResponder" "bool" { "id" "SEL" }
[ 2drop 1 ]
}
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
: define-command ( word hash -- )
- default-flags swap union >r word-props r> update ;
+ default-flags swap assoc-union >r word-props r> update ;
: command-quot ( target command -- quot )
dup 1quotation swap +nullary+ word-prop
TUPLE: border size fill ;
: <border> ( child gap -- border )
- dup 2array { 0 0 } border construct-boa
+ dup 2array { 0 0 } border boa
<gadget> over set-delegate
tuck add-gadget ;
} set-gestures
: <button> ( gadget quot -- button )
- button construct-empty
+ button new
[ set-button-quot ] keep
[ set-gadget-delegate ] keep ;
{ [ dup button-pressed? ] [ drop button-paint-pressed ] }
{ [ dup button-selected? ] [ drop button-paint-selected ] }
{ [ dup button-rollover? ] [ drop button-paint-rollover ] }
- { [ t ] [ drop button-paint-plain ] }
+ [ drop button-paint-plain ]
} cond ;
M: button-paint draw-interior
: <repeat-button> ( label quot -- button )
#! Button that calls the quotation every 100ms as long as
#! the mouse is held down.
- repeat-button construct-empty
+ repeat-button new
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
TUPLE: checkmark-paint color ;
: @bottom-right 2 2 ;
: <frame> ( -- frame )
- frame construct-empty
+ frame new
<frame-grid> <grid> over set-gadget-delegate ;
: (fill-center) ( vec n -- )
IN: ui.gadgets.tests
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
-namespaces models kernel dlists math
+namespaces models kernel dlists math sets
math.parser ui sequences hashtables assocs io arrays
prettyprint io.streams.string ;
TUPLE: mock-gadget graft-called ungraft-called ;
: <mock-gadget>
- 0 0 mock-gadget construct-boa <gadget> over set-delegate ;
+ 0 0 mock-gadget boa <gadget> over set-delegate ;
M: mock-gadget graft*
dup mock-gadget-graft-called 1+
: fast-children-on ( rect axis children -- from to )
3dup
>r >r dup rect-loc swap rect-dim v+
- r> r> (fast-children-on) [ 1+ ] [ 0 ] if*
+ r> r> (fast-children-on) ?1+
>r
>r >r rect-loc
r> r> (fast-children-on) 0 or
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup not ] [ 2drop f ] }
- { [ t ] [ gadget-parent child? ] }
+ [ gadget-parent child? ]
} cond ;
GENERIC: focusable-child* ( gadget -- child/t )
TUPLE: labelled-gadget content ;
: <labelled-gadget> ( gadget title -- newgadget )
- labelled-gadget construct-empty
+ labelled-gadget new
[
<label> dup reverse-video-theme f track,
g-> set-labelled-gadget-content 1 track,
[ [ closable-gadget? ] is? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget )
- closable-gadget construct-empty
+ closable-gadget new
[
<title-bar> @top frame,
g-> set-closable-gadget-content @center frame,
selection-color swap set-pane-selection-color ;
: <pane> ( -- pane )
- pane construct-empty
+ pane new
<pile> over set-delegate
<shelf> over set-pane-prototype
<pile> <incremental> over add-output
dup gadget-children {
{ [ dup empty? ] [ 2drop "" <label> ] }
{ [ dup length 1 = ] [ nip first ] }
- { [ t ] [ drop ] }
+ [ drop ]
} cond ;
: smash-pane ( pane -- gadget ) pane-output smash-line ;
dup presentation-object over show-summary button-update ;
: <presentation> ( label object -- button )
- presentation construct-empty
+ presentation new
[ drop ] over set-presentation-hook
[ set-presentation-object ] keep
swap [ invoke-primary ] <roll-button>
{ [ dup t eq? ] [ drop (scroll>bottom) ] }
{ [ dup rect? ] [ swap (scroll>rect) ] }
{ [ dup ] [ swap (scroll>gadget) ] }
- { [ t ] [ drop dup scroller-value swap scroll ] }
+ [ drop dup scroller-value swap scroll ]
} cond ;
M: scroller layout*
} define-command
: <slot-editor> ( ref -- gadget )
- slot-editor construct-empty
+ slot-editor new
[ set-slot-editor-ref ] keep
[
toolbar,
} set-gestures
: <editable-slot> ( gadget ref -- editable-slot )
- editable-slot construct-empty
+ editable-slot new
{ 1 0 } <track> over set-gadget-delegate
[ drop <gadget> ] over set-editable-slot-printer
[ set-editable-slot-ref ] keep
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
math.vectors classes.tuple classes ui.gadgets boxes
-calendar alarms symbols combinators ;
+calendar alarms symbols combinators sets ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
TUPLE: gain-focus ; C: <gain-focus> gain-focus
! Higher-level actions
-TUPLE: cut-action ; C: <cut-action> cut-action
-TUPLE: copy-action ; C: <copy-action> copy-action
-TUPLE: paste-action ; C: <paste-action> paste-action
-TUPLE: delete-action ; C: <delete-action> delete-action
-TUPLE: select-all-action ; C: <select-all-action> select-all-action
+TUPLE: cut-action ; C: <cut-action> cut-action
+TUPLE: copy-action ; C: <copy-action> copy-action
+TUPLE: paste-action ; C: <paste-action> paste-action
+TUPLE: delete-action ; C: <delete-action> delete-action
+TUPLE: select-all-action ; C: <select-all-action> select-all-action
+
+TUPLE: left-action ; C: <left-action> left-action
+TUPLE: right-action ; C: <right-action> right-action
+TUPLE: up-action ; C: <up-action> up-action
+TUPLE: down-action ; C: <down-action> down-action
+
+TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
+TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
: generalize-gesture ( gesture -- newgesture )
tuple>array 1 head* >tuple ;
TUPLE: key-down mods sym ;
: <key-gesture> ( mods sym action? class -- mods' sym' )
- >r [ S+ rot remove swap ] unless r> construct-boa ; inline
+ >r [ S+ rot remove swap ] unless r> boa ; inline
: <key-down> ( mods sym action? -- key-down )
key-down <key-gesture> ;
{ [ multi-click-button? not ] [ f ] }
{ [ multi-click-position? not ] [ f ] }
{ [ multi-click-position? not ] [ f ] }
- { [ t ] [ t ] }
+ [ t ]
} cond nip ;
: update-click# ( button -- )
button-down-# [ " " % # ] when*
] "" make ;
+M: left-action gesture>string drop "Swipe left" ;
+
+M: right-action gesture>string drop "Swipe right" ;
+
+M: up-action gesture>string drop "Swipe up" ;
+
+M: down-action gesture>string drop "Swipe down" ;
+
+M: zoom-in-action gesture>string drop "Zoom in" ;
+
+M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
+
M: object gesture>string drop f ;
: my-pprint pprint ;
-[ drop t ] \ my-pprint [ ] [ ] f operation construct-boa "op" set
+[ drop t ] \ my-pprint [ ] [ ] f operation boa "op" set
[ [ 3 my-pprint ] ] [
3 "op" get operation-command command-quot
[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
-[ drop t ] \ my-pprint [ ] [ editor-string ] f operation construct-boa
+[ drop t ] \ my-pprint [ ] [ editor-string ] f operation boa
"op" set
[ "\"4\"" ] [
H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
: define-operation ( pred command flags -- )
- default-flags swap union
+ default-flags swap assoc-union
dupd define-command <operation>
operations get push ;
{
{ [ dup gadget-visible? not ] [ drop ] }
{ [ dup gadget-clipped? not ] [ (draw-gadget) ] }
- { [ t ] [ [ (draw-gadget) ] with-clipping ] }
+ [ [ (draw-gadget) ] with-clipping ]
} cond ;
! Pen paint properties
swap set-browser-gadget-history ;
: <browser-gadget> ( -- gadget )
- browser-gadget construct-empty
+ browser-gadget new
dup init-history [
toolbar,
g <help-pane> g-> set-browser-gadget-pane
{ T{ key-down f { A+ } "v" } com-vocabularies }
{ T{ key-down f f "F1" } browser-help }
} define-command-map
+
+browser-gadget "multi-touch" f {
+ { T{ left-action } com-back }
+ { T{ right-action } com-forward }
+} define-command-map
] make-filled-pile ;
: <debugger> ( error restarts restart-hook -- gadget )
- debugger construct-empty
+ debugger new
[
toolbar,
<restart-list> g-> set-debugger-restarts
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget )
- f deploy-gadget construct-boa [
+ f deploy-gadget boa [
dup <deploy-settings>
g-> set-deploy-gadget-settings gadget,
buttons,
] with-pane ;
: <inspector-gadget> ( -- gadget )
- inspector-gadget construct-empty
+ inspector-gadget new
[
toolbar,
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
{ T{ key-down f f "F1" } inspector-help }
} define-command-map
+inspector-gadget "multi-touch" f {
+ { T{ left-action } &back }
+} define-command-map
+
M: inspector-gadget tool-scroller
inspector-gadget-pane find-scroller ;
IN: ui.tools.interactor.tests
-USING: ui.tools.interactor tools.test ;
+USING: ui.tools.interactor ui.gadgets.panes namespaces
+ui.gadgets.editors concurrency.promises threads listener
+tools.test kernel calendar parser ;
-\ <interactor> must-infer
+[
+ \ <interactor> must-infer
+
+ [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+ [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ <promise> "promise" set ] unit-test
+
+ [
+ "interactor" get stream-read-quot "promise" get fulfill
+ ] "Interactor test" spawn drop
+
+ ! This should not throw an exception
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+
+ [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
+] with-interactive-vocabs
drop parse-lines-interactive
] [
2nip
- dup delegate unexpected-eof? [ drop f ] when
+ dup parse-error? [
+ dup error>> unexpected-eof? [ drop f ] when
+ ] when
] recover ;
: handle-interactive ( lines interactor -- quot/f ? )
tuck try-parse {
{ [ dup quotation? ] [ nip t ] }
{ [ dup not ] [ drop "\n" swap user-input f f ] }
- { [ t ] [ handle-parse-error f f ] }
+ [ handle-parse-error f f ]
} cond ;
M: interactor stream-read-quot
[ interactor-yield ] keep {
{ [ over not ] [ drop ] }
{ [ over callable? ] [ drop ] }
- { [ t ] [
+ [
[ handle-interactive ] keep swap
[ interactor-finish ] [ nip stream-read-quot ] if
- ] }
+ ]
} cond ;
M: interactor pref-dim*
: <input-scroller> ( interactor -- scroller )
<scroller>
- input-scroller construct-empty
+ input-scroller new
[ set-gadget-delegate ] keep ;
M: input-scroller pref-dim*
{
{ [ dup not ] [ 2drop ] }
{ [ 2dup memq? ] [ 2drop ] }
- { [ t ] [ push ] }
+ [ push ]
} cond ;
: insert-word ( word -- )
TUPLE: stack-display ;
: <stack-display> ( -- gadget )
- stack-display construct-empty
+ stack-display new
g workspace-listener swap [
dup <toolbar> f track,
listener-gadget-stack [ stack. ]
f <model> swap set-listener-gadget-stack ;
: <listener-gadget> ( -- gadget )
- listener-gadget construct-empty dup init-listener
+ listener-gadget new dup init-listener
[ listener-output, listener-input, ] { 0 1 } build-track ;
: listener-help "ui-listener" help-window ;
TUPLE: profiler-gadget pane ;
: <profiler-gadget> ( -- gadget )
- profiler-gadget construct-empty
+ profiler-gadget new
[
toolbar,
<pane> g-> set-profiler-gadget-pane
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
- live-search construct-empty
+ live-search new
[
<search-field> g-> set-live-search-field f track,
<search-list> g-> set-live-search-list
parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.slots ui.operations ui.tools.browser
-ui.tools.interactor ui.tools.listener ui.tools.operations
-ui.tools.profiler ui.tools.walker ui.tools.workspace vocabs ;
+ui.tools.interactor ui.tools.inspector ui.tools.listener
+ui.tools.operations ui.tools.profiler ui.tools.walker
+ui.tools.workspace vocabs ;
IN: ui.tools
ARTICLE: "ui-presentations" "Presentations in the UI"
$nl
"The slot editor has a toolbar containing various commands."
{ $command-map slot-editor "toolbar" }
+{ $command-map inspector-gadget "multi-touch" }
"The following commands are also available."
{ $command-map source-editor "word" } ;
ARTICLE: "ui-browser" "UI browser"
"The browser is used to display Factor code, documentation, and vocabularies."
{ $command-map browser-gadget "toolbar" }
+{ $command-map browser-gadget "multi-touch" }
"Browsers are instances of " { $link browser-gadget } "." ;
ARTICLE: "ui-profiler" "UI profiler"
{ $command-map workspace "tool-switching" }
{ $command-map workspace "scrolling" }
{ $command-map workspace "workflow" }
+{ $command-map workspace "multi-touch" }
{ $heading "Implementation" }
"Workspaces are instances of " { $link workspace } "." ;
{ T{ key-down f { A+ } "4" } com-profiler }
} define-command-map
+workspace "multi-touch" f {
+ { T{ zoom-out-action } com-listener }
+ { T{ up-action } refresh-all }
+} define-command-map
+
\ workspace-window
H{ { +nullary+ t } } define-command
: <variables-gadget> ( model -- gadget )
<namestack-display> <scroller>
- variables-gadget construct-empty
+ variables-gadget new
[ set-gadget-delegate ] keep ;
M: variables-gadget pref-dim* drop { 400 400 } ;
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
- over <traceback-gadget> f walker-gadget construct-boa [
+ over <traceback-gadget> f walker-gadget boa [
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-traceback 1 track,
{
{ [ dup walker-gadget? not ] [ 2drop f ] }
{ [ dup walker-gadget-closing? ] [ 2drop f ] }
- { [ t ] [ walker-gadget-thread eq? ] }
+ [ walker-gadget-thread eq? ]
} cond ;
: find-walker-window ( thread -- world/f )
: traverse-step ( path gadget -- path' gadget' )
>r unclip r> gadget-children ?nth ;
-: make-node ( quot -- ) { } make node construct-boa , ; inline
+: make-node ( quot -- ) { } make node boa , ; inline
: traverse-to-path ( topath gadget -- )
dup not [
{ [ pick empty? ] [ rot drop traverse-to-path ] }
{ [ over empty? ] [ nip traverse-from-path ] }
{ [ pick first pick first = ] [ traverse-child ] }
- { [ t ] [ traverse-middle ] }
+ [ traverse-middle ]
} cond ;
: gadget-subtree ( frompath topath gadget -- seq )
prettyprint dlists sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.flags ;
+hashtables concurrency.flags sets ;
IN: ui
! Assoc mapping aliens to gadgets
windows.opengl32 windows.messages windows.types windows.nt
windows threads libc combinators continuations command-line
shuffle opengl ui.render unicode.case ascii math.bitfields
-locals symbols ;
+locals symbols accessors ;
IN: ui.windows
SINGLETON: windows-ui-backend
wParam keystroke>gesture <key-up>
hWnd window-focus send-gesture drop ;
+: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ >r 4dup r> 2nip nip
+ swap window set-world-active? DefWindowProc ;
+
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
- dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
+ {
+ { [ over SC_MINIMIZE = ] [ f set-window-active ] }
+ { [ over SC_RESTORE = ] [ t set-window-active ] }
+ { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
+ { [ dup alpha? ] [ 4drop 0 ] }
+ { [ t ] [ DefWindowProc ] }
+ } cond ;
: cleanup-window ( handle -- )
dup win-title [ free ] when*
{ [ windows get empty? ] [ drop ] }
{ [ dup peek-message? ] [ ui-wait event-loop ] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
- { [ t ] [
+ [
dup TranslateMessage drop
dup DispatchMessage drop
event-loop
- ] }
+ ]
} cond ;
: register-wndclassex ( -- class )
{
{ [ dup XA_PRIMARY = ] [ drop selection get ] }
{ [ dup XA_CLIPBOARD = ] [ drop clipboard get ] }
- { [ t ] [ drop <clipboard> ] }
+ [ drop <clipboard> ]
} cond ;
: encode-clipboard ( string type -- bytes )
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
- { [ t ] [ drop send-notify-failure ] }
+ [ drop send-notify-failure ]
} cond ;
M: x11-ui-backend (close-window) ( handle -- )
} case ;
: trim-blank ( str -- newstr )
- dup [ blank? not ] find-last 1+* head ;
+ [ blank? ] right-trim ;
: process-other-extend ( lines -- set )
[ "#" split1 drop ";" split1 drop trim-blank ] map
{ [ dup jamo? ] [ jamo-class ] }
{ [ dup grapheme-control? ] [ control-class ] }
{ [ extend? ] [ Extend ] }
- { [ t ] [ Any ] }
+ [ Any ]
} cond ;
: init-grapheme-table ( -- table )
: last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap
- [ grapheme-class dup rot grapheme-break? ] find-last-index
- nip -1 or 1+ ;
+ [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
[
other-extend-lines process-other-extend \ other-extend set-value
drop dot-over =
dup CHAR: i HEX: 131 ? ,
] }
- { [ t ] [ , drop f ] }
+ [ , drop f ]
} cond ;
: turk>lower ( string -- lower-i )
>>
! Convenience functions
-: 1+* ( n/f _ -- n+1 )
- drop [ 1+ ] [ 0 ] if* ;
-
: ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ;
dup process-names \ name-map set-value
13 over process-data \ simple-lower set-value
12 over process-data tuck \ simple-upper set-value
-14 over process-data swapd union \ simple-title set-value
+14 over process-data swapd assoc-union \ simple-title set-value
dup process-combining \ class-map set-value
dup process-canonical \ canonical-map set-value
\ combine-map set-value
0 reorder-loop ;
: reorder-back ( string i -- )
- over [ non-starter? not ] find-last* 1+* reorder-next 2drop ;
+ over [ non-starter? not ] find-last* drop ?1+ reorder-next 2drop ;
: decompose ( string quot -- decomposed )
! When there are 8 and 32-bit strings, this'll be
USING: arrays io kernel math namespaces splitting prettyprint
sequences sorting vectors words inverse inspector shuffle
-math.functions ;
+math.functions sets ;
IN: units
TUPLE: dimensioned value top bot ;
TUPLE: dimensions-not-equal ;
: dimensions-not-equal ( -- * )
- \ dimensions-not-equal construct-empty throw ;
+ \ dimensions-not-equal new throw ;
M: dimensions-not-equal summary drop "Dimensions do not match" ;
[ remove-one ] curry bi@ ;
: symbolic-reduce ( seq seq -- seq seq )
- 2dup seq-intersect dup empty?
+ 2dup intersect dup empty?
[ drop ] [ first 2remove-one symbolic-reduce ] if ;
: <dimensioned> ( n top bot -- obj )
symbolic-reduce
[ natural-sort ] bi@
- dimensioned construct-boa ;
+ dimensioned boa ;
: >dimensioned< ( d -- n top bot )
{ dimensioned-value dimensioned-top dimensioned-bot }
: S_IFMT OCT: 170000 ; ! These bits determine file type.
-: S_IFDIR OCT: 40000 ; ! Directory.
-: S_IFCHR OCT: 20000 ; ! Character device.
-: S_IFBLK OCT: 60000 ; ! Block device.
-: S_IFREG OCT: 100000 ; ! Regular file.
-: S_IFIFO OCT: 010000 ; ! FIFO.
-: S_IFLNK OCT: 120000 ; ! Symbolic link.
-: S_IFSOCK OCT: 140000 ; ! Socket.
-
-: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
-
-: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
-: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
-: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
-: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
-: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
-: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
-: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
+: S_IFDIR OCT: 40000 ; inline ! Directory.
+: S_IFCHR OCT: 20000 ; inline ! Character device.
+: S_IFBLK OCT: 60000 ; inline ! Block device.
+: S_IFREG OCT: 100000 ; inline ! Regular file.
+: S_IFIFO OCT: 010000 ; inline ! FIFO.
+: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
+: S_IFSOCK OCT: 140000 ; inline ! Socket.
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! File Access Permissions
: CRYPT_MACHINE_KEYSET HEX: 20 ; inline
: CRYPT_SILENT HEX: 40 ; inline
+C-STRUCT: ACL
+ { "BYTE" "AclRevision" }
+ { "BYTE" "Sbz1" }
+ { "WORD" "AclSize" }
+ { "WORD" "AceCount" }
+ { "WORD" "Sbz2" } ;
+
+TYPEDEF: ACL* PACL
+
+: ACCESS_ALLOWED_ACE_TYPE 0 ; inline
+: ACCESS_DENIED_ACE_TYPE 1 ; inline
+: SYSTEM_AUDIT_ACE_TYPE 2 ; inline
+: SYSTEM_ALARM_ACE_TYPE 3 ; inline
+
+: OBJECT_INHERIT_ACE HEX: 1 ; inline
+: CONTAINER_INHERIT_ACE HEX: 2 ; inline
+: NO_PROPAGATE_INHERIT_ACE HEX: 4 ; inline
+: INHERIT_ONLY_ACE HEX: 8 ; inline
+: VALID_INHERIT_FLAGS HEX: f ; inline
+
+C-STRUCT: ACE_HEADER
+ { "BYTE" "AceType" }
+ { "BYTE" "AceFlags" }
+ { "WORD" "AceSize" } ;
+
+TYPEDEF: ACE_HEADER* PACE_HEADER
+
+C-STRUCT: ACCESS_ALLOWED_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE
+
+C-STRUCT: ACCESS_DENIED_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE
+
+
+C-STRUCT: SYSTEM_AUDIT_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE
+
+C-STRUCT: SYSTEM_ALARM_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE
+
+C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
+
+
+! typedef enum _TOKEN_INFORMATION_CLASS {
+: TokenUser 1 ; inline
+: TokenGroups 2 ; inline
+: TokenPrivileges 3 ; inline
+: TokenOwner 4 ; inline
+: TokenPrimaryGroup 5 ; inline
+: TokenDefaultDacl 6 ; inline
+: TokenSource 7 ; inline
+: TokenType 8 ; inline
+: TokenImpersonationLevel 9 ; inline
+: TokenStatistics 10 ; inline
+: TokenRestrictedSids 11 ; inline
+: TokenSessionId 12 ; inline
+: TokenGroupsAndPrivileges 13 ; inline
+: TokenSessionReference 14 ; inline
+: TokenSandBoxInert 15 ; inline
+! } TOKEN_INFORMATION_CLASS;
+
+: DELETE HEX: 00010000 ; inline
+: READ_CONTROL HEX: 00020000 ; inline
+: WRITE_DAC HEX: 00040000 ; inline
+: WRITE_OWNER HEX: 00080000 ; inline
+: SYNCHRONIZE HEX: 00100000 ; inline
+: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
+
+: STANDARD_RIGHTS_READ READ_CONTROL ; inline
+: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
+: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
+
+: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
+: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
+: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
+: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
+: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
+: TOKEN_DUPLICATE HEX: 0002 ; inline
+: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
+: TOKEN_IMPERSONATE HEX: 0004 ; inline
+: TOKEN_QUERY HEX: 0008 ; inline
+: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
+: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
+: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
+
+: TOKEN_WRITE
+ {
+ STANDARD_RIGHTS_WRITE
+ TOKEN_ADJUST_PRIVILEGES
+ TOKEN_ADJUST_GROUPS
+ TOKEN_ADJUST_DEFAULT
+ } flags ; foldable
+
+: TOKEN_ALL_ACCESS
+ {
+ STANDARD_RIGHTS_REQUIRED
+ TOKEN_ASSIGN_PRIMARY
+ TOKEN_DUPLICATE
+ TOKEN_IMPERSONATE
+ TOKEN_QUERY
+ TOKEN_QUERY_SOURCE
+ TOKEN_ADJUST_PRIVILEGES
+ TOKEN_ADJUST_GROUPS
+ TOKEN_ADJUST_SESSIONID
+ TOKEN_ADJUST_DEFAULT
+ } flags ; foldable
+
! : I_ScGetCurrentGroupStateW ;
! : A_SHAFinal ;
! : AddAccessDeniedAce ;
! : AddAccessDeniedAceEx ;
! : AddAccessDeniedObjectAce ;
-! : AddAce ;
+FUNCTION: BOOL AddAce ( PACL pAcl, DWORD dwAceRevision, DWORD dwStartingAceIndex, LPVOID pAceList, DWORD nAceListLength ) ;
! : AddAuditAccessAce ;
! : AddAuditAccessAceEx ;
! : AddAuditAccessObjectAce ;
! : ImpersonateLoggedOnUser ;
! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ;
-! : InitializeAcl ;
+FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
! : InitializeSecurityDescriptor ;
! : InitializeSid ;
! : InitiateSystemShutdownA ;
! : OpenEventLogA ;
! : OpenEventLogW ;
-! typedef enum _TOKEN_INFORMATION_CLASS {
-: TokenUser 1 ;
-: TokenGroups 2 ;
-: TokenPrivileges 3 ;
-: TokenOwner 4 ;
-: TokenPrimaryGroup 5 ;
-: TokenDefaultDacl 6 ;
-: TokenSource 7 ;
-: TokenType 8 ;
-: TokenImpersonationLevel 9 ;
-: TokenStatistics 10 ;
-: TokenRestrictedSids 11 ;
-: TokenSessionId 12 ;
-: TokenGroupsAndPrivileges 13 ;
-: TokenSessionReference 14 ;
-: TokenSandBoxInert 15 ;
-! } TOKEN_INFORMATION_CLASS;
-
-: DELETE HEX: 00010000 ; inline
-: READ_CONTROL HEX: 00020000 ; inline
-: WRITE_DAC HEX: 00040000 ; inline
-: WRITE_OWNER HEX: 00080000 ; inline
-: SYNCHRONIZE HEX: 00100000 ; inline
-: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
-
-: STANDARD_RIGHTS_READ READ_CONTROL ; inline
-: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
-: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
-
-: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
-: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
-: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
-: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
-: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
-: TOKEN_DUPLICATE HEX: 0002 ; inline
-: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
-: TOKEN_IMPERSONATE HEX: 0004 ; inline
-: TOKEN_QUERY HEX: 0008 ; inline
-: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
-: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
-: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
-
-: TOKEN_WRITE
- {
- STANDARD_RIGHTS_WRITE
- TOKEN_ADJUST_PRIVILEGES
- TOKEN_ADJUST_GROUPS
- TOKEN_ADJUST_DEFAULT
- } flags ; foldable
-
-: TOKEN_ALL_ACCESS
- {
- STANDARD_RIGHTS_REQUIRED
- TOKEN_ASSIGN_PRIMARY
- TOKEN_DUPLICATE
- TOKEN_IMPERSONATE
- TOKEN_QUERY
- TOKEN_QUERY_SOURCE
- TOKEN_ADJUST_PRIVILEGES
- TOKEN_ADJUST_GROUPS
- TOKEN_ADJUST_SESSIONID
- TOKEN_ADJUST_DEFAULT
- } flags ; foldable
-
FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle,
DWORD DesiredAccess,
PHANDLE TokenHandle ) ;
: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline
: LM_SETITEM WM_USER HEX: 0302 + ; inline
: LM_GETITEM WM_USER HEX: 0303 + ; inline
+
+
+: WA_INACTIVE 0 ; inline
+: WA_ACTIVE 1 ; inline
+: WA_CLICKACTIVE 2 ; inline
+
+: SC_SIZE HEX: f000 ; inline
+: SC_MOVE HEX: f010 ; inline
+: SC_MINIMIZE HEX: f020 ; inline
+: SC_MAXIMIZE HEX: f030 ; inline
+: SC_NEXTWINDOW HEX: f040 ; inline
+: SC_PREVWINDOW HEX: f050 ; inline
+: SC_CLOSE HEX: f060 ; inline
+: SC_VSCROLL HEX: f070 ; inline
+: SC_HSCROLL HEX: f080 ; inline
+: SC_MOUSEMENU HEX: f090 ; inline
+: SC_KEYMENU HEX: f100 ; inline
+: SC_ARRANGE HEX: f110 ; inline
+: SC_RESTORE HEX: f120 ; inline
+: SC_TASKLIST HEX: f130 ; inline
+: SC_SCREENSAVE HEX: f140 ; inline
+: SC_HOTKEY HEX: f150 ; inline
TUPLE: x-clipboard atom contents ;
: <x-clipboard> ( atom -- clipboard )
- "" x-clipboard construct-boa ;
+ "" x-clipboard boa ;
: selection-property ( -- n )
"org.factorcode.Factor.SELECTION" x-atom ;
: handle-event ( event window -- )
over XAnyEvent-type {
- { [ dup Expose = ] [ drop expose-event ] }
- { [ dup ConfigureNotify = ] [ drop configure-event ] }
- { [ dup ButtonPress = ] [ drop button-down-event$ ] }
- { [ dup ButtonRelease = ] [ drop button-up-event$ ] }
- { [ dup EnterNotify = ] [ drop enter-event ] }
- { [ dup LeaveNotify = ] [ drop leave-event ] }
- { [ dup MotionNotify = ] [ drop motion-event ] }
- { [ dup KeyPress = ] [ drop key-down-event ] }
- { [ dup KeyRelease = ] [ drop key-up-event ] }
- { [ dup FocusIn = ] [ drop focus-in-event ] }
- { [ dup FocusOut = ] [ drop focus-out-event ] }
- { [ dup SelectionNotify = ] [ drop selection-notify-event ] }
- { [ dup SelectionRequest = ] [ drop selection-request-event ] }
- { [ dup ClientMessage = ] [ drop client-event ] }
- { [ t ] [ 3drop ] }
- } cond ;
+ { Expose [ expose-event ] }
+ { ConfigureNotify [ configure-event ] }
+ { ButtonPress [ button-down-event$ ] }
+ { ButtonRelease [ button-up-event$ ] }
+ { EnterNotify [ enter-event ] }
+ { LeaveNotify [ leave-event ] }
+ { MotionNotify [ motion-event ] }
+ { KeyPress [ key-down-event ] }
+ { KeyRelease [ key-up-event ] }
+ { FocusIn [ focus-in-event ] }
+ { FocusOut [ focus-out-event ] }
+ { SelectionNotify [ selection-notify-event ] }
+ { SelectionRequest [ selection-request-event ] }
+ { ClientMessage [ client-event ] }
+ [ 3drop ]
+ } case ;
: configured-loc ( event -- dim )
dup XConfigureEvent-x swap XConfigureEvent-y 2array ;
TUPLE: server-error tag message ;
: server-error ( tag message -- * )
- \ server-error construct-boa throw ;
+ \ server-error boa throw ;
M: server-error error.
"Error in XML supplied to server" print
dup children>string {
{ [ dup "1" = ] [ 2drop t ] }
{ [ "0" = ] [ drop f ] }
- { [ t ] [ "Bad boolean" server-error ] }
+ [ "Bad boolean" server-error ]
} cond ;
: unstruct-member ( tag -- )
] if* ;
M: attrs assoc-size attrs-alist length ;
-M: attrs new-assoc drop V{ } new <attrs> ;
+M: attrs new-assoc drop V{ } new
-sequence <attrs> ;
M: attrs >alist attrs-alist ;
: >attrs ( assoc -- attrs )
continuations assocs sequences.deep ;
! This is insufficient
+\ read-xml must-infer
+
SYMBOL: xml-file
[ ] [ "extra/xml/tests/test.xml" resource-path
[ file>xml ] with-html-entities xml-file set ] unit-test
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.errors xml.data xml.utilities xml.char-classes
+USING: xml.errors xml.data xml.utilities xml.char-classes sets
xml.entities kernel state-parser kernel namespaces strings math
math.parser sequences assocs arrays splitting combinators unicode.case ;
IN: xml.tokenize
{ [ dup not ] [ 2drop ] }
{ [ 2dup = ] [ 2drop next ] }
{ [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
- { [ t ] [ , next (parse-char) ] }
+ [ , next (parse-char) ]
} cond ;
: parse-char ( ch -- string )
T{ name f "" "version" f }
T{ name f "" "encoding" f }
T{ name f "" "standalone" f }
- } swap seq-diff
+ } swap diff
dup empty? [ drop ] [ <extra-attrs> throw ] if ;
: good-version ( version -- version )
{
{ [ get-char dup CHAR: ! = ] [ drop next direct ] }
{ [ CHAR: ? = ] [ next instruct ] }
- { [ t ] [
+ [
start-tag [ dup add-ns pop-ns <closer> ]
[ middle-tag end-tag ] if
CHAR: > expect
- ] }
+ ]
} cond ;
: run-process ( tag word -- )
2dup "xtable" word-prop
>r dup name-tag r> at* [ 2nip call ] [
- drop \ process-missing construct-boa throw
+ drop \ process-missing boa throw
] if ;
: PROCESS:
xml-pprint? get [ -1 indentation +@ ] when ;\r
\r
: trim-whitespace ( string -- no-whitespace )\r
- [ [ blank? not ] find drop 0 or ] keep\r
- [ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep\r
- subseq ;\r
+ [ blank? ] trim ;\r
\r
: ?filter-children ( children -- no-whitespace )\r
xml-pprint? get [\r
TAG: MODE
"NAME" over at >r
- mode construct-empty {
+ mode new {
{ "FILE" f set-mode-file }
{ "FILE_NAME_GLOB" f set-mode-file-name-glob }
{ "FIRST_LINE_GLOB" f set-mode-first-line-glob }
USING: kernel strings assocs sequences hashtables sorting
- unicode.case unicode.categories ;
+ unicode.case unicode.categories sets ;
IN: xmode.keyword-map
! Based on org.gjt.sp.jedit.syntax.KeywordMap
] keep ;
: merge-rule-set-props ( props rule-set -- )
- [ rule-set-props union ] keep set-rule-set-props ;
+ [ rule-set-props assoc-union ] keep set-rule-set-props ;
! Top-level entry points
: parse-mode-tag ( tag -- rule-sets )
} set-slots ;
: <rule-set> ( -- ruleset )
- rule-set construct-empty dup init-rule-set ;
+ rule-set new dup init-rule-set ;
MEMO: standard-rule-set ( id -- ruleset )
<rule-set> [ set-rule-set-default ] keep ;
;
: construct-rule ( class -- rule )
- >r rule construct-empty r> construct-delegate ; inline
+ >r rule new r> construct-delegate ; inline
TUPLE: seq-rule ;
TUPLE: company employees type ;
-: <company> V{ } clone f company construct-boa ;
+: <company> V{ } clone f company boa ;
: add-employee company-employees push ;
TUPLE: employee name description ;
TAG: employee
- employee construct-empty
+ employee new
{ { "name" f set-employee-name } { f set-employee-description } }
init-from-tag swap add-employee ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io lint kernel math tools.test ;
+IN: lint.tests
+
+! Don't write code like this
+: lint1
+ [ "hi" print ] [ ] if ; ! when
+
+[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
+
+: lint2
+ 1 + ; ! 1+
+[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
+
+: lint3
+ dup -rot ; ! tuck
+
+[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors arrays assocs combinators.lib io kernel
+macros math namespaces prettyprint quotations sequences
+vectors vocabs words html.elements slots.private tar ;
+IN: lint
+
+SYMBOL: def-hash
+SYMBOL: def-hash-keys
+
+: set-hash-vector ( val key hash -- )
+ 2dup at -rot >r >r ?push r> r> set-at ;
+
+: add-word-def ( word quot -- )
+ dup callable? [
+ def-hash get-global set-hash-vector
+ ] [
+ 2drop
+ ] if ;
+
+: more-defs
+ {
+ { [ swap >r swap r> ] -rot }
+ { [ swap swapd ] -rot }
+ { [ >r swap r> swap ] rot }
+ { [ swapd swap ] rot }
+ { [ dup swap ] over }
+ { [ dup -rot ] tuck }
+ { [ >r swap r> ] swapd }
+ { [ nip nip ] 2nip }
+ { [ drop drop ] 2drop }
+ { [ drop drop drop ] 3drop }
+ { [ 0 = ] zero? }
+ { [ pop drop ] pop* }
+ { [ [ ] if ] when }
+ } [ first2 swap add-word-def ] 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
+ {
+ [ get ] [ t ] [ { } ] [ . ] [ drop f ]
+ [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
+ [ ">" write-html ] [ <unimplemented-typeflag> throw ]
+ [ "/>" write-html ]
+ } ;
+
+H{ } clone def-hash set-global
+all-words [ dup word-def add-word-def ] each
+more-defs
+
+! Remove empty word defs
+def-hash get-global [
+ drop empty? not
+] assoc-subset
+
+! Remove constants [ 1 ]
+[
+ drop dup length 1 = swap first number? and not
+] assoc-subset
+
+! Remove set-alien-cell, etc.
+[
+ drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
+] assoc-subset
+
+! Remove trivial defs
+[
+ drop trivial-defs member? not
+] assoc-subset
+
+! Remove n m shift defs
+[
+ drop dup length 3 = [
+ dup first2 [ number? ] both?
+ swap third \ shift = and not
+ ] [ drop t ] if
+] assoc-subset
+
+! Remove [ n slot ]
+[
+ drop dup length 2 = [
+ first2 \ slot = swap number? and not
+ ] [ drop t ] if
+] assoc-subset def-hash set-global
+
+: find-duplicates
+ def-hash get-global [
+ nip length 1 >
+ ] assoc-subset ;
+
+def-hash get-global keys def-hash-keys set-global
+
+GENERIC: lint ( obj -- seq )
+
+M: object lint ( obj -- seq )
+ drop f ;
+
+: subseq/member? ( subseq/member seq -- ? )
+ { [ 2dup start ] [ 2dup member? ] } || 2nip ;
+
+M: callable lint ( quot -- seq )
+ def-hash-keys get [
+ swap subseq/member?
+ ] with subset ;
+
+M: word lint ( word -- seq )
+ word-def dup callable? [ lint ] [ drop f ] if ;
+
+: word-path. ( word -- )
+ [ word-vocabulary ":" ] keep unparse 3append write nl ;
+
+: (lint.) ( pair -- )
+ first2 >r word-path. r> [
+ bl bl bl bl
+ dup .
+ "-----------------------------------" print
+ def-hash get at [ bl bl bl bl word-path. ] each
+ nl
+ ] each nl nl ;
+
+: lint. ( alist -- )
+ [ (lint.) ] each ;
+
+
+GENERIC: run-lint ( obj -- obj )
+
+: (trim-self)
+ def-hash get-global at* [
+ dupd remove empty? not
+ ] [
+ drop f
+ ] if ;
+
+: trim-self ( seq -- newseq )
+ [ [ (trim-self) ] subset ] assoc-map ;
+
+: filter-symbols ( alist -- alist )
+ [
+ nip first dup def-hash get at
+ [ first ] bi@ literalize = not
+ ] assoc-subset ;
+
+M: sequence run-lint ( seq -- seq )
+ [
+ global [ dup . flush ] bind
+ dup lint
+ ] { } map>assoc
+ trim-self
+ [ second empty? not ] subset
+ 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
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel math.constants ;
+IN: random-tester.databank
+
+: databank ( -- array )
+ {
+ ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
+ pi 1/0. -1/0. 0/0. [ ]
+ f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
+ C{ 2 2 } C{ 1/0. 1/0. }
+ } ;
+
--- /dev/null
+USING: compiler continuations io kernel math namespaces
+prettyprint quotations random sequences vectors
+compiler.units ;
+USING: random-tester.databank random-tester.safe-words ;
+IN: random-tester
+
+SYMBOL: errored
+SYMBOL: before
+SYMBOL: after
+SYMBOL: quot
+TUPLE: random-tester-error ;
+
+: setup-test ( #data #code -- data... quot )
+ #! Variable stack effect
+ >r [ databank random ] times r>
+ [ drop \ safe-words get random ] map >quotation ;
+
+: test-compiler ! ( data... quot -- ... )
+ errored off
+ dup quot set
+ datastack 1 head* before set
+ [ call ] [ drop ] recover
+ datastack after set
+ clear
+ before get [ ] each
+ quot get [ compile-call ] [ errored on ] recover ;
+
+: do-test ! ( data... quot -- )
+ .s flush test-compiler
+ errored get [
+ datastack after get 2dup = [
+ 2drop
+ ] [
+ [ . ] each
+ "--" print
+ [ . ] each
+ quot get .
+ random-tester-error construct-empty throw
+ ] if
+ ] unless clear ;
+
+: random-test1 ( #data #code -- )
+ setup-test do-test ;
+
+: random-test2 ( -- )
+ 3 2 setup-test do-test ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel math sequences namespaces hashtables words
+arrays parser compiler syntax io prettyprint optimizer
+random math.constants math.functions layouts random-tester.utils ;
+IN: random-tester
+
+! Tweak me
+: max-length 15 ; inline
+: max-value 1000000000 ; inline
+
+! varying bit-length random number
+: random-bits ( n -- int )
+ random 2 swap ^ random ;
+
+: random-seq ( -- seq )
+ { [ ] { } V{ } "" } random
+ [ max-length random [ max-value random , ] times ] swap make ;
+
+: random-string
+ [ max-length random [ max-value random , ] times ] "" make ;
+
+: special-integers ( -- seq ) \ special-integers get ;
+[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
+{ } make \ special-integers set-global
+: special-floats ( -- seq ) \ special-floats get ;
+[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
+{ } make \ special-floats set-global
+: special-complexes ( -- seq ) \ special-complexes get ;
+[
+ { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
+ e , e neg , pi , pi neg ,
+ 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
+ pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
+ e neg e neg rect> , e e rect> ,
+] { } make \ special-complexes set-global
+
+: random-fixnum ( -- fixnum )
+ most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
+
+: random-bignum ( -- bignum )
+ 400 random-bits first-bignum + 50% [ neg ] when ;
+
+: random-integer ( -- n )
+ 50% [
+ random-fixnum
+ ] [
+ 50% [ random-bignum ] [ special-integers get random ] if
+ ] if ;
+
+: random-positive-integer ( -- int )
+ random-integer dup 0 < [
+ neg
+ ] [
+ dup 0 = [ 1 + ] when
+ ] if ;
+
+: random-ratio ( -- ratio )
+ 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
+
+: random-float ( -- float )
+ 50% [ random-ratio ] [ special-floats get random ] if
+ 50%
+ [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
+ >float ;
+
+: random-number ( -- number )
+ {
+ [ random-integer ]
+ [ random-ratio ]
+ [ random-float ]
+ } do-one ;
+
+: random-complex ( -- C )
+ random-number random-number rect> ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel namespaces sequences sorting vocabs ;
+USING: arrays assocs generic hashtables math math.intervals math.parser math.functions refs shuffle vectors words ;
+IN: random-tester.safe-words
+
+: ?-words
+ {
+ delegate
+
+ /f
+
+ bits>float bits>double
+ float>bits double>bits
+
+ >bignum >boolean >fixnum >float
+
+ array? integer? complex? value-ref? ref? key-ref?
+ interval? number?
+ wrapper? tuple?
+ [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
+ 2^ not
+ ! arrays
+ resize-array <array>
+ ! assocs
+ (assoc-stack)
+ new-assoc
+ assoc-like
+ <hashtable>
+ all-integers? (all-integers?) ! hangs?
+ assoc-push-if
+
+ (clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
+ } ;
+
+: bignum-words
+ {
+ next-power-of-2 (next-power-of-2)
+ times
+ hashcode hashcode*
+ } ;
+
+: initialization-words
+ {
+ init-namespaces
+ } ;
+
+: stack-words
+ {
+ dup
+ drop 2drop 3drop
+ roll -roll 2swap
+
+ >r r>
+ } ;
+
+: stateful-words
+ {
+ counter
+ gensym
+ } ;
+
+: foo-words
+ {
+ set-retainstack
+ retainstack callstack
+ datastack
+ callstack>array
+ } ;
+
+: exit-words
+ {
+ call-clear die
+ } ;
+
+: bad-words ( -- array )
+ [
+ ?-words %
+ bignum-words %
+ initialization-words %
+ stack-words %
+ stateful-words %
+ exit-words %
+ foo-words %
+ ] { } make ;
+
+: safe-words ( -- array )
+ bad-words {
+ "alists" "arrays" "assocs" ! "bit-arrays" "byte-arrays"
+ ! "classes" "combinators" "compiler" "continuations"
+ ! "core-foundation" "definitions" "documents"
+ ! "float-arrays" "generic" "graphs" "growable"
+ "hashtables" ! io.*
+ "kernel" "math"
+ "math.bitfields" "math.complex" "math.constants" "math.floats"
+ "math.functions" "math.integers" "math.intervals" "math.libm"
+ "math.parser" "math.ratios" "math.vectors"
+ ! "namespaces" "quotations" "sbufs"
+ ! "queues" "strings" "sequences"
+ "vectors"
+ ! "words"
+ } [ words ] map concat seq-diff natural-sort ;
+
+safe-words \ safe-words set-global
+
+! foo dup (clone) = .
+! foo dup clone = .
+! f [ byte-array>bignum assoc-clone-like ] compile-1
+! 2 3.14 [ construct-empty number= ] compile-1
+! 3.14 [ <vector> assoc? ] compile-1
+! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
+
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: arrays assocs combinators.lib continuations kernel
+math math.functions memoize namespaces quotations random sequences
+sequences.private shuffle ;
+IN: random-tester.utils
+
+: %chance ( n -- ? )
+ 100 random > ;
+
+: 10% ( -- ? ) 10 %chance ;
+: 20% ( -- ? ) 20 %chance ;
+: 30% ( -- ? ) 30 %chance ;
+: 40% ( -- ? ) 40 %chance ;
+: 50% ( -- ? ) 50 %chance ;
+: 60% ( -- ? ) 60 %chance ;
+: 70% ( -- ? ) 70 %chance ;
+: 80% ( -- ? ) 80 %chance ;
+: 90% ( -- ? ) 90 %chance ;
+
+: call-if ( quot ? -- ) swap when ; inline
+
+: with-10% ( quot -- ) 10% call-if ; inline
+: with-20% ( quot -- ) 20% call-if ; inline
+: with-30% ( quot -- ) 30% call-if ; inline
+: with-40% ( quot -- ) 40% call-if ; inline
+: with-50% ( quot -- ) 50% call-if ; inline
+: with-60% ( quot -- ) 60% call-if ; inline
+: with-70% ( quot -- ) 70% call-if ; inline
+: with-80% ( quot -- ) 80% call-if ; inline
+: with-90% ( quot -- ) 90% call-if ; inline
+
+: random-key keys random ;
+: random-value [ random-key ] keep at ;
+
+: do-one ( seq -- ) random call ; inline
-#ifndef DEBUG
- CFLAGS += -fomit-frame-pointer
-#endif
+CFLAGS += -fomit-frame-pointer
EXE_SUFFIX =
DLL_PREFIX = lib
{
CELL *object;
- if(nursery->size - ALLOT_BUFFER_ZONE > a)
+ if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a)
{
/* If there is insufficient room, collect the nursery */
if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
+#include <ucontext.h>
+
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
+}
+
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
#ifndef environ
extern char ***_NSGetEnviron(void);
#define environ (*_NSGetEnviron())
-#endif
\ No newline at end of file
+#endif
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return ucontext->uc_stack.ss_sp;
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return ucontext->uc_stack.ss_sp;
-}
dpush(result);
}
+DEFINE_PRIMITIVE(os_env)
+{
+ char *name = unbox_char_string();
+ char *value = getenv(name);
+ if(value == NULL)
+ dpush(F);
+ else
+ box_char_string(value);
+}
+
DEFINE_PRIMITIVE(os_envs)
{
GROWABLE_ARRAY(result);
dpush(result);
}
+DEFINE_PRIMITIVE(set_os_env)
+{
+ char *key = unbox_char_string();
+ REGISTER_C_STRING(key);
+ char *value = unbox_char_string();
+ UNREGISTER_C_STRING(key);
+ setenv(key, value, 1);
+}
+
+DEFINE_PRIMITIVE(unset_os_env)
+{
+ char *key = unbox_char_string();
+ unsetenv(key);
+}
+
DEFINE_PRIMITIVE(set_os_envs)
{
F_ARRAY *array = untag_array(dpop());
Sleep(msec);
}
+DEFINE_PRIMITIVE(os_env)
+{
+ F_CHAR *key = unbox_u16_string();
+ F_CHAR *value = safe_malloc(MAX_UNICODE_PATH * 2);
+ int ret;
+ ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH * 2);
+ if(ret == 0)
+ dpush(F);
+ else
+ dpush(tag_object(from_u16_string(value)));
+ free(value);
+}
+
+DEFINE_PRIMITIVE(set_os_env)
+{
+ F_CHAR *key = unbox_u16_string();
+ REGISTER_C_STRING(key);
+ F_CHAR *value = unbox_u16_string();
+ UNREGISTER_C_STRING(key);
+ if(!SetEnvironmentVariable(key, value))
+ general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
+}
+
+DEFINE_PRIMITIVE(unset_os_env)
+{
+ if(!SetEnvironmentVariable(unbox_u16_string(), NULL)
+ && GetLastError() != ERROR_ENVVAR_NOT_FOUND)
+ general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
+}
+
DEFINE_PRIMITIVE(set_os_envs)
{
not_implemented_error();
#include "os-unix.h"
#ifdef __APPLE__
- #include "os-unix-ucontext.h"
#include "os-macosx.h"
#include "mach_signal.h"
#if defined(FACTOR_X86)
#include "os-linux-x86.32.h"
#elif defined(FACTOR_PPC)
- #include "os-unix-ucontext.h"
#include "os-linux-ppc.h"
#elif defined(FACTOR_ARM)
#include "os-linux-arm.h"
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_os_envs,
+ primitive_set_os_env,
+ primitive_unset_os_env,
primitive_set_os_envs,
primitive_resize_byte_array,
primitive_resize_bit_array,
exit(to_fixnum(dpop()));
}
-DEFINE_PRIMITIVE(os_env)
-{
- char *name = unbox_char_string();
- char *value = getenv(name);
- if(value == NULL)
- dpush(F);
- else
- box_char_string(value);
-}
-
DEFINE_PRIMITIVE(eq)
{
CELL lhs = dpop();
DECLARE_PRIMITIVE(exit);
DECLARE_PRIMITIVE(os_env);
DECLARE_PRIMITIVE(os_envs);
+DECLARE_PRIMITIVE(set_os_env);
+DECLARE_PRIMITIVE(unset_os_env);
DECLARE_PRIMITIVE(set_os_envs);
DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
word->counter = tag_fixnum(0);
word->compiledp = F;
word->profiling = NULL;
+ word->code = NULL;
REGISTER_UNTAGGED(word);
default_word_code(word,true);
memset((void*)AREF(array,0),'\0',capacity * CELLS);
else
{
+ /* No need for write barrier here. Either the object is in
+ the nursery, or it was allocated directly in tenured space
+ and the write barrier is already hit for us in that case. */
for(i = 0; i < capacity; i++)
- set_array_nth(array,i,fill);
+ put(AREF(array,i),fill);
}
return array;
}
memcpy(new_array + 1,array + 1,to_copy * CELLS);
for(i = to_copy; i < capacity; i++)
- set_array_nth(new_array,i,fill);
+ put(AREF(new_array,i),fill);
return new_array;
}
UNREGISTER_UNTAGGED(elts);
+ write_barrier((CELL)result);
+
memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
*result_count += elts_size;
untag_fixnum_fast(string->length)
* sizeof(u16));
UNREGISTER_UNTAGGED(string);
+
+ write_barrier((CELL)string);
string->aux = tag_object(aux);
}
}
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
- new_string->aux = tag_object(new_aux);
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
+ new_string->aux = tag_object(new_aux);
+
F_BYTE_ARRAY *aux = untag_object(string->aux);
memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
}
projects / factor.git / commitdiff