steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2008-03-13 18:47:21 -05:00
parent c3d41967f7 9a36f36ff7
commit de72d2dbd5
78 changed files with 1208 additions and 943 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
core/classes/classes-docs.factor
View File

@ -1,7 +1,7 @@
USING: help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math
layouts classes.private classes.union classes.mixin
classes.predicate ;
classes.predicate quotations ;
IN: classes
ARTICLE: "builtin-classes" "Built-in classes"
@ -114,24 +114,9 @@ HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
HELP: define-predicate*
{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
{ $description
"Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
{ $list
{ "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" }
{ "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" }
{ "the predicate word's " { $snippet "\"declared-effect\"" } " word property is set to a descriptive " { $link effect } }
}
"These properties are used by method dispatch and the help system."
}
$low-level-note ;
HELP: define-predicate
{ $values { "class" class } { "quot" "a quotation" } }
{ $description
"Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
}
{ $values { "class" class } { "quot" quotation } }
{ $description "Defines a predicate word for a class." }
$low-level-note ;
HELP: superclass

66
core/classes/classes-tests.factor
View File

@ -178,39 +178,39 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
DEFER: mixin-forget-test-g
[ "mixin-forget-test" forget-source ] with-compilation-unit
[ ] [
{
"USING: sequences ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } ] [ { } mixin-forget-test-g ] unit-test
[ H{ } mixin-forget-test-g ] must-fail
[ ] [
{
"USING: hashtables ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } mixin-forget-test-g ] must-fail
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
2 [
[ "mixin-forget-test" forget-source ] with-compilation-unit
[ ] [
{
"USING: sequences ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
[ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
[ ] [
{
"USING: hashtables ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
] times
! Method flattening interfered with mixin update
MIXIN: flat-mx-1

14
core/classes/classes.factor
View File

@ -31,17 +31,9 @@ PREDICATE: class tuple-class
PREDICATE: word predicate "predicating" word-prop >boolean ;
: define-predicate* ( class predicate quot -- )
over [
dupd predicate-effect define-declared
2dup 1quotation "predicate" set-word-prop
swap "predicating" set-word-prop
] [ 3drop ] if ;
: define-predicate ( class quot -- )
over "forgotten" word-prop [ 2drop ] [
>r dup predicate-word r> define-predicate*
] if ;
>r "predicate" word-prop first
r> predicate-effect define-declared ;
: superclass ( class -- super )
"superclass" word-prop ;
@ -257,6 +249,8 @@ PRIVATE>
over reset-class
over deferred? [ over define-symbol ] when
>r dup word-props r> union over set-word-props
dup predicate-word 2dup 1quotation "predicate" set-word-prop
over "predicating" set-word-prop
t "class" set-word-prop ;
GENERIC: update-predicate ( class -- )

2
core/compiler/errors/errors-docs.factor
View File

@ -9,7 +9,7 @@ ARTICLE: "compiler-errors" "Compiler warnings and errors"
{ $subsection :errors }
{ $subsection :warnings }
{ $subsection :linkage }
"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
{ $link with-compiler-errors } ;
HELP: compiler-errors

45
core/io/files/files-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.styles strings
io.backend io.files.private quotations ;
io.backend io.files.private quotations ;
IN: io.files
ARTICLE: "file-streams" "Reading and writing files"
@ -43,13 +43,19 @@ ARTICLE: "directories" "Directories"
{ $subsection make-directory }
{ $subsection make-directories } ;
! ARTICLE: "file-types" "File Types"
! { $table { +directory+ "" } }
! ;
ARTICLE: "fs-meta" "File meta-data"
{ $subsection file-info }
{ $subsection link-info }
{ $subsection exists? }
{ $subsection directory? }
{ $subsection file-length }
{ $subsection file-modified }
! { $subsection file-modified }
{ $subsection stat } ;
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
@ -119,11 +125,26 @@ HELP: file-name
! need a $class-description file-info
HELP: file-info
{ $values { "path" "a pathname string" }
{ "info" "a file-info tuple" } }
{ "info" file-info } }
{ $description "Queries the file system for meta data. "
"If path refers to a symbolic link, it is followed."
"If the file does not exist, an exception is thrown." } ;
"If the file does not exist, an exception is thrown." }
{ $class-description "File meta data" }
{ $table
{ "type" { "One of the following:"
{ $list { $link +regular-file+ }
{ $link +directory+ }
{ $link +symbolic-link+ } } } }
{ "size" "Size of the file in bytes" }
{ "modified" "Last modification timestamp." } }
;
! need a see also to link-info
HELP: link-info
@ -135,6 +156,8 @@ HELP: link-info
"If the file does not exist, an exception is thrown." } ;
! need a see also to file-info
{ file-info link-info } related-words
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
{ "stream" "an input stream" } }
@ -199,7 +222,7 @@ HELP: stat ( path -- directory? permissions length modified )
"Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values."
} ;
{ stat exists? directory? file-length file-modified } related-words
{ stat exists? directory? } related-words
HELP: path+
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
@ -227,13 +250,9 @@ HELP: directory*
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
HELP: file-length
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ;
HELP: file-modified
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
! HELP: file-modified
! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }

9
core/io/files/files.factor
View File

@ -86,11 +86,11 @@ SYMBOL: +unknown+
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
: file-length ( path -- n ) stat drop 2nip ;
! : file-length ( path -- n ) stat drop 2nip ;
: file-modified ( path -- n ) stat >r 3drop r> ;
: file-permissions ( path -- perm ) stat 2drop nip ;
! : file-permissions ( path -- perm ) stat 2drop nip ;
: exists? ( path -- ? ) file-modified >boolean ;
@ -220,7 +220,10 @@ M: pathname <=> [ pathname-string ] compare ;
>r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str )
dupd [ file-length read ] with-file-reader ;
dupd [ file-info file-info-size read ] with-file-reader ;
! : file-contents ( path encoding -- str )
! dupd [ file-length read ] with-file-reader ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline

17
core/parser/parser-tests.factor
View File

@ -430,3 +430,20 @@ IN: parser.tests
[ "resource:core/parser/test/assert-depth.factor" run-file ]
[ relative-overflow-stack { 1 2 3 } sequence= ]
must-fail-with
2 [
[ ] [
"IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
<string-reader> "d-f-s-test" parse-stream drop
] unit-test
[ ] [
"IN: parser.tests DEFER: d-f-s d-f-s FORGET: d-f-s SYMBOL: d-f-s d-f-s"
<string-reader> "d-f-s-test" parse-stream drop
] unit-test
[ ] [
"IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
<string-reader> "d-f-s-test" parse-stream drop
] unit-test
] times

2
core/parser/parser.factor
View File

@ -416,6 +416,7 @@ SYMBOL: interactive-vocabs
"tools.test"
"tools.threads"
"tools.time"
"tools.vocabs"
"vocabs"
"vocabs.loader"
"words"
@ -483,7 +484,6 @@ SYMBOL: interactive-vocabs
: finish-parsing ( lines quot -- )
file get
[ record-form ] keep
[ record-modified ] keep
[ record-definitions ] keep
record-checksum ;

17
core/source-files/source-files-docs.factor
View File

@ -3,16 +3,13 @@ definitions quotations compiler.units ;
IN: source-files
ARTICLE: "source-files" "Source files"
"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement features such as " { $link refresh-all } "."
"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "."
$nl
"The source file database:"
{ $subsection source-files }
"The class of source files:"
{ $subsection source-file }
"Testing if a source file has been changed on disk:"
{ $subsection source-modified? }
"Words intended for the parser:"
{ $subsection record-modified }
{ $subsection record-checksum }
{ $subsection record-form }
{ $subsection xref-source }
@ -34,22 +31,12 @@ HELP: source-file
{ $class-description "Instances retain information about loaded source files, and have the following slots:"
{ $list
{ { $link source-file-path } " - a pathname string." }
{ { $link source-file-modified } " - the result of " { $link file-modified } " at the time the source file was most recently loaded." }
{ { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." }
{ { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." }
{ { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" }
}
} ;
HELP: source-modified?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's modification time and CRC32 checksum of the file's contents against previously-recorded values." } ;
HELP: record-modified
{ $values { "source-file" source-file } }
{ $description "Records the modification time of the source file." }
$low-level-note ;
HELP: record-checksum
{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
{ $description "Records the CRC32 checksm of the source file's contents." }
@ -75,7 +62,7 @@ HELP: record-form
$low-level-note ;
HELP: reset-checksums
{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link refresh } "." } ;
{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ;
HELP: forget-source
{ $values { "path" "a pathname string" } }

43
core/source-files/source-files.factor
View File

@ -1,44 +1,25 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math
namespaces prettyprint sequences strings vectors words
quotations inspector io.styles io combinators sorting
splitting math.parser effects continuations debugger
io.files io.crc32 io.streams.string vocabs
hashtables graphs compiler.units io.encodings.utf8 ;
USING: arrays definitions generic assocs kernel math namespaces
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.crc32 vocabs hashtables
graphs compiler.units io.encodings.utf8 ;
IN: source-files
SYMBOL: source-files
TUPLE: source-file
path
modified checksum
checksum
uses definitions ;
: (source-modified?) ( path modified checksum -- ? )
pick file-modified rot [ 0 or ] 2apply >
[ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ;
: source-modified? ( path -- ? )
dup source-files get at [
dup source-file-path ?resource-path
over source-file-modified
rot source-file-checksum
(source-modified?)
] [
resource-exists?
] ?if ;
: record-modified ( source-file -- )
dup source-file-path ?resource-path file-modified
swap set-source-file-modified ;
: record-checksum ( lines source-file -- )
swap lines-crc32 swap set-source-file-checksum ;
>r lines-crc32 r> set-source-file-checksum ;
: (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> swap source-file-uses
[ crossref? ] subset ;
dup source-file-path <pathname>
swap source-file-uses [ crossref? ] subset ;
: xref-source ( source-file -- )
(xref-source) crossref get add-vertex ;
@ -67,9 +48,7 @@ uses definitions ;
: reset-checksums ( -- )
source-files get [
swap ?resource-path dup exists?
[
over record-modified
swap ?resource-path dup exists? [
utf8 file-lines swap record-checksum
] [ 2drop ] if
] assoc-each ;

22
core/vocabs/loader/loader-docs.factor
View File

@ -23,9 +23,6 @@ $nl
"Application vocabularies can define a main entry point, giving the user a convenient way to run the application:"
{ $subsection POSTPONE: MAIN: }
{ $subsection run }
"Reloading source files changed on disk:"
{ $subsection refresh }
{ $subsection refresh-all }
{ $see-also "vocabularies" "parser-files" "source-files" } ;
ABOUT: "vocabs.loader"
@ -42,20 +39,12 @@ HELP: vocab-main
HELP: vocab-roots
{ $var-description "A sequence of pathname strings to search for vocabularies." } ;
HELP: vocab-tests
{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
HELP: find-vocab-root
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
{ vocab-root find-vocab-root } related-words
HELP: vocab-files
{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
HELP: no-vocab
{ $values { "name" "a vocabulary name" } }
{ $description "Throws a " { $link no-vocab } "." }
@ -80,7 +69,7 @@ HELP: reload
HELP: require
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Loads a vocabulary if it has not already been loaded." }
{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files, use " { $link refresh } " or " { $link refresh-all } "." } ;
{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ;
HELP: run
{ $values { "vocab" "a vocabulary specifier" } }
@ -93,12 +82,3 @@ HELP: vocab-source-path
HELP: vocab-docs-path
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
{ $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
HELP: refresh
{ $values { "prefix" string } }
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
HELP: refresh-all
{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
{ refresh refresh-all } related-words

2
core/vocabs/loader/loader-tests.factor
View File

@ -3,7 +3,7 @@ IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs tuples definitions
debugger compiler.units ;
debugger compiler.units tools.vocabs ;
! This vocab should not exist, but just in case...
[ ] [

82
core/vocabs/loader/loader.factor
View File

@ -48,27 +48,6 @@ M: string vocab-root
M: vocab-link vocab-root
vocab-link-root ;
: vocab-tests ( vocab -- tests )
dup vocab-root [
[
f >vocab-link dup
dup "-tests.factor" vocab-dir+ vocab-path+
dup resource-exists? [ , ] [ drop ] if
dup vocab-dir "tests" path+ vocab-path+ dup
?resource-path directory keys [ ".factor" tail? ] subset
[ path+ , ] with each
] { } make
] [ drop f ] if ;
: vocab-files ( vocab -- seq )
f >vocab-link [
dup vocab-source-path [ , ] when*
dup vocab-docs-path [ , ] when*
vocab-tests %
] { } make ;
SYMBOL: load-help?
: source-was-loaded t swap set-vocab-source-loaded? ;
@ -119,68 +98,7 @@ SYMBOL: load-help?
"To define one, refer to \\ MAIN: help" print
] ?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 ;
: update-roots ( vocabs -- )
[ dup find-vocab-root swap vocab set-vocab-root ] each ;
: to-refresh ( prefix -- modified-sources modified-docs )
child-vocabs
dup update-roots
dup modified-sources swap modified-docs ;
: vocab-heading. ( vocab -- )
nl
"==== " write
dup vocab-name swap vocab write-object ":" print
nl ;
: load-error. ( triple -- )
dup first vocab-heading.
dup second print-error
drop ;
: load-failures. ( failures -- )
[ load-error. nl ] each ;
SYMBOL: blacklist
SYMBOL: failures
: require-all ( vocabs -- failures )
[
V{ } clone blacklist set
V{ } clone failures set
[
[ require ]
[ swap vocab-name failures get set-at ]
recover
] each
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. ;
: refresh ( prefix -- ) to-refresh do-refresh ;
SYMBOL: sources-changed?
[ t sources-changed? set-global ] "vocabs.loader" add-init-hook
: refresh-all ( -- )
"" refresh f sources-changed? set-global ;
GENERIC: (load-vocab) ( name -- vocab )

16
extra/benchmark/benchmark.factor
View File

@ -1,28 +1,28 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.browser
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
continuations debugger ;
continuations debugger combinators.cleave ;
IN: benchmark
: run-benchmark ( vocab -- result )
[ dup require [ run ] benchmark ] [ error. drop f f ] recover 2array ;
[ [ require ] [ [ run ] benchmark nip ] bi ] curry
[ error. f ] recover ;
: run-benchmarks ( -- assoc )
"benchmark" all-child-vocabs values concat [ vocab-name ] map
"benchmark" all-child-vocabs-seq
[ dup run-benchmark ] { } map>assoc ;
: benchmarks. ( assoc -- )
standard-table-style [
[
[ "Benchmark" write ] with-cell
[ "Run time (ms)" write ] with-cell
[ "GC time (ms)" write ] with-cell
[ "Time (ms)" write ] with-cell
] with-row
[
[
swap [ dup ($vocab-link) ] with-cell
first2 pprint-cell pprint-cell
[ [ 1array $vocab-link ] with-cell ]
[ pprint-cell ] bi*
] with-row
] assoc-each
] tabular-output ;

4
extra/benchmark/fasta/fasta.factor Normal file → Executable file
View File

@ -51,7 +51,7 @@ HINTS: random fixnum ;
dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ;
:: select-random ( seed chars floats -- elt )
:: select-random ( seed chars floats -- seed elt )
floats seed random -rot
[ >= ] curry find drop
chars nth-unsafe ; inline
@ -71,7 +71,7 @@ HINTS: random fixnum ;
write-description
[ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta ( k len alu -- )
:: make-repeat-fasta ( k len alu -- k' )
[let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len +

2
extra/bootstrap/tools/tools.factor
View File

@ -11,5 +11,7 @@ USING: vocabs.loader sequences ;
"tools.test"
"tools.time"
"tools.threads"
"tools.vocabs"
"tools.vocabs.browser"
"editors"
} [ require ] each

0
extra/builder/builder.factor Executable file → Normal file
View File

2
extra/builder/test/test.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: kernel namespaces sequences assocs builder continuations
io
io.files
prettyprint
tools.browser
tools.vocabs
tools.test
io.encodings.utf8
combinators.cleave

14
extra/bunny/deploy.factor
View File

@ -1,12 +1,14 @@
USING: tools.deploy.config ;
V{
H{
{ deploy-math? t }
{ deploy-reflection 1 }
{ deploy-name "Bunny" }
{ deploy-threads? t }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
{ deploy-name "Bunny" }
}

6
extra/bunny/outlined/outlined.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: arrays bunny.model bunny.cel-shaded
combinators.lib continuations kernel math multiline
opengl opengl.shaders opengl.framebuffers opengl.gl
opengl.capabilities sequences ui.gadgets ;
opengl.capabilities sequences ui.gadgets combinators.cleave ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
@ -177,7 +177,7 @@ TUPLE: bunny-outlined
[ bunny-outlined-normal-texture [ delete-texture ] when* ]
[ bunny-outlined-depth-texture [ delete-texture ] when* ]
[ f swap set-bunny-outlined-framebuffer-dim ]
} call-with
} cleave
] [ drop ] if ;
: remake-framebuffer-if-needed ( draw -- )
@ -237,4 +237,4 @@ M: bunny-outlined dispose
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
[ dispose-framebuffer ]
} call-with ;
} cleave ;

16
extra/combinators/cleave/cleave-docs.factor
View File

@ -9,6 +9,7 @@ ARTICLE: "cleave-combinators" "Cleave Combinators"
{ $subsection bi }
{ $subsection tri }
{ $subsection cleave }
{ $notes
"From the Merriam-Webster Dictionary: "
@ -49,10 +50,17 @@ HELP: tri
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: cleave
{ $code "( obj { q1 q2 ... qN } -- q1(obj) q2(obj) ... qN(obj) )" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "spread-combinators" "Spread Combinators"
{ $subsection bi* }
{ $subsection tri* } ;
{ $subsection tri* }
{ $subsection spread } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -80,3 +88,9 @@ HELP: tri*
{ "p(x)" "p applied to x" }
{ "q(y)" "q applied to y" }
{ "r(z)" "r applied to z" } } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: spread
{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ;

17
extra/combinators/cleave/cleave.factor
View File

@ -15,7 +15,10 @@ IN: combinators.cleave
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
: 2bi ( x y p q -- p(x,y) q(x,y) ) >r 2keep r> call ; inline
: 2tri ( x y z p q r -- p(x,y,z) q(x,y,z) r(x,y,z) )
>r >r 2keep r> 2keep r> call ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -33,6 +36,18 @@ MACRO: cleave ( seq -- )
[ drop ]
append ;
MACRO: 2cleave ( seq -- )
dup
[ drop [ 2dup ] ] map concat
swap
dup
[ drop [ >r >r ] ] map concat
swap
[ [ r> r> ] append ] map concat
3append
[ 2drop ]
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

6
extra/combinators/lib/lib.factor
View File

@ -133,9 +133,6 @@ MACRO: parallel-call ( quots -- )
: (make-call-with) ( quots -- quot )
[ [ keep ] curry ] map concat [ drop ] append ;
MACRO: call-with ( quots -- )
(make-call-with) ;
MACRO: map-call-with ( quots -- )
[ (make-call-with) ] keep length [ narray ] curry compose ;
@ -143,9 +140,6 @@ MACRO: map-call-with ( quots -- )
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
[ 2drop ] append ;
MACRO: call-with2 ( quots -- )
(make-call-with2) ;
MACRO: map-call-with2 ( quots -- )
[ (make-call-with2) ] keep length [ narray ] curry append ;

5
extra/editors/editors.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces sequences definitions io.files
inspector continuations tuples tools.crossref tools.browser
inspector continuations tuples tools.crossref tools.vocabs
io prettyprint source-files assocs vocabs vocabs.loader ;
IN: editors
@ -13,8 +13,7 @@ M: no-edit-hook summary
SYMBOL: edit-hook
: available-editors ( -- seq )
"editors" all-child-vocabs
values concat [ vocab-name ] map ;
"editors" all-child-vocabs-seq [ vocab-name ] map ;
: editor-restarts ( -- alist )
available-editors

10
extra/editors/vim/generate-syntax/generate-syntax.factor Normal file
View File

@ -0,0 +1,10 @@
! Generate a new factor.vim file for syntax highlighting
USING: http.server.templating.fhtml io.files ;
IN: editors.vim.generate-syntax
: generate-vim-syntax ( -- )
"misc/factor.vim.fgen" resource-path
"misc/factor.vim" resource-path
template-convert ;
MAIN: generate-vim-syntax

10
extra/editors/vim/generate-vim-syntax.factor
View File

@ -1,10 +0,0 @@
! Generate a new factor.vim file for syntax highlighting
REQUIRES: apps/http-server ;
IN: vim
USING: embedded io ;
"extras/factor.vim.fgen" resource-path
"extras/factor.vim" resource-path
embedded-convert

1
extra/help/handbook/handbook.factor
View File

@ -196,6 +196,7 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:"
{ $subsection "editor" }
{ $subsection "tools.crossref" }

2
extra/help/lint/lint.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences parser kernel help help.markup help.topics
words strings classes tools.browser namespaces io
words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate

3
extra/help/markup/markup.factor
View File

@ -169,7 +169,8 @@ M: f print-element drop ;
] if
] ($subsection) ;
: $vocab-link ( element -- ) first dup ($vocab-link) ;
: $vocab-link ( element -- )
first dup vocab-name swap ($vocab-link) ;
: $vocabulary ( element -- )
first word-vocabulary [

4
extra/help/topics/topics.factor Normal file → Executable file
View File

@ -7,6 +7,10 @@ IN: help.topics
TUPLE: link name ;
MIXIN: topic
INSTANCE: link topic
INSTANCE: word topic
GENERIC: >link ( obj -- obj )
M: link >link ;
M: vocab-spec >link ;

2
extra/help/tutorial/tutorial.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax ui.commands ui.operations
ui.tools.search ui.tools.workspace editors vocabs.loader
kernel sequences prettyprint tools.test strings
kernel sequences prettyprint tools.test tools.vocabs strings
unicode.categories unicode.case ;
IN: help.tutorial

3
extra/http/server/server.factor
View File

@ -3,7 +3,7 @@
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
new-slots html.elements accessors math.parser combinators.lib
vocabs.loader debugger html continuations random combinators
tools.vocabs debugger html continuations random combinators
destructors io.encodings.latin1 fry combinators.cleave ;
IN: http.server
@ -12,6 +12,7 @@ GENERIC: call-responder ( path responder -- response )
: <content> ( content-type -- response )
<response>
200 >>code
"Document follows" >>message
swap set-content-type ;
TUPLE: trivial-responder response ;

7
extra/http/server/static/static.factor
View File

@ -7,8 +7,6 @@ calendar.format new-slots accessors io.encodings.binary
combinators.cleave fry ;
IN: http.server.static
SYMBOL: responder
! special maps mime types to quots with effect ( path -- )
TUPLE: file-responder root hook special ;
@ -16,7 +14,8 @@ TUPLE: file-responder root hook special ;
>r unix-1970 r> seconds time+ ;
: file-http-date ( filename -- string )
file-modified unix-time>timestamp timestamp>http-string ;
file-info file-info-modified
unix-time>timestamp timestamp>http-string ;
: last-modified-matches? ( filename -- ? )
file-http-date dup [
@ -33,7 +32,7 @@ TUPLE: file-responder root hook special ;
[
<content>
swap
[ file-length "content-length" set-header ]
[ file-info file-info-size "content-length" set-header ]
[ file-http-date "last-modified" set-header ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
tri

2
extra/io/unix/files/files.factor
View File

@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal ;
M: unix-io copy-file ( from to -- )
[ (copy-file) ] 2keep swap file-permissions chmod io-error ;
[ (copy-file) ] 2keep swap file-info file-info-permissions io-error ;
: stat>type ( stat -- type )
stat-st_mode {

2
extra/io/unix/unix.factor
View File

@ -4,4 +4,4 @@ combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require
"vocabs.monitor" require
"tools.vocabs.monitor" require

47
extra/io/windows/files/files.factor Normal file → Executable file
View File

@ -3,7 +3,7 @@
USING: alien.c-types io.files io.windows kernel
math windows windows.kernel32 combinators.cleave
windows.time calendar combinators math.functions
sequences combinators.lib namespaces words symbols ;
sequences namespaces words symbols ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
@ -11,34 +11,27 @@ SYMBOLS: +read-only+ +hidden+ +system+
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +encrypted+ ;
: expand-constants ( word/obj -- obj'/obj )
dup word? [ execute ] when ;
: get-flags ( n seq -- seq' )
[
[
first2 expand-constants
[ swapd mask? [ , ] [ drop ] if ] 2curry
] map call-with
] { } make ;
: win32-file-attribute ( n attr symbol -- n )
>r dupd mask? [ r> , ] [ r> drop ] if ;
: win32-file-attributes ( n -- seq )
{
{ +read-only+ FILE_ATTRIBUTE_READONLY }
{ +hidden+ FILE_ATTRIBUTE_HIDDEN }
{ +system+ FILE_ATTRIBUTE_SYSTEM }
{ +directory+ FILE_ATTRIBUTE_DIRECTORY }
{ +archive+ FILE_ATTRIBUTE_ARCHIVE }
{ +device+ FILE_ATTRIBUTE_DEVICE }
{ +normal+ FILE_ATTRIBUTE_NORMAL }
{ +temporary+ FILE_ATTRIBUTE_TEMPORARY }
{ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE }
{ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT }
{ +compressed+ FILE_ATTRIBUTE_COMPRESSED }
{ +offline+ FILE_ATTRIBUTE_OFFLINE }
{ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED }
{ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED }
} get-flags ;
[
FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute
FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute
FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute
FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute
FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute
FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute
FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute
FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute
FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute
FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute
FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute
FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute
FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute
FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute
drop
] { } make ;
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;

14
extra/io/windows/launcher/launcher.factor
View File

@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking
io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators
io.backend new-slots accessors ;
io.backend new-slots accessors concurrency.flags ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
@ -137,18 +137,18 @@ M: windows-io kill-process* ( handle -- )
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
SYMBOL: wait-flag
: wait-loop ( -- )
processes get dup assoc-empty?
[ drop f sleep-until ]
[ drop wait-flag get-global lower-flag ]
[ wait-for-processes [ 100 sleep ] when ] if ;
SYMBOL: wait-thread
: start-wait-thread ( -- )
[ wait-loop t ] "Process wait" spawn-server
wait-thread set-global ;
<flag> wait-flag set-global
[ wait-loop t ] "Process wait" spawn-server drop ;
M: windows-io register-process
drop wait-thread get-global interrupt ;
drop wait-flag get-global raise-flag ;
[ start-wait-thread ] "io.windows.launcher" add-init-hook

2
extra/io/windows/nt/nt.factor
View File

@ -14,4 +14,4 @@ USE: io.backend
T{ windows-nt-io } set-io-backend
"vocabs.monitor" require
"tools.vocabs.monitor" require

2
extra/jamshred/jamshred.factor Normal file → Executable file
View File

@ -59,7 +59,7 @@ M: jamshred-gadget ungraft* ( gadget -- )
USE: vocabs.loader
jamshred-gadget H{
{ T{ key-down f f "r" } [ jamshred-restart refresh-all ] }
{ T{ key-down f f "r" } [ jamshred-restart ] }
{ T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
{ T{ motion } [ handle-mouse-motion ] }
} set-gestures

6
extra/locals/locals.factor
View File

@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private effects generic
compiler.units ;
compiler.units combinators.cleave ;
IN: locals
! Inspired by
@ -108,8 +108,8 @@ UNION: special local quote local-word local-reader local-writer ;
if ;
: (point-free) ( quot args -- newquot )
{ [ load-locals ] [ point-free-body ] [ point-free-end ] }
map-call-with2 concat >quotation ;
[ load-locals ] [ point-free-body ] [ point-free-end ]
2tri 3append >quotation ;
: point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ;

27
extra/math/matrices/matrices.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions
math.vectors ;
math.vectors combinators.cleave ;
IN: math.matrices
! Matrices
@ -33,23 +33,22 @@ IN: math.matrices
: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
: cross-i ( vec1 vec2 -- i )
over third over second * >r
swap second swap third * r> - ;
<PRIVATE
: cross-j ( vec1 vec2 -- j )
over first over third * >r
swap third swap first * r> - ;
: x first ; inline
: y second ; inline
: z third ; inline
: cross-k ( vec1 vec2 -- k )
over first over second * >r
swap second swap first * r> - ;
: i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
: j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
: k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
: cross ( vec1 vec2 -- vec3 )
[ cross-i ] 2keep [ cross-j ] 2keep cross-k 3array ;
PRIVATE>
: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
: proj ( v u -- w )
[ [ v. ] keep norm-sq / ] keep n*v ;
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;
: (gram-schmidt) ( v seq -- newseq )
[ dupd proj v- ] each ;

13
extra/opengl/demo-support/demo-support.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render combinators.cleave ;
IN: opengl.demo-support
: NEAR-PLANE 1.0 64.0 / ; inline
@ -47,14 +47,15 @@ M: demo-gadget pref-dim* ( gadget -- dim )
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
GL_MODELVIEW glMatrixMode
glLoadIdentity
{ [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
[ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
[ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } call-with ;
[ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
[ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
[ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ]
tri ;
: reset-last-drag-rel ( -- )
{ 0 0 } last-drag-loc set ;
{ 0 0 } last-drag-loc set-global ;
: last-drag-rel ( -- rel )
drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ;
drag-loc [ last-drag-loc get v- ] keep last-drag-loc set-global ;
: drag-yaw-pitch ( -- yaw pitch )
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;

4
extra/opengl/shaders/shaders.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien libc opengl math sequences combinators.lib
macros arrays ;
macros arrays combinators.cleave ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
@ -117,7 +117,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
: (make-with-gl-program) ( uniforms quot -- q )
[
\ dup ,
[ swap (with-gl-program-uniforms) , \ call-with , % ]
[ swap (with-gl-program-uniforms) , \ cleave , % ]
[ ] make ,
\ (with-gl-program) ,
] [ ] make ;

9
extra/semantic-db/hierarchy/hierarchy.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors db.tuples kernel new-slots semantic-db
semantic-db.relations sorting sequences sequences.deep ;
USING: accessors db.tuples hashtables kernel new-slots
semantic-db semantic-db.relations sequences sequences.deep ;
IN: semantic-db.hierarchy
TUPLE: tree id children ;
@ -34,9 +34,6 @@ C: <tree> tree
: get-node-hierarchy ( node-id -- tree )
dup children [ get-node-hierarchy ] map <tree> ;
: uniq ( sorted-seq -- seq )
f swap [ tuck = not ] subset nip ;
: (get-root-nodes) ( node-id -- root-nodes/node-id )
dup parents dup empty? [
drop
@ -45,4 +42,4 @@ C: <tree> tree
] if ;
: get-root-nodes ( node-id -- root-nodes )
(get-root-nodes) flatten natural-sort uniq ;
(get-root-nodes) flatten prune ;

9
extra/semantic-db/semantic-db-tests.factor
View File

@ -1,6 +1,7 @@
USING: accessors arrays continuations db db.sqlite db.tuples io.files
kernel math namespaces semantic-db semantic-db.context
semantic-db.hierarchy semantic-db.relations sequences tools.test
USING: accessors arrays continuations db db.sqlite
db.tuples io.files kernel math namespaces semantic-db
semantic-db.context semantic-db.hierarchy
semantic-db.relations sequences sorting tools.test
tools.walker ;
IN: semantic-db.tests
@ -63,7 +64,7 @@ test-db [
[ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
[ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
[ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
[ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map ] unit-test
[ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map natural-sort >array ] unit-test
[ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
] with-context
] with-db

4
extra/tools/browser/browser-tests.factor
View File

@ -1,4 +0,0 @@
IN: tools.browser.tests
USING: tools.browser tools.test help.markup ;
[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test

364
extra/tools/browser/browser.factor
View File

@ -1,364 +0,0 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces splitting sequences io.files kernel assocs
words vocabs vocabs.loader definitions parser continuations
inspector debugger io io.styles hashtables
sorting prettyprint source-files arrays combinators strings
system math.parser help.markup help.topics help.syntax
help.stylesheet memoize io.encodings.utf8 ;
IN: tools.browser
MEMO: (vocab-file-contents) ( path -- lines )
?resource-path dup exists?
[ utf8 file-lines ] [ drop f ] if ;
: vocab-file-contents ( vocab name -- seq )
vocab-path+ dup [ (vocab-file-contents) ] when ;
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-path+ [
?resource-path utf8 set-file-lines
] [
"The " swap vocab-name
" vocabulary was not loaded from the file system"
3append throw
] ?if ;
: vocab-summary-path ( vocab -- string )
vocab-dir "summary.txt" path+ ;
: vocab-summary ( vocab -- summary )
dup dup vocab-summary-path vocab-file-contents
dup empty? [
drop vocab-name " vocabulary" append
] [
nip first
] if ;
M: vocab summary
[
dup vocab-summary %
" (" %
vocab-words assoc-size #
" words)" %
] "" make ;
M: vocab-link summary vocab-summary ;
: set-vocab-summary ( string vocab -- )
>r 1array r>
dup vocab-summary-path
set-vocab-file-contents ;
: vocab-tags-path ( vocab -- string )
vocab-dir "tags.txt" path+ ;
: vocab-tags ( vocab -- tags )
dup vocab-tags-path vocab-file-contents ;
: set-vocab-tags ( tags vocab -- )
dup vocab-tags-path set-vocab-file-contents ;
: add-vocab-tags ( tags vocab -- )
[ vocab-tags append prune ] keep set-vocab-tags ;
: vocab-authors-path ( vocab -- string )
vocab-dir "authors.txt" path+ ;
: vocab-authors ( vocab -- authors )
dup vocab-authors-path vocab-file-contents ;
: set-vocab-authors ( authors vocab -- )
dup vocab-authors-path set-vocab-file-contents ;
: subdirs ( dir -- dirs )
directory [ second ] subset keys natural-sort ;
: (all-child-vocabs) ( root name -- vocabs )
[ vocab-dir path+ ?resource-path subdirs ] keep
dup empty? [
drop
] [
swap [ "." swap 3append ] with map
] if ;
: vocabs-in-dir ( root name -- )
dupd (all-child-vocabs) [
2dup vocab-dir? [ 2dup swap >vocab-link , ] when
vocabs-in-dir
] with each ;
: all-vocabs ( -- assoc )
vocab-roots get [
dup [ "" vocabs-in-dir ] { } make
] { } map>assoc ;
MEMO: all-vocabs-seq ( -- seq )
all-vocabs values concat ;
: dangerous? ( name -- ? )
#! Hack
{
{ [ "cpu." ?head ] [ t ] }
{ [ "io.unix" ?head ] [ t ] }
{ [ "io.windows" ?head ] [ t ] }
{ [ "ui.x11" ?head ] [ t ] }
{ [ "ui.windows" ?head ] [ t ] }
{ [ "ui.cocoa" ?head ] [ t ] }
{ [ "cocoa" ?head ] [ t ] }
{ [ "core-foundation" ?head ] [ t ] }
{ [ "vocabs.loader.test" ?head ] [ t ] }
{ [ "editors." ?head ] [ t ] }
{ [ ".windows" ?tail ] [ t ] }
{ [ ".unix" ?tail ] [ t ] }
{ [ "unix." ?head ] [ t ] }
{ [ ".linux" ?tail ] [ t ] }
{ [ ".bsd" ?tail ] [ t ] }
{ [ ".macosx" ?tail ] [ t ] }
{ [ "windows." ?head ] [ t ] }
{ [ "cocoa" ?head ] [ t ] }
{ [ ".test" ?tail ] [ t ] }
{ [ "raptor" ?head ] [ t ] }
{ [ dup "tools.deploy.app" = ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
: filter-dangerous ( seq -- seq' )
[ vocab-name dangerous? not ] subset ;
: try-everything ( -- failures )
all-vocabs-seq
filter-dangerous
require-all ;
: load-everything ( -- )
try-everything load-failures. ;
: unrooted-child-vocabs ( prefix -- seq )
dup empty? [ CHAR: . add ] unless
vocabs
[ vocab-root not ] subset
[
vocab-name swap ?head CHAR: . rot member? not and
] with subset
[ vocab ] map ;
: all-child-vocabs ( prefix -- assoc )
vocab-roots get [
over dupd dupd (all-child-vocabs)
swap [ >vocab-link ] curry map
] { } map>assoc
f rot unrooted-child-vocabs 2array add ;
: load-children ( prefix -- )
all-child-vocabs values concat
filter-dangerous
require-all
load-failures. ;
: vocab-status-string ( vocab -- string )
{
{ [ dup not ] [ drop "" ] }
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
{ [ t ] [ drop "[Loaded]" ] }
} cond ;
: write-status ( vocab -- )
vocab vocab-status-string write ;
: vocab. ( vocab -- )
[
dup [ write-status ] with-cell
dup [ ($link) ] with-cell
[ vocab-summary write ] with-cell
] with-row ;
: vocab-headings. ( -- )
[
[ "State" write ] with-cell
[ "Vocabulary" write ] with-cell
[ "Summary" write ] with-cell
] with-row ;
: root-heading. ( root -- )
[ "Children from " swap append ] [ "Children" ] if*
$heading ;
: vocabs. ( assoc -- )
[
dup empty? [
2drop
] [
swap root-heading.
standard-table-style [
vocab-headings. [ vocab. ] each
] ($grid)
] if
] assoc-each ;
: describe-summary ( vocab -- )
vocab-summary [
"Summary" $heading print-element
] when* ;
TUPLE: vocab-tag name ;
C: <vocab-tag> vocab-tag
: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
: describe-tags ( vocab -- )
vocab-tags f like [
"Tags" $heading tags.
] when* ;
TUPLE: vocab-author name ;
C: <vocab-author> vocab-author
: authors. ( seq -- ) [ <vocab-author> ] map $links ;
: describe-authors ( vocab -- )
vocab-authors f like [
"Authors" $heading authors.
] when* ;
: describe-help ( vocab -- )
vocab-help [
"Documentation" $heading nl ($link)
] when* ;
: describe-children ( vocab -- )
vocab-name all-child-vocabs vocabs. ;
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
"Files" $heading
[
snippet-style get [
code-style get [
stack.
] with-nesting
] with-style
] ($block)
] when* ;
: describe-words ( vocab -- )
words dup empty? [
"Words" $heading
dup natural-sort $links
] unless drop ;
: map>set ( seq quot -- )
map concat prune natural-sort ; inline
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words r> map
[ [ word? ] subset [ word-vocabulary ] map ] map>set
remove [ ] subset [ vocab ] map ; inline
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
: describe-uses ( vocab -- )
vocab-uses dup empty? [
"Uses" $heading
dup $links
] unless drop ;
: describe-usage ( vocab -- )
vocab-usage dup empty? [
"Used by" $heading
dup $links
] unless drop ;
: $describe-vocab ( element -- )
first
dup describe-children
dup vocab-root over vocab-dir? [
dup describe-summary
dup describe-tags
dup describe-authors
dup describe-files
] when
dup vocab [
dup describe-help
dup describe-words
dup describe-uses
dup describe-usage
] when drop ;
: keyed-vocabs ( str quot -- seq )
all-vocabs [
swap >r
[ >r 2dup r> swap call member? ] subset
r> swap
] assoc-map 2nip ; inline
: tagged ( tag -- assoc )
[ vocab-tags ] keyed-vocabs ;
: authored ( author -- assoc )
[ vocab-authors ] keyed-vocabs ;
: $tagged-vocabs ( element -- )
first tagged vocabs. ;
MEMO: all-tags ( -- seq )
all-vocabs-seq [ vocab-tags ] map>set ;
: $authored-vocabs ( element -- )
first authored vocabs. ;
MEMO: all-authors ( -- seq )
all-vocabs-seq [ vocab-authors ] map>set ;
: $tags ( element -- )
drop "Tags" $heading all-tags tags. ;
: $authors ( element -- )
drop "Authors" $heading all-authors authors. ;
M: vocab-spec article-title vocab-name " vocabulary" append ;
M: vocab-spec article-name vocab-name ;
M: vocab-spec article-content
vocab-name \ $describe-vocab swap 2array ;
M: vocab-spec article-parent drop "vocab-index" ;
M: vocab-tag >link ;
M: vocab-tag article-title
vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
M: vocab-tag article-name vocab-tag-name ;
M: vocab-tag article-content
\ $tagged-vocabs swap vocab-tag-name 2array ;
M: vocab-tag article-parent drop "vocab-index" ;
M: vocab-tag summary article-title ;
M: vocab-author >link ;
M: vocab-author article-title
vocab-author-name "Vocabularies by " swap append ;
M: vocab-author article-name vocab-author-name ;
M: vocab-author article-content
\ $authored-vocabs swap vocab-author-name 2array ;
M: vocab-author article-parent drop "vocab-index" ;
M: vocab-author summary article-title ;
: reset-cache ( -- )
\ (vocab-file-contents) reset-memoized
\ all-vocabs-seq reset-memoized
\ all-authors reset-memoized
\ all-tags reset-memoized ;

48
extra/tools/deploy/backend/backend.factor
View File

@ -34,31 +34,33 @@ IN: tools.deploy.backend
: ?, [ , ] [ drop ] if ;
: bootstrap-profile ( config -- profile )
: bootstrap-profile ( -- profile )
[
[
"math" deploy-math? get ?,
"compiler" deploy-compiler? get ?,
"ui" deploy-ui? get ?,
"io" native-io? ?,
] { } make
] bind ;
"math" deploy-math? get ?,
"compiler" deploy-compiler? get ?,
"ui" deploy-ui? get ?,
"io" native-io? ?,
] { } make ;
: staging-image-name ( profile -- name )
"staging." swap bootstrap-profile "-" join ".image" 3append ;
: staging-image-name ( -- name )
"staging."
bootstrap-profile strip-word-names? [ "strip" add ] when
"-" join ".image" 3append ;
: staging-command-line ( config -- flags )
[
"-i=" my-boot-image-name append ,
[
"-i=" my-boot-image-name append ,
"-output-image=" over staging-image-name append ,
"-output-image=" staging-image-name append ,
"-include=" swap bootstrap-profile " " join append ,
"-include=" bootstrap-profile " " join append ,
"-no-stack-traces" ,
strip-word-names? [ "-no-stack-traces" , ] when
"-no-user-init" ,
] { } make ;
"-no-user-init" ,
] { } make
] bind ;
: run-factor ( vm flags -- )
swap add* dup . run-with-output ; inline
@ -68,16 +70,18 @@ IN: tools.deploy.backend
: deploy-command-line ( image vocab config -- flags )
[
"-i=" swap staging-image-name append ,
[
"-i=" staging-image-name append ,
"-run=tools.deploy.shaker" ,
"-run=tools.deploy.shaker" ,
"-deploy-vocab=" swap append ,
"-deploy-vocab=" swap append ,
"-output-image=" swap append ,
"-output-image=" swap append ,
"-no-stack-traces" ,
] { } make ;
strip-word-names? [ "-no-stack-traces" , ] when
] { } make
] bind ;
: make-deploy-image ( vm image vocab config -- )
make-boot-image

2
extra/tools/deploy/config/config.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs.loader io.files io kernel sequences assocs
splitting parser prettyprint namespaces math vocabs
hashtables tools.browser ;
hashtables tools.vocabs ;
IN: tools.deploy.config
SYMBOL: deploy-name

26
extra/tools/deploy/deploy-tests.factor
View File

@ -1,11 +1,11 @@
IN: tools.deploy.tests
USING: tools.test system io.files kernel tools.deploy.config
tools.deploy.backend math ;
tools.deploy.backend math sequences io.launcher ;
: shake-and-bake
"." resource-path [
vm
"hello.image" temp-file
"test.image" temp-file
rot dup deploy-config make-deploy-image
] with-directory ;
@ -15,8 +15,30 @@ tools.deploy.backend math ;
"hello.image" temp-file file-length 500000 <=
] unit-test
[ ] [ "sudoku" shake-and-bake ] unit-test
[ t ] [
"hello.image" temp-file file-length 1500000 <=
] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test
[ t ] [
"hello.image" temp-file file-length 2000000 <=
] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [
"hello.image" temp-file file-length 3000000 <=
] unit-test
[ ] [
"tools.deploy.test.1" shake-and-bake
vm "-i=" "test.image" temp-file append try-process
] unit-test
[ ] [
"tools.deploy.test.2" shake-and-bake
vm "-i=" "test.image" temp-file append try-process
] unit-test

190
extra/tools/deploy/shaker/shaker.factor
View File

@ -1,11 +1,29 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
inspector layouts vocabs.loader prettyprint.config prettyprint
debugger io.streams.c io.streams.duplex io.files io.backend
quotations words.private tools.deploy.config compiler.units ;
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 ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: compiler.errors.private
QUALIFIED: compiler.units
QUALIFIED: continuations
QUALIFIED: definitions
QUALIFIED: init
QUALIFIED: inspector
QUALIFIED: io.backend
QUALIFIED: io.nonblocking
QUALIFIED: io.thread
QUALIFIED: layouts
QUALIFIED: libc.private
QUALIFIED: libc.private
QUALIFIED: listener
QUALIFIED: prettyprint.config
QUALIFIED: random.private
QUALIFIED: source-files
QUALIFIED: threads
QUALIFIED: vocabs
IN: tools.deploy.shaker
: strip-init-hooks ( -- )
@ -43,9 +61,6 @@ IN: tools.deploy.shaker
run-file
] when ;
: strip-assoc ( retained-keys assoc -- newassoc )
swap [ nip member? ] curry assoc-subset ;
: strip-word-names ( words -- )
"Stripping word names" show
[ f over set-word-name f swap set-word-vocabulary ] each ;
@ -57,8 +72,11 @@ IN: tools.deploy.shaker
: strip-word-props ( retain-props words -- )
"Stripping word properties" show
[
[ word-props strip-assoc f assoc-like ] keep
set-word-props
[
word-props swap
'[ , nip member? ] assoc-subset
f assoc-like
] keep set-word-props
] with each ;
: retained-props ( -- seq )
@ -81,10 +99,101 @@ IN: tools.deploy.shaker
strip-word-names? [ dup strip-word-names ] when
2drop ;
: strip-environment ( retain-globals -- )
: strip-recompile-hook ( -- )
[ [ f ] { } map>assoc ]
compiler.units:recompile-hook
set-global ;
: strip-vocab-globals ( except names -- words )
[ child-vocabs [ words ] map concat ] map concat seq-diff ;
: stripped-globals ( -- seq )
[
random.private:mt ,
{
bootstrap.stage2:bootstrap-time
continuations:error
continuations:error-continuation
continuations:error-thread
continuations:restarts
error-hook
init:init-hooks
inspector:inspector-hook
io.thread:io-thread
libc.private:mallocs
source-files:source-files
stderr
stdio
} %
deploy-threads? [
threads:initial-thread ,
] unless
strip-io? [ io.backend:io-backend , ] when
{ io.backend:io-backend io.nonblocking:default-buffer-size }
{ "alarms" "io" "tools" } strip-vocab-globals %
strip-dictionary? [
{ } { "cpu" } strip-vocab-globals %
{
vocabs:dictionary
lexer-factory
vocabs:load-vocab-hook
layouts:num-tags
layouts:num-types
layouts:tag-mask
layouts:tag-numbers
layouts:type-numbers
classes:typemap
vocab-roots
definitions:crossref
compiled-crossref
interactive-vocabs
word
compiler.units:recompile-hook
listener:listener-hook
lexer-factory
classes:update-map
classes:class<map
} %
] when
strip-prettyprint? [
{
prettyprint.config:margin
prettyprint.config:string-limit
prettyprint.config:tab-size
} %
] when
strip-debugger? [
{
compiler.errors.private:compiler-errors
continuations:thread-error-hook
} %
] when
deploy-c-types? get [
"c-types" "alien.c-types" lookup ,
] unless
deploy-ui? get [
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
] { } make ;
: strip-globals ( stripped-globals -- )
strip-globals? [
"Stripping environment" show
global strip-assoc 21 setenv
"Stripping globals" show
global swap
'[ drop , member? not ] assoc-subset
[ drop string? not ] assoc-subset ! strip CLI args
dup keys .
21 setenv
] [ drop ] if ;
: finish-deploy ( final-image -- )
@ -108,55 +217,6 @@ SYMBOL: deploy-vocab
] [ ] make "Boot quotation: " write dup . flush
set-boot-quot ;
: retained-globals ( -- seq )
[
builtins ,
strip-io? [ io-backend , ] unless
strip-dictionary? [
{
dictionary
inspector-hook
lexer-factory
load-vocab-hook
num-tags
num-types
tag-bits
tag-mask
tag-numbers
typemap
vocab-roots
} %
] unless
strip-prettyprint? [
{
tab-size
margin
} %
] unless
deploy-c-types? get [
"c-types" "alien.c-types" lookup ,
] when
native-io? [
"default-buffer-size" "io.nonblocking" lookup ,
] when
deploy-ui? get [
"ui" child-vocabs
"cocoa" child-vocabs
deploy-vocab get child-vocabs 3append
global keys [ word? ] subset
swap [ >r word-vocabulary r> member? ] curry
subset %
] when
] { } make dup . ;
: strip-recompile-hook ( -- )
[ [ f ] { } map>assoc ] recompile-hook set-global ;
: strip ( -- )
strip-libc
strip-cocoa
@ -165,7 +225,7 @@ SYMBOL: deploy-vocab
strip-init-hooks
deploy-vocab get vocab-main set-boot-quot*
retained-props >r
retained-globals strip-environment
stripped-globals strip-globals
r> strip-words ;
: (deploy) ( final-image vocab config -- )

6
extra/tools/deploy/test/1/1.factor Executable file
View File

@ -0,0 +1,6 @@
IN: tools.deploy.test.1
USING: threads ;
: deploy-test-1 1000 sleep ;
MAIN: deploy-test-1

14
extra/tools/deploy/test/1/deploy.factor Executable file
View File

@ -0,0 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-c-types? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-threads? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-name "tools.deploy.test.1" }
{ deploy-math? t }
{ deploy-compiler? t }
{ "stop-after-last-window?" t }
{ deploy-ui? f }
}

6
extra/tools/deploy/test/2/2.factor Executable file
View File

@ -0,0 +1,6 @@
IN: tools.deploy.test.2
USING: calendar calendar.format ;
: deploy-test-2 now (timestamp>string) ;
MAIN: deploy-test-2

14
extra/tools/deploy/test/2/deploy.factor Executable file
View File

@ -0,0 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-c-types? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-threads? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-name "tools.deploy.test.2" }
{ deploy-math? t }
{ deploy-compiler? t }
{ "stop-after-last-window?" t }
{ deploy-ui? f }
}

8
extra/tools/deploy/test/3/3.factor Executable file
View File

@ -0,0 +1,8 @@
IN: tools.deploy.test.3
USING: io.encodings.ascii io.files kernel ;
: deploy-test-3
"resource:extra/tools/deploy/test/3/3.factor"
?resource-path ascii file-contents drop ;
MAIN: deploy-test-3

14
extra/tools/deploy/test/3/deploy.factor Executable file
View File

@ -0,0 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-math? t }
{ deploy-reflection 1 }
{ deploy-name "tools.deploy.test.3" }
{ deploy-threads? t }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
{ deploy-ui? f }
{ deploy-io 3 }
{ deploy-compiler? t }
{ deploy-word-defs? f }
{ deploy-c-types? f }
}

6
extra/tools/disassembler/disassembler-tests.factor Executable file
View File

@ -0,0 +1,6 @@
IN: tools.disassembler.tests
USING: math tuples prettyprint.backend tools.disassembler
tools.test strings ;
[ ] [ \ + disassemble ] unit-test
[ ] [ { string pprint* } disassemble ] unit-test

6
extra/tools/disassembler/disassembler.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces qualified
system math generator.fixup io.encodings.ascii accessors ;
system math generator.fixup io.encodings.ascii accessors
generic ;
IN: tools.disassembler
: in-file "gdb-in.txt" temp-file ;
@ -22,6 +23,9 @@ M: pair make-disassemble-cmd
[ number>string write bl ] each
] with-file-writer ;
M: method-spec make-disassemble-cmd
first2 method make-disassemble-cmd ;
: run-gdb ( -- lines )
<process>
+closed+ >>stdin

2
extra/tools/test/test.factor
View File

@ -4,7 +4,7 @@ USING: namespaces arrays prettyprint sequences kernel
vectors quotations words parser assocs combinators
continuations debugger io io.files vocabs tools.time
vocabs.loader source-files compiler.units inspector
inference effects ;
inference effects tools.vocabs ;
IN: tools.test
SYMBOL: failures

0
extra/tools/browser/authors.txt → extra/tools/vocabs/browser/authors.txt
View File

7
extra/tools/vocabs/browser/browser-docs.factor Executable file
View File

@ -0,0 +1,7 @@
USING: help.markup help.syntax io strings ;
IN: tools.vocabs.browser
ARTICLE: "vocab-index" "Vocabulary index"
{ $tags }
{ $authors }
{ $describe-vocab "" } ;

4
extra/tools/vocabs/browser/browser-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: tools.vocabs.browser.tests
USING: tools.vocabs.browser tools.test help.markup ;
[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test

207
extra/tools/vocabs/browser/browser.factor Executable file
View File

@ -0,0 +1,207 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators vocabs vocabs.loader tools.vocabs io
io.files io.styles help.markup help.stylesheet sequences assocs
help.topics namespaces prettyprint words sorting definitions
arrays inspector ;
IN: tools.vocabs.browser
: vocab-status-string ( vocab -- string )
{
{ [ dup not ] [ drop "" ] }
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
{ [ t ] [ drop "[Loaded]" ] }
} cond ;
: write-status ( vocab -- )
vocab vocab-status-string write ;
: vocab. ( vocab -- )
[
dup [ write-status ] with-cell
dup [ ($link) ] with-cell
[ vocab-summary write ] with-cell
] with-row ;
: vocab-headings. ( -- )
[
[ "State" write ] with-cell
[ "Vocabulary" write ] with-cell
[ "Summary" write ] with-cell
] with-row ;
: root-heading. ( root -- )
[ "Children from " swap append ] [ "Children" ] if*
$heading ;
: vocabs. ( assoc -- )
[
dup empty? [
2drop
] [
swap root-heading.
standard-table-style [
vocab-headings. [ vocab. ] each
] ($grid)
] if
] assoc-each ;
: describe-summary ( vocab -- )
vocab-summary [
"Summary" $heading print-element
] when* ;
TUPLE: vocab-tag name ;
INSTANCE: vocab-tag topic
C: <vocab-tag> vocab-tag
: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
: describe-tags ( vocab -- )
vocab-tags f like [
"Tags" $heading tags.
] when* ;
TUPLE: vocab-author name ;
INSTANCE: vocab-author topic
C: <vocab-author> vocab-author
: authors. ( seq -- ) [ <vocab-author> ] map $links ;
: describe-authors ( vocab -- )
vocab-authors f like [
"Authors" $heading authors.
] when* ;
: describe-help ( vocab -- )
vocab-help [
"Documentation" $heading nl ($link)
] when* ;
: describe-children ( vocab -- )
vocab-name all-child-vocabs vocabs. ;
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
"Files" $heading
[
snippet-style get [
code-style get [
stack.
] with-nesting
] with-style
] ($block)
] when* ;
: describe-words ( vocab -- )
words dup empty? [
"Words" $heading
dup natural-sort $links
] unless drop ;
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words r> map
[ [ word? ] subset [ word-vocabulary ] map ] map>set
remove [ ] subset [ vocab ] map ; inline
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
: describe-uses ( vocab -- )
vocab-uses dup empty? [
"Uses" $heading
dup $links
] unless drop ;
: describe-usage ( vocab -- )
vocab-usage dup empty? [
"Used by" $heading
dup $links
] unless drop ;
: $describe-vocab ( element -- )
first
dup describe-children
dup vocab-root over vocab-dir? [
dup describe-summary
dup describe-tags
dup describe-authors
dup describe-files
] when
dup vocab [
dup describe-help
dup describe-words
dup describe-uses
dup describe-usage
] when drop ;
: keyed-vocabs ( str quot -- seq )
all-vocabs [
swap >r
[ >r 2dup r> swap call member? ] subset
r> swap
] assoc-map 2nip ; inline
: tagged ( tag -- assoc )
[ vocab-tags ] keyed-vocabs ;
: authored ( author -- assoc )
[ vocab-authors ] keyed-vocabs ;
: $tagged-vocabs ( element -- )
first tagged vocabs. ;
: $authored-vocabs ( element -- )
first authored vocabs. ;
: $tags ( element -- )
drop "Tags" $heading all-tags tags. ;
: $authors ( element -- )
drop "Authors" $heading all-authors authors. ;
INSTANCE: vocab topic
INSTANCE: vocab-link topic
M: vocab-spec article-title vocab-name " vocabulary" append ;
M: vocab-spec article-name vocab-name ;
M: vocab-spec article-content
vocab-name \ $describe-vocab swap 2array ;
M: vocab-spec article-parent drop "vocab-index" ;
M: vocab-tag >link ;
M: vocab-tag article-title
vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
M: vocab-tag article-name vocab-tag-name ;
M: vocab-tag article-content
\ $tagged-vocabs swap vocab-tag-name 2array ;
M: vocab-tag article-parent drop "vocab-index" ;
M: vocab-tag summary article-title ;
M: vocab-author >link ;
M: vocab-author article-title
vocab-author-name "Vocabularies by " swap append ;
M: vocab-author article-name vocab-author-name ;
M: vocab-author article-content
\ $authored-vocabs swap vocab-author-name 2array ;
M: vocab-author article-parent drop "vocab-index" ;
M: vocab-author summary article-title ;

0
extra/tools/browser/tags.txt → extra/tools/vocabs/browser/tags.txt
View File

0
extra/vocabs/monitor/authors.txt → extra/tools/vocabs/monitor/authors.txt
View File

6
extra/vocabs/monitor/monitor.factor → extra/tools/vocabs/monitor/monitor.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: threads io.files io.monitors init kernel
tools.browser namespaces continuations vocabs.loader ;
IN: vocabs.monitor
vocabs.loader tools.vocabs namespaces continuations ;
IN: tools.vocabs.monitor
! Use file system change monitoring to flush the tags/authors
! cache
@ -21,4 +21,4 @@ SYMBOL: vocab-monitor
[ monitor-thread t ] "Vocabulary monitor" spawn-server drop
] ignore-errors ;
[ start-monitor-thread ] "vocabs.monitor" add-init-hook
[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook

0
extra/vocabs/monitor/summary.txt → extra/tools/vocabs/monitor/summary.txt
View File

127
extra/tools/browser/browser-docs.factor → extra/tools/vocabs/vocabs-docs.factor
View File

@ -1,52 +1,75 @@
USING: help.markup help.syntax io strings ;
IN: tools.browser
ARTICLE: "vocab-index" "Vocabulary index"
{ $tags }
{ $authors }
{ $describe-vocab "" } ;
ARTICLE: "tools.browser" "Vocabulary browser"
"Getting and setting vocabulary meta-data:"
{ $subsection vocab-file-contents }
{ $subsection set-vocab-file-contents }
{ $subsection vocab-summary }
{ $subsection set-vocab-summary }
{ $subsection vocab-tags }
{ $subsection set-vocab-tags }
{ $subsection add-vocab-tags }
"Global meta-data:"
{ $subsection all-vocabs }
{ $subsection all-vocabs-seq }
{ $subsection all-tags }
{ $subsection all-authors }
"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:"
{ $subsection reset-cache } ;
HELP: vocab-file-contents
{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
HELP: set-vocab-file-contents
{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }
{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;
HELP: vocab-summary
{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }
{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
HELP: set-vocab-summary
{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }
{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;
HELP: vocab-tags
{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }
{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
HELP: set-vocab-tags
{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
HELP: all-vocabs
{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
USING: help.markup help.syntax strings ;
IN: tools.vocabs
ARTICLE: "tools.vocabs" "Vocabulary tools"
"Reloading source files changed on disk:"
{ $subsection refresh }
{ $subsection refresh-all }
"Vocabulary summaries:"
{ $subsection vocab-summary }
{ $subsection set-vocab-summary }
"Vocabulary tags:"
{ $subsection vocab-tags }
{ $subsection set-vocab-tags }
{ $subsection add-vocab-tags }
"Getting and setting vocabulary meta-data:"
{ $subsection vocab-file-contents }
{ $subsection set-vocab-file-contents }
"Global meta-data:"
{ $subsection all-vocabs }
{ $subsection all-vocabs-seq }
{ $subsection all-tags }
{ $subsection all-authors }
"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:"
{ $subsection reset-cache } ;
ABOUT: "tools.vocabs"
HELP: vocab-files
{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
HELP: vocab-tests
{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
HELP: source-modified?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ;
HELP: refresh
{ $values { "prefix" string } }
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
HELP: refresh-all
{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
{ refresh refresh-all } related-words
HELP: vocab-file-contents
{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
HELP: set-vocab-file-contents
{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }
{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;
HELP: vocab-summary
{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }
{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
HELP: set-vocab-summary
{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }
{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;
HELP: vocab-tags
{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }
{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
HELP: set-vocab-tags
{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
HELP: all-vocabs
{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;

268
extra/tools/vocabs/vocabs.factor Executable file
View File

@ -0,0 +1,268 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel io.encodings.utf8 vocabs.loader vocabs
sequences namespaces math.parser arrays hashtables assocs
memoize inspector sorting splitting combinators source-files
io debugger continuations compiler.errors init io.crc32 ;
IN: tools.vocabs
: vocab-tests-file, ( vocab -- )
dup "-tests.factor" vocab-dir+ vocab-path+
dup resource-exists? [ , ] [ drop ] if ;
: vocab-tests-dir, ( vocab -- )
dup vocab-dir "tests" path+ vocab-path+
dup resource-exists? [
dup ?resource-path directory keys
[ ".factor" tail? ] subset
[ path+ , ] with each
] [ drop ] if ;
: vocab-tests ( vocab -- tests )
dup vocab-root [
[
f >vocab-link dup
vocab-tests-file,
vocab-tests-dir,
] { } make
] [ drop f ] if ;
: vocab-files ( vocab -- seq )
f >vocab-link [
dup vocab-source-path [ , ] when*
dup vocab-docs-path [ , ] when*
vocab-tests %
] { } make ;
: source-modified? ( path -- ? )
dup source-files get at [
dup source-file-path ?resource-path utf8 file-lines lines-crc32
swap source-file-checksum = not
] [
resource-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 ;
: update-roots ( vocabs -- )
[ dup find-vocab-root swap vocab set-vocab-root ] each ;
: to-refresh ( prefix -- modified-sources modified-docs )
child-vocabs
dup update-roots
dup modified-sources swap modified-docs ;
: vocab-heading. ( vocab -- )
nl
"==== " write
dup vocab-name swap vocab write-object ":" print
nl ;
: load-error. ( triple -- )
dup first vocab-heading.
dup second print-error
drop ;
: load-failures. ( failures -- )
[ load-error. nl ] each ;
SYMBOL: failures
: require-all ( vocabs -- failures )
[
V{ } clone blacklist set
V{ } clone failures set
[
[ require ]
[ swap vocab-name failures get set-at ]
recover
] each
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. ;
: refresh ( prefix -- ) to-refresh do-refresh ;
SYMBOL: sources-changed?
[ t sources-changed? set-global ] "tools.vocabs" add-init-hook
: refresh-all ( -- )
"" refresh f sources-changed? set-global ;
MEMO: (vocab-file-contents) ( path -- lines )
?resource-path dup exists?
[ utf8 file-lines ] [ drop f ] if ;
: vocab-file-contents ( vocab name -- seq )
vocab-path+ dup [ (vocab-file-contents) ] when ;
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-path+ [
?resource-path utf8 set-file-lines
] [
"The " swap vocab-name
" vocabulary was not loaded from the file system"
3append throw
] ?if ;
: vocab-summary-path ( vocab -- string )
vocab-dir "summary.txt" path+ ;
: vocab-summary ( vocab -- summary )
dup dup vocab-summary-path vocab-file-contents
dup empty? [
drop vocab-name " vocabulary" append
] [
nip first
] if ;
M: vocab summary
[
dup vocab-summary %
" (" %
vocab-words assoc-size #
" words)" %
] "" make ;
M: vocab-link summary vocab-summary ;
: set-vocab-summary ( string vocab -- )
>r 1array r>
dup vocab-summary-path
set-vocab-file-contents ;
: vocab-tags-path ( vocab -- string )
vocab-dir "tags.txt" path+ ;
: vocab-tags ( vocab -- tags )
dup vocab-tags-path vocab-file-contents ;
: set-vocab-tags ( tags vocab -- )
dup vocab-tags-path set-vocab-file-contents ;
: add-vocab-tags ( tags vocab -- )
[ vocab-tags append prune ] keep set-vocab-tags ;
: vocab-authors-path ( vocab -- string )
vocab-dir "authors.txt" path+ ;
: vocab-authors ( vocab -- authors )
dup vocab-authors-path vocab-file-contents ;
: set-vocab-authors ( authors vocab -- )
dup vocab-authors-path set-vocab-file-contents ;
: subdirs ( dir -- dirs )
directory [ second ] subset keys natural-sort ;
: (all-child-vocabs) ( root name -- vocabs )
[ vocab-dir path+ ?resource-path subdirs ] keep
dup empty? [
drop
] [
swap [ "." swap 3append ] with map
] if ;
: vocabs-in-dir ( root name -- )
dupd (all-child-vocabs) [
2dup vocab-dir? [ 2dup swap >vocab-link , ] when
vocabs-in-dir
] with each ;
: all-vocabs ( -- assoc )
vocab-roots get [
dup [ "" vocabs-in-dir ] { } make
] { } map>assoc ;
MEMO: all-vocabs-seq ( -- seq )
all-vocabs values concat ;
: dangerous? ( name -- ? )
#! Hack
{
{ [ "cpu." ?head ] [ t ] }
{ [ "io.unix" ?head ] [ t ] }
{ [ "io.windows" ?head ] [ t ] }
{ [ "ui.x11" ?head ] [ t ] }
{ [ "ui.windows" ?head ] [ t ] }
{ [ "ui.cocoa" ?head ] [ t ] }
{ [ "cocoa" ?head ] [ t ] }
{ [ "core-foundation" ?head ] [ t ] }
{ [ "vocabs.loader.test" ?head ] [ t ] }
{ [ "editors." ?head ] [ t ] }
{ [ ".windows" ?tail ] [ t ] }
{ [ ".unix" ?tail ] [ t ] }
{ [ "unix." ?head ] [ t ] }
{ [ ".linux" ?tail ] [ t ] }
{ [ ".bsd" ?tail ] [ t ] }
{ [ ".macosx" ?tail ] [ t ] }
{ [ "windows." ?head ] [ t ] }
{ [ "cocoa" ?head ] [ t ] }
{ [ ".test" ?tail ] [ t ] }
{ [ "raptor" ?head ] [ t ] }
{ [ dup "tools.deploy.app" = ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
: filter-dangerous ( seq -- seq' )
[ vocab-name dangerous? not ] subset ;
: try-everything ( -- failures )
all-vocabs-seq
filter-dangerous
require-all ;
: load-everything ( -- )
try-everything load-failures. ;
: unrooted-child-vocabs ( prefix -- seq )
dup empty? [ CHAR: . add ] unless
vocabs
[ vocab-root not ] subset
[
vocab-name swap ?head CHAR: . rot member? not and
] with subset
[ vocab ] map ;
: all-child-vocabs ( prefix -- assoc )
vocab-roots get [
over dupd dupd (all-child-vocabs)
swap [ >vocab-link ] curry map
] { } map>assoc
f rot unrooted-child-vocabs 2array add ;
: all-child-vocabs-seq ( prefix -- assoc )
vocab-roots get swap [
dupd (all-child-vocabs)
[ vocab-dir? ] with subset
] curry map concat ;
: map>set ( seq quot -- )
map concat prune natural-sort ; inline
MEMO: all-tags ( -- seq )
all-vocabs-seq [ vocab-tags ] map>set ;
MEMO: all-authors ( -- seq )
all-vocabs-seq [ vocab-authors ] map>set ;
: reset-cache ( -- )
\ (vocab-file-contents) reset-memoized
\ all-vocabs-seq reset-memoized
\ all-authors reset-memoized
\ all-tags reset-memoized ;

3
extra/ui/freetype/freetype.factor
View File

@ -4,6 +4,7 @@ USING: alien alien.accessors alien.c-types arrays io kernel libc
math math.vectors namespaces opengl opengl.gl prettyprint assocs
sequences io.files io.styles continuations freetype
ui.gadgets.worlds ui.render ui.backend byte-arrays ;
IN: ui.freetype
TUPLE: freetype-renderer ;
@ -74,7 +75,7 @@ M: freetype-renderer free-fonts ( world -- )
: open-face ( font style -- face )
ttf-name ttf-path
dup malloc-file-contents
swap file-length
swap file-info file-info-size
(open-face) ;
SYMBOL: dpi

4
extra/ui/render/render-docs.factor
View File

@ -1,5 +1,5 @@
USING: ui.gadgets ui.gestures help.markup help.syntax
kernel classes strings opengl.gl ;
kernel classes strings opengl.gl models ;
IN: ui.render
HELP: gadget
@ -15,7 +15,7 @@ HELP: gadget
{ { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
{ { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." }
{ { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
{ { $link gadget-model } " - XXX" }
{ { $link gadget-model } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
}
"Gadgets delegate to " { $link rect } " instances holding their location and dimensions." }
{ $notes

8
extra/ui/tools/operations/operations.factor
View File

@ -8,7 +8,7 @@ namespaces parser prettyprint quotations tools.annotations
editors tools.profiler tools.test tools.time tools.walker
ui.commands ui.gadgets.editors ui.gestures ui.operations
ui.tools.deploy vocabs vocabs.loader words sequences
tools.browser classes compiler.units ;
tools.vocabs classes compiler.units ;
IN: ui.tools.operations
V{ } clone operations set-global
@ -84,11 +84,7 @@ UNION: definition word method-spec link vocab vocab-link ;
{ +secondary+ t }
} define-operation
[
class
{ link word vocab vocab-link vocab-tag vocab-author }
memq?
] \ com-follow H{
[ topic? ] \ com-follow H{
{ +keyboard+ T{ key-down f { C+ } "H" } }
{ +primary+ t }
} define-operation

2
extra/ui/tools/search/search.factor
View File

@ -7,7 +7,7 @@ source-files definitions strings tools.completion tools.crossref
tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
tools.browser unicode.case calendar ui ;
tools.vocabs unicode.case calendar ui ;
IN: ui.tools.search
TUPLE: live-search field list ;

3
extra/ui/tools/tools.factor
View File

@ -8,7 +8,8 @@ prettyprint quotations sequences ui ui.commands ui.gadgets
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.gadgets.presentations ui.gestures words vocabs.loader
tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ;
tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
mirrors ;
IN: ui.tools
: <workspace-tabs> ( -- tabs )

11
extra/ui/windows/windows.factor
View File

@ -266,11 +266,6 @@ SYMBOL: nc-buttons
key-modifiers swap message>button
[ <button-down> ] [ <button-up> ] if ;
: mouse-buttons ( -- seq ) WM_LBUTTONDOWN WM_RBUTTONDOWN 2array ;
: capture-mouse? ( umsg -- ? )
mouse-buttons member? ;
: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
nip >r mouse-event>gesture r> >lo-hi rot window ;
@ -287,8 +282,10 @@ SYMBOL: nc-buttons
mouse-captured off ;
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
>r >r dup capture-mouse? [ over set-capture ] when r> r>
prepare-mouse send-button-down ;
>r >r
over set-capture
dup message>button drop nc-buttons get delete
r> r> prepare-mouse send-button-down ;
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
mouse-captured get [ release-capture ] when

97
misc/factor.vim
View File

@ -21,15 +21,26 @@ else
set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
endif
syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple
syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple
syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
syn match factorComment /\<#! .*/ contains=factorTodo
syn match factorComment /\<! .*/ contains=factorTodo
syn region None matchgroup=factorDefinition start=/\<\(C\|M\|G\|UNION\|PREDICATE\)\?:\>/ end=/\<;\>/ contains=@factorCluster,factorStackEffect,factorStackEffectErr,factorArray0,factorQuotation0
syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
syn region None matchgroup=factorPrivate start=/\<<PRIVATE\>/ end=/\<PRIVATE>\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN
syn region None matchgroup=factorGeneric start=/\<GENERIC:\>/ end=/$/ contains=factorStackEffect,factorStackEffectErr
syn keyword factorBoolean boolean f general-t t
syn keyword factorCompileDirective inline foldable parsing
@ -37,15 +48,17 @@ syn keyword factorCompileDirective inline foldable parsing
" kernel vocab keywords
syn keyword factorKeyword continuation-name set-datastack wrapper continuation-catch set-continuation-name slip pick 2slip 2nip tuple set-boot clone with-datastack cpu -roll tuck -rot (continue) set-continuation-retain swapd <continuation> >boolean wrapper? dupd 3dup dup ifcc callstack windows? os-env = over continuation alist>quot ? <wrapper> 2dup cond win64? <quotation> continue 3drop hashcode quotation xor when curry millis set-callstack unless >r die version callcc0 or os callcc1 get-walker-hook depth equal? 3keep no-cond? continue-with if exit tuple? set-retainstack unix? (continue-with) general-t continuation? 3slip <no-cond> macosx? r> rot win32? retainstack 2apply >quotation >continuation< type continuation-call clear call drop continuation-data set-continuation-call 2drop no-cond unit set-continuation-data keep-datastack and when* quotation? ?if literalize datastack swap unless* 2swap set-continuation-catch eq? not roll set-walker-hook continuation-retain with make-dip wrapped keep 2keep <=> if* nip
syn keyword factorKeyword sin integer? log2 cot oct> number>string integer first-bignum sech abs repeat tanh real? vmin norm-sq neg between? asech >rect bignum? atanh -i * + fp-nan? - small / sqrt infimum fix-float cosech even? v*n < bits>double > most-positive-fixnum ^theta numerator digit+ >base (random-int) acosech cosh min pi number vmax zero? sum digit> rem bitor supremum string>integer most-negative-fixnum >polar >fraction ceiling acos acot ^ asin acosh /f ratio e fixnum? /i ^n cis coth 1+ 1- conjugate sinh acosec i number= number? double>bits epsilon float product string>number n/v norm max tan acoth absq float? asinh denominator rational? fixnum rect> >fixnum imaginary recip exp sec bitxor w>h/h >bin align base> times log <= [-] init-random sq odd? (repeat) [v-] ^mag bitnot ratio? random-int >digit (next-power-of-2) v* v+ v- v. v/ >float [-1,1]? arg small? bitand set-axis >oct v/n complex rational shift (^) polar> (gcd) cosec next-power-of-2 >float-rect atan sgn >= float>bits normalize real bin> complex? gcd d>w/w hex> mod string>ratio asec floor n*v >hex truncate bits>float vneg >bignum bignum power-of-2? integer, /mod (string>integer) cos
syn keyword factorKeyword second sort-values all-eq? pop* find slice-error-reason inject-with prune remove (group) split1-slice slice-error (slice*) split* head-slice* find* split, first remove-nth hash-prune push-if ?push reverse subseq split1 diff subset split new padding column? copy-into-check column@ <column> peek last/first add find-last ?nth add* slice-from cache-nth subseq? <reversed> <slice-error> (3append) replace-slice reversed-seq find-last-with empty? ((append)) reversed? reversed@ map-with find-last-with* set-slice-error-reason set-column-col natural-sort (subst) set-slice-seq index* concat push binsearch slice-seq 3append nsort length tail-slice* reversed ?head sequence= ?tail sequence? memq? join split-next, delete set-nth subst monotonic? group map flip unclip set-reversed-seq find-last* start* max-length assoc min-length all-equal? all? pad-left contains? inject slice <slice> first2 first3 first4 exchange bounds-check? column-seq check-slice pad-right each subset-with unpair tail head interleave (delete) copy-into sort sequence reduce set-slice-from set-slice-to 2map (cut) member? cut rassoc (append) last-index* sort-keys change-nth 2each >sequence nth tail* head* third tail-slice set-length collapse-slice column (mismatch) contains-with? push-new pop tail? head? slice? slice@ delete-all binsearch* move find-with* 2reduce slice-to find-with like slice-error? set-column-seq nappend column-col cut* (split) index each-with last-index fourth append accumulate drop-prefix mismatch head-slice all-with? start
syn keyword factorKeyword namespace-error-object inc dec make off bind get-global init-namespaces set-global namespace on ndrop namespace-error? namestack namespace-error +@ # % make-hash global , set-namestack with-scope building <namespace-error> change nest set-namespace-error-object get set counter
syn keyword factorKeyword array <array> pair byte-array pair? 1array 2array resize-array 4array 3array byte-array? <byte-array> array? >array
syn keyword factorKeyword cwd duplex-stream pathname? set-pathname-string with-log-file directory duplex-stream-out format <nested-style-stream> (readln) duplex-stream? read1 with-stream-style c-stream-error? <file-reader> stream-write1 with-stream line-reader? set-duplex-stream-out server? cr> <check-closed> directory? log-message flush format-column stream-readln nested-style-stream? <line-reader> <file-r/w> set-timeout write-pathname file-modified duplex-stream-closed? print set-duplex-stream-closed? pathname line-reader ?resource-path terpri write-object le> string-out stream-terpri log-client do-nested-style path+ <c-stream-error> set-client-stream-host plain-writer? server-stream resource-path >be parent-dir with-stream* <file-writer> server-loop string-in nested-style-stream stream-close stream-copy c-stream-error <client-stream> with-style client-stream-host stat plain-writer file-length contents <string-reader> stream-read stream-format check-closed? set-client-stream-port <duplex-stream> <server> write1 bl write-outliner map-last (with-stream-style) set-line-reader-cr tabular-output (lines) stream-write log-stream server-client (stream-copy) with-nested-stream lines readln cd client-stream nth-byte with-logging stream-read1 nested-style-stream-style accept check-closed client-stream-port do-nested-quot pathname-string set-nested-style-stream-style read home close with-stream-table stdio be> log-error duplex-stream-out+ server stream-flush set-duplex-stream-in line-reader-cr >le with-client <client> <pathname> <string-writer> (directory) set-server-client stream-print with-server exists? <plain-writer> with-nesting string-lines write duplex-stream-in client-stream? duplex-stream-in+
syn keyword factorKeyword sbuf ch>upper string? LETTER? >sbuf >lower quotable? string>sbuf blank? string sbuf? printable? >string letter? resize-string control? alpha? <string> >upper Letter? ch>lower digit? <sbuf> ch>string
syn keyword factorKeyword <vector> >vector array>vector vector? vector
syn keyword factorKeyword set-restart-continuation cleanup error-hook restart-name restarts. stack-underflow. expired-error. restart restart? word-xt. (:help-none) set-catchstack c-string-error. condition <assert> debug-help :get datastack-overflow. set-condition-restarts condition? error. objc-error. print-error assert :res catchstack rethrow assert= kernel-error restart-obj assert? undefined-symbol-error. retainstack-overflow. restarts error-help divide-by-zero-error. ffi-error. signal-error. (:help-multi) set-restart-obj xt. memory-error. retainstack-underflow. set-condition-continuation datastack-underflow. try assert-depth error-continuation error-stack-trace assert-expect recover :edit kernel-error? error callstack-overflow. stack-overflow. callstack-underflow. set-assert-got set-restart-name restart-continuation condition-restarts heap-scan-error. :help type-check-error. <condition> assert-got throw negative-array-size-error. :c condition-continuation :trace undefined-word-error. io-error. parse-dump <restart> set-assert-expect :r :s compute-restarts catch restart.
syn keyword factorKeyword or construct-delegate set-slots tuck while wrapper nip hashcode wrapper? both? callstack>array die dupd set-delegate callstack callstack? 3dup pick curry build >boolean ?if clone eq? = ? swapd call-clear 2over 2keep 3keep construct general-t clear 2dup when not tuple? 3compose dup call object wrapped unless* if* 2apply >r curry-quot drop when* retainstack -rot delegate with 3slip construct-boa slip compose-first compose-second 3drop construct-empty either? curry? datastack compare curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if <=> unless compose? tuple keep 2curry object? equal? set-datastack 2slip 2drop most <wrapper> null r> set-callstack dip xor rot -roll
syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc union search-alist assoc-like key? update at* assoc-empty? at+ set-at assoc-all? assoc-hashcode intersect change-at assoc-each assoc-subset values rename-at value-at (assoc-stack) at cache assoc>map assoc-contains? assoc assoc-map assoc-pusher diff (assoc>map) assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute delete-at assoc-find keys
syn keyword factorKeyword case dispatch-case-quot with-datastack alist>quot dispatch-case hash-case-table <buckets> hash-case-quot no-cond no-case? cond distribute-buckets (distribute-buckets) contiguous-range? cond>quot no-cond? no-case recursive-hashcode linear-case-quot hash-dispatch-quot case>quot
syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 before? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? after? fixnum before=? bignum sq neg denominator [-] (all-integers?) times find-last-integer (each-integer) bit? * + - / >= bitand find-integer complex < real > log2 integer? max number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift between? float 1+ 1- min fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator after=? /f
syn keyword factorKeyword slice-to append left-trim clone-like 3sequence set-column-seq map-as reversed pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* member? unclip virtual-sequence? set-length last-index* <column> drop-prefix bounds-error? set-slice-seq set-column-col seq-diff map start open-slice midpoint@ add* set-immutable-seq move-forward fourth delete set-slice-to all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) column? reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice index* move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right concat find* set-slice-from flip sum find-last* immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice column-seq sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find column remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index seq-intersect push-if 2all? lengthen column-col joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first bounds-error add bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice sum-lengths new 2each head* infimum subset slice-error subseq replace-slice repetition push trim sequence-hashcode mismatch
syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc
syn keyword factorKeyword <array> 3array >array 4array pair? array pair 2array 1array resize-array array?
syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln
syn keyword factorKeyword resize-string >string <string> 1string string string?
syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector
syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation <restart> ifcc continuation-name set-restart-continuation ignore-errors continuation-retain continue <continuation> restart-continuation with-disposal set-continuation-catch restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation <condition> set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts
syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
@ -73,11 +86,16 @@ syn match factorBackslash /\<\\\>\s\+\S\+\>/
syn region factorUsing start=/\<USING:\>/ end=/;/
syn region factorRequires start=/\<REQUIRES:\>/ end=/;/
syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget
syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
syn match factorDefer /\<DEFER:\s\+\S\+\>/
syn match factorForget /\<FORGET:\s\+\S\+\>/
syn match factorMixin /\<MIXIN:\s\+\S\+\>/
syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
syn match factorMain /\<MAIN:\s\+\S\+\>/
syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
syn match factorAlien /\<ALIEN:\s\+\d\+\>/
@ -87,8 +105,6 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
"misc:
" HELP:
" ARTICLE:
" PROVIDE:
" MAIN:
"literals:
" PRIMITIVE:
@ -106,8 +122,11 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
syn match factorStackEffectErr /\<)\>/
syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
syn match factorMultiStringContents /.*/ contained
"syn match factorStackEffectErr /\<)\>/
"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
"adapted from lisp.vim
@ -127,18 +146,18 @@ else
endif
if exists("g:factor_norainbow")
syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
else
syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif
syn match factorBracketErr /\<\]\>/
@ -163,11 +182,21 @@ if version >= 508 || !exists("did_factor_syn_inits")
HiLink factorKeyword Keyword
HiLink factorOperator Operator
HiLink factorBoolean Boolean
HiLink factorDefinition Typedef
HiLink factorDefnDelims Typedef
HiLink factorMethodDelims Typedef
HiLink factorGenericDelims Typedef
HiLink factorGenericNDelims Typedef
HiLink factorConstructor Typedef
HiLink factorPrivate Special
HiLink factorPrivateDefnDelims Special
HiLink factorPrivateMethodDelims Special
HiLink factorPGenericDelims Special
HiLink factorPGenericNDelims Special
HiLink factorString String
HiLink factorSbuf String
HiLink factorMultiStringContents String
HiLink factorMultiStringDelims Typedef
HiLink factorBracketErr Error
HiLink factorStackEffectErr Error
HiLink factorComplex Number
HiLink factorRatio Number
HiLink factorBinary Number
@ -186,14 +215,17 @@ if version >= 508 || !exists("did_factor_syn_inits")
HiLink factorCharErr Error
HiLink factorDelimiter Delimiter
HiLink factorBackslash Special
HiLink factorCompileDirective Keyword
HiLink factorCompileDirective Typedef
HiLink factorSymbol Define
HiLink factorMixin Typedef
HiLink factorInstance Typedef
HiLink factorHook Typedef
HiLink factorMain Define
HiLink factorPostpone Define
HiLink factorDefer Define
HiLink factorForget Define
HiLink factorAlien Define
HiLink factorTuple Typedef
HiLink factorGeneric Define
if &bg == "dark"
hi hlLevel0 ctermfg=red guifg=red1
@ -230,3 +262,4 @@ set expandtab
set autoindent " annoying?
" vim: syntax=vim

85
misc/factor.vim.fgen
View File

@ -1,4 +1,4 @@
<% USING: kernel io prettyprint words sequences ;
<% USING: kernel io prettyprint vocabs sequences ;
%>" Vim syntax file
" Language: factor
" Maintainer: Alex Chapman <chapman.alex@gmail.com>
@ -22,15 +22,26 @@ else
set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
endif
syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple
syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple
syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
syn match factorComment /\<#! .*/ contains=factorTodo
syn match factorComment /\<! .*/ contains=factorTodo
syn region None matchgroup=factorDefinition start=/\<\(C\|M\|G\|UNION\|PREDICATE\)\?:\>/ end=/\<;\>/ contains=@factorCluster,factorStackEffect,factorStackEffectErr,factorArray0,factorQuotation0
syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
syn region None matchgroup=factorPrivate start=/\<<PRIVATE\>/ end=/\<PRIVATE>\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN
syn region None matchgroup=factorGeneric start=/\<GENERIC:\>/ end=/$/ contains=factorStackEffect,factorStackEffectErr
syn keyword factorBoolean boolean f general-t t
syn keyword factorCompileDirective inline foldable parsing
@ -40,10 +51,13 @@ syn keyword factorCompileDirective inline foldable parsing
! that this changes factor.vim from around 8k to around 100k (and is a bit
! broken)
! vocabs [ words [ "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] when* ] each %>
! vocabs [ words [ "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] when* ] each
%>
" kernel vocab keywords
<% { "kernel" "math" "sequences" "namespaces" "arrays" "io" "strings" "vectors" "errors" } [ words "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] each %>
<% { "kernel" "assocs" "combinators" "math" "sequences" "namespaces" "arrays" "io" "strings" "vectors" "continuations" } [
words "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write
] each %>
syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
syn cluster factorNumber contains=@factorReal,factorComplex
@ -70,11 +84,16 @@ syn match factorBackslash /\<\\\>\s\+\S\+\>/
syn region factorUsing start=/\<USING:\>/ end=/;/
syn region factorRequires start=/\<REQUIRES:\>/ end=/;/
syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget
syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
syn match factorDefer /\<DEFER:\s\+\S\+\>/
syn match factorForget /\<FORGET:\s\+\S\+\>/
syn match factorMixin /\<MIXIN:\s\+\S\+\>/
syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
syn match factorMain /\<MAIN:\s\+\S\+\>/
syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
syn match factorAlien /\<ALIEN:\s\+\d\+\>/
@ -84,8 +103,6 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
"misc:
" HELP:
" ARTICLE:
" PROVIDE:
" MAIN:
"literals:
" PRIMITIVE:
@ -103,8 +120,11 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
syn match factorStackEffectErr /\<)\>/
syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
syn match factorMultiStringContents /.*/ contained
"syn match factorStackEffectErr /\<)\>/
"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
"adapted from lisp.vim
@ -124,18 +144,18 @@ else
endif
if exists("g:factor_norainbow")
syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL
else
syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1
syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2
syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3
syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4
syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5
syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6
syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7
syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8
syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9
syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif
syn match factorBracketErr /\<\]\>/
@ -160,11 +180,21 @@ if version >= 508 || !exists("did_factor_syn_inits")
HiLink factorKeyword Keyword
HiLink factorOperator Operator
HiLink factorBoolean Boolean
HiLink factorDefinition Typedef
HiLink factorDefnDelims Typedef
HiLink factorMethodDelims Typedef
HiLink factorGenericDelims Typedef
HiLink factorGenericNDelims Typedef
HiLink factorConstructor Typedef
HiLink factorPrivate Special
HiLink factorPrivateDefnDelims Special
HiLink factorPrivateMethodDelims Special
HiLink factorPGenericDelims Special
HiLink factorPGenericNDelims Special
HiLink factorString String
HiLink factorSbuf String
HiLink factorMultiStringContents String
HiLink factorMultiStringDelims Typedef
HiLink factorBracketErr Error
HiLink factorStackEffectErr Error
HiLink factorComplex Number
HiLink factorRatio Number
HiLink factorBinary Number
@ -183,14 +213,17 @@ if version >= 508 || !exists("did_factor_syn_inits")
HiLink factorCharErr Error
HiLink factorDelimiter Delimiter
HiLink factorBackslash Special
HiLink factorCompileDirective Keyword
HiLink factorCompileDirective Typedef
HiLink factorSymbol Define
HiLink factorMixin Typedef
HiLink factorInstance Typedef
HiLink factorHook Typedef
HiLink factorMain Define
HiLink factorPostpone Define
HiLink factorDefer Define
HiLink factorForget Define
HiLink factorAlien Define
HiLink factorTuple Typedef
HiLink factorGeneric Define
if &bg == "dark"
hi hlLevel0 ctermfg=red guifg=red1