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

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

db4
Eric Mertens 2008-04-13 03:34:31 -07:00
parent f881ec0109 4fe4605e9e
commit e6546e62e1
42 changed files with 522 additions and 381 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
core/command-line/command-line-docs.factor
View File

@ -7,9 +7,10 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" }
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}

2
core/compiler/compiler.factor
View File

@ -20,7 +20,7 @@ IN: compiler
: finish-compile ( word effect dependencies -- )
>r dupd save-effect r>
over compiled-unxref
over crossref? [ compiled-xref ] [ 2drop ] if ;
over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[

4
core/compiler/units/units.factor
View File

@ -66,7 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- )
: compile ( words -- )
recompile-hook get call
dup [ drop crossref? ] assoc-contains?
dup [ drop compiled-crossref? ] assoc-contains?
modify-code-heap ;
SYMBOL: outdated-tuples
@ -82,7 +82,7 @@ SYMBOL: update-tuples-hook
: finish-compilation-unit ( -- )
call-recompile-hook
call-update-tuples-hook
dup [ drop crossref? ] assoc-contains? modify-code-heap
dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
updated-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )

18
core/generic/standard/engines/tuple/tuple.factor
View File

@ -63,14 +63,14 @@ M: trivial-tuple-dispatch-engine engine>quot
] "" make ;
PREDICATE: tuple-dispatch-engine-word < word
"tuple-dispatch-engine" word-prop ;
"tuple-dispatch-generic" word-prop generic? ;
M: tuple-dispatch-engine-word stack-effect
"tuple-dispatch-generic" word-prop
[ extra-values ] [ stack-effect clone ] bi
[ length + ] change-in ;
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: tuple-dispatch-engine-word crossref?
M: tuple-dispatch-engine-word compiled-crossref?
drop t ;
: remember-engine ( word -- )
@ -78,12 +78,10 @@ M: tuple-dispatch-engine-word crossref?
: <tuple-dispatch-engine-word> ( engine -- word )
tuple-dispatch-engine-word-name f <word>
{
[ t "tuple-dispatch-engine" set-word-prop ]
[ generic get "tuple-dispatch-generic" set-word-prop ]
[ remember-engine ]
[ ]
} cleave ;
[ generic get "tuple-dispatch-generic" set-word-prop ]
[ remember-engine ]
[ ]
tri ;
: define-tuple-dispatch-engine-word ( engine quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ;

13
core/generic/standard/standard-tests.factor
View File

@ -2,7 +2,8 @@ IN: generic.standard.tests
USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable ;
quotations inference vectors growable hashtables sbufs
prettyprint ;
GENERIC: lo-tag-test
@ -268,3 +269,13 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
[ "vector growable sequence" ] [
V{ } my-var [ call-next-hooker ] with-variable
] unit-test
GENERIC: no-stack-effect-decl
M: hashtable no-stack-effect-decl ;
M: vector no-stack-effect-decl ;
M: sbuf no-stack-effect-decl ;
[ ] [ \ no-stack-effect-decl see ] unit-test
[ ] [ \ no-stack-effect-decl word-def . ] unit-test

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

@ -39,11 +39,19 @@ ARTICLE: "symbolic-links" "Symbolic links"
"Not all operating systems support symbolic links."
{ $see-also link-info } ;
ARTICLE: "directories" "Directories"
"Current directory:"
ARTICLE: "current-directory" "Current working directory"
"File system I/O operations use the value of a variable to resolve relative pathnames:"
{ $subsection current-directory }
"This variable can be changed with a pair of words:"
{ $subsection set-current-directory }
{ $subsection with-directory }
"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
{ $subsection (normalize-path) }
"The second is to change the working directory of the current process:"
{ $subsection cd }
{ $subsection cwd } ;
ARTICLE: "directories" "Directories"
"Home directory:"
{ $subsection home }
"Directory listing:"
@ -51,7 +59,8 @@ ARTICLE: "directories" "Directories"
{ $subsection directory* }
"Creating directories:"
{ $subsection make-directory }
{ $subsection make-directories } ;
{ $subsection make-directories }
{ $subsection "current-directory" } ;
ARTICLE: "file-types" "File Types"
"Platform-independent types:"
@ -242,11 +251,21 @@ HELP: cd
{ cd cwd current-directory set-current-directory with-directory } related-words
HELP: current-directory
{ $description "A variable holding the current directory. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ;
{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable."
$nl
"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ;
HELP: set-current-directory
{ $values { "path" "a pathname string" } }
{ $description "Changes the " { $link current-directory } " variable."
$nl
"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound."
$nl
"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
@ -300,7 +319,7 @@ HELP: directory*
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
{ $description "Resolve a path relative to the Factor source code location." } ;
HELP: pathname
{ $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;

7
core/io/streams/duplex/duplex-docs.factor
View File

@ -4,8 +4,7 @@ IN: io.streams.duplex
ARTICLE: "io.streams.duplex" "Duplex streams"
"Duplex streams combine an input stream and an output stream into a bidirectional stream."
{ $subsection duplex-stream }
{ $subsection <duplex-stream> }
{ $subsection check-closed } ;
{ $subsection <duplex-stream> } ;
ABOUT: "io.streams.duplex"
@ -16,7 +15,5 @@ HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
HELP: check-closed
{ $values { "stream" "a duplex stream" } }
{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
HELP: stream-closed-twice
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;

56
core/io/streams/duplex/duplex.factor
View File

@ -1,75 +1,77 @@
! Copyright (C) 2005 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations io accessors ;
IN: io.streams.duplex
USING: kernel continuations io ;
! We ensure that the stream can only be closed once, to preserve
! integrity of duplex I/O ports.
TUPLE: duplex-stream in out closed? ;
TUPLE: duplex-stream in out closed ;
: <duplex-stream> ( in out -- stream )
f duplex-stream construct-boa ;
ERROR: stream-closed-twice ;
: check-closed ( stream -- )
duplex-stream-closed? [ stream-closed-twice ] when ;
<PRIVATE
: duplex-stream-in+ ( duplex -- stream )
dup check-closed duplex-stream-in ;
: check-closed ( stream -- stream )
dup closed>> [ stream-closed-twice ] when ; inline
: duplex-stream-out+ ( duplex -- stream )
dup check-closed duplex-stream-out ;
: in ( duplex -- stream ) check-closed in>> ;
: out ( duplex -- stream ) check-closed out>> ;
PRIVATE>
M: duplex-stream stream-flush
duplex-stream-out+ stream-flush ;
out stream-flush ;
M: duplex-stream stream-readln
duplex-stream-in+ stream-readln ;
in stream-readln ;
M: duplex-stream stream-read1
duplex-stream-in+ stream-read1 ;
in stream-read1 ;
M: duplex-stream stream-read-until
duplex-stream-in+ stream-read-until ;
in stream-read-until ;
M: duplex-stream stream-read-partial
duplex-stream-in+ stream-read-partial ;
in stream-read-partial ;
M: duplex-stream stream-read
duplex-stream-in+ stream-read ;
in stream-read ;
M: duplex-stream stream-write1
duplex-stream-out+ stream-write1 ;
out stream-write1 ;
M: duplex-stream stream-write
duplex-stream-out+ stream-write ;
out stream-write ;
M: duplex-stream stream-nl
duplex-stream-out+ stream-nl ;
out stream-nl ;
M: duplex-stream stream-format
duplex-stream-out+ stream-format ;
out stream-format ;
M: duplex-stream make-span-stream
duplex-stream-out+ make-span-stream ;
out make-span-stream ;
M: duplex-stream make-block-stream
duplex-stream-out+ make-block-stream ;
out make-block-stream ;
M: duplex-stream make-cell-stream
duplex-stream-out+ make-cell-stream ;
out make-cell-stream ;
M: duplex-stream stream-write-table
duplex-stream-out+ stream-write-table ;
out stream-write-table ;
M: duplex-stream dispose
#! The output stream is closed first, in case both streams
#! are attached to the same file descriptor, the output
#! buffer needs to be flushed before we close the fd.
dup duplex-stream-closed? [
t over set-duplex-stream-closed?
[ dup duplex-stream-out dispose ]
[ dup duplex-stream-in dispose ] [ ] cleanup
dup closed>> [
t >>closed
[ dup out>> dispose ]
[ dup in>> dispose ] [ ] cleanup
] unless drop ;

2
core/math/math.factor
View File

@ -62,6 +62,8 @@ M: object zero? drop f ;
: neg ( x -- -x ) 0 swap - ; foldable
: recip ( x -- y ) 1 swap / ; foldable
: ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; foldable

12
core/parser/parser-docs.factor
View File

@ -358,6 +358,18 @@ HELP: scan-word
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
$parsing-note ;
HELP: invalid-slot-name
{ $values { "name" string } }
{ $description "Throws an " { $link invalid-slot-name } " error." }
{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
{ $code
"TUPLE: my-mistaken-tuple slot-a slot-b"
""
": some-word ( a b c -- ) ... ;"
}
} ;
HELP: unexpected
{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
{ $description "Throws an " { $link unexpected } " error." }

30
core/parser/parser.factor
View File

@ -184,6 +184,9 @@ M: parse-error summary
M: parse-error compute-restarts
error>> compute-restarts ;
M: parse-error error-help
error>> error-help ;
SYMBOL: use
SYMBOL: in
@ -298,12 +301,35 @@ M: no-word-error summary
] "" make note.
] with each ;
ERROR: invalid-slot-name name ;
M: invalid-slot-name summary
drop
"Invalid slot name" ;
: (parse-tuple-slots) ( -- )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
#! TUPLE: blahblah foo bing
#!
#! : ...
scan {
{ [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop ] }
[ , (parse-tuple-slots) ]
} cond ;
: parse-tuple-slots ( -- seq )
[ (parse-tuple-slots) ] { } make ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] }
[ >r tuple ";" parse-tokens r> prefix ]
{ "<" [ scan-word parse-tuple-slots ] }
[ >r tuple parse-tuple-slots r> prefix ]
} case 3dup check-slot-shadowing ;
ERROR: staging-violation word ;

6
core/words/words.factor
View File

@ -71,6 +71,10 @@ M: word crossref?
word-vocabulary >boolean
] if ;
GENERIC: compiled-crossref? ( word -- ? )
M: word compiled-crossref? crossref? ;
GENERIC# (quot-uses) 1 ( obj assoc -- )
M: object (quot-uses) 2drop ;
@ -97,7 +101,7 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
[ drop crossref? ] assoc-subset
[ drop compiled-crossref? ] assoc-subset
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;

46
extra/builder/build/build.factor Normal file
View File

@ -0,0 +1,46 @@
USING: io.files io.launcher io.encodings.utf8 prettyprint
builder.util builder.common builder.child builder.release
builder.report builder.email builder.cleanup ;
IN: builder.build
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: create-build-dir ( -- )
datestamp >stamp
build-dir make-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: enter-build-dir ( -- ) build-dir set-current-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: clone-builds-factor ( -- )
{ "git" "clone" builds/factor } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: record-id ( -- )
"factor"
[ git-id "../git-id" utf8 [ . ] with-file-writer ]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: build ( -- )
reset-status
create-build-dir
enter-build-dir
clone-builds-factor
record-id
build-child
release
report
email-report
cleanup ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: build

250
extra/builder/builder.factor
View File

@ -1,259 +1,21 @@
USING: kernel namespaces sequences splitting system combinators continuations
parser io io.files io.launcher io.sockets prettyprint threads
bootstrap.image benchmark vars bake smtp builder.util accessors
debugger io.encodings.utf8
calendar
tools.test
USING: kernel debugger io.files threads calendar
builder.common
builder.benchmark
builder.release ;
builder.updates
builder.build ;
IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cd ( path -- ) set-current-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds/factor ( -- path ) builds "factor" append-path ;
: build-dir ( -- path ) builds stamp> append-path ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prepare-build-machine ( -- )
builds make-directory
builds
[
{ "git" "clone" "git://factorcode.org/git/factor.git" } try-process
]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: enter-build-dir ( -- )
datestamp >stamp
builds cd
stamp> make-directory
stamp> cd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
{ "git" "show" } utf8 <process-stream>
[ readln ] with-stream " " split second ;
: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gnu-make ( -- string )
os { freebsd openbsd netbsd } member?
[ "gmake" ]
[ "make" ]
if ;
: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-vm ( -- desc )
<process>
{ gnu-make } to-strings >>command
"../compile-log" >>stdout
+stdout+ >>stderr ;
: do-make-vm ( -- )
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: copy-image ( -- )
builds/factor my-boot-image-name append-path ".." copy-file-into
builds/factor my-boot-image-name append-path "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bootstrap-cmd ( -- cmd )
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
: bootstrap ( -- desc )
<process>
bootstrap-cmd >>command
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
60 minutes >>timeout ;
: do-bootstrap ( -- )
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
: builder-test-cmd ( -- cmd )
{ "./factor" "-run=builder.test" } to-strings ;
: builder-test ( -- desc )
<process>
builder-test-cmd >>command
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
240 minutes >>timeout ;
: do-builder-test ( -- )
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status
: (build) ( -- )
builds-check
build-status off
enter-build-dir
"report" utf8
[
"Build machine: " write host-name print
"CPU: " write cpu .
"OS: " write os .
"Build directory: " write current-directory get print
git-clone [ "git clone failed" print ] run-or-bail
"factor"
[
record-git-id
do-make-clean
do-make-vm
copy-image
do-bootstrap
do-builder-test
]
with-directory
"test-log" delete-file
"git id: " write "git-id" eval-file print nl
"Boot time: " write "boot-time" eval-file milli-seconds>time print
"Load time: " write "load-time" eval-file milli-seconds>time print
"Test time: " write "test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
"test-failures" cat
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks.
nl
show-benchmark-deltas
"benchmarks" ".." copy-file-into
release
]
with-file-writer
build-status on ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-from
SYMBOL: builder-recipients
: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
: send-builder-email ( -- )
<email>
builder-from get >>from
builder-recipients get >>to
subject >>subject
"./report" file>string >>body
send-email ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
! : build ( -- )
! [ (build) ] try
! builds cd stamp> cd
! [ send-builder-email ] try
! { "rm" "-rf" "factor" } [ ] run-or-bail
! [ compress-image ] try ;
: build ( -- )
[
(build)
build-dir
[
{ "rm" "-rf" "factor" } try-process
compress-image
]
with-directory
]
try
send-builder-email ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: bootstrap.image.download
: git-pull ( -- desc )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: updates-available? ( -- ? )
git-id
git-pull try-process
git-id
= not ;
: new-image-available? ( -- ? )
my-boot-image-name need-new-image?
[ download-my-image t ]
[ f ]
if ;
: build-loop ( -- )
builds-check
[
builds/factor
[
updates-available? new-image-available? or
[ build ]
when
]
with-directory
builds/factor set-current-directory
new-code-available? [ build ] when
]
try
5 minutes sleep
build-loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: build-loop
MAIN: build-loop

68
extra/builder/child/child.factor Normal file
View File

@ -0,0 +1,68 @@
USING: namespaces debugger io.files io.launcher accessors bootstrap.image
calendar builder.util builder.common ;
IN: builder.child
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-vm ( -- )
<process>
gnu-make >>command
"../compile-log" >>stdout
+stdout+ >>stderr
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
: copy-image ( -- )
builds-factor-image ".." copy-file-into
builds-factor-image "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: boot-cmd ( -- cmd )
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
: boot ( -- )
<process>
boot-cmd >>command
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
60 minutes >>timeout
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
: test ( -- )
<process>
test-cmd >>command
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
240 minutes >>timeout
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (build-child) ( -- )
make-clean
make-vm status-vm on
copy-image
boot status-boot on
test status-test on
status on ;
: build-child ( -- )
"factor" set-current-directory
[ (build-child) ] try
".." set-current-directory ;

24
extra/builder/cleanup/cleanup.factor Normal file
View File

@ -0,0 +1,24 @@
USING: kernel namespaces io.files io.launcher bootstrap.image
builder.util builder.common ;
IN: builder.cleanup
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-debug
: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
: delete-child-factor ( -- )
build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
: cleanup ( -- )
builder-debug get f =
[
"test-log" delete-file
delete-child-factor
compress-image
]
when ;

49
extra/builder/common/common.factor
View File

@ -1,5 +1,7 @@
USING: kernel namespaces io.files sequences vars ;
USING: kernel namespaces sequences splitting
io io.files io.launcher io.encodings.utf8 prettyprint
vars builder.util ;
IN: builder.common
@ -16,4 +18,47 @@ SYMBOL: builds-dir
VAR: stamp
SYMBOL: upload-to-factorcode
: builds/factor ( -- path ) builds "factor" append-path ;
: build-dir ( -- path ) builds stamp> append-path ;
: create-build-dir ( -- )
datestamp >stamp
build-dir make-directory ;
: enter-build-dir ( -- ) build-dir set-current-directory ;
: clone-builds-factor ( -- )
{ "git" "clone" builds/factor } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prepare-build-machine ( -- )
builds make-directory
builds
[ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: status-vm
SYMBOL: status-boot
SYMBOL: status-test
SYMBOL: status-build
SYMBOL: status-release
SYMBOL: status
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: reset-status ( -- )
{ status-vm status-boot status-test status-build status-release status }
[ off ]
each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode

22
extra/builder/email/email.factor Normal file
View File

@ -0,0 +1,22 @@
USING: kernel namespaces accessors smtp builder.util builder.common ;
IN: builder.email
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-from
SYMBOL: builder-recipients
: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
: email-report ( -- )
<email>
builder-from get >>from
builder-recipients get >>to
subject >>subject
"report" file>string >>body
send-email ;

2
extra/builder/release/branch/branch.factor
View File

@ -36,5 +36,5 @@ IN: builder.release.branch
: update-clean-branch ( -- )
upload-to-factorcode get
[ update-clean-branch ]
[ (update-clean-branch) ]
when ;

7
extra/builder/release/release.factor
View File

@ -1,5 +1,5 @@
USING: kernel system namespaces sequences splitting combinators
USING: kernel debugger system namespaces sequences splitting combinators
io io.files io.launcher prettyprint bootstrap.image
bake combinators.cleave
builder.util
@ -18,9 +18,10 @@ IN: builder.release
tidy
make-archive
upload
save-archive ;
save-archive
status-release on ;
: clean-build? ( -- ? )
{ "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
: release ( -- ) clean-build? [ (release) ] when ;
: release ( -- ) [ clean-build? [ (release) ] when ] try ;

35
extra/builder/report/report.factor Normal file
View File

@ -0,0 +1,35 @@
USING: kernel namespaces debugger system io io.files io.sockets
io.encodings.utf8 prettyprint benchmark
builder.util builder.common ;
IN: builder.report
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (report) ( -- )
"Build machine: " write host-name print
"CPU: " write cpu .
"OS: " write os .
"Build directory: " write build-dir print
"git id: " write "git-id" eval-file print nl
status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
status-boot get f = [ "boot-log" cat "Boot error" throw ] when
status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
"Boot time: " write "boot-time" eval-file milli-seconds>time print
"Load time: " write "load-time" eval-file milli-seconds>time print
"Test time: " write "test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
"test-failures" cat
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks. ;
: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;

12
extra/builder/test/test.factor
View File

@ -1,16 +1,4 @@
! USING: kernel namespaces sequences assocs continuations
! vocabs vocabs.loader
! io
! io.files
! prettyprint
! tools.vocabs
! tools.test
! io.encodings.utf8
! combinators.cleave
! help.lint
! bootstrap.stage2 benchmark builder.util ;
USING: kernel namespaces assocs
io.files io.encodings.utf8 prettyprint
help.lint

31
extra/builder/updates/updates.factor Normal file
View File

@ -0,0 +1,31 @@
USING: kernel io.launcher bootstrap.image bootstrap.image.download
builder.util builder.common ;
IN: builder.updates
: git-pull-cmd ( -- cmd )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: updates-available? ( -- ? )
git-id
git-pull-cmd try-process
git-id
= not ;
: new-image-available? ( -- ? )
my-boot-image-name need-new-image?
[ download-my-image t ]
[ f ]
if ;
: new-code-available? ( -- ? )
updates-available?
new-image-available?
or ;

23
extra/builder/util/util.factor
View File

@ -25,11 +25,11 @@ DEFER: to-strings
: to-string ( obj -- str )
dup class
{
{ string [ ] }
{ quotation [ call ] }
{ word [ execute ] }
{ fixnum [ number>string ] }
{ array [ to-strings concat ] }
{ \ string [ ] }
{ \ quotation [ call ] }
{ \ word [ execute ] }
{ \ fixnum [ number>string ] }
{ \ array [ to-strings concat ] }
}
case ;
@ -97,4 +97,15 @@ USE: prettyprint
: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gnu-make ( -- string )
os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
{ "git" "show" } utf8 <process-stream> [ readln ] with-stream
" " split second ;

19
extra/circular/circular.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http;//factorcode.org/license.txt for BSD license
USING: kernel sequences math sequences.private strings ;
USING: kernel sequences math sequences.private strings
accessors ;
IN: circular
! a circular sequence wraps another sequence, but begins at an
@ -11,27 +12,27 @@ TUPLE: circular seq start ;
0 circular construct-boa ;
: circular-wrap ( n circular -- n circular )
[ circular-start + ] keep
[ circular-seq length rem ] keep ; inline
[ start>> + ] keep
[ seq>> length rem ] keep ; inline
M: circular length circular-seq length ;
M: circular length seq>> length ;
M: circular virtual@ circular-wrap circular-seq ;
M: circular virtual@ circular-wrap seq>> ;
M: circular nth virtual@ nth ;
M: circular set-nth virtual@ set-nth ;
M: circular virtual-seq seq>> ;
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
circular-wrap set-circular-start ;
circular-wrap (>>start) ;
: push-circular ( elt circular -- )
[ set-first ] keep 1 swap change-circular-start ;
[ set-first ] [ 1 swap change-circular-start ] bi ;
: <circular-string> ( n -- circular )
0 <string> <circular> ;
M: circular virtual-seq circular-seq ;
INSTANCE: circular virtual-sequence

1
extra/core-foundation/fsevents/fsevents.factor
View File

@ -153,7 +153,6 @@ SYMBOL: event-stream-callbacks
[
event-stream-callbacks global
[ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
1 \ event-stream-counter set-global
] "core-foundation" add-init-hook
: add-event-source-callback ( quot -- id )

3
extra/documents/documents.factor
View File

@ -184,8 +184,7 @@ M: one-char-elt next-elt 2drop ;
[ >r blank? r> xor ] curry ; inline
: (prev-word) ( ? col str -- col )
rot break-detector find-last*
drop [ 1+ ] [ 0 ] if* ;
rot break-detector find-last* drop ?1+ ;
: (next-word) ( ? col str -- col )
[ rot break-detector find* drop ] keep

4
extra/inverse/inverse.factor
View File

@ -195,6 +195,10 @@ DEFER: _
\ first3 [ 3array ] define-inverse
\ first4 [ 4array ] define-inverse
\ prefix [ unclip ] define-inverse
\ unclip [ prefix ] define-inverse
\ suffix [ dup 1 head* swap peek ] define-inverse
! Constructor inverse
: deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ;

4
extra/io/monitors/monitors-tests.factor
View File

@ -75,13 +75,13 @@ os { winnt linux macosx } member? [
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
[ ] [ "c1" get 15 seconds await-timeout ] unit-test
[ ] [ "c1" get 1 minutes await-timeout ] unit-test
[ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
[ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
[ ] [ "c2" get 15 seconds await-timeout ] unit-test
[ ] [ "c2" get 1 minutes await-timeout ] unit-test
! Dispose twice
[ ] [ "m" get dispose ] unit-test

9
extra/io/nonblocking/nonblocking.factor
View File

@ -3,7 +3,7 @@
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.streams.duplex io.encodings
io.backend continuations debugger classes byte-arrays namespaces
splitting dlists assocs io.encodings.binary accessors ;
splitting dlists assocs io.encodings.binary inspector accessors ;
IN: io.nonblocking
SYMBOL: default-buffer-size
@ -43,8 +43,13 @@ TUPLE: output-port < port ;
: pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ;
ERROR: port-closed-error port ;
M: port-closed-error summary
drop "Port has been closed" ;
: check-closed ( port -- port )
dup closed>> [ "Port closed" throw ] when ;
dup closed>> [ port-closed-error ] when ;
HOOK: cancel-io io-backend ( port -- )

4
extra/io/windows/nt/monitors/monitors-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: io.windows.nt.monitors.tests
USING: io.windows.nt.monitors tools.test ;
\ fill-queue-thread must-infer

58
extra/io/windows/nt/monitors/monitors.factor
View File

@ -3,12 +3,14 @@
USING: alien alien.c-types libc destructors locals
kernel math assocs namespaces continuations sequences hashtables
sorting arrays combinators math.bitfields strings system
io.windows io.windows.nt.backend io.monitors io.nonblocking
io.buffers io.files io.timeouts io accessors threads
accessors threads
io.backend io.windows io.windows.nt.backend io.monitors
io.nonblocking io.buffers io.files io.timeouts io
windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
normalize-path
FILE_LIST_DIRECTORY
share-mode
f
@ -28,8 +30,8 @@ TUPLE: win32-monitor < monitor port ;
: begin-reading-changes ( port -- overlapped )
{
[ handle>> handle>> ]
[ buffer>> buffer-ptr ]
[ buffer>> buffer-size ]
[ buffer>> ptr>> ]
[ buffer>> size>> ]
[ recursive>> 1 0 ? ]
} cleave
FILE_NOTIFY_CHANGE_ALL
@ -39,12 +41,11 @@ TUPLE: win32-monitor < monitor port ;
: read-changes ( port -- bytes )
[
[
dup begin-reading-changes
swap [ save-callback ] 2keep
check-closed ! we may have closed it...
get-overlapped-result
] with-timeout
dup begin-reading-changes
swap [ save-callback ] 2keep
check-closed ! we may have closed it...
dup eof>> [ "EOF??" throw ] when
get-overlapped-result
] with-destructors ;
: parse-action ( action -- changed )
@ -55,32 +56,45 @@ TUPLE: win32-monitor < monitor port ;
{ FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] }
{ FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] }
[ drop +modify-file+ ]
} case ;
} case 1array ;
: memory>u16-string ( alien len -- string )
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
: parse-notify-record ( buffer -- changed path )
[ FILE_NOTIFY_INFORMATION-Action parse-action ]
[ FILE_NOTIFY_INFORMATION-FileName ]
[ FILE_NOTIFY_INFORMATION-FileNameLength ] tri
memory>u16-string ;
: parse-notify-record ( buffer -- path changed )
[
[ FILE_NOTIFY_INFORMATION-FileName ]
[ FILE_NOTIFY_INFORMATION-FileNameLength ]
bi memory>u16-string
]
[ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
: (file-notify-records) ( buffer -- buffer )
dup ,
dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
[ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
(file-notify-records)
] unless ;
: file-notify-records ( buffer -- seq )
[ dup FILE_NOTIFY_INFORMATION-NextEntryOffset 0 > ]
[ [ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien> ] keep ]
[ ] unfold nip ;
[ (file-notify-records) drop ] { } make ;
: parse-notify-records ( monitor buffer -- )
file-notify-records
[ parse-notify-record rot queue-change ] with each ;
: fill-queue ( monitor -- )
dup port>> [ buffer>> buffer-ptr ] [ read-changes zero? ] bi
[ 2dup parse-notify-records ] unless 2drop ;
dup port>> check-closed
[ buffer>> ptr>> ] [ read-changes zero? ] bi
[ 2dup parse-notify-records ] unless
2drop ;
: (fill-queue-thread) ( monitor -- )
dup fill-queue (fill-queue-thread) ;
: fill-queue-thread ( monitor -- )
dup fill-queue fill-queue ;
[ dup fill-queue (fill-queue-thread) ]
[ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ;
M:: winnt (monitor) ( path recursive? mailbox -- monitor )
[

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

@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port
2dup save-callback
get-overlapped-result drop ;
M: winnt (client) ( addrspec -- client-in client-out )
M: winnt ((client)) ( addrspec -- client-in client-out )
[
\ ConnectEx-args construct-empty
over make-sockaddr/size pick init-connect

2
extra/macros/summary.txt
View File

@ -1 +1 @@
Utility for defining compiler transforms, and short-circuiting boolean operators
Utility for defining compiler transforms

4
extra/sequences/lib/lib.factor
View File

@ -227,8 +227,8 @@ PRIVATE>
: ?nth* ( n seq -- elt/f ? )
2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
: nths ( indices seq -- seq' )
[ swap nth ] with map ;
: nths ( seq indices -- seq' )
swap [ nth ] curry map ;
: replace ( str oldseq newseq -- str' )
zip >hashtable substitute ;

2
extra/ui/gadgets/gadgets.factor
View File

@ -111,7 +111,7 @@ M: gadget children-on nip gadget-children ;
: fast-children-on ( rect axis children -- from to )
3dup
>r >r dup rect-loc swap rect-dim v+
r> r> (fast-children-on) [ 1+ ] [ 0 ] if*
r> r> (fast-children-on) ?1+
>r
>r >r rect-loc
r> r> (fast-children-on) 0 or

12
extra/ui/gestures/gestures.factor
View File

@ -281,4 +281,16 @@ M: button-down gesture>string
button-down-# [ " " % # ] when*
] "" make ;
M: left-action gesture>string drop "Swipe left" ;
M: right-action gesture>string drop "Swipe right" ;
M: up-action gesture>string drop "Swipe up" ;
M: down-action gesture>string drop "Swipe down" ;
M: zoom-in-action gesture>string drop "Zoom in" ;
M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
M: object gesture>string drop f ;

8
extra/ui/tools/tools-docs.factor
View File

@ -2,8 +2,9 @@ USING: editors help.markup help.syntax inspector io listener
parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.slots ui.operations ui.tools.browser
ui.tools.interactor ui.tools.listener ui.tools.operations
ui.tools.profiler ui.tools.walker ui.tools.workspace vocabs ;
ui.tools.interactor ui.tools.inspector ui.tools.listener
ui.tools.operations ui.tools.profiler ui.tools.walker
ui.tools.workspace vocabs ;
IN: ui.tools
ARTICLE: "ui-presentations" "Presentations in the UI"
@ -46,12 +47,14 @@ $nl
$nl
"The slot editor has a toolbar containing various commands."
{ $command-map slot-editor "toolbar" }
{ $command-map inspector-gadget "multi-touch" }
"The following commands are also available."
{ $command-map source-editor "word" } ;
ARTICLE: "ui-browser" "UI browser"
"The browser is used to display Factor code, documentation, and vocabularies."
{ $command-map browser-gadget "toolbar" }
{ $command-map browser-gadget "multi-touch" }
"Browsers are instances of " { $link browser-gadget } "." ;
ARTICLE: "ui-profiler" "UI profiler"
@ -110,6 +113,7 @@ ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
{ $command-map workspace "tool-switching" }
{ $command-map workspace "scrolling" }
{ $command-map workspace "workflow" }
{ $command-map workspace "multi-touch" }
{ $heading "Implementation" }
"Workspaces are instances of " { $link workspace } "." ;

5
extra/unicode/breaks/breaks.factor
View File

@ -21,7 +21,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
} case ;
: trim-blank ( str -- newstr )
dup [ blank? not ] find-last 1+* head ;
[ blank? ] right-trim ;
: process-other-extend ( lines -- set )
[ "#" split1 drop ";" split1 drop trim-blank ] map
@ -110,8 +110,7 @@ VALUE: grapheme-table
: last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap
[ grapheme-class dup rot grapheme-break? ] find-last-index
nip -1 or 1+ ;
[ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
[
other-extend-lines process-other-extend \ other-extend set-value

3
extra/unicode/data/data.factor
View File

@ -12,9 +12,6 @@ IN: unicode.data
>>
! Convenience functions
: 1+* ( n/f _ -- n+1 )
drop [ 1+ ] [ 0 ] if* ;
: ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ;

2
extra/unicode/normalize/normalize.factor
View File

@ -67,7 +67,7 @@ IN: unicode.normalize
0 reorder-loop ;
: reorder-back ( string i -- )
over [ non-starter? not ] find-last* 1+* reorder-next 2drop ;
over [ non-starter? not ] find-last* drop ?1+ reorder-next 2drop ;
: decompose ( string quot -- decomposed )
! When there are 8 and 32-bit strings, this'll be

4
extra/xml/writer/writer.factor
View File

@ -29,9 +29,7 @@ SYMBOL: indenter
xml-pprint? get [ -1 indentation +@ ] when ;
: trim-whitespace ( string -- no-whitespace )
[ [ blank? not ] find drop 0 or ] keep
[ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep
subseq ;
[ blank? ] trim ;
: ?filter-children ( children -- no-whitespace )
xml-pprint? get [