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

db4
Matthew Willis 2008-03-14 00:33:47 -07:00
commit cedd0813cd
113 changed files with 1661 additions and 1143 deletions

View File

@ -98,26 +98,36 @@ H{ } clone class<map set
H{ } clone update-map set
! Builtin classes
: builtin-predicate ( class predicate -- )
: builtin-predicate-quot ( class -- quot )
[
over "type" word-prop dup
"type" word-prop dup
\ tag-mask get < \ tag \ type ? , , \ eq? ,
] [ ] make define-predicate* ;
] [ ] make ;
: register-builtin ( class -- )
dup "type" word-prop builtins get set-nth ;
: define-builtin-predicate ( class -- )
dup
dup builtin-predicate-quot define-predicate
predicate-word make-inline ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
: define-builtin ( symbol predicate slotspec -- )
>r dup make-inline >r
dup dup lookup-type-number "type" set-word-prop
: register-builtin ( class -- )
dup
dup lookup-type-number "type" set-word-prop
dup "type" word-prop builtins get set-nth ;
: define-builtin-slots ( symbol slotspec -- )
dupd 1 simple-slots
2dup "slots" set-word-prop
define-slots ;
: define-builtin ( symbol slotspec -- )
>r
dup register-builtin
dup f f builtin-class define-class
dup r> builtin-predicate
dup r> 1 simple-slots 2dup "slots" set-word-prop
dupd define-slots
register-builtin ;
dup define-builtin-predicate
r> define-builtin-slots ;
H{ } clone typemap set
num-types get f <array> builtins set
@ -128,17 +138,15 @@ num-types get f <array> builtins set
"null" "kernel" create drop
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
"fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
"bignum" "math" create "bignum?" "math" create { } define-builtin
"bignum" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
"tuple" "kernel" create "tuple?" "kernel" create
{ } define-builtin
"tuple" "kernel" create { } define-builtin
"ratio" "math" create "ratio?" "math" create
{
"ratio" "math" create {
{
{ "integer" "math" }
"numerator"
@ -153,11 +161,10 @@ num-types get f <array> builtins set
}
} define-builtin
"float" "math" create "float?" "math" create { } define-builtin
"float" "math" create { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
"complex" "math" create "complex?" "math" create
{
"complex" "math" create {
{
{ "real" "math" }
"real-part"
@ -172,14 +179,13 @@ num-types get f <array> builtins set
}
} define-builtin
"f" "syntax" lookup "not" "kernel" create
{ } define-builtin
"f" "syntax" lookup { } define-builtin
"array" "arrays" create "array?" "arrays" create
{ } define-builtin
! do not word...
"wrapper" "kernel" create "wrapper?" "kernel" create
{
"array" "arrays" create { } define-builtin
"wrapper" "kernel" create {
{
{ "object" "kernel" }
"wrapped"
@ -188,8 +194,7 @@ num-types get f <array> builtins set
}
} define-builtin
"string" "strings" create "string?" "strings" create
{
"string" "strings" create {
{
{ "array-capacity" "sequences.private" }
"length"
@ -203,8 +208,7 @@ num-types get f <array> builtins set
}
} define-builtin
"quotation" "quotations" create "quotation?" "quotations" create
{
"quotation" "quotations" create {
{
{ "object" "kernel" }
"array"
@ -219,8 +223,7 @@ num-types get f <array> builtins set
}
} define-builtin
"dll" "alien" create "dll?" "alien" create
{
"dll" "alien" create {
{
{ "byte-array" "byte-arrays" }
"path"
@ -230,8 +233,7 @@ num-types get f <array> builtins set
}
define-builtin
"alien" "alien" create "alien?" "alien" create
{
"alien" "alien" create {
{
{ "c-ptr" "alien" }
"alien"
@ -246,8 +248,7 @@ define-builtin
}
define-builtin
"word" "words" create "word?" "words" create
{
"word" "words" create {
f
{
{ "object" "kernel" }
@ -287,26 +288,25 @@ define-builtin
}
} define-builtin
"byte-array" "byte-arrays" create
"byte-array?" "byte-arrays" create
{ } define-builtin
"byte-array" "byte-arrays" create { } define-builtin
"bit-array" "bit-arrays" create
"bit-array?" "bit-arrays" create
{ } define-builtin
"bit-array" "bit-arrays" create { } define-builtin
"float-array" "float-arrays" create
"float-array?" "float-arrays" create
{ } define-builtin
"float-array" "float-arrays" create { } define-builtin
"callstack" "kernel" create "callstack?" "kernel" create
{ } define-builtin
"callstack" "kernel" create { } define-builtin
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create
"f" "syntax" lookup builtins get remove [ ] subset f union-class
define-class
"f" "syntax" create [ not ] "predicate" set-word-prop
"f?" "syntax" create "syntax" vocab-words delete-at
"general-t" "kernel" create [ ] "predicate" set-word-prop
"general-t?" "kernel" create "syntax" vocab-words delete-at
! Catch-all class for providing a default method.
"object" "kernel" create [ drop t ] "predicate" set-word-prop
"object" "kernel" create

View File

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

View File

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

View File

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

View File

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

View File

@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
alien alien.accessors alien.compiler alien.structs slots
layouts alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

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

View File

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

View File

@ -21,7 +21,7 @@ IN: builder.benchmark
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
"../../benchmarks" "../benchmarks" [ eval-file ] 2apply
"../benchmarks" "benchmarks" [ eval-file ] 2apply
compare-tables
sort-values ;

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

@ -4,6 +4,7 @@ USING: kernel namespaces sequences splitting system combinators continuations
bootstrap.image benchmark vars bake smtp builder.util accessors
io.encodings.utf8
calendar
tools.test
builder.common
builder.benchmark
builder.release ;
@ -131,7 +132,10 @@ SYMBOL: build-status
"Test time: " write "test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
"test-all-vocabs" eval-file test-failures.
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks.

View File

@ -4,7 +4,7 @@ USING: kernel namespaces sequences assocs builder continuations
io
io.files
prettyprint
tools.browser
tools.vocabs
tools.test
io.encodings.utf8
combinators.cleave
@ -21,13 +21,19 @@ IN: builder.test
: do-tests ( -- )
run-all-tests
"../test-all-vocabs" utf8
[
[ keys . ]
[ test-failures. ]
bi
]
with-file-writer ;
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
bi ;
! : do-tests ( -- )
! run-all-tests
! "../test-all-vocabs" utf8
! [
! [ keys . ]
! [ test-failures. ]
! bi
! ]
! with-file-writer ;
: do-help-lint ( -- )
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;

View File

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

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

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

View File

@ -0,0 +1,108 @@
USING: kernel quotations help.syntax help.markup ;
IN: combinators.cleave
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "cleave-combinators" "Cleave Combinators"
"Basic cleavers:"
{ $subsection bi }
{ $subsection tri }
"General cleave: "
{ $subsection cleave }
"Cleave combinators for quotations with arity 2:"
{ $subsection 2bi }
{ $subsection 2tri }
{ $notes
"From the Merriam-Webster Dictionary: "
$nl
{ $strong "cleave" }
{ $list
{ $emphasis "To divide by or as if by a cutting blow" }
{ $emphasis "To separate into distinct parts and especially into "
"groups having divergent views" } }
$nl
"The Joy programming language has a " { $emphasis "cleave" } " combinator." }
;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: bi
{ $values { "x" object }
{ "p" quotation }
{ "q" quotation }
{ "p(x)" "p applied to x" }
{ "q(x)" "q applied to x" } } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: tri
{ $values { "x" object }
{ "p" quotation }
{ "q" quotation }
{ "r" quotation }
{ "p(x)" "p applied to x" }
{ "q(x)" "q applied to x" }
{ "r(x)" "r applied to x" } } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: cleave
{ $code "( obj { q1 q2 ... qN } -- q1(obj) q2(obj) ... qN(obj) )" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
{ bi tri cleave 2bi 2tri } related-words
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "spread-combinators" "Spread Combinators"
{ $subsection bi* }
{ $subsection tri* }
{ $subsection spread } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: bi*
{ $values { "x" object }
{ "y" object }
{ "p" quotation }
{ "q" quotation }
{ "p(x)" "p applied to x" }
{ "q(y)" "q applied to y" } } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: tri*
{ $values { "x" object }
{ "y" object }
{ "z" object }
{ "p" quotation }
{ "q" quotation }
{ "r" quotation }
{ "p(x)" "p applied to x" }
{ "q(y)" "q applied to y" }
{ "r(z)" "r applied to z" } } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: spread
{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ;

View File

@ -7,17 +7,18 @@ IN: combinators.cleave
! The cleaver family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bi ( obj quot quot -- val val ) >r keep r> call ; inline
: tri ( obj quot quot quot -- val val val )
>r pick >r bi r> r> call ; inline
: bi ( x p q -- p(x) q(x) ) >r keep r> call ; inline
: tri ( x p q r -- p(x) q(x) r(x) ) >r pick >r bi r> r> call ; inline
: tetra ( obj quot quot quot quot -- val val val val )
>r >r pick >r bi r> r> r> bi ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -35,13 +36,25 @@ MACRO: cleave ( seq -- )
[ drop ]
append ;
MACRO: 2cleave ( seq -- )
dup
[ drop [ 2dup ] ] map concat
swap
dup
[ drop [ >r >r ] ] map concat
swap
[ [ r> r> ] append ] map concat
3append
[ 2drop ]
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bi* ( obj obj quot quot -- val val ) >r swap slip r> call ; inline
: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline
: tri* ( obj obj obj quot quot quot -- val val val )
: tri* ( x y z p q r -- p(x) q(y) r(z) )
>r rot >r bi* r> r> call ; inline
: tetra* ( obj obj obj obj quot quot quot quot -- val val val val )

View File

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

View File

@ -30,9 +30,11 @@ SYMBOL: person3
SYMBOL: person4
: test-tuples ( -- )
[ person drop-table ] [ drop ] recover
[ ] [ person ensure-table ] unit-test
[ ] [ person drop-table ] unit-test
[ ] [ person create-table ] unit-test
[ person create-table ] must-fail
[ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test
@ -191,8 +193,8 @@ TUPLE: annotation n paste-id summary author mode contents ;
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
! [ native-person-schema test-tuples ] test-postgresql
! [ assigned-person-schema test-tuples ] test-postgresql
TUPLE: serialize-me id data ;
@ -211,7 +213,7 @@ TUPLE: serialize-me id data ;
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
[ test-serialize ] test-sqlite
[ test-serialize ] test-postgresql
! [ test-serialize ] test-postgresql
TUPLE: exam id name score ;

View File

@ -3,7 +3,8 @@
USING: arrays assocs classes db kernel namespaces
tuples words sequences slots math
math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ;
mirrors sequences.lib tools.walker combinators.lib
combinators.cleave ;
IN: db.tuples
: define-persistent ( class table columns -- )
@ -73,6 +74,9 @@ HOOK: insert-tuple* db ( tuple statement -- )
: drop-table ( class -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: ensure-table ( class -- )
[ dup drop-table ] ignore-errors create-table ;
: insert-native ( tuple -- )
dup class
db get db-insert-statements [ <insert-native-statement> ] cache

View File

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

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

@ -43,6 +43,21 @@ IN: farkup.tests
[ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
[ "<p>=foo\n</p>" ] [ "=foo\n" convert-farkup ] unit-test
[ "<h1>foo</h1>\n" ] [ "=foo=\n" convert-farkup ] unit-test
[ "<p>lol</p><h1>foo</h1>\n" ] [ "lol=foo=\n" convert-farkup ] unit-test
[ "<p>=foo\n</p>" ] [ "=foo\n" convert-farkup ] unit-test
[ "<p>=foo</p>" ] [ "=foo" convert-farkup ] unit-test
[ "<p>==foo</p>" ] [ "==foo" convert-farkup ] unit-test
[ "<p>=</p><h1>foo</h1>" ] [ "==foo=" convert-farkup ] unit-test
[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test

View File

@ -42,14 +42,44 @@ MEMO: h2 ( -- parser ) "==" "h2" delimited ;
MEMO: h3 ( -- parser ) "===" "h3" delimited ;
MEMO: h4 ( -- parser ) "====" "h4" delimited ;
MEMO: eq ( -- parser )
[
h1 ensure-not ,
h2 ensure-not ,
h3 ensure-not ,
h4 ensure-not ,
"=" token ,
] seq* ;
: render-code ( string mode -- string' )
>r string-lines r>
[ [ htmlize-lines ] with-html-stream ] with-string-writer ;
: escape-link ( href text -- href-esc text-esc )
>r escape-quoted-string r> escape-string ;
: make-link ( href text -- seq )
>r escape-quoted-string r> escape-string
escape-link
[ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
: make-image-link ( href alt -- seq )
escape-link
[
"<img src=\"" , swap , "\"" ,
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
"/>" , ]
{ } make ;
MEMO: image-link ( -- parser )
[
"[[image:" token hide ,
[ "|]" member? not ] satisfy repeat1 [ >string ] action ,
"|" token hide
[ CHAR: ] = not ] satisfy repeat0 2seq
[ first >string ] action optional ,
"]]" token hide ,
] seq* [ first2 make-image-link ] action ;
MEMO: simple-link ( -- parser )
[
"[[" token hide ,
@ -66,7 +96,7 @@ MEMO: labelled-link ( -- parser )
"]]" token hide ,
] seq* [ first2 make-link ] action ;
MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ;
MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
DEFER: line
MEMO: list-item ( -- parser )
@ -92,20 +122,17 @@ MEMO: table ( -- parser )
MEMO: code ( -- parser )
[
"[" token hide ,
[ "{" member? not ] satisfy repeat1 optional [ >string ] action ,
[ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
"{" token hide ,
[
[ any-char , "}]" token ensure-not , ] seq*
repeat1 [ concat >string ] action ,
[ any-char , "}]" token hide , ] seq* optional [ >string ] action ,
] seq* [ concat ] action ,
"}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
"}]" token hide ,
] seq* [ first2 swap render-code ] action ;
MEMO: line ( -- parser )
[
text , strong , emphasis , link ,
superscript , subscript , inline-code ,
escaped-char , delimiter ,
escaped-char , delimiter , eq ,
] choice* repeat1 ;
MEMO: paragraph ( -- parser )

View File

@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
"\"mydata.dat\" dup file-length ["
"\"mydata.dat\" dup file-info file-info-length ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}

View File

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

View File

@ -344,7 +344,7 @@ HELP: $side-effects
HELP: $notes
{ $values { "element" "a markup element" } }
{ $description "Prints the errors subheading found on the help page of some words. This section should usage tips and pitfalls." } ;
{ $description "Prints the notes subheading found on the help page of some words. This section should document usage tips and pitfalls." } ;
HELP: $see
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }

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

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

View File

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

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

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

View File

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

View File

@ -95,5 +95,4 @@ PRIVATE>
swap >>post-data-type ;
: http-post ( content-type content url -- response string )
#! The content is URL encoded for you.
>r url-encode r> <post-request> http-request contents ;
<post-request> http-request contents ;

View File

@ -4,7 +4,8 @@ USING: fry hashtables io io.streams.string kernel math
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
combinators vectors sorting new-slots accessors calendar
calendar.format quotations arrays ;
calendar.format quotations arrays combinators.cleave
combinators.lib byte-arrays ;
IN: http
: http-port 80 ; inline
@ -12,18 +13,21 @@ IN: http
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
dup letter?
over LETTER? or
over digit? or
swap "/_-." member? or ; foldable
{
[ dup letter? ]
[ dup LETTER? ]
[ dup digit? ]
[ dup "/_-.:" member? ]
} || nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[ [
dup url-quotable? [ , ] [ push-utf8 ] if
] each ] "" make ;
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
@ -108,7 +112,12 @@ IN: http
] when ;
: assoc>query ( hash -- str )
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
[
[ url-encode ]
[ dup number? [ number>string ] when url-encode ]
bi*
"=" swap 3append
] { } assoc>map
"&" join ;
TUPLE: cookie name value path domain expires http-only ;
@ -169,10 +178,10 @@ cookies ;
: <request>
request construct-empty
"1.1" >>version
http-port >>port
H{ } clone >>query
V{ } clone >>cookies ;
"1.1" >>version
http-port >>port
H{ } clone >>query
V{ } clone >>cookies ;
: query-param ( request key -- value )
swap query>> at ;
@ -245,6 +254,10 @@ SYMBOL: max-post-request
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
: parse-post-data ( request -- request )
dup post-data-type>> "application/x-www-form-urlencoded" =
[ dup post-data>> query>assoc >>post-data ] when ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ;
@ -257,24 +270,31 @@ SYMBOL: max-post-request
read-post-data
extract-host
extract-post-data-type
parse-post-data
extract-cookies ;
: write-method ( request -- request )
dup method>> write bl ;
: write-url ( request -- request )
dup path>> url-encode write
dup query>> dup assoc-empty? [ drop ] [
"?" write
assoc>query write
] if ;
: (link>string) ( url query -- url' )
[ url-encode ] [ assoc>query ] bi*
dup empty? [ drop ] [ "?" swap 3append ] if ;
: write-url ( request -- )
[ path>> ] [ query>> ] bi (link>string) write ;
: write-request-url ( request -- request )
write-url bl ;
dup write-url bl ;
: write-version ( request -- request )
"HTTP/" write dup request-version write crlf ;
: unparse-post-data ( request -- request )
dup post-data>> dup sequence? [ drop ] [
assoc>query >>post-data
"application/x-www-form-urlencoded" >>post-data-type
] if ;
: write-request-header ( request -- request )
dup header>> >hashtable
over host>> [ "host" pick set-at ] when*
@ -287,6 +307,7 @@ SYMBOL: max-post-request
dup post-data>> [ write ] when* ;
: write-request ( request -- )
unparse-post-data
write-method
write-request-url
write-version
@ -297,15 +318,16 @@ SYMBOL: max-post-request
: request-url ( request -- url )
[
dup host>> [
"http://" write
dup host>> url-encode write
":" write
dup port>> number>string write
] when
dup path>> "/" head? [ "/" write ] unless
write-url
drop
[
dup host>> [
[ "http://" write host>> url-encode write ]
[ ":" write port>> number>string write ]
bi
] [ drop ] if
]
[ path>> "/" head? [ "/" write ] unless ]
[ write-url ]
tri
] with-string-writer ;
: set-header ( request/response value key -- request/response )

View File

@ -29,6 +29,7 @@ blah
STRING: action-request-test-2
POST http://foo/bar/baz HTTP/1.1
content-length: 5
content-type: application/x-www-form-urlencoded
xxx=4
;

View File

@ -17,14 +17,6 @@ TUPLE: action init display submit get-params post-params ;
[ <400> ] >>display
[ <400> ] >>submit ;
: extract-params ( path -- assoc )
+path+ associate
request get dup method>> {
{ "GET" [ query>> ] }
{ "HEAD" [ query>> ] }
{ "POST" [ post-data>> query>assoc ] }
} case union ;
: with-validator ( string quot -- result error? )
'[ , @ f ] [
dup validation-error? [ t ] [ rethrow ] if
@ -50,12 +42,10 @@ TUPLE: action init display submit get-params post-params ;
action get display>> call exit-with ;
M: action call-responder ( path action -- response )
[ extract-params params set ]
[
action set
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case
] bi* ;
[ +path+ associate request-params union params set ]
[ action set ] bi*
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case ;

View File

@ -30,7 +30,8 @@ SYMBOL: login-failed?
: successful-login ( user -- response )
logged-in-user sset
post-login-url sget f <permanent-redirect> ;
post-login-url sget "" or f <permanent-redirect>
f post-login-url sset ;
:: <login-action> ( -- action )
[let | form [ <login-form> ] |

View File

@ -1,10 +1,13 @@
<% USING: http.server.auth.login http.server.components kernel
namespaces ; %>
<% USING: http.server.auth.login http.server.components http.server
kernel namespaces ; %>
<html>
<body>
<h1>Login required</h1>
<form method="POST" action="login">
<% hidden-form-field %>
<table>
<tr>
@ -30,10 +33,12 @@ login-failed? get
<p>
<% allow-registration? [ %>
<a href="register">Register</a>
<a href="<% "register" f write-link %>">Register</a>
<% ] when %>
<% allow-password-recovery? [ %>
<a href="recover-password">Recover Password</a>
<a href="<% "recover-password" f write-link %>">
Recover Password
</a>
<% ] when %>
</p>

View File

@ -1,4 +1,4 @@
<% USING: http.server.components ; %>
<% USING: http.server.components http.server ; %>
<html>
<body>
<h1>Recover lost password: step 1 of 4</h1>
@ -6,6 +6,9 @@
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
<form method="POST" action="recover-password">
<% hidden-form-field %>
<table>
<tr>

View File

@ -1,4 +1,4 @@
<% USING: http.server.components http.server.auth.login
<% USING: http.server.components http.server.auth.login http.server
namespaces kernel combinators ; %>
<html>
<body>
@ -7,6 +7,9 @@ namespaces kernel combinators ; %>
<p>Choose a new password for your account.</p>
<form method="POST" action="new-password">
<% hidden-form-field %>
<table>
<% "username" component render-edit %>
@ -32,7 +35,7 @@ namespaces kernel combinators ; %>
<p><input type="submit" value="Set password" />
<% password-mismatch? get [
"passwords do not match" render-error
"passwords do not match" render-error
] when %>
</p>

View File

@ -1,10 +1,10 @@
<% USING: http.server.components http.server.auth.login
namespaces kernel combinators ; %>
<% USING: http.server ; %>
<html>
<body>
<h1>Recover lost password: step 4 of 4</h1>
<p>Your password has been reset. You may now <a href="login">log in</a>.</p>
<p>Your password has been reset.
You may now <a href="<% "login" f write-link %>">log in</a>.</p>
</body>
</html>

View File

@ -1,10 +1,12 @@
<% USING: http.server.components http.server.auth.login
namespaces kernel combinators ; %>
http.server namespaces kernel combinators ; %>
<html>
<body>
<h1>New user registration</h1>
<form method="POST" action="register">
<% hidden-form-field %>
<table>
<tr>

View File

@ -14,9 +14,7 @@ user "USERS"
{ "profile" "PROFILE" FACTOR-BLOB }
} define-persistent
: init-users-table ( -- )
[ user drop-table ] ignore-errors
user create-table ;
: init-users-table user ensure-table ;
TUPLE: from-db ;

View File

@ -3,15 +3,23 @@
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
new-slots html.elements accessors math.parser combinators.lib
vocabs.loader debugger html continuations random combinators
tools.vocabs debugger html continuations random combinators
destructors io.encodings.latin1 fry combinators.cleave ;
IN: http.server
GENERIC: call-responder ( path responder -- response )
: request-params ( -- assoc )
request get dup method>> {
{ "GET" [ query>> ] }
{ "HEAD" [ query>> ] }
{ "POST" [ post-data>> ] }
} case ;
: <content> ( content-type -- response )
<response>
200 >>code
"Document follows" >>message
swap set-content-type ;
TUPLE: trivial-responder response ;
@ -44,19 +52,27 @@ SYMBOL: 404-responder
[ <404> ] <trivial-responder> 404-responder set-global
: url-redirect ( to query -- url )
#! Different host.
dup assoc-empty? [
drop
] [
assoc>query "?" swap 3append
] if ;
SYMBOL: link-hook
: modify-query ( query -- query )
link-hook get [ ] or call ;
: link>string ( url query -- url' )
modify-query (link>string) ;
: write-link ( url query -- )
link>string write ;
SYMBOL: form-hook
: hidden-form-field ( -- )
form-hook get [ ] or call ;
: absolute-redirect ( to query -- url )
#! Same host.
request get clone
swap [ >>query ] when*
swap >>path
swap url-encode >>path
request-url ;
: replace-last-component ( path with -- path' )
@ -66,11 +82,12 @@ SYMBOL: 404-responder
request get clone
swap [ >>query ] when*
swap [ '[ , replace-last-component ] change-path ] when*
dup query>> modify-query >>query
request-url ;
: derive-url ( to query -- url )
{
{ [ over "http://" head? ] [ url-redirect ] }
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
{ [ t ] [ relative-redirect ] }
} cond ;

View File

@ -2,6 +2,8 @@ IN: http.server.sessions.tests
USING: tools.test http.server.sessions math namespaces
kernel accessors ;
[ H{ } ] [ H{ } add-session-id ] unit-test
: with-session \ session swap with-variable ; inline
TUPLE: foo ;
@ -10,7 +12,9 @@ C: <foo> foo
M: foo init-session* drop 0 "x" sset ;
f <session> [
f <session> "123" >>id [
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
[ ] [ 3 "x" sset ] unit-test
[ 9 ] [ "x" sget sq ] unit-test

View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random
boxes alarms new-slots accessors http http.server
quotations hashtables sequences fry combinators.cleave ;
quotations hashtables sequences fry combinators.cleave
html.elements ;
IN: http.server.sessions
! ! ! ! ! !
@ -67,12 +68,6 @@ TUPLE: session manager id namespace alarm ;
: sessions ( -- manager/f )
\ session get dup [ manager>> ] when ;
GENERIC: session-link* ( url query sessions -- string )
M: object session-link* 2drop url-encode ;
: session-link ( url query -- string ) sessions session-link* ;
TUPLE: null-sessions ;
: <null-sessions>
@ -88,23 +83,30 @@ TUPLE: url-sessions ;
: sess-id "factorsessid" ;
: current-session ( responder request -- session )
sess-id query-param swap get-session ;
: current-session ( responder -- session )
>r request-params sess-id swap at r> get-session ;
: add-session-id ( query -- query' )
\ session get [ id>> sess-id associate union ] when* ;
: session-form-field ( -- )
<input
"hidden" =type
sess-id =id
sess-id =name
\ session get id>> =value
input/> ;
M: url-sessions call-responder ( path responder -- response )
dup request get current-session [
[ add-session-id ] link-hook set
[ session-form-field ] form-hook set
dup current-session [
call-responder/session
] [
nip
f swap new-session sess-id associate <temporary-redirect>
] if* ;
M: url-sessions session-link*
drop
url-encode
\ session get id>> sess-id associate union assoc>query
dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
TUPLE: cookie-sessions ;
: <cookie-sessions> ( responder -- responder' )

View File

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

View File

@ -0,0 +1,9 @@
USING: io.encodings.string io.encodings.ascii tools.test strings arrays ;
IN: io.encodings.ascii.tests
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test
[ { 128 } >string ascii encode ] must-fail
[ B{ 127 } ] [ { 127 } ascii encode ] unit-test
[ "bar" ] [ "bar" ascii decode ] unit-test
[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test

View File

@ -3,13 +3,16 @@
USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
IN: io.encodings.ascii
: encode-check<= ( string stream max -- )
: encode-check< ( string stream max -- )
[ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
: push-if< ( sbuf character max -- )
over <= [ drop HEX: fffd ] when swap push ;
TUPLE: ascii ;
M: ascii stream-write-encoded ( string stream encoding -- )
drop 128 encode-check<= ;
drop 128 encode-check< ;
M: ascii decode-step
drop dup 128 >= [ decode-error ] [ swap push ] if ;
drop 128 push-if< ;

View File

@ -0,0 +1,9 @@
USING: io.encodings.string io.encodings.latin1 tools.test strings arrays ;
IN: io.encodings.latin1.tests
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
[ { 256 } >string latin1 encode ] must-fail
[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
[ "bar" ] [ "bar" latin1 decode ] unit-test
[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test

View File

@ -6,7 +6,7 @@ IN: io.encodings.latin1
TUPLE: latin1 ;
M: latin1 stream-write-encoded
drop 256 encode-check<= ;
drop 256 encode-check< ;
M: latin1 decode-step
drop swap push ;

4
extra/io/mmap/mmap-tests.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors

View File

@ -1,15 +1,15 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.nonblocking io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations math.bitfields
byte-arrays alien combinators combinators.cleave calendar
io.encodings.binary ;
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators combinators.cleave
calendar io.encodings.binary ;
IN: io.unix.files
M: unix-io cwd
MAXPATHLEN dup <byte-array> swap
getcwd [ (io-error) ] unless* ;
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
M: unix-io cd
chdir io-error ;
@ -68,7 +68,9 @@ M: unix-io delete-directory ( path -- )
] with-disposal ;
M: unix-io copy-file ( from to -- )
[ (copy-file) ] 2keep swap file-permissions chmod io-error ;
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
2bi ;
: stat>type ( stat -- type )
stat-st_mode {
@ -82,8 +84,8 @@ M: unix-io copy-file ( from to -- )
{ [ t ] [ +unknown+ ] }
} cond nip ;
M: unix-io file-info ( path -- info )
stat* {
: stat>file-info ( stat -- info )
{
[ stat>type ]
[ stat-st_size ]
[ stat-st_mode ]
@ -91,11 +93,8 @@ M: unix-io file-info ( path -- info )
} cleave
\ file-info construct-boa ;
M: unix-io file-info ( path -- info )
stat* stat>file-info ;
M: unix-io link-info ( path -- info )
lstat* {
[ stat>type ]
[ stat-st_size ]
[ stat-st_mode ]
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
} cleave
\ file-info construct-boa ;
lstat* stat>file-info ;

View File

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

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

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

View File

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

View File

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

View File

@ -76,7 +76,7 @@ M: win32-file close-handle ( handle -- )
] when drop ;
: open-append ( path -- handle length )
dup file-length dup [
dup file-info file-info-size dup [
>r (open-append) r> 2dup set-file-pointer
] [
drop open-write

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

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

View File

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

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

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

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

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

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

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

View File

@ -88,7 +88,7 @@ M: string b, ( n string -- ) heap-size b, ;
read [ zero? ] right-trim dup empty? [ drop f ] when ;
: (read-128-ber) ( n -- n )
1 read first
read1
[ >r 7 shift r> 7 clear-bit bitor ] keep
7 bit? [ (read-128-ber) ] when ;

View File

@ -1,9 +1,19 @@
! Copyright (C) 2007 Chris Double.
! Copyright (C) 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax peg peg.parsers.private
unicode.categories ;
IN: peg.parsers
HELP: 1token
{ $values
{ "ch" "a character" }
{ "parser" "a parser" }
} { $description
"Calls 1string on a character and returns a parser that matches that character."
} { $examples
{ $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse parse-result-ast ." "\"a\"" }
} { $see-also 'string' } ;
HELP: (list-of)
{ $values
{ "items" "a sequence" }

View File

@ -21,6 +21,8 @@ M: just-parser compile ( parser -- quot )
MEMO: just ( parser -- parser )
just-parser construct-boa init-parser ;
MEMO: 1token ( ch -- parser ) 1string token ;
<PRIVATE
MEMO: (list-of) ( items separator repeat1? -- parser )
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq

View File

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

View File

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

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

View File

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

View File

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

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

View File

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

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.
! See http://factorcode.org/license.txt for BSD license.
USING: threads io.files io.monitors init kernel
tools.browser namespaces continuations vocabs.loader ;
IN: vocabs.monitor
vocabs.loader tools.vocabs namespaces continuations ;
IN: tools.vocabs.monitor
! Use file system change monitoring to flush the tags/authors
! cache
@ -21,4 +21,4 @@ SYMBOL: vocab-monitor
[ monitor-thread t ] "Vocabulary monitor" spawn-server drop
] ignore-errors ;
[ start-monitor-thread ] "vocabs.monitor" add-init-hook
[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook

View File

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

Some files were not shown because too many files have changed in this diff Show More