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

db4
Doug Coleman 2008-03-13 18:47:21 -05:00
commit de72d2dbd5
78 changed files with 1208 additions and 943 deletions

View File

@ -1,7 +1,7 @@
USING: help.markup help.syntax kernel kernel.private USING: help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math namespaces sequences words arrays layouts help effects math
layouts classes.private classes.union classes.mixin layouts classes.private classes.union classes.mixin
classes.predicate ; classes.predicate quotations ;
IN: classes IN: classes
ARTICLE: "builtin-classes" "Built-in classes" ARTICLE: "builtin-classes" "Built-in classes"
@ -114,24 +114,9 @@ HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a 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." } ; { $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 HELP: define-predicate
{ $values { "class" class } { "quot" "a quotation" } } { $values { "class" class } { "quot" quotation } }
{ $description { $description "Defines a predicate word for a class." }
"Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
}
$low-level-note ; $low-level-note ;
HELP: superclass HELP: superclass

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

View File

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

View File

@ -9,7 +9,7 @@ ARTICLE: "compiler-errors" "Compiler warnings and errors"
{ $subsection :errors } { $subsection :errors }
{ $subsection :warnings } { $subsection :warnings }
{ $subsection :linkage } { $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 } ; { $link with-compiler-errors } ;
HELP: compiler-errors HELP: compiler-errors

View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.styles strings USING: help.markup help.syntax io io.styles strings
io.backend io.files.private quotations ; io.backend io.files.private quotations ;
IN: io.files IN: io.files
ARTICLE: "file-streams" "Reading and writing files" ARTICLE: "file-streams" "Reading and writing files"
@ -43,13 +43,19 @@ ARTICLE: "directories" "Directories"
{ $subsection make-directory } { $subsection make-directory }
{ $subsection make-directories } ; { $subsection make-directories } ;
! ARTICLE: "file-types" "File Types"
! { $table { +directory+ "" } }
! ;
ARTICLE: "fs-meta" "File meta-data" ARTICLE: "fs-meta" "File meta-data"
{ $subsection file-info } { $subsection file-info }
{ $subsection link-info } { $subsection link-info }
{ $subsection exists? } { $subsection exists? }
{ $subsection directory? } { $subsection directory? }
{ $subsection file-length } ! { $subsection file-modified }
{ $subsection file-modified }
{ $subsection stat } ; { $subsection stat } ;
ARTICLE: "delete-move-copy" "Deleting, moving, copying files" ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
@ -119,11 +125,26 @@ HELP: file-name
! need a $class-description file-info ! need a $class-description file-info
HELP: file-info HELP: file-info
{ $values { "path" "a pathname string" } { $values { "path" "a pathname string" }
{ "info" "a file-info tuple" } } { "info" file-info } }
{ $description "Queries the file system for meta data. " { $description "Queries the file system for meta data. "
"If path refers to a symbolic link, it is followed." "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 ! need a see also to link-info
HELP: link-info HELP: link-info
@ -135,6 +156,8 @@ HELP: link-info
"If the file does not exist, an exception is thrown." } ; "If the file does not exist, an exception is thrown." } ;
! need a see also to file-info ! need a see also to file-info
{ file-info link-info } related-words
HELP: <file-reader> HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } } { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
{ "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." "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+ HELP: path+
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $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" } "." } { $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." } ; { $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
HELP: file-length ! HELP: file-modified
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } ! { $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." } ; ! { $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 HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } } { $values { "path" "a pathname string" } { "newpath" "a pathname string" } }

View File

@ -86,11 +86,11 @@ SYMBOL: +unknown+
: stat ( path -- directory? permissions length modified ) : stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ; 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-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 ; : exists? ( path -- ? ) file-modified >boolean ;
@ -220,7 +220,10 @@ M: pathname <=> [ pathname-string ] compare ;
>r <file-reader> r> with-stream ; inline >r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str ) : 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 -- ) : with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline >r <file-writer> r> with-stream ; inline

View File

@ -430,3 +430,20 @@ IN: parser.tests
[ "resource:core/parser/test/assert-depth.factor" run-file ] [ "resource:core/parser/test/assert-depth.factor" run-file ]
[ relative-overflow-stack { 1 2 3 } sequence= ] [ relative-overflow-stack { 1 2 3 } sequence= ]
must-fail-with 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

View File

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

View File

@ -3,16 +3,13 @@ definitions quotations compiler.units ;
IN: source-files IN: source-files
ARTICLE: "source-files" "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 $nl
"The source file database:" "The source file database:"
{ $subsection source-files } { $subsection source-files }
"The class of source files:" "The class of source files:"
{ $subsection source-file } { $subsection source-file }
"Testing if a source file has been changed on disk:"
{ $subsection source-modified? }
"Words intended for the parser:" "Words intended for the parser:"
{ $subsection record-modified }
{ $subsection record-checksum } { $subsection record-checksum }
{ $subsection record-form } { $subsection record-form }
{ $subsection xref-source } { $subsection xref-source }
@ -34,22 +31,12 @@ HELP: source-file
{ $class-description "Instances retain information about loaded source files, and have the following slots:" { $class-description "Instances retain information about loaded source files, and have the following slots:"
{ $list { $list
{ { $link source-file-path } " - a pathname string." } { { $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-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-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" } { { $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 HELP: record-checksum
{ $values { "source-file" source-file } { "lines" "a sequence of strings" } } { $values { "source-file" source-file } { "lines" "a sequence of strings" } }
{ $description "Records the CRC32 checksm of the source file's contents." } { $description "Records the CRC32 checksm of the source file's contents." }
@ -75,7 +62,7 @@ HELP: record-form
$low-level-note ; $low-level-note ;
HELP: reset-checksums 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 HELP: forget-source
{ $values { "path" "a pathname string" } } { $values { "path" "a pathname string" } }

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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math USING: arrays definitions generic assocs kernel math namespaces
namespaces prettyprint sequences strings vectors words prettyprint sequences strings vectors words quotations inspector
quotations inspector io.styles io combinators sorting io.styles io combinators sorting splitting math.parser effects
splitting math.parser effects continuations debugger continuations debugger io.files io.crc32 vocabs hashtables
io.files io.crc32 io.streams.string vocabs graphs compiler.units io.encodings.utf8 ;
hashtables graphs compiler.units io.encodings.utf8 ;
IN: source-files IN: source-files
SYMBOL: source-files SYMBOL: source-files
TUPLE: source-file TUPLE: source-file
path path
modified checksum checksum
uses definitions ; 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 -- ) : 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 ) : (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> swap source-file-uses dup source-file-path <pathname>
[ crossref? ] subset ; swap source-file-uses [ crossref? ] subset ;
: xref-source ( source-file -- ) : xref-source ( source-file -- )
(xref-source) crossref get add-vertex ; (xref-source) crossref get add-vertex ;
@ -67,9 +48,7 @@ uses definitions ;
: reset-checksums ( -- ) : reset-checksums ( -- )
source-files get [ source-files get [
swap ?resource-path dup exists? swap ?resource-path dup exists? [
[
over record-modified
utf8 file-lines swap record-checksum utf8 file-lines swap record-checksum
] [ 2drop ] if ] [ 2drop ] if
] assoc-each ; ] assoc-each ;

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:" "Application vocabularies can define a main entry point, giving the user a convenient way to run the application:"
{ $subsection POSTPONE: MAIN: } { $subsection POSTPONE: MAIN: }
{ $subsection run } { $subsection run }
"Reloading source files changed on disk:"
{ $subsection refresh }
{ $subsection refresh-all }
{ $see-also "vocabularies" "parser-files" "source-files" } ; { $see-also "vocabularies" "parser-files" "source-files" } ;
ABOUT: "vocabs.loader" ABOUT: "vocabs.loader"
@ -42,20 +39,12 @@ HELP: vocab-main
HELP: vocab-roots HELP: vocab-roots
{ $var-description "A sequence of pathname strings to search for vocabularies." } ; { $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 HELP: find-vocab-root
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } } { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
{ $description "Searches for a vocabulary in the vocabulary roots." } ; { $description "Searches for a vocabulary in the vocabulary roots." } ;
{ vocab-root find-vocab-root } related-words { 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 HELP: no-vocab
{ $values { "name" "a vocabulary name" } } { $values { "name" "a vocabulary name" } }
{ $description "Throws a " { $link no-vocab } "." } { $description "Throws a " { $link no-vocab } "." }
@ -80,7 +69,7 @@ HELP: reload
HELP: require HELP: require
{ $values { "vocab" "a vocabulary specifier" } } { $values { "vocab" "a vocabulary specifier" } }
{ $description "Loads a vocabulary if it has not already been loaded." } { $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 HELP: run
{ $values { "vocab" "a vocabulary specifier" } } { $values { "vocab" "a vocabulary specifier" } }
@ -93,12 +82,3 @@ HELP: vocab-source-path
HELP: vocab-docs-path HELP: vocab-docs-path
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } } { $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." } ; { $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

View File

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

View File

@ -48,27 +48,6 @@ M: string vocab-root
M: vocab-link vocab-root M: vocab-link vocab-root
vocab-link-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? SYMBOL: load-help?
: source-was-loaded t swap set-vocab-source-loaded? ; : source-was-loaded t swap set-vocab-source-loaded? ;
@ -119,68 +98,7 @@ SYMBOL: load-help?
"To define one, refer to \\ MAIN: help" print "To define one, refer to \\ MAIN: help" print
] ?if ; ] ?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: 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 ) GENERIC: (load-vocab) ( name -- vocab )

View File

@ -1,28 +1,28 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 arrays assocs io.styles io help.markup prettyprint sequences
continuations debugger ; continuations debugger combinators.cleave ;
IN: benchmark IN: benchmark
: run-benchmark ( vocab -- result ) : 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 ) : run-benchmarks ( -- assoc )
"benchmark" all-child-vocabs values concat [ vocab-name ] map "benchmark" all-child-vocabs-seq
[ dup run-benchmark ] { } map>assoc ; [ dup run-benchmark ] { } map>assoc ;
: benchmarks. ( assoc -- ) : benchmarks. ( assoc -- )
standard-table-style [ standard-table-style [
[ [
[ "Benchmark" write ] with-cell [ "Benchmark" write ] with-cell
[ "Run time (ms)" write ] with-cell [ "Time (ms)" write ] with-cell
[ "GC time (ms)" write ] with-cell
] with-row ] with-row
[ [
[ [
swap [ dup ($vocab-link) ] with-cell [ [ 1array $vocab-link ] with-cell ]
first2 pprint-cell pprint-cell [ pprint-cell ] bi*
] with-row ] with-row
] assoc-each ] assoc-each
] tabular-output ; ] 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 dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ; 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 floats seed random -rot
[ >= ] curry find drop [ >= ] curry find drop
chars nth-unsafe ; inline chars nth-unsafe ; inline
@ -71,7 +71,7 @@ HINTS: random fixnum ;
write-description write-description
[ make-random-fasta ] 2curry split-lines ; inline [ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta ( k len alu -- ) :: make-repeat-fasta ( k len alu -- k' )
[let | kn [ alu length ] | [let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len + k len +

View File

@ -11,5 +11,7 @@ USING: vocabs.loader sequences ;
"tools.test" "tools.test"
"tools.time" "tools.time"
"tools.threads" "tools.threads"
"tools.vocabs"
"tools.vocabs.browser"
"editors" "editors"
} [ require ] each } [ 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
io.files io.files
prettyprint prettyprint
tools.browser tools.vocabs
tools.test tools.test
io.encodings.utf8 io.encodings.utf8
combinators.cleave combinators.cleave

View File

@ -1,12 +1,14 @@
USING: tools.deploy.config ; 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-ui? t }
{ deploy-io 3 } { deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-compiler? t } { deploy-compiler? t }
{ deploy-math? t } { deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-c-types? 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 USING: arrays bunny.model bunny.cel-shaded
combinators.lib continuations kernel math multiline combinators.lib continuations kernel math multiline
opengl opengl.shaders opengl.framebuffers opengl.gl opengl opengl.shaders opengl.framebuffers opengl.gl
opengl.capabilities sequences ui.gadgets ; opengl.capabilities sequences ui.gadgets combinators.cleave ;
IN: bunny.outlined IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source STRING: outlined-pass1-fragment-shader-main-source
@ -177,7 +177,7 @@ TUPLE: bunny-outlined
[ bunny-outlined-normal-texture [ delete-texture ] when* ] [ bunny-outlined-normal-texture [ delete-texture ] when* ]
[ bunny-outlined-depth-texture [ delete-texture ] when* ] [ bunny-outlined-depth-texture [ delete-texture ] when* ]
[ f swap set-bunny-outlined-framebuffer-dim ] [ f swap set-bunny-outlined-framebuffer-dim ]
} call-with } cleave
] [ drop ] if ; ] [ drop ] if ;
: remake-framebuffer-if-needed ( draw -- ) : remake-framebuffer-if-needed ( draw -- )
@ -237,4 +237,4 @@ M: bunny-outlined dispose
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ] [ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ] [ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
[ dispose-framebuffer ] [ dispose-framebuffer ]
} call-with ; } cleave ;

View File

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

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 ] [ drop ]
append ; 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 ! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

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

View File

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

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

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

View File

@ -196,6 +196,7 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.timeouts" } ; { $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools" ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:" "Exploratory tools:"
{ $subsection "editor" } { $subsection "editor" }
{ $subsection "tools.crossref" } { $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. ! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences parser kernel help help.markup help.topics 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 io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate vocabs.loader assocs editors continuations classes.predicate

View File

@ -169,7 +169,8 @@ M: f print-element drop ;
] if ] if
] ($subsection) ; ] ($subsection) ;
: $vocab-link ( element -- ) first dup ($vocab-link) ; : $vocab-link ( element -- )
first dup vocab-name swap ($vocab-link) ;
: $vocabulary ( element -- ) : $vocabulary ( element -- )
first word-vocabulary [ 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 ; TUPLE: link name ;
MIXIN: topic
INSTANCE: link topic
INSTANCE: word topic
GENERIC: >link ( obj -- obj ) GENERIC: >link ( obj -- obj )
M: link >link ; M: link >link ;
M: vocab-spec >link ; M: vocab-spec >link ;

View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax ui.commands ui.operations USING: help.markup help.syntax ui.commands ui.operations
ui.tools.search ui.tools.workspace editors vocabs.loader 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 ; unicode.categories unicode.case ;
IN: help.tutorial IN: help.tutorial

View File

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

View File

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

View File

@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal ; ] with-disposal ;
M: unix-io copy-file ( from to -- ) 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>type ( stat -- type )
stat-st_mode { stat-st_mode {

View File

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

View File

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

View File

@ -14,4 +14,4 @@ USE: io.backend
T{ windows-nt-io } set-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 USE: vocabs.loader
jamshred-gadget H{ 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{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
{ T{ motion } [ handle-mouse-motion ] } { T{ motion } [ handle-mouse-motion ] }
} set-gestures } set-gestures

View File

@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private effects generic prettyprint.sections sequences.private effects generic
compiler.units ; compiler.units combinators.cleave ;
IN: locals IN: locals
! Inspired by ! Inspired by
@ -108,8 +108,8 @@ UNION: special local quote local-word local-reader local-writer ;
if ; if ;
: (point-free) ( quot args -- newquot ) : (point-free) ( quot args -- newquot )
{ [ load-locals ] [ point-free-body ] [ point-free-end ] } [ load-locals ] [ point-free-body ] [ point-free-end ]
map-call-with2 concat >quotation ; 2tri 3append >quotation ;
: point-free ( quot args -- newquot ) : point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ; 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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions USING: arrays kernel sequences math math.functions
math.vectors ; math.vectors combinators.cleave ;
IN: math.matrices IN: math.matrices
! Matrices ! Matrices
@ -33,23 +33,22 @@ IN: math.matrices
: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ; : mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ; : mnorm ( m -- n ) dup mmax abs m/n ;
: cross-i ( vec1 vec2 -- i ) <PRIVATE
over third over second * >r
swap second swap third * r> - ;
: cross-j ( vec1 vec2 -- j ) : x first ; inline
over first over third * >r : y second ; inline
swap third swap first * r> - ; : z third ; inline
: cross-k ( vec1 vec2 -- k ) : i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
over first over second * >r : j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
swap second swap first * r> - ; : k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
: cross ( vec1 vec2 -- vec3 ) PRIVATE>
[ cross-i ] 2keep [ cross-j ] 2keep cross-k 3array ;
: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
: proj ( v u -- w ) : proj ( v u -- w )
[ [ v. ] keep norm-sq / ] keep n*v ; [ [ v. ] [ norm-sq ] bi / ] keep n*v ;
: (gram-schmidt) ( v seq -- newseq ) : (gram-schmidt) ( v seq -- newseq )
[ dupd proj v- ] each ; [ 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 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 IN: opengl.demo-support
: NEAR-PLANE 1.0 64.0 / ; inline : 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_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
GL_MODELVIEW glMatrixMode GL_MODELVIEW glMatrixMode
glLoadIdentity glLoadIdentity
{ [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
[ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
[ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } call-with ; [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ]
tri ;
: reset-last-drag-rel ( -- ) : reset-last-drag-rel ( -- )
{ 0 0 } last-drag-loc set ; { 0 0 } last-drag-loc set-global ;
: last-drag-rel ( -- rel ) : 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 ) : drag-yaw-pitch ( -- yaw pitch )
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ; 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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien libc opengl math sequences combinators.lib assocs alien libc opengl math sequences combinators.lib
macros arrays ; macros arrays combinators.cleave ;
IN: opengl.shaders IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- ) : 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 ) : (make-with-gl-program) ( uniforms quot -- q )
[ [
\ dup , \ dup ,
[ swap (with-gl-program-uniforms) , \ call-with , % ] [ swap (with-gl-program-uniforms) , \ cleave , % ]
[ ] make , [ ] make ,
\ (with-gl-program) , \ (with-gl-program) ,
] [ ] make ; ] [ ] make ;

View File

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

View File

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

View File

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

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 ;

View File

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

View File

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

View File

@ -1,11 +1,11 @@
IN: tools.deploy.tests IN: tools.deploy.tests
USING: tools.test system io.files kernel tools.deploy.config USING: tools.test system io.files kernel tools.deploy.config
tools.deploy.backend math ; tools.deploy.backend math sequences io.launcher ;
: shake-and-bake : shake-and-bake
"." resource-path [ "." resource-path [
vm vm
"hello.image" temp-file "test.image" temp-file
rot dup deploy-config make-deploy-image rot dup deploy-config make-deploy-image
] with-directory ; ] with-directory ;
@ -15,8 +15,30 @@ tools.deploy.backend math ;
"hello.image" temp-file file-length 500000 <= "hello.image" temp-file file-length 500000 <=
] unit-test ] 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 [ ] [ "hello-ui" shake-and-bake ] unit-test
[ t ] [ [ t ] [
"hello.image" temp-file file-length 2000000 <= "hello.image" temp-file file-length 2000000 <=
] unit-test ] 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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces continuations.private kernel.private init USING: qualified io.streams.c init fry namespaces assocs kernel
assocs kernel vocabs words sequences memory io system arrays parser tools.deploy.config vocabs sequences words words.private
continuations math definitions mirrors splitting parser classes memory kernel.private continuations io prettyprint
inspector layouts vocabs.loader prettyprint.config prettyprint vocabs.loader debugger system strings ;
debugger io.streams.c io.streams.duplex io.files io.backend QUALIFIED: bootstrap.stage2
quotations words.private tools.deploy.config compiler.units ; 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 IN: tools.deploy.shaker
: strip-init-hooks ( -- ) : strip-init-hooks ( -- )
@ -43,9 +61,6 @@ IN: tools.deploy.shaker
run-file run-file
] when ; ] when ;
: strip-assoc ( retained-keys assoc -- newassoc )
swap [ nip member? ] curry assoc-subset ;
: strip-word-names ( words -- ) : strip-word-names ( words -- )
"Stripping word names" show "Stripping word names" show
[ f over set-word-name f swap set-word-vocabulary ] each ; [ 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 -- ) : strip-word-props ( retain-props words -- )
"Stripping word properties" show "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 ; ] with each ;
: retained-props ( -- seq ) : retained-props ( -- seq )
@ -81,10 +99,101 @@ IN: tools.deploy.shaker
strip-word-names? [ dup strip-word-names ] when strip-word-names? [ dup strip-word-names ] when
2drop ; 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? [ strip-globals? [
"Stripping environment" show "Stripping globals" show
global strip-assoc 21 setenv global swap
'[ drop , member? not ] assoc-subset
[ drop string? not ] assoc-subset ! strip CLI args
dup keys .
21 setenv
] [ drop ] if ; ] [ drop ] if ;
: finish-deploy ( final-image -- ) : finish-deploy ( final-image -- )
@ -108,55 +217,6 @@ SYMBOL: deploy-vocab
] [ ] make "Boot quotation: " write dup . flush ] [ ] make "Boot quotation: " write dup . flush
set-boot-quot ; 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 ( -- )
strip-libc strip-libc
strip-cocoa strip-cocoa
@ -165,7 +225,7 @@ SYMBOL: deploy-vocab
strip-init-hooks strip-init-hooks
deploy-vocab get vocab-main set-boot-quot* deploy-vocab get vocab-main set-boot-quot*
retained-props >r retained-props >r
retained-globals strip-environment stripped-globals strip-globals
r> strip-words ; r> strip-words ;
: (deploy) ( final-image vocab config -- ) : (deploy) ( final-image vocab config -- )

View File

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

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 }
}

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

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 }
}

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

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 }
}

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

View File

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

View File

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

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 "" } ;

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

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 ;

View File

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

View File

@ -1,52 +1,75 @@
USING: help.markup help.syntax io strings ; USING: help.markup help.syntax strings ;
IN: tools.browser IN: tools.vocabs
ARTICLE: "vocab-index" "Vocabulary index" ARTICLE: "tools.vocabs" "Vocabulary tools"
{ $tags } "Reloading source files changed on disk:"
{ $authors } { $subsection refresh }
{ $describe-vocab "" } ; { $subsection refresh-all }
"Vocabulary summaries:"
ARTICLE: "tools.browser" "Vocabulary browser" { $subsection vocab-summary }
"Getting and setting vocabulary meta-data:" { $subsection set-vocab-summary }
{ $subsection vocab-file-contents } "Vocabulary tags:"
{ $subsection set-vocab-file-contents } { $subsection vocab-tags }
{ $subsection vocab-summary } { $subsection set-vocab-tags }
{ $subsection set-vocab-summary } { $subsection add-vocab-tags }
{ $subsection vocab-tags } "Getting and setting vocabulary meta-data:"
{ $subsection set-vocab-tags } { $subsection vocab-file-contents }
{ $subsection add-vocab-tags } { $subsection set-vocab-file-contents }
"Global meta-data:" "Global meta-data:"
{ $subsection all-vocabs } { $subsection all-vocabs }
{ $subsection all-vocabs-seq } { $subsection all-vocabs-seq }
{ $subsection all-tags } { $subsection all-tags }
{ $subsection all-authors } { $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:" "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 } ; { $subsection reset-cache } ;
HELP: vocab-file-contents ABOUT: "tools.vocabs"
{ $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: vocab-files
{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
HELP: set-vocab-file-contents { $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
{ $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-tests
{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
HELP: vocab-summary { $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
{ $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: source-modified?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
HELP: set-vocab-summary { $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." } ;
{ $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: refresh
{ $values { "prefix" string } }
HELP: vocab-tags { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
{ $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: refresh-all
{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
HELP: set-vocab-tags
{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } { refresh refresh-all } related-words
{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
HELP: vocab-file-contents
HELP: all-vocabs { $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } { $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
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 ;

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 math math.vectors namespaces opengl opengl.gl prettyprint assocs
sequences io.files io.styles continuations freetype sequences io.files io.styles continuations freetype
ui.gadgets.worlds ui.render ui.backend byte-arrays ; ui.gadgets.worlds ui.render ui.backend byte-arrays ;
IN: ui.freetype IN: ui.freetype
TUPLE: freetype-renderer ; TUPLE: freetype-renderer ;
@ -74,7 +75,7 @@ M: freetype-renderer free-fonts ( world -- )
: open-face ( font style -- face ) : open-face ( font style -- face )
ttf-name ttf-path ttf-name ttf-path
dup malloc-file-contents dup malloc-file-contents
swap file-length swap file-info file-info-size
(open-face) ; (open-face) ;
SYMBOL: dpi SYMBOL: dpi

View File

@ -1,5 +1,5 @@
USING: ui.gadgets ui.gestures help.markup help.syntax USING: ui.gadgets ui.gestures help.markup help.syntax
kernel classes strings opengl.gl ; kernel classes strings opengl.gl models ;
IN: ui.render IN: ui.render
HELP: gadget 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-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-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-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." } "Gadgets delegate to " { $link rect } " instances holding their location and dimensions." }
{ $notes { $notes

View File

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

View File

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

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.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.gadgets.presentations ui.gestures words vocabs.loader 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 IN: ui.tools
: <workspace-tabs> ( -- tabs ) : <workspace-tabs> ( -- tabs )

View File

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

View File

@ -21,15 +21,26 @@ else
set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255 set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
endif 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 factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
syn match factorComment /\<#! .*/ contains=factorTodo syn match factorComment /\<#! .*/ contains=factorTodo
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 factorBoolean boolean f general-t t
syn keyword factorCompileDirective inline foldable parsing syn keyword factorCompileDirective inline foldable parsing
@ -37,15 +48,17 @@ syn keyword factorCompileDirective inline foldable parsing
" kernel vocab keywords " 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 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 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 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 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 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 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 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 array <array> pair byte-array pair? 1array 2array resize-array 4array 3array byte-array? <byte-array> array? >array 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 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 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 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 <array> 3array >array 4array pair? array pair 2array 1array resize-array array?
syn keyword factorKeyword <vector> >vector array>vector vector? vector 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 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 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 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 factorUsing start=/\<USING:\>/ end=/;/
syn region factorRequires start=/\<REQUIRES:\>/ 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 factorSymbol /\<SYMBOL:\s\+\S\+\>/
syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/ syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
syn match factorDefer /\<DEFER:\s\+\S\+\>/ syn match factorDefer /\<DEFER:\s\+\S\+\>/
syn match factorForget /\<FORGET:\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\+\>/ syn match factorAlien /\<ALIEN:\s\+\d\+\>/
@ -87,8 +105,6 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
"misc: "misc:
" HELP: " HELP:
" ARTICLE: " ARTICLE:
" PROVIDE:
" MAIN:
"literals: "literals:
" PRIMITIVE: " PRIMITIVE:
@ -106,8 +122,11 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
syn match factorStackEffectErr /\<)\>/ syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ syn match factorMultiStringContents /.*/ contained
"syn match factorStackEffectErr /\<)\>/
"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
"adapted from lisp.vim "adapted from lisp.vim
@ -127,18 +146,18 @@ else
endif endif
if exists("g:factor_norainbow") 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 else
syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif endif
syn match factorBracketErr /\<\]\>/ syn match factorBracketErr /\<\]\>/
@ -163,11 +182,21 @@ if version >= 508 || !exists("did_factor_syn_inits")
HiLink factorKeyword Keyword HiLink factorKeyword Keyword
HiLink factorOperator Operator HiLink factorOperator Operator
HiLink factorBoolean Boolean 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 factorString String
HiLink factorSbuf String HiLink factorSbuf String
HiLink factorMultiStringContents String
HiLink factorMultiStringDelims Typedef
HiLink factorBracketErr Error HiLink factorBracketErr Error
HiLink factorStackEffectErr Error
HiLink factorComplex Number HiLink factorComplex Number
HiLink factorRatio Number HiLink factorRatio Number
HiLink factorBinary Number HiLink factorBinary Number
@ -186,14 +215,17 @@ if version >= 508 || !exists("did_factor_syn_inits")
HiLink factorCharErr Error HiLink factorCharErr Error
HiLink factorDelimiter Delimiter HiLink factorDelimiter Delimiter
HiLink factorBackslash Special HiLink factorBackslash Special
HiLink factorCompileDirective Keyword HiLink factorCompileDirective Typedef
HiLink factorSymbol Define HiLink factorSymbol Define
HiLink factorMixin Typedef
HiLink factorInstance Typedef
HiLink factorHook Typedef
HiLink factorMain Define
HiLink factorPostpone Define HiLink factorPostpone Define
HiLink factorDefer Define HiLink factorDefer Define
HiLink factorForget Define HiLink factorForget Define
HiLink factorAlien Define HiLink factorAlien Define
HiLink factorTuple Typedef HiLink factorTuple Typedef
HiLink factorGeneric Define
if &bg == "dark" if &bg == "dark"
hi hlLevel0 ctermfg=red guifg=red1 hi hlLevel0 ctermfg=red guifg=red1
@ -230,3 +262,4 @@ set expandtab
set autoindent " annoying? set autoindent " annoying?
" vim: syntax=vim " vim: syntax=vim

View File

@ -1,4 +1,4 @@
<% USING: kernel io prettyprint words sequences ; <% USING: kernel io prettyprint vocabs sequences ;
%>" Vim syntax file %>" Vim syntax file
" Language: factor " Language: factor
" Maintainer: Alex Chapman <chapman.alex@gmail.com> " 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 set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
endif 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 factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
syn match factorComment /\<#! .*/ contains=factorTodo syn match factorComment /\<#! .*/ contains=factorTodo
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 factorBoolean boolean f general-t t
syn keyword factorCompileDirective inline foldable parsing 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 ! that this changes factor.vim from around 8k to around 100k (and is a bit
! broken) ! 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 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 factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
syn cluster factorNumber contains=@factorReal,factorComplex syn cluster factorNumber contains=@factorReal,factorComplex
@ -70,11 +84,16 @@ syn match factorBackslash /\<\\\>\s\+\S\+\>/
syn region factorUsing start=/\<USING:\>/ end=/;/ syn region factorUsing start=/\<USING:\>/ end=/;/
syn region factorRequires start=/\<REQUIRES:\>/ 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 factorSymbol /\<SYMBOL:\s\+\S\+\>/
syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/ syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
syn match factorDefer /\<DEFER:\s\+\S\+\>/ syn match factorDefer /\<DEFER:\s\+\S\+\>/
syn match factorForget /\<FORGET:\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\+\>/ syn match factorAlien /\<ALIEN:\s\+\d\+\>/
@ -84,8 +103,6 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
"misc: "misc:
" HELP: " HELP:
" ARTICLE: " ARTICLE:
" PROVIDE:
" MAIN:
"literals: "literals:
" PRIMITIVE: " PRIMITIVE:
@ -103,8 +120,11 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
syn match factorStackEffectErr /\<)\>/ syn region factorMultiString matchgroup=factorMultiStringDelims start=/\<STRING:\s\+\S\+\>/ end=/^;$/ contains=factorMultiStringContents
syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ syn match factorMultiStringContents /.*/ contained
"syn match factorStackEffectErr /\<)\>/
"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
"adapted from lisp.vim "adapted from lisp.vim
@ -124,18 +144,18 @@ else
endif endif
if exists("g:factor_norainbow") 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 else
syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 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\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0
endif endif
syn match factorBracketErr /\<\]\>/ syn match factorBracketErr /\<\]\>/
@ -160,11 +180,21 @@ if version >= 508 || !exists("did_factor_syn_inits")
HiLink factorKeyword Keyword HiLink factorKeyword Keyword
HiLink factorOperator Operator HiLink factorOperator Operator
HiLink factorBoolean Boolean 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 factorString String
HiLink factorSbuf String HiLink factorSbuf String
HiLink factorMultiStringContents String
HiLink factorMultiStringDelims Typedef
HiLink factorBracketErr Error HiLink factorBracketErr Error
HiLink factorStackEffectErr Error
HiLink factorComplex Number HiLink factorComplex Number
HiLink factorRatio Number HiLink factorRatio Number
HiLink factorBinary Number HiLink factorBinary Number
@ -183,14 +213,17 @@ if version >= 508 || !exists("did_factor_syn_inits")
HiLink factorCharErr Error HiLink factorCharErr Error
HiLink factorDelimiter Delimiter HiLink factorDelimiter Delimiter
HiLink factorBackslash Special HiLink factorBackslash Special
HiLink factorCompileDirective Keyword HiLink factorCompileDirective Typedef
HiLink factorSymbol Define HiLink factorSymbol Define
HiLink factorMixin Typedef
HiLink factorInstance Typedef
HiLink factorHook Typedef
HiLink factorMain Define
HiLink factorPostpone Define HiLink factorPostpone Define
HiLink factorDefer Define HiLink factorDefer Define
HiLink factorForget Define HiLink factorForget Define
HiLink factorAlien Define HiLink factorAlien Define
HiLink factorTuple Typedef HiLink factorTuple Typedef
HiLink factorGeneric Define
if &bg == "dark" if &bg == "dark"
hi hlLevel0 ctermfg=red guifg=red1 hi hlLevel0 ctermfg=red guifg=red1