Merge branch 'master' of git://factorcode.org/git/factor
Eduardo Cavazos
commit
e465b4d585
|
|
@ -89,6 +89,11 @@ set_md5sum() {
|
|||
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
|
||||
}
|
||||
|
|
@ -185,6 +190,7 @@ find_architecture() {
|
|||
i386) ARCH=x86;;
|
||||
i686) ARCH=x86;;
|
||||
amd64) ARCH=x86;;
|
||||
ppc64) ARCH=ppc;;
|
||||
*86) ARCH=x86;;
|
||||
*86_64) ARCH=x86;;
|
||||
"Power Macintosh") ARCH=ppc;;
|
||||
|
|
|
|||
|
|
@ -732,6 +732,8 @@ define-builtin
|
|||
{ "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" }
|
||||
|
|
|
|||
|
|
@ -2,26 +2,6 @@ IN: definitions.tests
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
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." }
|
||||
|
|
|
|||
|
|
@ -79,6 +79,18 @@ ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph"
|
|||
"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
|
||||
|
|
@ -94,6 +106,7 @@ $nl
|
|||
{ $subsection "inference-branches" }
|
||||
{ $subsection "inference-recursive" }
|
||||
{ $subsection "inference-limitations" }
|
||||
{ $subsection "inference-errors" }
|
||||
{ $subsection "dataflow-graphs" }
|
||||
{ $subsection "compiler-transforms" } ;
|
||||
|
||||
|
|
@ -105,16 +118,7 @@ HELP: inference-error
|
|||
{ $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" } "."
|
||||
} ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -587,6 +587,10 @@ set-primitive-effect
|
|||
|
||||
\ (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
|
||||
|
|
|
|||
|
|
@ -7,9 +7,7 @@ ABOUT: "system"
|
|||
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 }
|
||||
|
|
@ -19,7 +17,16 @@ ARTICLE: "system" "System interface"
|
|||
{ $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:"
|
||||
|
|
@ -30,7 +37,7 @@ ARTICLE: "cpu" "Processor Detection"
|
|||
"Processor families:"
|
||||
{ $subsection x86 } ;
|
||||
|
||||
ARTICLE: "os" "Operating System Detection"
|
||||
ARTICLE: "os" "Operating system detection"
|
||||
"Operating system detection:"
|
||||
{ $subsection os }
|
||||
"Supported operating systems:"
|
||||
|
|
@ -98,7 +105,23 @@ HELP: set-os-envs
|
|||
}
|
||||
{ $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
|
||||
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-env unset-os-env set-os-envs } related-words
|
||||
|
||||
HELP: image
|
||||
{ $values { "path" "a pathname string" } }
|
||||
|
|
|
|||
|
|
@ -12,3 +12,10 @@ os unix? [
|
|||
[ ] [ "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
|
||||
|
||||
|
|
|
|||
|
|
@ -110,6 +110,8 @@ IN: vocabs.loader.tests
|
|||
] 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
|
||||
|
|
|
|||
|
|
@ -6,8 +6,7 @@ IN: db.postgresql.ffi
|
|||
|
||||
<< "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 >>
|
||||
|
||||
|
|
|
|||
|
|
@ -224,7 +224,7 @@ $nl
|
|||
":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"
|
||||
|
|
@ -259,7 +259,7 @@ $nl
|
|||
{ $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"
|
||||
|
|
@ -273,7 +273,7 @@ $nl
|
|||
$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."
|
||||
|
|
@ -285,7 +285,7 @@ $nl
|
|||
"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." }
|
||||
|
|
@ -312,7 +312,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
|
|||
$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." }
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ $nl
|
|||
|
||||
HELP: next-change
|
||||
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
|
||||
{ $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" } "." } ;
|
||||
{ $description "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" } "." } ;
|
||||
|
||||
HELP: with-monitor
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,38 @@
|
|||
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 macosx linux } member? [
|
||||
[ "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> "c" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"b" get count-down
|
||||
[
|
||||
"m" get next-change drop
|
||||
dup print flush right-trim-separators
|
||||
"xyz" tail? not
|
||||
] [ ] [ ] while
|
||||
"c" 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
|
||||
|
||||
[ ] [ "c" get 30 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
||||
[ "m" get dispose ] must-fail
|
||||
] when
|
||||
|
|
@ -1,87 +1,130 @@
|
|||
! 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
|
||||
|
||||
! "setup" objects
|
||||
TUPLE: profile server port nickname password default-channels ;
|
||||
C: <profile> profile
|
||||
! utils
|
||||
: split-at-first ( seq separators -- before after )
|
||||
dupd '[ , member? ] find
|
||||
[ cut 1 tail ]
|
||||
[ swap ]
|
||||
if ;
|
||||
|
||||
TUPLE: channel-profile name password auto-rejoin ;
|
||||
C: <channel-profile> channel-profile
|
||||
: 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: irc-profile server port nickname password default-channels ;
|
||||
C: <irc-profile> irc-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 construct-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 construct-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 ;
|
||||
|
|
@ -89,123 +132,155 @@ SYMBOL: irc-client
|
|||
: 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 port -- stream )
|
||||
<inet> latin1 <client> ;
|
||||
|
||||
: connect ( server -- ) 6667 connect* ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: quit ( text -- )
|
||||
: PRIVMSG ( nick line -- )
|
||||
[ "PRIVMSG " irc-write irc-write ] dip
|
||||
" :" irc-write irc-print ;
|
||||
|
||||
: SAY ( nick line -- )
|
||||
PRIVMSG ;
|
||||
|
||||
: 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 ;
|
||||
name>> "_" append NICK ;
|
||||
|
||||
: delegate-timestamp ( obj -- obj )
|
||||
now <irc-message> over set-delegate ;
|
||||
: 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 ;
|
||||
|
||||
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> ] }
|
||||
! Reader
|
||||
: handle-reader-message ( irc-client irc-message -- )
|
||||
dup handle-irc swap stream-channel>> to ;
|
||||
|
||||
{ { ?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> ] }
|
||||
: 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* ;
|
||||
|
||||
{ { "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> ] }
|
||||
! Controller commands
|
||||
GENERIC: handle-command ( obj -- )
|
||||
|
||||
! { { ?name "353" ?name2 _ ?channel ?text }
|
||||
! [ ?text ?channel ?name2 make-member-list ] }
|
||||
{ _ [ line get <unhandled> ] }
|
||||
} match-cond
|
||||
delegate-timestamp handle-irc flush ;
|
||||
M: object handle-command ( obj -- )
|
||||
. ;
|
||||
|
||||
: irc-loop ( -- )
|
||||
irc-stream> stream-readln
|
||||
[ match-irc irc-loop ] when* ;
|
||||
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 ;
|
||||
|
|
@ -1,98 +0,0 @@
|
|||
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 } ;
|
||||
|
|
@ -3,13 +3,74 @@
|
|||
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?
|
||||
|
|
@ -32,6 +93,10 @@ GENERIC: method-prologue ( combination -- quot )
|
|||
} 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 ] ] }
|
||||
|
|
@ -52,209 +117,164 @@ GENERIC: method-prologue ( combination -- quot )
|
|||
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 )
|
||||
[
|
||||
word-name %
|
||||
"-(" % [ "," % ] [ word-name % ] interleave ")" %
|
||||
] "" make ;
|
||||
: method-word-name ( specializer generic -- string )
|
||||
[ word-name % "-" % unparse % ] "" 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
|
||||
: method-word-props ( specializer generic -- assoc )
|
||||
[
|
||||
"multi-method-generic" set
|
||||
"multi-method-specializer" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: <method> ( specializer generic -- word )
|
||||
[ method-word-props ] 2keep
|
||||
method-word-name f <word>
|
||||
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. ;
|
||||
"Available methods: " print
|
||||
generic>> methods canonicalize-specializers drop sort-methods
|
||||
keys [ niceify-method ] map stack. ;
|
||||
|
||||
TUPLE: standard-combination ;
|
||||
|
||||
M: standard-combination method-prologue drop [ ] ;
|
||||
|
||||
M: standard-combination generic-prologue drop [ ] ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: update-generic ( word -- )
|
||||
dup make-generic define ;
|
||||
|
||||
: define-generic ( word combination -- )
|
||||
over "multi-combination" word-prop over = [
|
||||
2drop
|
||||
] [
|
||||
dupd "multi-combination" set-word-prop
|
||||
dup H{ } clone "multi-methods" set-word-prop
|
||||
update-generic
|
||||
] if ;
|
||||
|
||||
: define-standard-generic ( word -- )
|
||||
T{ standard-combination } define-generic ;
|
||||
|
||||
: 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
|
||||
|
||||
: 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
|
||||
|
||||
: define-method ( quot classes generic -- )
|
||||
>r [ bootstrap-word ] map r>
|
||||
[ <method> ] 2keep
|
||||
[ set-at ] with-methods ;
|
||||
|
||||
: forget-method ( classes generic -- )
|
||||
: forget-method ( specializer generic -- )
|
||||
[ delete-at ] with-methods ;
|
||||
|
||||
: method>spec ( method -- spec )
|
||||
dup method-classes swap method-generic prefix ;
|
||||
[ "multi-method-specializer" word-prop ]
|
||||
[ "multi-method-generic" word-prop ] bi prefix ;
|
||||
|
||||
: define-generic ( word -- )
|
||||
dup "multi-methods" word-prop [
|
||||
drop
|
||||
] [
|
||||
[ H{ } clone "multi-methods" set-word-prop ]
|
||||
[ update-generic ]
|
||||
bi
|
||||
] if ;
|
||||
|
||||
! Syntax
|
||||
: GENERIC:
|
||||
CREATE define-generic ; parsing
|
||||
|
||||
: parse-method ( -- quot classes generic )
|
||||
parse-definition dup 2 tail over second rot first ;
|
||||
parse-definition [ 2 tail ] [ second ] [ first ] tri ;
|
||||
|
||||
: METHOD:
|
||||
location
|
||||
>r parse-method [ define-method ] 2keep prefix r>
|
||||
remember-definition ; parsing
|
||||
: create-method-in ( specializer generic -- method )
|
||||
create-method dup save-location f set-word ;
|
||||
|
||||
: CREATE-METHOD
|
||||
scan-word scan-object swap create-method-in ;
|
||||
|
||||
: (METHOD:) CREATE-METHOD parse-definition ;
|
||||
|
||||
: 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 ;
|
||||
syntax:M: generic definer drop \ GENERIC: f ;
|
||||
|
||||
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: 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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,66 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
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 } ;
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
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
|
||||
|
|
@ -318,11 +318,11 @@ M: object build-locals ( code ast -- )
|
|||
|
||||
M: ebnf-action (transform) ( ast -- parser )
|
||||
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
|
||||
string-lines [ parse-lines ] with-compilation-unit action ;
|
||||
string-lines parse-lines action ;
|
||||
|
||||
M: ebnf-semantic (transform) ( ast -- parser )
|
||||
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
|
||||
string-lines [ parse-lines ] with-compilation-unit semantic ;
|
||||
string-lines parse-lines semantic ;
|
||||
|
||||
M: ebnf-var (transform) ( ast -- parser )
|
||||
parser>> (transform) ;
|
||||
|
|
@ -361,7 +361,11 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
|
|||
[ compiled-parse ] curry [ with-scope ] curry ;
|
||||
|
||||
: replace-escapes ( string -- string )
|
||||
"\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ;
|
||||
[
|
||||
"\\t" token [ drop "\t" ] action ,
|
||||
"\\n" token [ drop "\n" ] action ,
|
||||
"\\r" token [ drop "\r" ] action ,
|
||||
] choice* replace ;
|
||||
|
||||
: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,9 @@ SYMBOL: fail
|
|||
SYMBOL: lrstack
|
||||
SYMBOL: heads
|
||||
|
||||
: failed? ( obj -- ? )
|
||||
fail = ;
|
||||
|
||||
: delegates ( -- cache )
|
||||
\ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
|
||||
|
||||
|
|
@ -66,21 +69,18 @@ C: <head> peg-head
|
|||
#! 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.
|
||||
|
|
@ -90,21 +90,29 @@ C: <head> peg-head
|
|||
#! 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)
|
||||
: 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 -- )
|
||||
h p setup-growth
|
||||
r eval-rule
|
||||
dup fail = pos get m pos>> <= or [
|
||||
dup m stop-growth? [
|
||||
drop
|
||||
] [
|
||||
m (>>ans)
|
||||
pos get m (>>pos)
|
||||
r p m h (grow-lr)
|
||||
m update-m
|
||||
h p r m (grow-lr)
|
||||
] if ; inline
|
||||
|
||||
:: grow-lr ( r p m h -- ast )
|
||||
:: grow-lr ( h p r m -- ast )
|
||||
h p heads get set-at
|
||||
r p m h (grow-lr)
|
||||
h p r m (grow-lr)
|
||||
p heads get delete-at
|
||||
m pos>> pos set m ans>>
|
||||
; inline
|
||||
|
|
@ -128,10 +136,10 @@ C: <head> peg-head
|
|||
|
|
||||
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>>
|
||||
|
|
@ -150,8 +158,7 @@ C: <head> peg-head
|
|||
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
|
||||
|
|
@ -207,20 +214,18 @@ C: <head> peg-head
|
|||
|
||||
GENERIC: (compile) ( 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 = [
|
||||
: execute-parser ( word -- result )
|
||||
pos get apply-rule dup failed? [
|
||||
drop f
|
||||
] [
|
||||
input-slice swap <parse-result>
|
||||
] if
|
||||
]
|
||||
] ;
|
||||
] if ; inline
|
||||
|
||||
: parser-body ( parser -- quot )
|
||||
#! Return the body of the word that is the compiled version
|
||||
#! of the parser.
|
||||
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.
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
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
|
||||
|
|
@ -1,24 +1,46 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: threads io.files io.monitors init kernel
|
||||
vocabs.loader tools.vocabs namespaces continuations ;
|
||||
vocabs vocabs.loader tools.vocabs namespaces continuations
|
||||
sequences splitting assocs command-line ;
|
||||
IN: tools.vocabs.monitor
|
||||
|
||||
! Use file system change monitoring to flush the tags/authors
|
||||
! cache
|
||||
SYMBOL: vocab-monitor
|
||||
: vocab-dir>vocab-name ( path -- vocab )
|
||||
left-trim-separators right-trim-separators
|
||||
{ { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;
|
||||
|
||||
: monitor-thread ( -- )
|
||||
vocab-monitor get-global
|
||||
next-change 2drop
|
||||
t sources-changed? set-global reset-cache ;
|
||||
: path>vocab-name ( path -- vocab )
|
||||
dup ".factor" tail? [ parent-directory ] when ;
|
||||
|
||||
: start-monitor-thread
|
||||
: chop-vocab-root ( path -- path' )
|
||||
"resource:" prepend-path (normalize-path)
|
||||
dup vocab-roots get
|
||||
[ (normalize-path) ] map
|
||||
[ head? ] with find nip
|
||||
?head drop ;
|
||||
|
||||
: path>vocab ( path -- vocab )
|
||||
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
|
||||
|
||||
: monitor-thread ( monitor -- )
|
||||
#! On OS X, monitors give us the full path, so we chop it
|
||||
#! off if its there.
|
||||
next-change drop path>vocab changed-vocab reset-cache ;
|
||||
|
||||
: start-monitor-thread ( -- )
|
||||
#! Silently ignore errors during monitor creation since
|
||||
#! monitors are not supported on all platforms.
|
||||
[
|
||||
"" resource-path t <monitor> vocab-monitor set-global
|
||||
[ monitor-thread t ] "Vocabulary monitor" spawn-server drop
|
||||
"" resource-path t <monitor> [ monitor-thread t ] curry
|
||||
"Vocabulary monitor" spawn-server drop
|
||||
|
||||
H{ } clone changed-vocabs set-global
|
||||
|
||||
vocabs [ changed-vocab ] each
|
||||
] ignore-errors ;
|
||||
|
||||
[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook
|
||||
[
|
||||
"-no-monitors" cli-args get member? [
|
||||
start-monitor-thread
|
||||
] unless
|
||||
] "tools.vocabs.monitor" add-init-hook
|
||||
|
|
|
|||
|
|
@ -21,55 +21,25 @@ IN: tools.vocabs
|
|||
|
||||
: vocab-tests ( vocab -- tests )
|
||||
[
|
||||
dup vocab-tests-file [ , ] when*
|
||||
vocab-tests-dir [ % ] when*
|
||||
[ vocab-tests-file [ , ] when* ]
|
||||
[ vocab-tests-dir [ % ] when* ] bi
|
||||
] { } make ;
|
||||
|
||||
: vocab-files ( vocab -- seq )
|
||||
[
|
||||
dup vocab-source-path [ , ] when*
|
||||
dup vocab-docs-path [ , ] when*
|
||||
vocab-tests %
|
||||
[ vocab-source-path [ , ] when* ]
|
||||
[ vocab-docs-path [ , ] when* ]
|
||||
[ vocab-tests % ] tri
|
||||
] { } make ;
|
||||
|
||||
: source-modified? ( path -- ? )
|
||||
dup source-files get at [
|
||||
dup source-file-path
|
||||
dup exists? [
|
||||
utf8 file-lines lines-crc32
|
||||
swap source-file-checksum = not
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] [
|
||||
exists?
|
||||
] ?if ;
|
||||
|
||||
: modified ( seq quot -- seq )
|
||||
[ dup ] swap compose { } map>assoc
|
||||
[ nip ] assoc-subset
|
||||
[ nip source-modified? ] assoc-subset keys ; inline
|
||||
|
||||
: modified-sources ( vocabs -- seq )
|
||||
[ vocab-source-path ] modified ;
|
||||
|
||||
: modified-docs ( vocabs -- seq )
|
||||
[ vocab-docs-path ] modified ;
|
||||
|
||||
: to-refresh ( prefix -- modified-sources modified-docs )
|
||||
child-vocabs
|
||||
dup modified-sources swap modified-docs ;
|
||||
|
||||
: vocab-heading. ( vocab -- )
|
||||
nl
|
||||
"==== " write
|
||||
dup vocab-name swap vocab write-object ":" print
|
||||
[ vocab-name ] [ vocab write-object ] bi ":" print
|
||||
nl ;
|
||||
|
||||
: load-error. ( triple -- )
|
||||
dup first vocab-heading.
|
||||
dup second print-error
|
||||
drop ;
|
||||
[ first vocab-heading. ] [ second print-error ] bi ;
|
||||
|
||||
: load-failures. ( failures -- )
|
||||
[ load-error. nl ] each ;
|
||||
|
|
@ -88,31 +58,100 @@ SYMBOL: failures
|
|||
failures get
|
||||
] with-compiler-errors ;
|
||||
|
||||
: do-refresh ( modified-sources modified-docs -- )
|
||||
2dup
|
||||
[ f swap set-vocab-docs-loaded? ] each
|
||||
[ f swap set-vocab-source-loaded? ] each
|
||||
append prune require-all load-failures. ;
|
||||
: source-modified? ( path -- ? )
|
||||
dup source-files get at [
|
||||
dup source-file-path
|
||||
dup exists? [
|
||||
utf8 file-lines lines-crc32
|
||||
swap source-file-checksum = not
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] [
|
||||
exists?
|
||||
] ?if ;
|
||||
|
||||
SYMBOL: changed-vocabs
|
||||
|
||||
[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
|
||||
|
||||
: changed-vocab ( vocab -- )
|
||||
dup vocab
|
||||
[ dup changed-vocabs get-global set-at ] [ drop ] if ;
|
||||
|
||||
: unchanged-vocab ( vocab -- )
|
||||
changed-vocabs get-global delete-at ;
|
||||
|
||||
: unchanged-vocabs ( vocabs -- )
|
||||
[ unchanged-vocab ] each ;
|
||||
|
||||
: filter-changed ( vocabs -- vocabs' )
|
||||
changed-vocabs get [
|
||||
[ key? ] curry subset
|
||||
] when* ;
|
||||
|
||||
SYMBOL: modified-sources
|
||||
SYMBOL: modified-docs
|
||||
|
||||
: (to-refresh) ( vocab variable loaded? path -- )
|
||||
dup [
|
||||
swap [
|
||||
pick changed-vocabs get key? [
|
||||
source-modified? [ get push ] [ 2drop ] if
|
||||
] [ 3drop ] if
|
||||
] [ drop get push ] if
|
||||
] [ 2drop 2drop ] if ;
|
||||
|
||||
: to-refresh ( prefix -- modified-sources modified-docs unchanged )
|
||||
[
|
||||
V{ } clone modified-sources set
|
||||
V{ } clone modified-docs set
|
||||
|
||||
child-vocabs [
|
||||
[
|
||||
[
|
||||
[ modified-sources ]
|
||||
[ vocab-source-loaded? ]
|
||||
[ vocab-source-path ]
|
||||
tri (to-refresh)
|
||||
] [
|
||||
[ modified-docs ]
|
||||
[ vocab-docs-loaded? ]
|
||||
[ vocab-docs-path ]
|
||||
tri (to-refresh)
|
||||
] bi
|
||||
] each
|
||||
|
||||
modified-sources get
|
||||
modified-docs get
|
||||
]
|
||||
[ modified-sources get modified-docs get append swap seq-diff ] bi
|
||||
] with-scope ;
|
||||
|
||||
: do-refresh ( modified-sources modified-docs unchanged -- )
|
||||
unchanged-vocabs
|
||||
[
|
||||
[ [ f swap set-vocab-source-loaded? ] each ]
|
||||
[ [ f swap set-vocab-docs-loaded? ] each ] bi*
|
||||
]
|
||||
[
|
||||
append prune
|
||||
[ unchanged-vocabs ]
|
||||
[ require-all load-failures. ] bi
|
||||
] 2bi ;
|
||||
|
||||
: refresh ( prefix -- ) to-refresh do-refresh ;
|
||||
|
||||
SYMBOL: sources-changed?
|
||||
: refresh-all ( -- ) "" refresh ;
|
||||
|
||||
[ t sources-changed? set-global ] "tools.vocabs" add-init-hook
|
||||
|
||||
: refresh-all ( -- )
|
||||
"" refresh f sources-changed? set-global ;
|
||||
|
||||
MEMO: (vocab-file-contents) ( path -- lines )
|
||||
dup exists? [ utf8 file-lines ] [ drop f ] if ;
|
||||
|
||||
: vocab-file-contents ( vocab name -- seq )
|
||||
vocab-append-path dup [ (vocab-file-contents) ] when ;
|
||||
MEMO: vocab-file-contents ( vocab name -- seq )
|
||||
vocab-append-path dup
|
||||
[ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;
|
||||
|
||||
: set-vocab-file-contents ( seq vocab name -- )
|
||||
dupd vocab-append-path [
|
||||
utf8 set-file-lines
|
||||
\ (vocab-file-contents) reset-memoized
|
||||
\ vocab-file-contents reset-memoized
|
||||
] [
|
||||
"The " swap vocab-name
|
||||
" vocabulary was not loaded from the file system"
|
||||
|
|
@ -261,7 +300,7 @@ MEMO: all-authors ( -- seq )
|
|||
|
||||
: reset-cache ( -- )
|
||||
root-cache get-global clear-assoc
|
||||
\ (vocab-file-contents) reset-memoized
|
||||
\ vocab-file-contents reset-memoized
|
||||
\ all-vocabs-seq reset-memoized
|
||||
\ all-authors reset-memoized
|
||||
\ all-tags reset-memoized ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Eric Mertens
|
||||
|
|
@ -0,0 +1 @@
|
|||
A efficient implementation of a disjoint-set datastructure
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
USING: accessors arrays combinators kernel math sequences namespaces ;
|
||||
|
||||
IN: unionfind
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: unionfind parents ranks counts ;
|
||||
|
||||
SYMBOL: uf
|
||||
|
||||
: count ( a -- n )
|
||||
uf get counts>> nth ;
|
||||
|
||||
: add-count ( p a -- )
|
||||
count [ + ] curry uf get counts>> swap change-nth ;
|
||||
|
||||
: parent ( a -- p )
|
||||
uf get parents>> nth ;
|
||||
|
||||
: set-parent ( p a -- )
|
||||
uf get parents>> set-nth ;
|
||||
|
||||
: link-sets ( p a -- )
|
||||
[ set-parent ]
|
||||
[ add-count ] 2bi ;
|
||||
|
||||
: rank ( a -- r )
|
||||
uf get ranks>> nth ;
|
||||
|
||||
: inc-rank ( a -- )
|
||||
uf get ranks>> [ 1+ ] change-nth ;
|
||||
|
||||
: topparent ( a -- p )
|
||||
[ parent ] keep
|
||||
2dup = [
|
||||
[ topparent ] dip
|
||||
2dup set-parent
|
||||
] unless drop ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <unionfind> ( n -- unionfind )
|
||||
[ >array ]
|
||||
[ 0 <array> ]
|
||||
[ 1 <array> ] tri
|
||||
unionfind construct-boa ;
|
||||
|
||||
: equiv-set-size ( a uf -- n )
|
||||
uf [ topparent count ] with-variable ;
|
||||
|
||||
: equiv? ( a b uf -- ? )
|
||||
uf [ [ topparent ] bi@ = ] with-variable ;
|
||||
|
||||
: equate ( a b uf -- )
|
||||
uf [
|
||||
[ topparent ] bi@
|
||||
2dup [ rank ] compare sgn
|
||||
{
|
||||
{ -1 [ swap link-sets ] }
|
||||
{ 1 [ link-sets ] }
|
||||
{ 0 [
|
||||
2dup =
|
||||
[ 2drop ]
|
||||
[
|
||||
[ link-sets ]
|
||||
[ drop inc-rank ] 2bi
|
||||
] if
|
||||
]
|
||||
}
|
||||
} case
|
||||
] with-variable ;
|
||||
|
|
@ -315,7 +315,7 @@ INLINE void* allot_object(CELL type, CELL a)
|
|||
{
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,12 @@
|
|||
#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])
|
||||
|
|
|
|||
|
|
@ -16,3 +16,9 @@ DLLEXPORT void c_to_factor_toplevel(CELL quot);
|
|||
extern char ***_NSGetEnviron(void);
|
||||
#define environ (*_NSGetEnviron())
|
||||
#endif
|
||||
|
||||
INLINE void *ucontext_stack_pointer(void *uap)
|
||||
{
|
||||
ucontext_t *ucontext = (ucontext_t *)uap;
|
||||
return ucontext->uc_stack.ss_sp;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,7 +0,0 @@
|
|||
#include <ucontext.h>
|
||||
|
||||
INLINE void *ucontext_stack_pointer(void *uap)
|
||||
{
|
||||
ucontext_t *ucontext = (ucontext_t *)uap;
|
||||
return ucontext->uc_stack.ss_sp;
|
||||
}
|
||||
25
vm/os-unix.c
25
vm/os-unix.c
|
|
@ -85,6 +85,16 @@ DEFINE_PRIMITIVE(read_dir)
|
|||
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);
|
||||
|
|
@ -103,6 +113,21 @@ DEFINE_PRIMITIVE(os_envs)
|
|||
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());
|
||||
|
|
|
|||
|
|
@ -215,6 +215,36 @@ void sleep_millis(DWORD msec)
|
|||
Sleep(msec);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(os_env)
|
||||
{
|
||||
F_CHAR *key = unbox_u16_string();
|
||||
F_CHAR *value = safe_malloc(MAX_UNICODE_PATH);
|
||||
int ret;
|
||||
ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH);
|
||||
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();
|
||||
|
|
|
|||
|
|
@ -27,7 +27,6 @@
|
|||
#include "os-unix.h"
|
||||
|
||||
#ifdef __APPLE__
|
||||
#include "os-unix-ucontext.h"
|
||||
#include "os-macosx.h"
|
||||
#include "mach_signal.h"
|
||||
|
||||
|
|
@ -84,7 +83,6 @@
|
|||
#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"
|
||||
|
|
|
|||
|
|
@ -182,6 +182,8 @@ void *primitives[] = {
|
|||
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,
|
||||
|
|
|
|||
10
vm/run.c
10
vm/run.c
|
|
@ -280,16 +280,6 @@ DEFINE_PRIMITIVE(exit)
|
|||
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();
|
||||
|
|
|
|||
Loading…
Reference in New Issue