diff --git a/Makefile b/Makefile
old mode 100755
new mode 100644
index 769aeacb8c..aa520063e3
--- a/Makefile
+++ b/Makefile
@@ -149,14 +149,11 @@ macosx.app: factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
- install_name_tool \
- -id @executable_path/../Frameworks/libfreetype.6.dylib \
- Factor.app/Contents/Frameworks/libfreetype.6.dylib
install_name_tool \
-change libfactor.dylib \
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
-
+
factor: $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor
old mode 100755
new mode 100644
diff --git a/basis/alias/alias.factor b/basis/alias/alias.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
old mode 100755
new mode 100644
diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ascii/ascii.factor b/basis/ascii/ascii.factor
old mode 100755
new mode 100644
diff --git a/basis/bit-arrays/bit-arrays-tests.factor b/basis/bit-arrays/bit-arrays-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor
old mode 100755
new mode 100644
diff --git a/basis/bit-vectors/bit-vectors-docs.factor b/basis/bit-vectors/bit-vectors-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/handbook/handbook.factor b/basis/bootstrap/handbook/handbook.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/image/upload/upload.factor b/basis/bootstrap/image/upload/upload.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/io/io.factor b/basis/bootstrap/io/io.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/random/random.factor b/basis/bootstrap/random/random.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/ui/tools/tools.factor b/basis/bootstrap/ui/tools/tools.factor
old mode 100755
new mode 100644
diff --git a/basis/bootstrap/unicode/unicode.factor b/basis/bootstrap/unicode/unicode.factor
old mode 100755
new mode 100644
diff --git a/basis/boxes/boxes-docs.factor b/basis/boxes/boxes-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/boxes/boxes-tests.factor b/basis/boxes/boxes-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor
old mode 100755
new mode 100644
diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
index c3d84fc783..64c74a494a 100644
--- a/basis/calendar/calendar-docs.factor
+++ b/basis/calendar/calendar-docs.factor
@@ -165,7 +165,15 @@ HELP: milliseconds
{ $values { "x" number } { "duration" duration } }
{ $description "Creates a duration object with the specified number of milliseconds." } ;
-{ years months days hours minutes seconds milliseconds } related-words
+HELP: microseconds
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of microseconds." } ;
+
+HELP: nanoseconds
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of nanoseconds." } ;
+
+{ years months days hours minutes seconds milliseconds microseconds nanoseconds } related-words
HELP: leap-year?
{ $values { "obj" object } { "?" "a boolean" } }
@@ -263,7 +271,27 @@ HELP: duration>milliseconds
}
} ;
-{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds } related-words
+HELP: duration>microseconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in microseconds." }
+{ $examples
+ { $example "USING: calendar prettyprint ;"
+ "6 seconds duration>microseconds ."
+ "6000000"
+ }
+} ;
+
+HELP: duration>nanoseconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in nanoseconds." }
+{ $examples
+ { $example "USING: calendar prettyprint ;"
+ "6 seconds duration>nanoseconds ."
+ "6000000000"
+ }
+} ;
+
+{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds duration>microseconds duration>nanoseconds } related-words
HELP: time-
@@ -484,6 +512,12 @@ HELP: time-since-midnight
{ $values { "timestamp" timestamp } { "duration" duration } }
{ $description "Calculates a " { $snippet "duration" } " that represents the elapsed time since midnight of the input " { $snippet "timestamp" } "." } ;
+HELP: since-1970
+{ $values
+ { "duration" duration }
+ { "timestamp" timestamp } }
+{ $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ;
+
ARTICLE: "calendar" "Calendar"
"The two data types used throughout the calendar library:"
{ $subsection timestamp }
@@ -528,6 +562,8 @@ ARTICLE: "using-durations" "Using durations"
{ $subsection minutes }
{ $subsection seconds }
{ $subsection milliseconds }
+{ $subsection microseconds }
+{ $subsection nanoseconds }
{ $subsection instant }
"Converting a duration to a number:"
{ $subsection duration>years }
@@ -536,7 +572,9 @@ ARTICLE: "using-durations" "Using durations"
{ $subsection duration>hours }
{ $subsection duration>minutes }
{ $subsection duration>seconds }
-{ $subsection duration>milliseconds } ;
+{ $subsection duration>milliseconds }
+{ $subsection duration>microseconds }
+{ $subsection duration>nanoseconds } ;
ARTICLE: "relative-timestamps" "Relative timestamps"
"In the future:"
diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
old mode 100755
new mode 100644
index c2c386a790..c002760748
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -2,8 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary
-combinators.short-circuit ;
+locals classes.tuple math.order summary combinators.short-circuit ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
@@ -129,6 +128,8 @@ PRIVATE>
: minutes ( x -- duration ) instant clone swap >>minute ;
: seconds ( x -- duration ) instant clone swap >>second ;
: milliseconds ( x -- duration ) 1000 / seconds ;
+: microseconds ( x -- duration ) 1000000 / seconds ;
+: nanoseconds ( x -- duration ) 1000000000 / seconds ;
GENERIC: leap-year? ( obj -- ? )
@@ -261,6 +262,8 @@ M: duration <=> [ duration>years ] compare ;
: duration>minutes ( duration -- x ) duration>years minutes-per-year * ;
: duration>seconds ( duration -- x ) duration>years seconds-per-year * ;
: duration>milliseconds ( duration -- x ) duration>seconds 1000 * ;
+: duration>microseconds ( duration -- x ) duration>seconds 1000000 * ;
+: duration>nanoseconds ( duration -- x ) duration>seconds 1000000000 * ;
GENERIC: time- ( time1 time2 -- time3 )
@@ -398,6 +401,9 @@ PRIVATE>
: time-since-midnight ( timestamp -- duration )
dup midnight time- ;
+: since-1970 ( duration -- timestamp )
+ unix-1970 time+ >local-time ;
+
M: timestamp sleep-until timestamp>millis sleep-until ;
M: duration sleep hence sleep-until ;
diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor
old mode 100755
new mode 100644
diff --git a/basis/calendar/model/model.factor b/basis/calendar/model/model.factor
old mode 100755
new mode 100644
diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor
index 1da554e0f1..d5b66ffc1a 100644
--- a/basis/calendar/unix/unix.factor
+++ b/basis/calendar/unix/unix.factor
@@ -1,7 +1,17 @@
-USING: alien alien.c-types arrays calendar kernel structs
-math unix.time namespaces system ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax arrays calendar
+kernel math unix unix.time namespaces system ;
IN: calendar.unix
+: timeval>unix-time ( timeval -- timestamp )
+ [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
+ time+ since-1970 ;
+
+: timespec>unix-time ( timeval -- timestamp )
+ [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
+ time+ since-1970 ;
+
: get-time ( -- alien )
f time <uint> localtime ;
diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor
old mode 100755
new mode 100644
diff --git a/basis/channels/channels-tests.factor b/basis/channels/channels-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor
old mode 100755
new mode 100644
diff --git a/basis/channels/examples/examples.factor b/basis/channels/examples/examples.factor
old mode 100755
new mode 100644
diff --git a/basis/channels/remote/remote.factor b/basis/channels/remote/remote.factor
old mode 100755
new mode 100644
diff --git a/basis/checksums/adler-32/adler-32-docs.factor b/basis/checksums/adler-32/adler-32-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/checksums/md5/md5-docs.factor b/basis/checksums/md5/md5-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
old mode 100755
new mode 100644
diff --git a/basis/checksums/sha1/sha1-tests.factor b/basis/checksums/sha1/sha1-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor
old mode 100755
new mode 100644
diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
old mode 100755
new mode 100644
diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor
old mode 100755
new mode 100644
diff --git a/basis/cocoa/application/application-docs.factor b/basis/cocoa/application/application-docs.factor
index 55fa5e10b8..791613e876 100644
--- a/basis/cocoa/application/application-docs.factor
+++ b/basis/cocoa/application/application-docs.factor
@@ -26,6 +26,10 @@ HELP: with-cocoa
{ $values { "quot" quotation } }
{ $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
+HELP: cocoa-app
+{ $values { "quot" quotation } }
+{ $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
+
HELP: do-event
{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
@@ -46,13 +50,16 @@ HELP: objc-error
{ $error-description "Thrown by the Objective C runtime when an error occurs, for example, sending a message to an object with an unrecognized selector." } ;
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
+"Utilities:"
{ $subsection NSApp }
-{ $subsection with-autorelease-pool }
-{ $subsection with-cocoa }
{ $subsection do-event }
{ $subsection add-observer }
{ $subsection remove-observer }
-{ $subsection install-delegate } ;
+{ $subsection install-delegate }
+"Combinators:"
+{ $subsection cocoa-app }
+{ $subsection with-autorelease-pool }
+{ $subsection with-cocoa } ;
IN: cocoa.application
ABOUT: "cocoa-application-utils"
diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
old mode 100755
new mode 100644
index a28952ea33..8f32782d76
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -30,7 +30,7 @@ IN: cocoa.application
FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- )
- [ NSApp drop call ] with-autorelease-pool ;
+ [ NSApp drop call ] with-autorelease-pool ; inline
: next-event ( app -- event )
0 f CFRunLoopDefaultMode 1
@@ -50,6 +50,13 @@ FUNCTION: void NSBeep ( ) ;
: finish-launching ( -- ) NSApp -> finishLaunching ;
+: cocoa-app ( quot -- )
+ [
+ call
+ finish-launching
+ NSApp -> run
+ ] with-cocoa ; inline
+
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
diff --git a/basis/cocoa/cocoa-docs.factor b/basis/cocoa/cocoa-docs.factor
index a971288251..dd8d331b35 100644
--- a/basis/cocoa/cocoa-docs.factor
+++ b/basis/cocoa/cocoa-docs.factor
@@ -16,9 +16,16 @@ HELP: SUPER->
{ send super-send POSTPONE: -> POSTPONE: SUPER-> } related-words
+HELP: IMPORT:
+{ $syntax "IMPORT: name" }
+{ $description "Makes an Objective C class available for use." }
+{ $examples
+ { $code "IMPORT: QTMovie" "QTMovie \"My Movie.mov\" <NSString> f -> movieWithFile:error:" }
+} ;
+
ARTICLE: "objc-calling" "Calling Objective C code"
"Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
-{ $subsection import-objc-class }
+{ $subsection POSTPONE: IMPORT: }
"Every imported Objective C class has as corresponding class word in the " { $vocab-link "cocoa.classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
$nl
"Messages can be sent to classes and instances using a pair of parsing words:"
diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor
old mode 100755
new mode 100644
index 744d577c0d..ab86796236
--- a/basis/cocoa/cocoa.factor
+++ b/basis/cocoa/cocoa.factor
@@ -3,7 +3,7 @@
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
core-foundation namespaces assocs hashtables compiler.units
-lexer ;
+lexer init ;
IN: cocoa
: (remember-send) ( selector variable -- )
@@ -27,6 +27,16 @@ SYMBOL: super-sent-messages
scan dup remember-super-send parsed \ super-send parsed ;
parsing
+SYMBOL: frameworks
+
+frameworks global [ V{ } clone or ] change-at
+
+[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
+
+: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; parsing
+
+: IMPORT: scan [ ] import-objc-class ; parsing
+
"Compiling Objective C bridge..." print
"cocoa.classes" create-vocab drop
diff --git a/basis/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor
index f78981c923..9b5e3fdfd9 100644
--- a/basis/cocoa/messages/messages-docs.factor
+++ b/basis/cocoa/messages/messages-docs.factor
@@ -32,11 +32,7 @@ HELP: alien>objc-types
HELP: import-objc-class
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } }
-{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." }
-{ $notes "In most cases, the quotation should be " { $link f } "." }
-{ $examples
- { $code "\"QTMovie\" f import-objc-class" "QTMovie \"My Movie.mov\" <NSString> f -> movieWithFile:error:" }
-} ;
+{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ;
HELP: root-class
{ $values { "class" alien } { "root" alien } }
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
old mode 100755
new mode 100644
index 7977485b02..09601ef8cc
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -4,7 +4,8 @@ USING: accessors alien alien.c-types alien.strings arrays assocs
combinators compiler kernel math namespaces make parser
prettyprint prettyprint.sections quotations sequences strings
words cocoa.runtime io macros memoize debugger
-io.encodings.ascii effects compiler.generator libc libc.private ;
+io.encodings.ascii effects compiler.generator libc libc.private
+parser lexer init core-foundation ;
IN: cocoa.messages
: make-sender ( method function -- quot )
diff --git a/basis/cocoa/pasteboard/pasteboard.factor b/basis/cocoa/pasteboard/pasteboard.factor
old mode 100755
new mode 100644
diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor
old mode 100755
new mode 100644
diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor
old mode 100755
new mode 100644
diff --git a/basis/colors/colors.factor b/basis/colors/colors.factor
index 77a1f46c87..1183c2e46c 100644
--- a/basis/colors/colors.factor
+++ b/basis/colors/colors.factor
@@ -1,48 +1,33 @@
-! Copyright (C) 2003, 2007, 2008 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators sequences arrays classes.tuple accessors colors.hsv ;
-
+USING: kernel accessors ;
IN: colors
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
TUPLE: color ;
TUPLE: rgba < color red green blue alpha ;
-TUPLE: hsva < color hue saturation value alpha ;
-
-TUPLE: gray < color gray alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+C: <rgba> rgba
GENERIC: >rgba ( object -- rgba )
M: rgba >rgba ( rgba -- rgba ) ;
-M: hsva >rgba ( hsva -- rgba )
- { [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array
- [ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ;
-
-M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
-
M: color red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ;
M: color blue>> ( color -- blue ) >rgba blue>> ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: black T{ rgba f 0.0 0.0 0.0 1.0 } ;
-: blue T{ rgba f 0.0 0.0 1.0 1.0 } ;
-: cyan T{ rgba f 0 0.941 0.941 1 } ;
-: gray T{ rgba f 0.6 0.6 0.6 1.0 } ;
-: green T{ rgba f 0.0 1.0 0.0 1.0 } ;
-: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ;
-: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ;
-: magenta T{ rgba f 0.941 0 0.941 1 } ;
-: orange T{ rgba f 0.941 0.627 0 1 } ;
-: purple T{ rgba f 0.627 0 0.941 1 } ;
-: red T{ rgba f 1.0 0.0 0.0 1.0 } ;
-: white T{ rgba f 1.0 1.0 1.0 1.0 } ;
-: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ;
+: black T{ rgba f 0.0 0.0 0.0 1.0 } ; inline
+: blue T{ rgba f 0.0 0.0 1.0 1.0 } ; inline
+: cyan T{ rgba f 0 0.941 0.941 1 } ; inline
+: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; inline
+: green T{ rgba f 0.0 1.0 0.0 1.0 } ; inline
+: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; inline
+: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; inline
+: magenta T{ rgba f 0.941 0 0.941 1 } ; inline
+: orange T{ rgba f 0.941 0.627 0 1 } ; inline
+: purple T{ rgba f 0.627 0 0.941 1 } ; inline
+: red T{ rgba f 1.0 0.0 0.0 1.0 } ; inline
+: white T{ rgba f 1.0 1.0 1.0 1.0 } ; inline
+: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; inline
diff --git a/basis/colors/gray/gray.factor b/basis/colors/gray/gray.factor
new file mode 100644
index 0000000000..26ec1177b6
--- /dev/null
+++ b/basis/colors/gray/gray.factor
@@ -0,0 +1,11 @@
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: colors kernel accessors ;
+IN: colors.gray
+
+TUPLE: gray < color gray alpha ;
+
+C: <gray> gray
+
+M: gray >rgba ( gray -- rgba )
+ [ gray>> dup dup ] [ alpha>> ] bi <rgba> ;
diff --git a/basis/colors/hsv/hsv-tests.factor b/basis/colors/hsv/hsv-tests.factor
new file mode 100644
index 0000000000..8a736553bb
--- /dev/null
+++ b/basis/colors/hsv/hsv-tests.factor
@@ -0,0 +1,26 @@
+IN: colors.hsv.tests
+USING: accessors kernel colors colors.hsv tools.test math ;
+
+: hsv>rgb ( h s v -- r g b )
+ [ 360 * ] 2dip
+ 1 <hsva> >rgba [ red>> ] [ green>> ] [ blue>> ] tri ;
+
+[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
+
+[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
+[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
+
+[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
+[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
+
+[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
+[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
+
+[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
+[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
+
+[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
+[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
+
+[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
+[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
diff --git a/basis/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor
index dd2811822b..6f658818a1 100644
--- a/basis/colors/hsv/hsv.factor
+++ b/basis/colors/hsv/hsv.factor
@@ -1,41 +1,38 @@
-! Copyright (C) 2007 Eduardo Cavazos
+! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators arrays sequences math math.functions ;
-
+USING: colors kernel combinators math math.functions accessors ;
IN: colors.hsv
-<PRIVATE
-
-: H ( hsv -- H ) first ;
-
-: S ( hsv -- S ) second ;
-
-: V ( hsv -- V ) third ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
-
-: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
-
-: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
-
-: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-PRIVATE>
-
! h [0,360)
! s [0,1]
! v [0,1]
+TUPLE: hsva < color hue saturation value alpha ;
-: hsv>rgb ( hsv -- rgb )
-dup Hi
-{ { 0 [ [ V ] [ t ] [ p ] tri ] }
- { 1 [ [ q ] [ V ] [ p ] tri ] }
- { 2 [ [ p ] [ V ] [ t ] tri ] }
- { 3 [ [ p ] [ q ] [ V ] tri ] }
- { 4 [ [ t ] [ p ] [ V ] tri ] }
- { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
+C: <hsva> hsva
+
+<PRIVATE
+
+: Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod ; inline
+
+: f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
+
+: p ( hsv -- p ) [ saturation>> 1 swap - ] [ value>> ] bi * ; inline
+
+: q ( hsv -- q ) [ [ f ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
+
+: t ( hsv -- t ) [ [ f 1 swap - ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
+
+PRIVATE>
+
+M: hsva >rgba ( hsva -- rgba )
+ [
+ dup Hi
+ {
+ { 0 [ [ value>> ] [ t ] [ p ] tri ] }
+ { 1 [ [ q ] [ value>> ] [ p ] tri ] }
+ { 2 [ [ p ] [ value>> ] [ t ] tri ] }
+ { 3 [ [ p ] [ q ] [ value>> ] tri ] }
+ { 4 [ [ t ] [ p ] [ value>> ] tri ] }
+ { 5 [ [ value>> ] [ p ] [ q ] tri ] }
+ } case
+ ] [ alpha>> ] bi <rgba> ;
diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor
old mode 100755
new mode 100644
index ecc88a7a5e..e8bdc561b7
--- a/basis/compiler/generator/fixup/fixup.factor
+++ b/basis/compiler/generator/fixup/fixup.factor
@@ -13,7 +13,7 @@ TUPLE: frame-required n ;
: frame-required ( n -- ) \ frame-required boa , ;
-: stack-frame-size ( code -- n )
+: compute-stack-frame-size ( code -- n )
no-stack-frame [
dup frame-required? [ n>> max ] [ drop ] if
] reduce ;
@@ -37,7 +37,7 @@ M: label fixup*
: if-stack-frame ( frame-size quot -- )
swap dup no-stack-frame =
- [ 2drop ] [ stack-frame swap call ] if ; inline
+ [ 2drop ] [ stack-frame-size swap call ] if ; inline
M: word fixup*
{
@@ -146,7 +146,7 @@ SYMBOL: literal-table
: fixup ( code -- literals relocation labels code )
[
init-fixup
- dup stack-frame-size swap [ fixup* ] each drop
+ dup compute-stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >byte-array
diff --git a/basis/compiler/generator/generator-docs.factor b/basis/compiler/generator/generator-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor
old mode 100755
new mode 100644
index 0a9885357e..22de9d3587
--- a/basis/compiler/generator/generator.factor
+++ b/basis/compiler/generator/generator.factor
@@ -296,24 +296,20 @@ M: #return-recursive generate-node
: return-size ( ctype -- n )
#! Amount of space we reserve for a return value.
- dup large-struct? [ heap-size ] [ drop 0 ] if ;
+ dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
: alien-stack-frame ( params -- n )
- alien-parameters parameter-sizes drop ;
+ stack-frame new
+ swap
+ [ return>> return-size >>return ]
+ [ alien-parameters parameter-sizes drop >>params ] bi
+ dup [ params>> ] [ return>> ] bi + >>size
+ dup size>> stack-frame-size >>total-size ;
-: alien-invoke-frame ( params -- n )
- #! Two cells for temporary storage, temp@ and on x86.64,
- #! small struct return value unpacking
- [ return>> return-size ] [ alien-stack-frame ] bi
- + 2 cells + ;
-
-: set-stack-frame ( n -- )
- dup [ frame-required ] when* \ stack-frame set ;
-
-: with-stack-frame ( n quot -- )
- swap set-stack-frame
+: with-stack-frame ( params quot -- )
+ swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
call
- f set-stack-frame ; inline
+ stack-frame off ; inline
GENERIC: reg-size ( register-class -- n )
@@ -416,8 +412,8 @@ M: long-long-type flatten-value-type ( type -- types )
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
- return>> dup large-struct?
- [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+ return>> large-struct?
+ [ %prepare-box-struct cell ] [ 0 ] if ;
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
@@ -476,7 +472,7 @@ M: no-such-symbol compiler-error-type
M: #alien-invoke generate-node
params>>
- dup alien-invoke-frame [
+ dup [
end-basic-block
%prepare-alien-invoke
dup objects>registers
@@ -490,7 +486,7 @@ M: #alien-invoke generate-node
! #alien-indirect
M: #alien-indirect generate-node
params>>
- dup alien-invoke-frame [
+ dup [
! Flush registers
end-basic-block
! Save registers for GC
@@ -556,7 +552,7 @@ TUPLE: callback-context ;
: callback-unwind ( params -- n )
{
- { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
@@ -572,7 +568,7 @@ TUPLE: callback-context ;
dup xt>> dup [
init-templates
%prologue-later
- dup alien-stack-frame [
+ dup [
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor
old mode 100755
new mode 100644
index 4c39da0479..f1b3e32eed
--- a/basis/compiler/tests/optimizer.factor
+++ b/basis/compiler/tests/optimizer.factor
@@ -362,3 +362,18 @@ TUPLE: some-tuple x ;
[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
+
+! Loop detection problem found by doublec
+SYMBOL: counter
+
+DEFER: loop-bbb
+
+: loop-aaa ( -- )
+ counter inc counter get 2 < [ loop-bbb ] when ; inline recursive
+
+: loop-bbb ( -- )
+ [ loop-aaa ] with-scope ; inline recursive
+
+: loop-ccc ( -- ) loop-bbb ;
+
+[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tests/templates-early.factor b/basis/compiler/tests/templates-early.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/templates.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tree/def-use/def-use-tests.factor b/basis/compiler/tree/def-use/def-use-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index d73e8b7db1..19ee051ac6 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -8,7 +8,7 @@ math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
-float-arrays ;
+float-arrays system ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@@ -590,6 +590,8 @@ MIXIN: empty-mixin
[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
+[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor
old mode 100755
new mode 100644
diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index 7fc38239f1..d586ff398f 100644
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -76,13 +76,25 @@ M: #declare propagate-before
: fold-call ( #call word -- )
[ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
-: predicate-output-infos ( info class -- info )
+: predicate-output-infos/literal ( info class -- info )
+ [ literal>> ] dip
+ '[ _ _ instance? <literal-info> ]
+ [ drop object-info ]
+ recover ;
+
+: predicate-output-infos/class ( info class -- info )
[ class>> ] dip {
{ [ 2dup class<= ] [ t <literal-info> ] }
{ [ 2dup classes-intersect? not ] [ f <literal-info> ] }
[ object-info ]
} cond 2nip ;
+: predicate-output-infos ( info class -- info )
+ over literal?>>
+ [ predicate-output-infos/literal ]
+ [ predicate-output-infos/class ]
+ if ;
+
: propagate-predicate ( #call word -- infos )
#! We need to force the caller word to recompile when the class
#! is redefined, since now we're making assumptions but the
diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor
index c66c182869..b1f9406092 100644
--- a/basis/compiler/tree/recursive/recursive-tests.factor
+++ b/basis/compiler/tree/recursive/recursive-tests.factor
@@ -148,3 +148,27 @@ DEFER: a'
[ a' ] build-tree analyze-recursive
\ b' label-is-loop?
] unit-test
+
+DEFER: a''
+
+: b'' ( -- )
+ a'' ; inline recursive
+
+: a'' ( -- )
+ b'' a'' ; inline recursive
+
+[ t ] [
+ [ a'' ] build-tree analyze-recursive
+ \ a'' label-is-not-loop?
+] unit-test
+
+: loop-in-non-loop ( x quot: ( i -- ) -- )
+ over 0 > [
+ [ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
+ ] [ 2drop ] if ; inline recursive
+
+[ t ] [
+ [ 10 [ [ drop ] each-integer ] loop-in-non-loop ]
+ build-tree analyze-recursive
+ \ (each-integer) label-is-loop?
+] unit-test
diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor
index d1e4c7c70e..d257cd6600 100644
--- a/basis/compiler/tree/recursive/recursive.factor
+++ b/basis/compiler/tree/recursive/recursive.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces accessors sequences deques
+USING: kernel assocs arrays namespaces accessors sequences deques
search-deques compiler.tree compiler.tree.combinators ;
IN: compiler.tree.recursive
@@ -50,11 +50,10 @@ GENERIC: collect-loop-info* ( tail? node -- )
loop-stack get length swap loop-heights get set-at ;
M: #recursive collect-loop-info*
- nip
[
[
label>>
- [ loop-stack [ swap suffix ] change ]
+ [ swap 2array loop-stack [ swap suffix ] change ]
[ remember-loop-info ]
[ t >>loop? drop ]
tri
@@ -62,7 +61,7 @@ M: #recursive collect-loop-info*
[ t swap child>> (collect-loop-info) ] bi
] with-scope ;
-: current-loop-nesting ( label -- labels )
+: current-loop-nesting ( label -- alist )
loop-stack get swap loop-heights get at tail ;
: disqualify-loop ( label -- )
@@ -71,7 +70,10 @@ M: #recursive collect-loop-info*
M: #call-recursive collect-loop-info*
label>>
swap [ dup disqualify-loop ] unless
- dup current-loop-nesting [ loop-calls get push-at ] with each ;
+ dup current-loop-nesting
+ [ keys [ loop-calls get push-at ] with each ]
+ [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
+ bi ;
M: #if collect-loop-info*
children>> [ (collect-loop-info) ] with each ;
diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/count-downs/count-downs-docs.factor b/basis/concurrency/count-downs/count-downs-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/count-downs/count-downs-tests.factor b/basis/concurrency/count-downs/count-downs-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/distributed/distributed-docs.factor b/basis/concurrency/distributed/distributed-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor
old mode 100755
new mode 100644
index 5e2f1bb6d1..99ad239011
--- a/basis/concurrency/distributed/distributed.factor
+++ b/basis/concurrency/distributed/distributed.factor
@@ -10,7 +10,7 @@ SYMBOL: local-node
: handle-node-client ( -- )
deserialize
- [ first2 get-process send ] [ stop-server ] if* ;
+ [ first2 get-process send ] [ stop-this-server ] if* ;
: <node-server> ( addrspec -- threaded-server )
<threaded-server>
diff --git a/basis/concurrency/exchangers/exchangers-docs.factor b/basis/concurrency/exchangers/exchangers-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/exchangers/exchangers-tests.factor b/basis/concurrency/exchangers/exchangers-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/exchangers/exchangers.factor b/basis/concurrency/exchangers/exchangers.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/flags/flags.factor b/basis/concurrency/flags/flags.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/futures/futures-docs.factor b/basis/concurrency/futures/futures-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/futures/futures-tests.factor b/basis/concurrency/futures/futures-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/futures/futures.factor b/basis/concurrency/futures/futures.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/locks/locks-docs.factor b/basis/concurrency/locks/locks-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/messaging/messaging-tests.factor b/basis/concurrency/messaging/messaging-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/promises/promises-tests.factor b/basis/concurrency/promises/promises-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/promises/promises.factor b/basis/concurrency/promises/promises.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/semaphores/semaphores-docs.factor b/basis/concurrency/semaphores/semaphores-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/concurrency/semaphores/semaphores.factor b/basis/concurrency/semaphores/semaphores.factor
old mode 100755
new mode 100644
diff --git a/unmaintained/webapps/help/authors.txt b/basis/core-foundation/run-loop/authors.txt
old mode 100755
new mode 100644
similarity index 100%
rename from unmaintained/webapps/help/authors.txt
rename to basis/core-foundation/run-loop/authors.txt
diff --git a/basis/core-foundation/run-loop/summary.txt b/basis/core-foundation/run-loop/summary.txt
new file mode 100644
index 0000000000..ae92138528
--- /dev/null
+++ b/basis/core-foundation/run-loop/summary.txt
@@ -0,0 +1 @@
+CoreFoundation run loop integration
diff --git a/unmaintained/webapps/pastebin/authors.txt b/basis/core-foundation/run-loop/thread/authors.txt
old mode 100755
new mode 100644
similarity index 100%
rename from unmaintained/webapps/pastebin/authors.txt
rename to basis/core-foundation/run-loop/thread/authors.txt
diff --git a/basis/core-foundation/run-loop/thread/summary.txt b/basis/core-foundation/run-loop/thread/summary.txt
new file mode 100644
index 0000000000..e5818b3d78
--- /dev/null
+++ b/basis/core-foundation/run-loop/thread/summary.txt
@@ -0,0 +1 @@
+Vocabulary with init hook for running CoreFoundation event loop
diff --git a/basis/core-foundation/run-loop/thread/tags.txt b/basis/core-foundation/run-loop/thread/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/core-foundation/run-loop/thread/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
old mode 100755
new mode 100644
index 63c52d1025..f22d4a2a90
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic kernel kernel.private math memory
-namespaces make sequences layouts system hashtables classes
-alien byte-arrays combinators words sets ;
+USING: accessors arrays generic kernel kernel.private math
+memory namespaces make sequences layouts system hashtables
+classes alien byte-arrays combinators words sets ;
IN: cpu.architecture
! Register classes
@@ -33,10 +33,9 @@ GENERIC# load-literal 1 ( obj vreg -- )
HOOK: load-indirect cpu ( obj reg -- )
-HOOK: stack-frame cpu ( frame-size -- n )
+HOOK: stack-frame-size cpu ( frame-size -- n )
-: stack-frame* ( -- n )
- \ stack-frame get stack-frame ;
+TUPLE: stack-frame total-size size params return ;
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
@@ -117,7 +116,7 @@ HOOK: %box cpu ( n reg-class func -- )
HOOK: %box-long-long cpu ( n func -- )
-HOOK: %prepare-box-struct cpu ( size -- )
+HOOK: %prepare-box-struct cpu ( -- )
HOOK: %box-small-struct cpu ( c-type -- )
diff --git a/basis/cpu/ppc/allot/allot.factor b/basis/cpu/ppc/allot/allot.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor
old mode 100755
new mode 100644
index 80ee1802e1..357349193e
--- a/basis/cpu/ppc/architecture/architecture.factor
+++ b/basis/cpu/ppc/architecture/architecture.factor
@@ -43,7 +43,7 @@ IN: cpu.ppc.architecture
: xt-save ( n -- i ) 2 cells - ;
-M: ppc stack-frame ( n -- i )
+M: ppc stack-frame-size ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
@@ -166,11 +166,13 @@ M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
M: stack-params %load-param-reg ( stack reg reg-class -- )
drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
+: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
+
M: stack-params %save-param-reg ( stack reg reg-class -- )
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
- 0 1 rot param@ stack-frame* + LWZ
+ 0 1 rot next-param@ LWZ
0 1 rot local@ STW ;
M: ppc %prepare-unbox ( -- )
@@ -197,10 +199,8 @@ M: ppc %unbox-long-long ( n func -- )
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
- ! Compute destination address
- 4 1 roll local@ ADDI
- ! Load struct size
- heap-size 5 LI
+ ! Compute destination address and load struct size
+ [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
! Call the function
"to_value_struct" f %alien-invoke ;
@@ -218,23 +218,18 @@ M: ppc %box-long-long ( n func -- )
4 1 rot cell + local@ LWZ
] when* r> f %alien-invoke ;
-: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ;
+: struct-return@ ( n -- n )
+ [ stack-frame get params>> ] unless* local@ ;
-: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
-
-M: ppc %prepare-box-struct ( size -- )
+M: ppc %prepare-box-struct ( -- )
#! Compute target address for value struct return
- 3 1 rot f struct-return@ ADDI
+ 3 1 f struct-return@ ADDI
3 1 0 local@ STW ;
M: ppc %box-large-struct ( n c-type -- )
- #! If n = f, then we're boxing a returned struct
- heap-size
- [ swap struct-return@ ] keep
- ! Compute destination address
- 3 1 roll ADDI
- ! Load struct size
- 4 LI
+ ! If n = f, then we're boxing a returned struct
+ ! Compute destination address and load struct size
+ [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
! Call the function
"box_value_struct" f %alien-invoke ;
@@ -256,10 +251,10 @@ M: ppc %alien-callback ( quot -- )
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- 3 1 cell temp@ STW ;
+ 3 11 MR ;
M: ppc %alien-indirect ( -- )
- 11 1 cell temp@ LWZ (%call) ;
+ (%call) ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/ppc/linux/bootstrap.factor b/basis/cpu/ppc/linux/bootstrap.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/ppc/macosx/bootstrap.factor b/basis/cpu/ppc/macosx/bootstrap.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
old mode 100755
new mode 100644
index 50d8025b38..dc891a8178
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -1,13 +1,12 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays cpu.x86.assembler
+USING: locals alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
-stack-checker.known-words
-compiler.generator.registers compiler.generator.fixup
-compiler.generator system layouts combinators
-command-line compiler compiler.units io vocabs.loader accessors
-init ;
+stack-checker.known-words compiler.generator.registers
+compiler.generator.fixup compiler.generator system layouts
+combinators command-line compiler compiler.units io
+vocabs.loader accessors init ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
@@ -18,7 +17,6 @@ IN: cpu.x86.32
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
-M: x86.32 stack-save-reg EDX ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
@@ -32,15 +30,20 @@ M: x86.32 struct-small-enough? ( size -- ? )
heap-size { 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
+: struct-return@ ( n -- operand )
+ [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
+
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return ( n reg-class -- src dst )
- return-reg stack-reg rot [+] ;
-M: int-regs load-return-reg load/store-int-return MOV ;
-M: int-regs store-return-reg load/store-int-return swap MOV ;
+
+M: int-regs load-return-reg
+ return-reg swap next-stack@ MOV ;
+
+M: int-regs store-return-reg
+ [ stack@ ] [ return-reg ] bi* MOV ;
M: float-regs param-regs drop { } ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
@@ -48,23 +51,26 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
M: float-regs push-return-reg
- stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
+ stack-reg swap reg-size
+ [ SUB ] [ [ [] ] dip FSTP ] 2bi ;
: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
-: load/store-float-return ( n reg-class -- op size )
- [ stack@ ] [ reg-size ] bi* ;
-M: float-regs load-return-reg load/store-float-return FLD ;
-M: float-regs store-return-reg load/store-float-return FSTP ;
+M: float-regs load-return-reg
+ [ next-stack@ ] [ reg-size ] bi* FLD ;
+
+M: float-regs store-return-reg
+ [ stack@ ] [ reg-size ] bi* FSTP ;
: align-sub ( n -- )
- dup 16 align swap - ESP swap SUB ;
+ [ align-stack ] keep - decr-stack-reg ;
: align-add ( n -- )
- 16 align ESP swap ADD ;
+ align-stack incr-stack-reg ;
: with-aligned-stack ( n quot -- )
- swap dup align-sub slip align-add ; inline
+ [ [ align-sub ] [ call ] bi* ]
+ [ [ align-add ] [ drop ] bi* ] 2bi ; inline
M: x86.32 fixnum>slot@ 1 SHR ;
@@ -77,68 +83,51 @@ M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ;
-: box@ ( n reg-class -- stack@ )
- #! Used for callbacks; we want to box the values given to
- #! us by the C function caller. Computes stack location of
- #! nth parameter; note that we must go back one more stack
- #! frame, since %box sets one up to call the one-arg boxer
- #! function. The size of this stack frame so far depends on
- #! the reg-class of the boxer's arg.
- reg-size neg + stack-frame* + 20 + ;
-
: (%box) ( n reg-class -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
- over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
- push-return-reg ;
+ over [ load-return-reg ] [ 2drop ] if ;
-M: x86.32 %box ( n reg-class func -- )
- over reg-size [
- >r (%box) r> f %alien-invoke
+M:: x86.32 %box ( n reg-class func -- )
+ n reg-class (%box)
+ reg-class reg-size [
+ reg-class push-return-reg
+ func f %alien-invoke
] with-aligned-stack ;
: (%box-long-long) ( n -- )
- #! If n is f, push the return registers onto the stack; we
- #! are boxing a return value of a C function. If n is an
- #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
- #! boxing a parameter being passed to a callback from C.
[
- int-regs box@
- EDX over stack@ MOV
- EAX swap cell - stack@ MOV
- ] when*
- EDX PUSH
- EAX PUSH ;
+ EDX over next-stack@ MOV
+ EAX swap cell - next-stack@ MOV
+ ] when* ;
M: x86.32 %box-long-long ( n func -- )
+ [ (%box-long-long) ] dip
8 [
- [ (%box-long-long) ] [ f %alien-invoke ] bi*
+ EDX PUSH
+ EAX PUSH
+ f %alien-invoke
] with-aligned-stack ;
-: struct-return@ ( size n -- n )
- [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.32 %box-large-struct ( n c-type -- )
+M:: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
- heap-size
- [ swap struct-return@ ] keep
- ECX ESP roll [+] LEA
+ ECX n struct-return@ LEA
8 [
! Push struct size
- PUSH
+ c-type heap-size PUSH
! Push destination address
ECX PUSH
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
-M: x86.32 %prepare-box-struct ( size -- )
+M: x86.32 %prepare-box-struct ( -- )
! Compute target address for value struct return
- EAX ESP rot f struct-return@ [+] LEA
+ EAX f struct-return@ LEA
! Store it as the first parameter
- ESP [] EAX MOV ;
+ 0 stack@ EAX MOV ;
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
@@ -207,13 +196,12 @@ M: x86 %unbox-small-struct ( size -- )
} case ;
M: x86.32 %unbox-large-struct ( n c-type -- )
- #! Alien must be in EAX.
- heap-size
+ ! Alien must be in EAX.
! Compute destination address
- ECX ESP roll [+] LEA
+ ECX rot stack@ LEA
12 [
! Push struct size
- PUSH
+ heap-size PUSH
! Push destination address
ECX PUSH
! Push source address
@@ -224,10 +212,10 @@ M: x86.32 %unbox-large-struct ( n c-type -- )
M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- cell temp@ EAX MOV ;
+ EBP EAX MOV ;
M: x86.32 %alien-indirect ( -- )
- cell temp@ CALL ;
+ EBP CALL ;
M: x86.32 %alien-callback ( quot -- )
4 [
@@ -239,7 +227,7 @@ M: x86.32 %alien-callback ( quot -- )
M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
- ! Save top of data stack
+ ! Save top of data stack in non-volatile register
%prepare-unbox
EAX PUSH
! Restore data/call/retain stacks
@@ -260,7 +248,7 @@ M: x86.32 %cleanup ( alien-node -- )
{
{
[ dup abi>> "stdcall" = ]
- [ alien-stack-frame ESP swap SUB ]
+ [ drop ESP stack-frame get params>> SUB ]
} {
[ dup return>> large-struct? ]
[ drop EAX PUSH ]
diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
old mode 100755
new mode 100644
index 01b8935e39..5bcd733eaa
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -12,7 +12,6 @@ IN: cpu.x86.64
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
-M: x86.64 stack-save-reg RSI ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
@@ -46,7 +45,9 @@ M: stack-params %load-param-reg
r> stack@ R11 MOV ;
M: stack-params %save-param-reg
- >r stack-frame* + cell + swap r> %load-param-reg ;
+ drop
+ R11 swap next-stack@ MOV
+ stack@ R11 MOV ;
: with-return-regs ( quot -- )
[
@@ -121,7 +122,7 @@ M: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in RDI
heap-size
! Load destination address
- RSI RSP roll [+] LEA
+ RSI rot stack@ LEA
! Load structure size
RDX swap MOV
! Copy the struct to the C stack
@@ -145,7 +146,7 @@ M: x86.64 %box-long-long ( n func -- )
M: x86.64 struct-small-enough? ( size -- ? )
heap-size 2 cells <= ;
-: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
+: box-struct-field@ ( i -- operand ) 1+ cells stack@ ;
: %box-struct-field ( c-type i -- )
box-struct-field@ swap reg-class>> {
@@ -163,22 +164,22 @@ M: x86.64 %box-small-struct ( c-type -- )
"box_small_struct" f %alien-invoke
] with-return-regs ;
-: struct-return@ ( size n -- n )
- [ ] [ \ stack-frame get swap - ] ?if ;
+: struct-return@ ( n -- operand )
+ [ stack-frame get params>> ] unless* stack@ ;
M: x86.64 %box-large-struct ( n c-type -- )
! Struct size is parameter 2
- heap-size
- RSI over MOV
+ RSI swap heap-size MOV
! Compute destination address
- swap struct-return@ RDI RSP rot [+] LEA
+ RDI swap struct-return@ LEA
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
-M: x86.64 %prepare-box-struct ( size -- )
+M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
- RAX RSP rot f struct-return@ [+] LEA
- RSP 0 [+] RAX MOV ;
+ RAX f struct-return@ LEA
+ ! Store it as the first parameter
+ 0 stack@ RAX MOV ;
M: x86.64 %prepare-var-args RAX RAX XOR ;
@@ -192,10 +193,10 @@ M: x86.64 %alien-invoke
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- cell temp@ RAX MOV ;
+ RBP RAX MOV ;
M: x86.64 %alien-indirect ( -- )
- cell temp@ CALL ;
+ RBP CALL ;
M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
@@ -203,12 +204,14 @@ M: x86.64 %alien-callback ( quot -- )
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
- ! Put former top of data stack in RDI
- cell temp@ RDI MOV
+ ! Save top of data stack
+ RSP 8 SUB
+ RDI PUSH
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Put former top of data stack in RDI
- RDI cell temp@ MOV
+ RDI POP
+ RSP 8 ADD
! Unbox former top of data stack to return registers
unbox-return ;
diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
old mode 100755
new mode 100644
index c97552a649..01256fb4c5
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -10,10 +10,16 @@ IN: cpu.x86.architecture
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
HOOK: stack-reg cpu ( -- reg )
-HOOK: stack-save-reg cpu ( -- reg )
: stack@ ( n -- op ) stack-reg swap [+] ;
+: next-stack@ ( n -- operand )
+ #! nth parameter from the next stack frame. Used to box
+ #! input values to callbacks; the callback has its own
+ #! stack frame set up, and we want to read the frame
+ #! set up by the caller.
+ stack-frame get total-size>> + stack@ ;
+
: reg-stack ( n reg -- op ) swap cells neg [+] ;
M: ds-loc v>operand n>> ds-reg reg-stack ;
@@ -32,8 +38,8 @@ M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( stack@ reg-class -- )
-GENERIC: store-return-reg ( stack@ reg-class -- )
+GENERIC: load-return-reg ( n reg-class -- )
+GENERIC: store-return-reg ( n reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu ( -- reg )
@@ -45,21 +51,27 @@ HOOK: prepare-division cpu ( -- )
M: immediate load-literal v>operand swap v>operand MOV ;
-M: x86 stack-frame ( n -- i )
- 3 cells + 16 align cell - ;
+: align-stack ( n -- n' )
+ os macosx? cpu x86.64? or [ 16 align ] when ;
+
+M: x86 stack-frame-size ( n -- i )
+ 3 cells + align-stack ;
M: x86 %save-word-xt ( -- )
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
-: factor-area-size ( -- n ) 4 cells ;
+: decr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
M: x86 %prologue ( n -- )
- dup cell + PUSH
+ dup PUSH
temp-reg v>operand PUSH
- stack-reg swap 2 cells - SUB ;
+ 3 cells - decr-stack-reg ;
-M: x86 %epilogue ( n -- )
- stack-reg swap ADD ;
+: incr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
HOOK: %alien-global cpu ( symbol dll register -- )
@@ -137,8 +149,6 @@ M: x86 small-enough? ( n -- ? )
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
-
M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
old mode 100755
new mode 100644
diff --git a/basis/cpu/x86/sse2/sse2.factor b/basis/cpu/x86/sse2/sse2.factor
old mode 100755
new mode 100644
diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor
index 74b72b8789..16a8228fca 100644
--- a/basis/db/db-docs.factor
+++ b/basis/db/db-docs.factor
@@ -5,27 +5,22 @@ alien assocs strings math multiline quotations ;
IN: db
HELP: db
-{ $description "The " { $snippet "db" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries." } ;
+{ $description "The " { $snippet "db" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries." } ;
HELP: new-db
{ $values { "class" class } { "obj" object } }
-{ $description "Creates a new database object from a given class." } ;
-
-HELP: make-db*
-{ $values { "object" object } { "db" object } { "db" object } }
-{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
-
-HELP: make-db
-{ $values { "object" object } { "class" class } { "db" db } }
-{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
+{ $description "Creates a new database object from a given class with caches for prepared statements. Does not actually connect to the database until " { $link db-open } " or " { $link with-db } " is called." }
+{ $notes "User-defined databases must call this constructor word instead of " { $link new } "." } ;
HELP: db-open
{ $values { "db" db } { "db" db } }
-{ $description "Opens a database using the configuration data stored in a " { $link db } " tuple." } ;
+{ $description "Opens a database using the configuration data stored in a " { $link db } " tuple. The database object now references a database handle that must be cleaned up. Therefore, it is better to use the " { $link with-db } " combinator than calling this word directly." } ;
HELP: db-close
{ $values { "handle" alien } }
-{ $description "Closes a database using the handle provided." } ;
+{ $description "Closes a database using the handle provided. Use of the " { $link with-db } " combinator is preferred over manually opening and closing databases so that resources are not leaked." } ;
+
+{ db-open db-close with-db } related-words
HELP: dispose-statements
{ $values { "assoc" assoc } }
@@ -38,65 +33,57 @@ HELP: db-dispose
HELP: statement
{ $description "A " { $snippet "statement" } " stores the information about a statemen, such as the SQL statement text, the in/out parameters, and type information." } ;
-HELP: simple-statement
-{ $description } ;
-
-HELP: prepared-statement
-{ $description } ;
-
HELP: result-set
{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use."
{ $subsection "db-random-access-result-set" }
{ $subsection "db-sequential-result-set" }
} ;
-HELP: init-result-set
-{ $values
- { "result-set" result-set } }
-{ $description "" } ;
-
HELP: new-result-set
{ $values
{ "query" "a query" } { "handle" alien } { "class" class }
{ "result-set" result-set } }
{ $description "Creates a new " { $link result-set } " object of type " { $snippet "class" } "." } ;
-
HELP: new-statement
{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
{ $description "Makes a new statement object from the given parameters." } ;
+HELP: bind-statement
+{ $values
+ { "obj" object } { "statement" statement } }
+{ $description "Sets the statement's " { $slot "bind-params" } " and calls " { $link bind-statement* } " to do the database-specific bind. Sets " { $slot "bound?" } " to true if binding succeeds." } ;
+
+HELP: bind-statement*
+{ $values
+ { "statement" statement } }
+{ $description "Does a low-level bind of the SQL statement's tuple parameters if the database requires. Some databases should treat this as a no-op and bind instead when the actual statement is run." } ;
+
HELP: <simple-statement>
{ $values { "string" string } { "in" sequence } { "out" sequence }
{ "statement" statement } }
-{ $description "Makes a new simple statement object from the given parameters." } ;
+{ $description "Makes a new simple statement object from the given parameters.." }
+{ $warning "Using a simple statement can lead to SQL injection attacks in PostgreSQL. The Factor database implementation for SQLite only uses " { $link <prepared-statement> } " as the sole kind of statement; simple statements alias to prepared ones." } ;
HELP: <prepared-statement>
{ $values { "string" string } { "in" sequence } { "out" sequence }
{ "statement" statement } }
-{ $description "Makes a new prepared statement object from the given parameters." } ;
+{ $description "Makes a new prepared statement object from the given parameters. A prepared statement's parameters will be escaped by the database backend to avoid SQL injection attacks. Prepared statements should be preferred over simple statements." } ;
HELP: prepare-statement
{ $values { "statement" statement } }
{ $description "For databases which implement a method on this generic, it does some internal processing to ready the statement for execution." } ;
-HELP: bind-statement*
-{ $values { "statement" statement } }
-{ $description "" } ;
-
HELP: low-level-bind
-{ $values { "statement" statement } }
-{ $description "" } ;
-
-HELP: bind-tuple
-{ $values { "tuple" tuple } { "statement" statement } }
-{ $description "" } ;
+{ $values
+ { "statement" statement } }
+{ $description "For use with prepared statements, methods on this word should bind the datatype in the SQL spec to its identifier in the SQL string. To name bound variables, SQLite uses identifiers in the form of " { $snippet ":name" } ", while PostgreSQL uses increasing numbers beginning with a dollar sign, e.g. " { $snippet "$1" } "." } ;
HELP: query-results
{ $values { "query" object }
{ "result-set" result-set }
}
-{ $description "Returns a " { $link result-set } " object representing the reults of a SQL query." } ;
+{ $description "Returns a " { $link result-set } " object representing the results of a SQL query. See " { $link "db-result-sets" } "." } ;
HELP: #rows
{ $values { "result-set" result-set } { "n" integer } }
@@ -125,41 +112,14 @@ HELP: more-rows?
{ $values { "result-set" result-set } { "?" "a boolean" } }
{ $description "Returns true if the " { $link result-set } " has more rows to traverse." } ;
-HELP: execute-statement*
-{ $values { "statement" statement } { "type" object } }
-{ $description } ;
-
-HELP: execute-one-statement
-{ $values
- { "statement" null } }
-{ $description "" } ;
-
-HELP: execute-statement
-{ $values { "statement" statement } }
-{ $description "" } ;
-
-
-
-
HELP: begin-transaction
{ $description "Begins a new transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
-HELP: bind-statement
-{ $values
- { "obj" object } { "statement" null } }
-{ $description "" } ;
-
HELP: commit-transaction
{ $description "Commits a transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
-HELP: default-query
-{ $values
- { "query" null }
- { "result-set" null } }
-{ $description "" } ;
-
HELP: in-transaction
{ $description "A variable that is set true when a transaction is in progress." } ;
@@ -170,14 +130,14 @@ HELP: in-transaction?
HELP: query-each
{ $values
- { "statement" null } { "quot" quotation } }
-{ $description "" } ;
+ { "statement" statement } { "quot" quotation } }
+{ $description "A combinator that calls a quotation on a sequence of SQL statements to their results query results." } ;
HELP: query-map
{ $values
- { "statement" null } { "quot" quotation }
+ { "statement" statement } { "quot" quotation }
{ "seq" sequence } }
-{ $description "" } ;
+{ $description "A combinator that maps a sequence of SQL statements to their results query results." } ;
HELP: rollback-transaction
{ $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ;
@@ -211,8 +171,8 @@ HELP: sql-row-typed
HELP: with-db
{ $values
- { "seq" sequence } { "class" class } { "quot" quotation } }
-{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ;
+ { "db" db } { "quot" quotation } }
+{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. See " { $link "db-custom-database-combinators" } " for help setting up database access." } ;
HELP: with-transaction
{ $values
@@ -220,22 +180,18 @@ HELP: with-transaction
{ $description "" } ;
ARTICLE: "db" "Database library"
+"Accessing a database:"
{ $subsection "db-custom-database-combinators" }
+"Higher-level database help:"
+{ $vocab-subsection "Database types" "db.types" }
+{ $vocab-subsection "High-level tuple/database integration" "db.tuples" }
+"Low-level database help:"
{ $subsection "db-protocol" }
{ $subsection "db-result-sets" }
{ $subsection "db-lowlevel-tutorial" }
-"Higher-level database:"
-{ $vocab-subsection "Database types" "db.types" }
-{ $vocab-subsection "High-level tuple/database integration" "db.tuples" }
-! { $subsection "db-tuples" }
-! { $subsection "db-tuples-protocol" }
-! { $subsection "db-tuples-tutorial" }
"Supported database backends:"
{ $vocab-subsection "SQLite" "db.sqlite" }
-{ $vocab-subsection "PostgreSQL" "db.postgresql" }
-"To add support for another database to Factor:"
-{ $subsection "db-porting-the-library" }
-;
+{ $vocab-subsection "PostgreSQL" "db.postgresql" } ;
ARTICLE: "db-random-access-result-set" "Random access result sets"
"Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates."
@@ -247,7 +203,7 @@ $nl
{ $subsection row-column-typed } ;
ARTICLE: "db-sequential-result-set" "Sequential result sets"
-"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal."
+"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal."
$nl
"Databases which work in this way must provide methods for the following traversal words:"
{ $subsection more-rows? }
@@ -272,27 +228,75 @@ $nl
{ $subsection row-column-typed } ;
ARTICLE: "db-protocol" "Low-level database protocol"
-"The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries."
+"The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries." $nl
+"Opening a database:"
+{ $subsection db-open }
+"Closing a database:"
+{ $subsection db-close }
+"Creating tatements:"
+{ $subsection <simple-statement> }
+{ $subsection <prepared-statement> }
+"Using statements with the database:"
+{ $subsection prepare-statement }
+{ $subsection bind-statement* }
+{ $subsection low-level-bind }
+"Performing a query:"
+{ $subsection query-results }
+"Handling query results:"
+{ $subsection "db-result-sets" }
;
+! { $subsection bind-tuple }
ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "."
-;
-
-ARTICLE: "db-porting-the-library" "Porting the database library"
-"This section is not yet written."
-;
-
-ARTICLE: "db-custom-database-combinators" "Custom database combinators"
-"Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl
-
-"Make a " { $snippet "with-" } " word to open, close, and use your database."
+"Executing a SQL command:"
+{ $subsection sql-command }
+"Executing a query directly:"
+{ $subsection sql-query }
+"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
+"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
{ $code <"
USING: db.sqlite db io.files ;
-: with-my-database ( quot -- )
- { "my-database.db" temp-file } sqlite-db rot with-db ;
-"> }
+: with-book-db ( quot -- )
+ "book.db" temp-file <sqlite-db> swap with-db ;"> }
+"Now let's create the table manually:"
+{ $code <" "create table books
+ (id integer primary key, title text, author text, date_published timestamp,
+ edition integer, cover_price double, condition text)"
+ [ sql-command ] with-book-db" "> }
+"Time to insert some books:"
+{ $code <"
+"insert into books
+ (title, author, date_published, edition, cover_price, condition)
+ values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')"
+[ sql-command ] with-book-db"> }
+"Now let's select the book:"
+{ $code <"
+"select id, title, cover_price from books;" [ sql-query ] with-book-db "> }
+"Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
+"In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
-;
+ARTICLE: "db-custom-database-combinators" "Custom database combinators"
+"Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl
+
+"Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
+
+"SQLite example combinator:"
+{ $code <"
+USING: db.sqlite db io.files ;
+: with-sqlite-db ( quot -- )
+ "my-database.db" temp-file <sqlite-db> swap with-db ;"> }
+
+"PostgreSQL example combinator:"
+{ $code <" USING: db.postgresql db ;
+: with-postgresql-db ( quot -- )
+ <postgresql-db>
+ "localhost" >>host
+ 5432 >>port
+ "erg" >>username
+ "secrets?" >>password
+ "factor-test" >>database
+ swap with-db ;">
+} ;
ABOUT: "db"
diff --git a/basis/db/db-tests.factor b/basis/db/db-tests.factor
old mode 100755
new mode 100644
index 3f1dab2c37..56b6c25a19
--- a/basis/db/db-tests.factor
+++ b/basis/db/db-tests.factor
@@ -3,4 +3,4 @@ IN: db.tests
{ 1 0 } [ [ drop ] query-each ] must-infer-as
{ 1 1 } [ [ ] query-map ] must-infer-as
-{ 2 0 } [ [ ] with-db ] must-infer-as
+{ 1 0 } [ [ ] with-db ] must-infer-as
diff --git a/basis/db/db.factor b/basis/db/db.factor
old mode 100755
new mode 100644
index 87bf21d261..bf23005bc2
--- a/basis/db/db.factor
+++ b/basis/db/db.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations destructors kernel math
namespaces sequences classes.tuple words strings
-tools.walker accessors combinators ;
+tools.walker accessors combinators fry ;
IN: db
TUPLE: db
@@ -17,10 +17,6 @@ TUPLE: db
H{ } clone >>update-statements
H{ } clone >>delete-statements ; inline
-GENERIC: make-db* ( object db -- db )
-
-: make-db ( object class -- db ) new-db make-db* ;
-
GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
@@ -111,27 +107,26 @@ M: object execute-statement* ( statement type -- )
: query-map ( statement quot -- seq )
accumulator [ query-each ] dip { } like ; inline
-: with-db ( seq class quot -- )
- [ make-db db-open db ] dip
- [ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
- inline
+: with-db ( db quot -- )
+ [ db-open db ] dip
+ '[ db get [ drop @ ] with-disposal ] with-variable ; inline
+! Words for working with raw SQL statements
: default-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
: sql-query ( sql -- rows )
f f <simple-statement> [ default-query ] with-disposal ;
-: sql-command ( sql -- )
- dup string? [
- f f <simple-statement> [ execute-statement ] with-disposal
- ] [
- ! [
- [ sql-command ] each
- ! ] with-transaction
- ] if ;
+: (sql-command) ( string -- )
+ f f <simple-statement> [ execute-statement ] with-disposal ;
+: sql-command ( sql -- )
+ dup string? [ (sql-command) ] [ [ (sql-command) ] each ] if ;
+
+! Transactions
SYMBOL: in-transaction
+
HOOK: begin-transaction db ( -- )
HOOK: commit-transaction db ( -- )
HOOK: rollback-transaction db ( -- )
diff --git a/basis/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor
index f07d1e8468..0a68db501b 100644
--- a/basis/db/pools/pools-tests.factor
+++ b/basis/db/pools/pools-tests.factor
@@ -4,7 +4,7 @@ accessors kernel math destructors ;
\ <db-pool> must-infer
-{ 2 0 } [ [ ] with-db-pool ] must-infer-as
+{ 1 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
@@ -13,7 +13,7 @@ USE: db.sqlite
[ "pool-test.db" temp-file delete-file ] ignore-errors
-[ ] [ "pool-test.db" temp-file sqlite-db <db-pool> "pool" set ] unit-test
+[ ] [ "pool-test.db" temp-file <sqlite-db> <db-pool> "pool" set ] unit-test
[ ] [ "pool" get expired>> t >>expired drop ] unit-test
diff --git a/basis/db/pools/pools.factor b/basis/db/pools/pools.factor
index 63153c451e..8bc5e87f0e 100644
--- a/basis/db/pools/pools.factor
+++ b/basis/db/pools/pools.factor
@@ -1,21 +1,20 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays namespaces sequences continuations
-io.pools db ;
+io.pools db fry ;
IN: db.pools
-TUPLE: db-pool < pool db params ;
+TUPLE: db-pool < pool db ;
-: <db-pool> ( params db -- pool )
+: <db-pool> ( db -- pool )
db-pool <pool>
- swap >>db
- swap >>params ;
+ swap >>db ;
-: with-db-pool ( db params quot -- )
- >r <db-pool> r> with-pool ; inline
+: with-db-pool ( db quot -- )
+ [ <db-pool> ] dip with-pool ; inline
M: db-pool make-connection ( pool -- )
- [ params>> ] [ db>> ] bi make-db db-open ;
+ db>> db-open ;
: with-pooled-db ( pool quot -- )
- [ db swap with-variable ] curry with-pooled-connection ; inline
+ '[ db _ with-variable ] with-pooled-connection ; inline
diff --git a/basis/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor
old mode 100755
new mode 100644
diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor
old mode 100755
new mode 100644
diff --git a/basis/db/postgresql/postgresql-tests.factor b/basis/db/postgresql/postgresql-tests.factor
old mode 100755
new mode 100644
index 65b75a63dc..fe53e2416e
--- a/basis/db/postgresql/postgresql-tests.factor
+++ b/basis/db/postgresql/postgresql-tests.factor
@@ -1,13 +1,14 @@
-! You will need to run 'createdb factor-test' to create the database.
-! Set username and password in the 'connect' word.
-
USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db
-db.tuples db.types unicode.case ;
+db.tuples db.types unicode.case accessors ;
IN: db.postgresql.tests
: test-db ( -- postgresql-db )
- { "localhost" "postgres" "foob" "factor-test" } postgresql-db ;
+ <postgresql-db>
+ "localhost" >>host
+ "postgres" >>username
+ "thepasswordistrust" >>password
+ "factor-test" >>database ;
[ ] [ test-db [ ] with-db ] unit-test
@@ -92,4 +93,4 @@ IN: db.postgresql.tests
: with-dummy-db ( quot -- )
- >r T{ postgresql-db } db r> with-variable ;
+ [ T{ postgresql-db } db ] dip with-variable ;
diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor
old mode 100755
new mode 100644
index 28548d1260..08df25c13a
--- a/basis/db/postgresql/postgresql.factor
+++ b/basis/db/postgresql/postgresql.factor
@@ -10,28 +10,24 @@ USE: tools.walker
IN: db.postgresql
TUPLE: postgresql-db < db
- host port pgopts pgtty db user pass ;
+ host port pgopts pgtty database username password ;
+
+: <postgresql-db> ( -- postgresql-db )
+ postgresql-db new-db ;
TUPLE: postgresql-statement < statement ;
TUPLE: postgresql-result-set < result-set ;
-M: postgresql-db make-db* ( seq db -- db )
- >r first4 r>
- swap >>db
- swap >>pass
- swap >>user
- swap >>host ;
-
M: postgresql-db db-open ( db -- db )
dup {
[ host>> ]
[ port>> ]
[ pgopts>> ]
[ pgtty>> ]
- [ db>> ]
- [ user>> ]
- [ pass>> ]
+ [ database>> ]
+ [ username>> ]
+ [ password>> ]
} cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- )
@@ -102,7 +98,7 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
dup
- >r db get handle>> f r>
+ [ db get handle>> f ] dip
[ sql>> ] [ in-params>> ] bi
length f PQprepare postgresql-error
>>handle drop ;
@@ -121,7 +117,8 @@ M: postgresql-db bind% ( spec -- )
bind-name% 1, ;
M: postgresql-db bind# ( spec object -- )
- >r bind-name% f swap type>> r> <literal-bind> 1, ;
+ [ bind-name% f swap type>> ] dip
+ <literal-bind> 1, ;
: create-table-sql ( class -- statement )
[
@@ -143,7 +140,7 @@ M: postgresql-db bind# ( spec object -- )
: create-function-sql ( class -- statement )
[
- >r remove-id r>
+ [ remove-id ] dip
"create function add_" 0% dup 0%
"(" 0%
over [ "," 0% ]
diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor
index 0b206cea8f..768ec70185 100644
--- a/basis/db/queries/queries.factor
+++ b/basis/db/queries/queries.factor
@@ -145,10 +145,13 @@ M: db <delete-tuples-statement> ( tuple table -- sql )
where-clause
] query-make ;
+ERROR: all-slots-ignored class ;
+
M: db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
[ dupd filter-ignores ] dip
+ over empty? [ all-slots-ignored ] when
over
[ ", " 0% ]
[ dup column-name>> 0% 2, ] interleave
diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor
old mode 100755
new mode 100644
diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor
old mode 100755
new mode 100644
diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor
old mode 100755
new mode 100644
index 67eac2702b..fe95980bcf
--- a/basis/db/sqlite/sqlite-tests.factor
+++ b/basis/db/sqlite/sqlite-tests.factor
@@ -4,7 +4,7 @@ continuations db.types db.tuples unicode.case ;
IN: db.sqlite.tests
: db-path "test.db" temp-file ;
-: test.db db-path sqlite-db ;
+: test.db db-path <sqlite-db> ;
[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor
old mode 100755
new mode 100644
index dfd9fab08c..8580b9012c
--- a/basis/db/sqlite/sqlite.factor
+++ b/basis/db/sqlite/sqlite.factor
@@ -11,8 +11,9 @@ IN: db.sqlite
TUPLE: sqlite-db < db path ;
-M: sqlite-db make-db* ( path db -- db )
- swap >>path ;
+: <sqlite-db> ( path -- sqlite-db )
+ sqlite-db new-db
+ swap >>path ;
M: sqlite-db db-open ( db -- db )
dup path>> sqlite-open >>handle ;
@@ -48,8 +49,8 @@ M: sqlite-result-set dispose ( result-set -- )
handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
M: sqlite-statement low-level-bind ( statement -- )
- [ bind-params>> ] [ handle>> ] bi
- [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
+ [ handle>> ] [ bind-params>> ] bi
+ [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
@@ -78,7 +79,8 @@ M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
tuck
[ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
rot set-slot-named
- >r [ key>> ] [ type>> ] bi r> swap <sqlite-low-level-binding> ;
+ [ [ key>> ] [ type>> ] bi ] dip
+ swap <sqlite-low-level-binding> ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
@@ -100,7 +102,7 @@ M: sqlite-result-set row-column ( result-set n -- obj )
M: sqlite-result-set row-column-typed ( result-set n -- obj )
dup pick out-params>> nth type>>
- >r >r handle>> r> r> sqlite-column-typed ;
+ [ handle>> ] 2dip sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
dup handle>> sqlite-next >>has-more? drop ;
@@ -160,10 +162,10 @@ M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
<insert-db-assigned-statement> ;
M: sqlite-db bind# ( spec obj -- )
- >r
- [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
- [ type>> ] bi
- r> <literal-bind> 1, ;
+ [
+ [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+ [ type>> ] bi
+ ] dip <literal-bind> 1, ;
M: sqlite-db bind% ( spec -- )
dup 1, column-name>> ":" prepend 0% ;
diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor
index d7ee3a5ad2..02f5dfa38c 100644
--- a/basis/db/tuples/tuples-docs.factor
+++ b/basis/db/tuples/tuples-docs.factor
@@ -1,9 +1,63 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel
-quotations sequences strings multiline math db.types ;
+quotations sequences strings multiline math db.types db ;
IN: db.tuples
+HELP: create-sql-statement
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "Generates the SQL code for creating a table for a given class." } ;
+
+HELP: drop-sql-statement
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "Generates the SQL code for dropping a table for a given class." } ;
+
+HELP: insert-tuple-set-key
+{ $values
+ { "tuple" tuple } { "statement" statement } }
+{ $description "Inserts a tuple and sets its primary key in one word. This is necessary for some databases." } ;
+
+HELP: <count-statement>
+{ $values
+ { "query" query }
+ { "statement" statement } }
+{ $description "A database-specific hook for generating the SQL for a count statement." } ;
+
+HELP: <delete-tuples-statement>
+{ $values
+ { "tuple" tuple } { "class" class }
+ { "object" object } }
+{ $description "A database-specific hook for generating the SQL for an delete statement." } ;
+
+HELP: <insert-db-assigned-statement>
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "A database-specific hook for generating the SQL for an insert statement with a database-assigned primary key." } ;
+
+HELP: <insert-user-assigned-statement>
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "A database-specific hook for generating the SQL for an insert statement with a user-assigned primary key." } ;
+
+HELP: <select-by-slots-statement>
+{ $values
+ { "tuple" tuple } { "class" class }
+ { "tuple" tuple } }
+{ $description "A database-specific hook for generating the SQL for a select statement." } ;
+
+HELP: <update-tuple-statement>
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "A database-specific hook for generating the SQL for an update statement." } ;
+
+
HELP: define-persistent
{ $values
{ "class" class } { "table" string } { "columns" "an array of slot specifiers" } }
@@ -128,7 +182,21 @@ ARTICLE: "db-tuples-words" "High-level tuple/database words"
{ $subsection count-tuples } ;
ARTICLE: "db-tuples-protocol" "Tuple database protocol"
-;
+"Creating a table:"
+{ $subsection create-sql-statement }
+"Dropping a table:"
+{ $subsection drop-sql-statement }
+"Inserting a tuple:"
+{ $subsection <insert-db-assigned-statement> }
+{ $subsection <insert-user-assigned-statement> }
+"Updating a tuple:"
+{ $subsection <update-tuple-statement> }
+"Deleting tuples:"
+{ $subsection <delete-tuples-statement> }
+"Selecting tuples:"
+{ $subsection <select-by-slots-statement> }
+"Counting tuples:"
+{ $subsection <count-statement> } ;
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
@@ -190,7 +258,7 @@ T{ book
{ $list
"Make a new tuple to represent your data"
{ "Map the Factor types to the database types with " { $link define-persistent } }
- { "Make a " { $link "db-custom-database-combinators" } " to open your database and run a " { $snippet "quotation" } }
+ { "Make a custom database combinator (see" { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
{ "Create a table with " { $link create-table } ", " { $link ensure-table } ", or " { $link recreate-table } }
{ "Start making and storing objects with " { $link insert-tuple } ", " { $link update-tuple } ", " { $link delete-tuples } ", and " { $link select-tuples } }
} ;
diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor
old mode 100755
new mode 100644
index 6114c7ebe1..f5569a97cd
--- a/basis/db/tuples/tuples-tests.factor
+++ b/basis/db/tuples/tuples-tests.factor
@@ -7,16 +7,34 @@ db.postgresql accessors random math.bitwise
math.ranges strings urls fry db.tuples.private ;
IN: db.tuples.tests
+: sqlite-db ( -- sqlite-db )
+ "tuples-test.db" temp-file <sqlite-db> ;
+
: test-sqlite ( quot -- )
- [ ] swap '[
- "tuples-test.db" temp-file sqlite-db _ with-db
- ] unit-test ;
+ '[
+ [ ] [
+ "tuples-test.db" temp-file <sqlite-db> _ with-db
+ ] unit-test
+ ] call ; inline
+
+: postgresql-db ( -- postgresql-db )
+ <postgresql-db>
+ "localhost" >>host
+ "postgres" >>username
+ "thepasswordistrust" >>password
+ "factor-test" >>database ;
: test-postgresql ( quot -- )
- [ ] swap '[
- { "localhost" "postgres" "foob" "factor-test" }
- postgresql-db _ with-db
- ] unit-test ;
+ '[
+ [ ] [ postgresql-db _ with-db ] unit-test
+ ] call ; inline
+
+! These words leak resources, but are useful for interactivel testing
+: sqlite-test-db ( -- )
+ sqlite-db db-open db set ;
+
+: postgresql-test-db ( -- )
+ postgresql-db db-open db set ;
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob url ;
@@ -356,9 +374,7 @@ TUPLE: exam id name score ;
[ f ]
[ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
- ! FIXME
- ! [ f ]
- ! [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] unit-test
+ [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] [ class>> "EXAM" = ] must-fail-with
[
{
@@ -641,10 +657,3 @@ compound-foo "COMPOUND_FOO"
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
-
-: sqlite-test-db ( -- )
- "tuples-test.db" temp-file sqlite-db make-db db-open db set ;
-
-: postgresql-test-db ( -- )
- { "localhost" "postgres" "foob" "factor-test" } postgresql-db
- make-db db-open db set ;
diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor
old mode 100755
new mode 100644
index 7f567697d2..7a5c9e41e6
--- a/basis/db/tuples/tuples.factor
+++ b/basis/db/tuples/tuples.factor
@@ -6,8 +6,6 @@ math.parser io prettyprint db.types continuations
destructors mirrors sets db.types ;
IN: db.tuples
-<PRIVATE
-! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- object )
HOOK: drop-sql-statement db ( class -- object )
@@ -18,10 +16,12 @@ HOOK: <delete-tuples-statement> db ( tuple class -- object )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: <count-statement> db ( query -- statement )
HOOK: query>statement db ( query -- statement )
-
HOOK: insert-tuple-set-key db ( tuple statement -- )
+<PRIVATE
+
SYMBOL: sql-counter
+
: next-sql-counter ( -- str )
sql-counter [ inc ] [ get ] bi number>string ;
@@ -65,8 +65,8 @@ GENERIC: eval-generator ( singleton -- object )
: do-count ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
-PRIVATE>
+PRIVATE>
! High level
ERROR: no-slots-named class seq ;
diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor
index 401bbbc4d7..f1a6ba6c6c 100644
--- a/basis/db/types/types-docs.factor
+++ b/basis/db/types/types-docs.factor
@@ -8,7 +8,7 @@ HELP: +autoincrement+
{ $description "" } ;
HELP: +db-assigned-id+
-{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
+{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
HELP: +default+
{ $description "" } ;
@@ -29,7 +29,7 @@ HELP: +primary-key+
{ $description "" } ;
HELP: +random-id+
-{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
+{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
HELP: +serial+
{ $description "" } ;
@@ -38,7 +38,7 @@ HELP: +unique+
{ $description "" } ;
HELP: +user-assigned-id+
-{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
+{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
HELP: <generator-bind>
{ $description "" } ;
@@ -53,7 +53,7 @@ HELP: BIG-INTEGER
{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
HELP: BLOB
-{ $description "A serialized Factor object. The database library automatically serializes the object for a SQL insert or update and deserializes it on a tuple query." } ;
+{ $description "A byte array." } ;
HELP: BOOLEAN
{ $description "Either true or false." } ;
@@ -65,7 +65,7 @@ HELP: DATETIME
{ $description "A date and a time." } ;
HELP: DOUBLE
-{ $description "Corresponds to Factor's 64bit floating-point numbers." } ;
+{ $description "Corresponds to Factor's 64-bit floating-point numbers." } ;
HELP: FACTOR-BLOB
{ $description "A serialized Factor object." } ;
@@ -77,30 +77,31 @@ HELP: NULL
{ $description "The SQL null type." } ;
HELP: REAL
-{ $description "" } ;
+{ $description "A real number of unlimited precision. May not be supported on all databases." } ;
HELP: SIGNED-BIG-INTEGER
-{ $description "For portability, if a number is known to be 64bit and signed, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
+{ $description "For portability, if a number is known to be 64bit and signed, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
HELP: TEXT
-{ $description "" } ;
+{ $description "Stores a string that is longer than a " { $link VARCHAR } ". SQLite uses this type for strings; it does not handle " { $link VARCHAR } " strings." } ;
HELP: TIME
-{ $description "" } ;
+{ $description "A timestamp without a date component." } ;
HELP: TIMESTAMP
{ $description "A Factor timestamp." } ;
HELP: UNSIGNED-BIG-INTEGER
-{ $description "For portability, if a number is known to be 64bit, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
+{ $description "For portability, if a number is known to be 64bit, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
{ INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER } related-words
HELP: URL
-{ $description "A Factor " { $link "urls" } " object." } ;
+{ $description "A Factor " { $link "urls" } " object." } ;
HELP: VARCHAR
-{ $description "The SQL varchar type. This type can take an integer as an argument." } ;
+{ $description "The SQL varchar type. This type can take an integer as an argument." }
+{ $examples { $unchecked-example "{ VARCHAR 256 }" "" } } ;
HELP: user-assigned-id-spec?
{ $values
@@ -279,8 +280,9 @@ ARTICLE: "db.types" "Database types"
{ $subsection DATETIME }
{ $subsection TIME }
{ $subsection TIMESTAMP }
-"Arbitrary Factor objects:"
+"Factor byte-arrays:"
{ $subsection BLOB }
+"Arbitrary Factor objects:"
{ $subsection FACTOR-BLOB }
"Factor URLs:"
{ $subsection URL } ;
diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor
old mode 100755
new mode 100644
diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
old mode 100755
new mode 100644
diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor
old mode 100755
new mode 100644
diff --git a/basis/delegate/protocols/protocols.factor b/basis/delegate/protocols/protocols.factor
old mode 100755
new mode 100644
diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
old mode 100755
new mode 100644
diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/editpadpro/editpadpro.factor b/basis/editors/editpadpro/editpadpro.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/editplus/editplus.factor b/basis/editors/editplus/editplus.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/emeditor/emeditor.factor b/basis/editors/emeditor/emeditor.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/gvim/gvim.factor b/basis/editors/gvim/gvim.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/gvim/windows/windows.factor b/basis/editors/gvim/windows/windows.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/jedit/jedit.factor b/basis/editors/jedit/jedit.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/notepadpp/notepadpp.factor b/basis/editors/notepadpp/notepadpp.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/ted-notepad/ted-notepad.factor b/basis/editors/ted-notepad/ted-notepad.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/textmate/textmate.factor b/basis/editors/textmate/textmate.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/ultraedit/ultraedit.factor b/basis/editors/ultraedit/ultraedit.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/vim/vim.factor b/basis/editors/vim/vim.factor
old mode 100755
new mode 100644
diff --git a/basis/editors/wordpad/wordpad.factor b/basis/editors/wordpad/wordpad.factor
old mode 100755
new mode 100644
diff --git a/basis/float-arrays/float-arrays-tests.factor b/basis/float-arrays/float-arrays-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor
old mode 100755
new mode 100644
diff --git a/basis/float-vectors/float-vectors-docs.factor b/basis/float-vectors/float-vectors-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/float-vectors/float-vectors-tests.factor b/basis/float-vectors/float-vectors-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/float-vectors/float-vectors.factor b/basis/float-vectors/float-vectors.factor
old mode 100755
new mode 100644
diff --git a/basis/freetype/freetype.factor b/basis/freetype/freetype.factor
old mode 100755
new mode 100644
diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/actions/actions-tests.factor b/basis/furnace/actions/actions-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor
index decee690a3..128ec448b7 100644
--- a/basis/furnace/alloy/alloy.factor
+++ b/basis/furnace/alloy/alloy.factor
@@ -17,19 +17,17 @@ IN: furnace.alloy
state-classes ensure-tables
user ensure-table ;
-: <alloy> ( responder db params -- responder' )
- [ [ init-furnace-tables ] with-db ]
+: <alloy> ( responder db -- responder' )
+ [ [ init-furnace-tables ] with-db ] keep
[
- [
- <asides>
- <conversations>
- <sessions>
- ] 2dip
- <db-persistence>
- <check-form-submissions>
- ] 2bi ;
+ <asides>
+ <conversations>
+ <sessions>
+ ] dip
+ <db-persistence>
+ <check-form-submissions> ;
-: start-expiring ( db params -- )
+: start-expiring ( db -- )
'[
- _ _ [ state-classes [ expire-state ] each ] with-db
+ _ [ state-classes [ expire-state ] each ] with-db
] 5 minutes every drop ;
diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/auth/basic/basic.factor b/basis/furnace/auth/basic/basic.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/auth/providers/assoc/assoc-tests.factor b/basis/furnace/auth/providers/assoc/assoc-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/auth/providers/assoc/assoc.factor b/basis/furnace/auth/providers/assoc/assoc.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/auth/providers/db/db-tests.factor b/basis/furnace/auth/providers/db/db-tests.factor
old mode 100755
new mode 100644
index fac5c23e4a..3bcd82a15d
--- a/basis/furnace/auth/providers/db/db-tests.factor
+++ b/basis/furnace/auth/providers/db/db-tests.factor
@@ -11,7 +11,7 @@ io.files accessors kernel ;
[ "auth-test.db" temp-file delete-file ] ignore-errors
-"auth-test.db" temp-file sqlite-db [
+"auth-test.db" temp-file <sqlite-db> [
user ensure-table
diff --git a/basis/furnace/auth/providers/db/db.factor b/basis/furnace/auth/providers/db/db.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/auth/providers/null/null.factor b/basis/furnace/auth/providers/null/null.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/auth/providers/providers.factor b/basis/furnace/auth/providers/providers.factor
old mode 100755
new mode 100644
diff --git a/basis/furnace/db/db.factor b/basis/furnace/db/db.factor
old mode 100755
new mode 100644
index b4a4386015..ed18e42a4f
--- a/basis/furnace/db/db.factor
+++ b/basis/furnace/db/db.factor
@@ -6,7 +6,7 @@ IN: furnace.db
TUPLE: db-persistence < filter-responder pool ;
-: <db-persistence> ( responder params db -- responder' )
+: <db-persistence> ( responder db -- responder' )
<db-pool> db-persistence boa ;
M: db-persistence call-responder*
diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor
old mode 100755
new mode 100644
index ff089a92b2..6bb3c1cd69
--- a/basis/furnace/sessions/sessions-tests.factor
+++ b/basis/furnace/sessions/sessions-tests.factor
@@ -48,9 +48,9 @@ M: foo call-responder*
<action>
[ [ ] "text/plain" <content> exit-with ] >>display ;
-[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors
+[ "auth-test.db" temp-file delete-file ] ignore-errors
-"auth-test.db" temp-file sqlite-db [
+"auth-test.db" temp-file <sqlite-db> [
<request> init-request
session ensure-table
diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor
old mode 100755
new mode 100644
diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
old mode 100755
new mode 100644
diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor
old mode 100755
new mode 100644
diff --git a/basis/hash2/hash2-tests.factor b/basis/hash2/hash2-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/heaps/authors.txt b/basis/heaps/authors.txt
index 1229a590fa..d0c12d9aa4 100755
--- a/basis/heaps/authors.txt
+++ b/basis/heaps/authors.txt
@@ -1,2 +1,3 @@
Doug Coleman
Ryan Murphy
+Slava Pestov
diff --git a/basis/heaps/heaps-docs.factor b/basis/heaps/heaps-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor
old mode 100755
new mode 100644
index 13b6a97654..e28eb3007a
--- a/basis/heaps/heaps-tests.factor
+++ b/basis/heaps/heaps-tests.factor
@@ -1,6 +1,5 @@
! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-
USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting
accessors math.order ;
@@ -54,9 +53,6 @@ IN: heaps.tests
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
] each
-: delete-random ( seq -- elt )
- dup length random dup pick nth >r swap delete-nth r> ;
-
: sort-entries ( entries -- entries' )
[ [ key>> ] compare ] sort ;
diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor
old mode 100755
new mode 100644
diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor
old mode 100755
new mode 100644
diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/help/definitions/definitions.factor b/basis/help/definitions/definitions.factor
old mode 100755
new mode 100644
diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor
old mode 100755
new mode 100644
index 51750d772f..c1505705da
--- a/basis/help/handbook/handbook.factor
+++ b/basis/help/handbook/handbook.factor
@@ -90,7 +90,7 @@ ARTICLE: "numbers" "Numbers"
{ $subsection "math-constants" }
{ $subsection "math-functions" }
{ $subsection "number-strings" }
-{ $subsection "random-numbers" }
+{ $subsection "random" }
"Number implementations:"
{ $subsection "integers" }
{ $subsection "rationals" }
diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/help/help.factor b/basis/help/help.factor
old mode 100755
new mode 100644
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
old mode 100755
new mode 100644
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
old mode 100755
new mode 100644
diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor
old mode 100755
new mode 100644
diff --git a/basis/help/syntax/syntax-tests.factor b/basis/help/syntax/syntax-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor
old mode 100755
new mode 100644
diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor
old mode 100755
new mode 100644
diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor
old mode 100755
new mode 100644
diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor
old mode 100755
new mode 100644
diff --git a/basis/html/templates/fhtml/fhtml-tests.factor b/basis/html/templates/fhtml/fhtml-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor
old mode 100755
new mode 100644
diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor
index a762d1a5ef..d4f277a7c3 100644
--- a/basis/http/client/client-docs.factor
+++ b/basis/http/client/client-docs.factor
@@ -95,6 +95,8 @@ ARTICLE: "http.client.errors" "HTTP client errors"
ARTICLE: "http.client" "HTTP client"
"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
$nl
+"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't load it, HTTPS will not load and images generated by " { $vocab-link "tools.deploy" } " will be smaller as a result."
+$nl
"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
{ $subsection "http.client.get" }
{ $subsection "http.client.post" }
diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
old mode 100755
new mode 100644
index aa1e0771ba..9260f15a7b
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -120,7 +120,7 @@ SYMBOL: redirects
] if ; inline recursive
: read-unchunked ( quot: ( chunk -- ) -- )
- 8192 read dup [
+ 8192 read-partial dup [
[ swap call ] [ drop read-unchunked ] 2bi
] [ 2drop ] if ; inline recursive
diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor
old mode 100755
new mode 100644
index 9a1421a3ad..b3930878ff
--- a/basis/http/http-tests.factor
+++ b/basis/http/http-tests.factor
@@ -179,12 +179,14 @@ http.server.dispatchers db.tuples ;
: add-quit-action
<action>
- [ stop-server "Goodbye" "text/html" <content> ] >>display
+ [ stop-this-server "Goodbye" "text/html" <content> ] >>display
"quit" add-responder ;
-: test-db "test.db" temp-file sqlite-db ;
+: test-db-file "test.db" temp-file ;
-[ test-db drop delete-file ] ignore-errors
+: test-db test-db-file <sqlite-db> ;
+
+[ test-db-file delete-file ] ignore-errors
test-db [
init-furnace-tables
diff --git a/basis/http/http.factor b/basis/http/http.factor
old mode 100755
new mode 100644
index cfc205dbb5..c90a1872ce
--- a/basis/http/http.factor
+++ b/basis/http/http.factor
@@ -3,7 +3,7 @@
USING: accessors kernel combinators math namespaces make
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
-math.parser calendar calendar.format present urls logging
+math.parser calendar calendar.format present urls
io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit
@@ -96,8 +96,6 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
drop
] { } make ;
-\ parse-cookie DEBUG add-input-logging
-
: check-cookie-string ( string -- string' )
dup "=;'\"\r\n" intersect empty?
[ "Bad cookie name or value" throw ] unless ;
diff --git a/basis/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor
index ce8257dec5..8e8e7358d1 100644
--- a/basis/http/parsers/parsers.factor
+++ b/basis/http/parsers/parsers.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit math math.order math.parser
kernel sequences sequences.deep peg peg.parsers assocs arrays
-hashtables strings unicode.case namespaces make ascii logging ;
+hashtables strings unicode.case namespaces make ascii ;
IN: http.parsers
: except ( quot -- parser )
@@ -61,8 +61,6 @@ PEG: parse-request-line ( string -- triple )
'space' ,
] seq* just ;
-\ parse-request-line DEBUG add-input-logging
-
: 'text' ( -- parser )
[ ctl? ] except ;
diff --git a/basis/http/server/cgi/cgi.factor b/basis/http/server/cgi/cgi.factor
old mode 100755
new mode 100644
diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor
old mode 100755
new mode 100644
index 547e1b69fb..697dec24ce
--- a/basis/http/server/server.factor
+++ b/basis/http/server/server.factor
@@ -24,6 +24,8 @@ html.elements
html.streams ;
IN: http.server
+\ parse-cookie DEBUG add-input-logging
+
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor
old mode 100755
new mode 100644
diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor
old mode 100755
new mode 100644
diff --git a/basis/interval-maps/interval-maps-docs.factor b/basis/interval-maps/interval-maps-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/interval-maps/interval-maps-tests.factor b/basis/interval-maps/interval-maps-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor
old mode 100755
new mode 100644
diff --git a/basis/io/buffers/buffers-docs.factor b/basis/io/buffers/buffers-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/io/buffers/buffers-tests.factor b/basis/io/buffers/buffers-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor
old mode 100755
new mode 100644
diff --git a/basis/io/encodings/8-bit/8-bit.factor b/basis/io/encodings/8-bit/8-bit.factor
old mode 100755
new mode 100644
diff --git a/basis/io/encodings/ascii/ascii-docs.factor b/basis/io/encodings/ascii/ascii-docs.factor
index fa496a3526..e0ab11f1a4 100644
--- a/basis/io/encodings/ascii/ascii-docs.factor
+++ b/basis/io/encodings/ascii/ascii-docs.factor
@@ -4,8 +4,8 @@ IN: io.encodings.ascii
HELP: ascii
{ $class-description "ASCII encoding descriptor." } ;
-ARTICLE: "ascii" "ASCII encoding"
+ARTICLE: "io.encodings.ascii" "ASCII encoding"
"By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown."
{ $subsection ascii } ;
-ABOUT: "ascii"
+ABOUT: "io.encodings.ascii"
diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor
old mode 100755
new mode 100644
diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor
old mode 100755
new mode 100644
diff --git a/basis/io/encodings/utf16/utf16-tests.factor b/basis/io/encodings/utf16/utf16-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/encodings/utf16/utf16.factor b/basis/io/encodings/utf16/utf16.factor
old mode 100755
new mode 100644
diff --git a/basis/io/launcher/launcher-docs.factor b/basis/io/launcher/launcher-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/io/launcher/launcher-tests.factor b/basis/io/launcher/launcher-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor
old mode 100755
new mode 100644
diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor
old mode 100755
new mode 100644
diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/io/monitors/monitors-tests.factor b/basis/io/monitors/monitors-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/monitors/monitors.factor b/basis/io/monitors/monitors.factor
old mode 100755
new mode 100644
diff --git a/basis/io/pipes/pipes-tests.factor b/basis/io/pipes/pipes-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/ports/ports-docs.factor b/basis/io/ports/ports-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor
old mode 100755
new mode 100644
diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor
old mode 100755
new mode 100644
index 839f3d8414..00711ce226
--- a/basis/io/servers/connection/connection-docs.factor
+++ b/basis/io/servers/connection/connection-docs.factor
@@ -58,9 +58,11 @@ ARTICLE: "io.servers.connection" "Threaded servers"
{ $subsection start-server }
{ $subsection start-server* }
{ $subsection wait-for-server }
+"Stopping the server:"
+{ $subsection stop-server }
"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
{ $subsection remote-address }
-{ $subsection stop-server }
+{ $subsection stop-this-server }
{ $subsection secure-port }
{ $subsection insecure-port }
"Additionally, the " { $link local-address } " variable is set, as in " { $link with-client } "." ;
@@ -88,7 +90,8 @@ HELP: handle-client*
HELP: start-server
{ $values { "threaded-server" threaded-server } }
-{ $description "Starts a threaded server, returning when a client handler calls " { $link stop-server } "." } ;
+{ $description "Starts a threaded server." }
+{ $notes "Use " { $link stop-server } " or " { $link stop-this-server } " to stop the server." } ;
HELP: wait-for-server
{ $values { "threaded-server" threaded-server } }
@@ -96,9 +99,13 @@ HELP: wait-for-server
HELP: start-server*
{ $values { "threaded-server" threaded-server } }
-{ $description "Starts a threaded server, returning as soon as it is accepting connections." } ;
+{ $description "Starts a threaded server, returning as soon as it is ready to begin accepting connections." } ;
HELP: stop-server
+{ $values { "threaded-server" threaded-server } }
+{ $description "Stops a threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
+
+HELP: stop-this-server
{ $description "Stops the current threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
HELP: secure-port
diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor
old mode 100755
new mode 100644
index aa8df0b16c..a3223ed2aa
--- a/basis/io/servers/connection/connection-tests.factor
+++ b/basis/io/servers/connection/connection-tests.factor
@@ -33,7 +33,7 @@ concurrency.promises io.encodings.ascii io threads calendar ;
<threaded-server>
5 >>max-connections
1237 >>insecure
- [ "Hello world." write stop-server ] >>handler
+ [ "Hello world." write stop-this-server ] >>handler
"server" set
] unit-test
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
old mode 100755
new mode 100644
index bde4e518ac..674ed8803c
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -105,7 +105,7 @@ M: threaded-server handle-client* handler>> call ;
threaded-server get encoding>> <server>
[ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
-\ start-accept-loop ERROR add-error-logging
+\ start-accept-loop NOTICE add-error-logging
: init-server ( threaded-server -- threaded-server )
dup semaphore>> [
@@ -136,8 +136,11 @@ PRIVATE>
[ wait-for-server ]
bi ;
-: stop-server ( -- )
- threaded-server get [ f ] change-sockets drop dispose-each ;
+: stop-server ( threaded-server -- )
+ [ f ] change-sockets drop dispose-each ;
+
+: stop-this-server ( -- )
+ threaded-server get stop-server ;
GENERIC: port ( addrspec -- n )
diff --git a/basis/io/sockets/secure/secure-tests.factor b/basis/io/sockets/secure/secure-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor
old mode 100755
new mode 100644
diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor
old mode 100755
new mode 100644
index 3c77be254c..3454f3384e
--- a/basis/io/sockets/sockets-docs.factor
+++ b/basis/io/sockets/sockets-docs.factor
@@ -104,7 +104,7 @@ HELP: <client>
} ;
HELP: with-client
-{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "quot" quotation } }
+{ $values { "remote" "an address specifier" } { "encoding" "an encoding descriptor" } { "quot" quotation } }
{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is bound to is stored in the " { $link local-address } " variable." }
{ $errors "Throws an error if the connection cannot be established." } ;
diff --git a/basis/io/sockets/sockets-tests.factor b/basis/io/sockets/sockets-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor
old mode 100755
new mode 100644
index 9bfcc7e310..c704382dd4
--- a/basis/io/sockets/sockets.factor
+++ b/basis/io/sockets/sockets.factor
@@ -17,10 +17,12 @@ IN: io.sockets
! Addressing
GENERIC: protocol-family ( addrspec -- af )
-GENERIC: sockaddr-type ( addrspec -- type )
+GENERIC: sockaddr-size ( addrspec -- n )
GENERIC: make-sockaddr ( addrspec -- sockaddr )
+GENERIC: empty-sockaddr ( addrspec -- sockaddr )
+
GENERIC: address-size ( addrspec -- n )
GENERIC: inet-ntop ( data addrspec -- str )
@@ -28,10 +30,10 @@ GENERIC: inet-ntop ( data addrspec -- str )
GENERIC: inet-pton ( str addrspec -- data )
: make-sockaddr/size ( addrspec -- sockaddr size )
- [ make-sockaddr ] [ sockaddr-type heap-size ] bi ;
+ [ make-sockaddr ] [ sockaddr-size ] bi ;
: empty-sockaddr/size ( addrspec -- sockaddr size )
- sockaddr-type [ <c-object> ] [ heap-size ] bi ;
+ [ empty-sockaddr ] [ sockaddr-size ] bi ;
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
@@ -74,7 +76,9 @@ M: inet4 address-size drop 4 ;
M: inet4 protocol-family drop PF_INET ;
-M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
+M: inet4 sockaddr-size drop "sockaddr-in" heap-size ;
+
+M: inet4 empty-sockaddr drop "sockaddr-in" <c-object> ;
M: inet4 make-sockaddr ( inet -- sockaddr )
"sockaddr-in" <c-object>
@@ -128,7 +132,9 @@ M: inet6 address-size drop 16 ;
M: inet6 protocol-family drop PF_INET6 ;
-M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
+M: inet6 sockaddr-size drop "sockaddr-in6" heap-size ;
+
+M: inet6 empty-sockaddr drop "sockaddr-in6" <c-object> ;
M: inet6 make-sockaddr ( inet -- sockaddr )
"sockaddr-in6" <c-object>
diff --git a/basis/io/streams/duplex/duplex-docs.factor b/basis/io/streams/duplex/duplex-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/io/streams/duplex/duplex-tests.factor b/basis/io/streams/duplex/duplex-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/streams/duplex/duplex.factor b/basis/io/streams/duplex/duplex.factor
old mode 100755
new mode 100644
diff --git a/basis/io/streams/null/null.factor b/basis/io/streams/null/null.factor
old mode 100755
new mode 100644
diff --git a/basis/io/thread/thread.factor b/basis/io/thread/thread.factor
old mode 100755
new mode 100644
diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/io/timeouts/timeouts.factor b/basis/io/timeouts/timeouts.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor
old mode 100755
new mode 100644
index 0e9139f431..5bb0b82555
--- a/basis/io/unix/backend/backend.factor
+++ b/basis/io/unix/backend/backend.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types generic assocs kernel kernel.private
-math io.ports sequences strings structs sbufs threads unix
+math io.ports sequences strings sbufs threads unix
vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces make io.timeouts
io.encodings.utf8 destructors accessors summary combinators
-locals ;
+locals unix.time ;
QUALIFIED: io
IN: io.unix.backend
diff --git a/basis/io/unix/bsd/bsd.factor b/basis/io/unix/bsd/bsd.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/epoll/epoll.factor b/basis/io/unix/epoll/epoll.factor
index 406a7fcb50..05a9bcfa8d 100644
--- a/basis/io/unix/epoll/epoll.factor
+++ b/basis/io/unix/epoll/epoll.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.ports io.unix.backend
bit-arrays sequences assocs unix unix.linux.epoll math
-namespaces structs ;
+namespaces unix.time ;
IN: io.unix.epoll
TUPLE: epoll-mx < mx events ;
diff --git a/basis/io/unix/files/bsd/bsd.factor b/basis/io/unix/files/bsd/bsd.factor
new file mode 100644
index 0000000000..18e713af2f
--- /dev/null
+++ b/basis/io/unix/files/bsd/bsd.factor
@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien.syntax math io.unix.files system
+unix.stat accessors combinators calendar.unix ;
+IN: io.unix.files.bsd
+
+TUPLE: bsd-file-info < unix-file-info birth-time flags gen ;
+
+M: bsd new-file-info ( -- class ) bsd-file-info new ;
+
+M: bsd stat>file-info ( stat -- file-info )
+ [ call-next-method ] keep
+ {
+ [ stat-st_flags >>flags ]
+ [ stat-st_gen >>gen ]
+ [ stat-st_birthtimespec timespec>unix-time >>birth-time ]
+ } cleave ;
diff --git a/basis/io/unix/files/bsd/tags.txt b/basis/io/unix/files/bsd/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/io/unix/files/bsd/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/io/unix/files/files-tests.factor b/basis/io/unix/files/files-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor
old mode 100755
new mode 100644
index c6eda50855..6ddb74f4a3
--- a/basis/io/unix/files/files.factor
+++ b/basis/io/unix/files/files.factor
@@ -4,7 +4,7 @@ USING: io.backend io.ports io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
-io.files.private destructors ;
+io.files.private destructors vocabs.loader calendar.unix ;
IN: io.unix.files
@@ -74,26 +74,14 @@ M: unix copy-file ( from to -- )
[ swap file-info permissions>> chmod io-error ]
2bi ;
-: stat>type ( stat -- type )
- stat-st_mode S_IFMT bitand {
- { S_IFREG [ +regular-file+ ] }
- { S_IFDIR [ +directory+ ] }
- { S_IFCHR [ +character-device+ ] }
- { S_IFBLK [ +block-device+ ] }
- { S_IFIFO [ +fifo+ ] }
- { S_IFLNK [ +symbolic-link+ ] }
- { S_IFSOCK [ +socket+ ] }
- [ drop +unknown+ ]
- } case ;
+HOOK: stat>file-info os ( stat -- file-info )
-: stat>file-info ( stat -- info )
- {
- [ stat>type ]
- [ stat-st_size ]
- [ stat-st_mode ]
- [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
- } cleave
- \ file-info boa ;
+HOOK: stat>type os ( stat -- file-info )
+
+HOOK: new-file-info os ( -- class )
+
+TUPLE: unix-file-info < file-info uid gid dev ino
+nlink rdev blocks blocksize ;
M: unix file-info ( path -- info )
normalize-path file-status stat>file-info ;
@@ -105,4 +93,46 @@ M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ;
M: unix read-link ( path -- path' )
- normalize-path read-symbolic-link ;
\ No newline at end of file
+ normalize-path read-symbolic-link ;
+
+M: unix new-file-info ( -- class ) unix-file-info new ;
+
+M: unix stat>file-info ( stat -- file-info )
+ [ new-file-info ] dip
+ {
+ [ stat>type >>type ]
+ [ stat-st_size >>size ]
+ [ stat-st_mode >>permissions ]
+ [ stat-st_ctimespec timespec>unix-time >>created ]
+ [ stat-st_mtimespec timespec>unix-time >>modified ]
+ [ stat-st_atimespec timespec>unix-time >>accessed ]
+ [ stat-st_uid >>uid ]
+ [ stat-st_gid >>gid ]
+ [ stat-st_dev >>dev ]
+ [ stat-st_ino >>ino ]
+ [ stat-st_nlink >>nlink ]
+ [ stat-st_rdev >>rdev ]
+ [ stat-st_blocks >>blocks ]
+ [ stat-st_blksize >>blocksize ]
+ } cleave ;
+
+M: unix stat>type ( stat -- type )
+ stat-st_mode S_IFMT bitand {
+ { S_IFREG [ +regular-file+ ] }
+ { S_IFDIR [ +directory+ ] }
+ { S_IFCHR [ +character-device+ ] }
+ { S_IFBLK [ +block-device+ ] }
+ { S_IFIFO [ +fifo+ ] }
+ { S_IFLNK [ +symbolic-link+ ] }
+ { S_IFSOCK [ +socket+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+! Linux has no extra fields in its stat struct
+os {
+ { macosx [ "io.unix.files.bsd" require ] }
+ { netbsd [ "io.unix.files.bsd" require ] }
+ { openbsd [ "io.unix.files.bsd" require ] }
+ { freebsd [ "io.unix.files.bsd" require ] }
+ { linux [ ] }
+} case
diff --git a/basis/io/unix/files/unique/unique.factor b/basis/io/unix/files/unique/unique.factor
index 95e321fd93..e47ac6a2e3 100644
--- a/basis/io/unix/files/unique/unique.factor
+++ b/basis/io/unix/files/unique/unique.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.unix.backend math.bitwise
unix io.files.unique.backend system ;
IN: io.unix.files.unique
diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/launcher/launcher-tests.factor b/basis/io/unix/launcher/launcher-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/launcher/parser/parser-tests.factor b/basis/io/unix/launcher/parser/parser-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/launcher/parser/parser.factor b/basis/io/unix/launcher/parser/parser.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/linux/linux.factor b/basis/io/unix/linux/linux.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/mmap/mmap.factor b/basis/io/unix/mmap/mmap.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/select/select.factor b/basis/io/unix/select/select.factor
old mode 100755
new mode 100644
index f0547da10e..f2a802a859
--- a/basis/io/unix/select/select.factor
+++ b/basis/io/unix/select/select.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.ports io.unix.backend
-bit-arrays sequences assocs unix math namespaces structs
-accessors math.order locals ;
+bit-arrays sequences assocs unix math namespaces
+accessors math.order locals unix.time ;
IN: io.unix.select
TUPLE: select-mx < mx read-fdset write-fdset ;
diff --git a/basis/io/unix/sockets/secure/secure.factor b/basis/io/unix/sockets/secure/secure.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/sockets/sockets.factor b/basis/io/unix/sockets/sockets.factor
old mode 100755
new mode 100644
index 50952dd217..8f9ff4f066
--- a/basis/io/unix/sockets/sockets.factor
+++ b/basis/io/unix/sockets/sockets.factor
@@ -139,7 +139,9 @@ M: unix (send) ( packet addrspec datagram -- )
! Unix domain sockets
M: local protocol-family drop PF_UNIX ;
-M: local sockaddr-type drop "sockaddr-un" c-type ;
+M: local sockaddr-size drop "sockaddr-un" heap-size ;
+
+M: local empty-sockaddr drop "sockaddr-un" <c-object> ;
M: local make-sockaddr
path>> (normalize-path)
diff --git a/basis/io/unix/unix-tests.factor b/basis/io/unix/unix-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/unix/unix.factor b/basis/io/unix/unix.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor
old mode 100755
new mode 100644
index 40e7e17402..dbe16f0a6e
--- a/basis/io/windows/files/files.factor
+++ b/basis/io/windows/files/files.factor
@@ -147,18 +147,18 @@ SYMBOLS: +read-only+ +hidden+ +system+
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
+ [ \ file-info new ] dip
{
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
[
[ WIN32_FIND_DATA-nFileSizeLow ]
- [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
+ [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
]
- [ WIN32_FIND_DATA-dwFileAttributes ]
- ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ]
- [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
- ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
- } cleave
- \ file-info boa ;
+ [ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
+ [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
+ [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
+ [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
+ } cleave ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object> [
@@ -168,23 +168,32 @@ SYMBOLS: +read-only+ +hidden+ +system+
] keep ;
: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
+ [ \ file-info new ] dip
{
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
[
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
- [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
+ [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
+ ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
+ [
+ BY_HANDLE_FILE_INFORMATION-ftCreationTime
+ FILETIME>timestamp >>created
+ ]
+ [
+ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
+ FILETIME>timestamp >>modified
+ ]
+ [
+ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
+ FILETIME>timestamp >>accessed
]
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ]
- ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
- [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
- ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
! [
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
! ]
- } cleave
- \ file-info boa ;
+ } cleave ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
diff --git a/basis/io/windows/files/unique/unique.factor b/basis/io/windows/files/unique/unique.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/launcher/launcher-tests.factor b/basis/io/windows/launcher/launcher-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/mmap/mmap.factor b/basis/io/windows/mmap/mmap.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/backend/backend.factor b/basis/io/windows/nt/backend/backend.factor
old mode 100755
new mode 100644
index 7fbc1dbcf9..73b77508b7
--- a/basis/io/windows/nt/backend/backend.factor
+++ b/basis/io/windows/nt/backend/backend.factor
@@ -1,9 +1,9 @@
USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.ports io.timeouts
-io.windows io.windows.files libc kernel math namespaces
-sequences threads windows windows.errors windows.kernel32
-strings splitting io.files io.buffers qualified ascii system
-accessors locals ;
+io.windows io.windows.files io.files io.buffers io.streams.c
+libc kernel math namespaces sequences threads windows
+windows.errors windows.kernel32 strings splitting qualified
+ascii system accessors locals ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
@@ -120,3 +120,5 @@ M: winnt (wait-to-read) ( port -- )
[ finish-read ]
tri
] with-destructors ;
+
+M: winnt (init-stdio) init-c-stdio ;
diff --git a/basis/io/windows/nt/files/files-tests.factor b/basis/io/windows/nt/files/files-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/launcher/launcher-tests.factor b/basis/io/windows/nt/launcher/launcher-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/launcher/launcher.factor b/basis/io/windows/nt/launcher/launcher.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/launcher/test/append.factor b/basis/io/windows/nt/launcher/test/append.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/launcher/test/env.factor b/basis/io/windows/nt/launcher/test/env.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/launcher/test/stderr.factor b/basis/io/windows/nt/launcher/test/stderr.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/monitors/monitors-tests.factor b/basis/io/windows/nt/monitors/monitors-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/monitors/monitors.factor b/basis/io/windows/nt/monitors/monitors.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/nt.factor b/basis/io/windows/nt/nt.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/pipes/pipes.factor b/basis/io/windows/nt/pipes/pipes.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/privileges/privileges.factor b/basis/io/windows/nt/privileges/privileges.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/nt/sockets/sockets.factor b/basis/io/windows/nt/sockets/sockets.factor
old mode 100755
new mode 100644
index 41c5e88f5f..5d94cf2d4a
--- a/basis/io/windows/nt/sockets/sockets.factor
+++ b/basis/io/windows/nt/sockets/sockets.factor
@@ -71,7 +71,7 @@ TUPLE: AcceptEx-args port
dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
: init-accept-buffer ( addr AcceptEx -- )
- swap sockaddr-type heap-size 16 +
+ swap sockaddr-size 16 +
[ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
drop ; inline
@@ -135,7 +135,7 @@ TUPLE: WSARecvFrom-args port
WSARecvFrom-args new
swap >>port
dup port>> handle>> handle>> >>s
- dup port>> addr>> sockaddr-type heap-size
+ dup port>> addr>> sockaddr-size
[ malloc &free >>lpFrom ]
[ malloc-int &free >>lpFromLen ] bi
make-receive-buffer >>lpBuffers
diff --git a/basis/io/windows/privileges/privileges.factor b/basis/io/windows/privileges/privileges.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/sockets/sockets.factor b/basis/io/windows/sockets/sockets.factor
old mode 100755
new mode 100644
diff --git a/basis/io/windows/windows.factor b/basis/io/windows/windows.factor
old mode 100755
new mode 100644
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
old mode 100755
new mode 100644
diff --git a/basis/lcs/lcs-docs.factor b/basis/lcs/lcs-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/lcs/lcs-tests.factor b/basis/lcs/lcs-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor
old mode 100755
new mode 100644
diff --git a/basis/libc/libc-tests.factor b/basis/libc/libc-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor
old mode 100755
new mode 100644
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
old mode 100755
new mode 100644
diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
old mode 100755
new mode 100644
diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor
old mode 100755
new mode 100644
diff --git a/basis/logging/insomniac/insomniac-docs.factor b/basis/logging/insomniac/insomniac-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/logging/insomniac/insomniac.factor b/basis/logging/insomniac/insomniac.factor
old mode 100755
new mode 100644
diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor
old mode 100755
new mode 100644
diff --git a/basis/logging/parser/parser.factor b/basis/logging/parser/parser.factor
old mode 100755
new mode 100644
diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor
old mode 100755
new mode 100644
diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor
old mode 100755
new mode 100644
diff --git a/basis/match/match-tests.factor b/basis/match/match-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/match/match.factor b/basis/match/match.factor
old mode 100755
new mode 100644
diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/math/complex/complex-tests.factor b/basis/math/complex/complex-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor
old mode 100755
new mode 100644
diff --git a/basis/math/constants/constants-docs.factor b/basis/math/constants/constants-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/math/constants/constants.factor b/basis/math/constants/constants.factor
old mode 100755
new mode 100644
diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
old mode 100755
new mode 100644
diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor
old mode 100755
new mode 100644
index 7d8d496737..ad2fb53dc4
--- a/basis/math/intervals/intervals-tests.factor
+++ b/basis/math/intervals/intervals-tests.factor
@@ -1,6 +1,6 @@
USING: math.intervals kernel sequences words math math.order
arrays prettyprint tools.test random vocabs combinators
-accessors ;
+accessors math.constants ;
IN: math.intervals.tests
[ empty-interval ] [ 2 2 (a,b) ] unit-test
diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor
old mode 100755
new mode 100644
index 7c3bf27e9d..213bfce354
--- a/basis/math/intervals/intervals.factor
+++ b/basis/math/intervals/intervals.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order
diff --git a/basis/math/libm/libm.factor b/basis/math/libm/libm.factor
old mode 100755
new mode 100644
diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor
old mode 100755
new mode 100644
diff --git a/basis/math/ratios/ratios-docs.factor b/basis/math/ratios/ratios-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/math/ratios/ratios-tests.factor b/basis/math/ratios/ratios-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor
old mode 100755
new mode 100644
diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor
old mode 100755
new mode 100644
diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor
old mode 100755
new mode 100644
diff --git a/basis/mime-types/mime-types.factor b/basis/mime-types/mime-types.factor
old mode 100755
new mode 100644
diff --git a/basis/mirrors/mirrors-docs.factor b/basis/mirrors/mirrors-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor
old mode 100755
new mode 100644
diff --git a/basis/models/compose/compose-docs.factor b/basis/models/compose/compose-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/models/compose/compose-tests.factor b/basis/models/compose/compose-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/models/compose/compose.factor b/basis/models/compose/compose.factor
old mode 100755
new mode 100644
diff --git a/basis/models/delay/delay-docs.factor b/basis/models/delay/delay-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/models/delay/delay.factor b/basis/models/delay/delay.factor
old mode 100755
new mode 100644
diff --git a/basis/models/filter/filter-docs.factor b/basis/models/filter/filter-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/models/filter/filter-tests.factor b/basis/models/filter/filter-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/models/filter/filter.factor b/basis/models/filter/filter.factor
old mode 100755
new mode 100644
diff --git a/basis/models/history/history-docs.factor b/basis/models/history/history-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/models/history/history-tests.factor b/basis/models/history/history-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/models/history/history.factor b/basis/models/history/history.factor
old mode 100755
new mode 100644
diff --git a/basis/models/mapping/mapping-tests.factor b/basis/models/mapping/mapping-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/models/mapping/mapping.factor b/basis/models/mapping/mapping.factor
old mode 100755
new mode 100644
diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/models/models-tests.factor b/basis/models/models-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/models/models.factor b/basis/models/models.factor
old mode 100755
new mode 100644
diff --git a/basis/models/range/range-docs.factor b/basis/models/range/range-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/models/range/range-tests.factor b/basis/models/range/range-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/models/range/range.factor b/basis/models/range/range.factor
old mode 100755
new mode 100644
diff --git a/basis/multiline/multiline-tests.factor b/basis/multiline/multiline-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor
old mode 100755
new mode 100644
diff --git a/basis/opengl/gl/windows/windows.factor b/basis/opengl/gl/windows/windows.factor
old mode 100755
new mode 100644
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
old mode 100755
new mode 100644
diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor
old mode 100755
new mode 100644
diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor
old mode 100755
new mode 100644
diff --git a/basis/openssl/openssl-tests.factor b/basis/openssl/openssl-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/openssl/openssl.factor b/basis/openssl/openssl.factor
old mode 100755
new mode 100644
diff --git a/basis/peg/parsers/parsers-docs.factor b/basis/peg/parsers/parsers-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor
old mode 100755
new mode 100644
diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor
old mode 100755
new mode 100644
diff --git a/basis/peg/search/search-docs.factor b/basis/peg/search/search-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/peg/search/search-tests.factor b/basis/peg/search/search-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/peg/search/search.factor b/basis/peg/search/search.factor
old mode 100755
new mode 100644
diff --git a/basis/present/present-docs.factor b/basis/present/present-docs.factor
index f148d96b32..bda7723173 100644
--- a/basis/present/present-docs.factor
+++ b/basis/present/present-docs.factor
@@ -8,6 +8,6 @@ ARTICLE: "present" "Converting objects to human-readable strings"
HELP: present
{ $values { "object" object } { "string" string } }
{ $contract "Outputs a human-readable string from an object." }
-{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $link "html.components" } " or " { $link "urls" } " vocabularies." } ;
+{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $link "urls" } " vocabularies." } ;
ABOUT: "present"
diff --git a/basis/prettyprint/backend/backend-docs.factor b/basis/prettyprint/backend/backend-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
old mode 100755
new mode 100644
diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
old mode 100755
new mode 100644
diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/qualified/qualified-docs.factor b/basis/qualified/qualified-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/random/dummy/dummy.factor b/basis/random/dummy/dummy.factor
old mode 100755
new mode 100644
diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor
old mode 100755
new mode 100644
index 3f0ebf692a..8a2a5031fa
--- a/basis/random/mersenne-twister/mersenne-twister-tests.factor
+++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor
@@ -3,17 +3,17 @@ random.mersenne-twister sequences tools.test math.order ;
IN: random.mersenne-twister.tests
: check-random ( max -- ? )
- dup >r random 0 r> between? ;
+ [ random 0 ] keep between? ;
[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test
-: make-100-randoms
- [ 100 [ 100 random , ] times ] { } make ;
+: randoms ( -- seq )
+ 100 [ 100 random ] replicate ;
: test-rng ( seed quot -- )
>r <mersenne-twister> r> with-random ;
-[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test
+[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
[ 1333075495 ] [
0 [ 1000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng
diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor
old mode 100755
new mode 100644
diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor
old mode 100644
new mode 100755
index 74751328d5..18c9ca781c
--- a/basis/random/random-docs.factor
+++ b/basis/random/random-docs.factor
@@ -1,12 +1,6 @@
-USING: help.markup help.syntax math ;
+USING: help.markup help.syntax math kernel sequences ;
IN: random
-ARTICLE: "random-numbers" "Generating random integers"
-"The " { $vocab-link "random" } " vocabulary implements the ``Mersenne Twister'' pseudo-random number generator algorithm."
-{ $subsection random } ;
-
-ABOUT: "random-numbers"
-
HELP: seed-random
{ $values { "tuple" "a random number generator" } { "seed" "an integer between 0 and 2^32-1" } }
{ $description "Seed the random number generator." }
@@ -21,9 +15,19 @@ HELP: random-bytes*
{ $description "Generates a byte-array of random bytes." } ;
HELP: random
-{ $values { "seq" "a sequence" } { "elt" "a random element" } }
-{ $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." }
-{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ;
+{ $values { "seq" sequence } { "elt" "a random element" } }
+{ $description "Outputs a random element of the input sequence. Outputs " { $link f } " if the sequence is empty." }
+{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " outputs an integer in the interval " { $snippet "[0,n)" } "." }
+{ $examples
+ { $unchecked-example "USING: random prettyprint ;"
+ "10 random ."
+ "3" }
+ { $unchecked-example "USING: random prettyprint ;"
+ "SYMBOL: heads"
+ "SYMBOL: tails"
+ "{ heads tails } random ."
+ "heads" }
+} ;
HELP: random-bytes
{ $values { "n" "an integer" } { "byte-array" "a random integer" } }
@@ -47,4 +51,39 @@ HELP: with-secure-random
{ $values { "quot" "a quotation" } }
{ $description "Calls the quotation with the secure random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
-{ with-random with-secure-random } related-words
+HELP: with-system-random
+{ $values { "quot" "a quotation" } }
+{ $description "Calls the quotation with the system's random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
+
+{ with-random with-secure-random with-system-random } related-words
+
+HELP: delete-random
+{ $values
+ { "seq" sequence }
+ { "elt" object } }
+{ $description "Deletes a random number from a sequence using " { $link delete-nth } " and returns the deleted object." } ;
+
+ARTICLE: "random-protocol" "Random protocol"
+"A random number generator must implement one of these two words:"
+{ $subsection random-32* }
+{ $subsection random-bytes* }
+"Optional, to seed a random number generator:"
+{ $subsection seed-random } ;
+
+ARTICLE: "random" "Generating random integers"
+"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers."
+$nl
+"The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
+$nl
+"Generate a random object:"
+{ $subsection random }
+"Combinators to change the random number generator:"
+{ $subsection with-random }
+{ $subsection with-system-random }
+{ $subsection with-secure-random }
+"Implementation:"
+{ $subsection "random-protocol" }
+"Deleting a random element from a sequence:"
+{ $subsection delete-random } ;
+
+ABOUT: "random"
diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor
index 89c0c02c4a..e686dd7301 100644
--- a/basis/random/random-tests.factor
+++ b/basis/random/random-tests.factor
@@ -15,3 +15,5 @@ IN: random.tests
[ t ] [ 10000 [ 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test
[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
+
+[ f ] [ 0 random ] unit-test
diff --git a/basis/random/random.factor b/basis/random/random.factor
index 5ee45e6729..845f8e004f 100755
--- a/basis/random/random.factor
+++ b/basis/random/random.factor
@@ -33,19 +33,24 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
random-generator get random-bytes*
] keep head ;
+<PRIVATE
+
+: random-integer ( n -- n' )
+ dup log2 7 + 8 /i 1+
+ [ random-bytes byte-array>bignum ]
+ [ 3 shift 2^ ] bi / * >integer ;
+
+PRIVATE>
+
+: random-bits ( n -- r ) 2^ random-integer ;
+
: random ( seq -- elt )
[ f ] [
- [
- length dup log2 7 + 8 /i 1+
- [ random-bytes byte-array>bignum ]
- [ 3 shift 2^ ] bi / * >integer
- ] keep nth
+ [ length random-integer ] keep nth
] if-empty ;
: delete-random ( seq -- elt )
- [ length random ] keep [ nth ] 2keep delete-nth ;
-
-: random-bits ( n -- r ) 2^ random ;
+ [ length random-integer ] keep [ nth ] 2keep delete-nth ;
: with-random ( tuple quot -- )
random-generator swap with-variable ; inline
diff --git a/basis/sequences/deep/deep-tests.factor b/basis/sequences/deep/deep-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/sequences/next/next.factor b/basis/sequences/next/next.factor
old mode 100755
new mode 100644
diff --git a/basis/serialize/serialize-docs.factor b/basis/serialize/serialize-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor
old mode 100755
new mode 100644
diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor
old mode 100755
new mode 100644
diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
old mode 100755
new mode 100644
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
old mode 100755
new mode 100644
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
old mode 100755
new mode 100644
diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor
old mode 100755
new mode 100644
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
old mode 100755
new mode 100644
diff --git a/basis/stack-checker/transforms/transforms-docs.factor b/basis/stack-checker/transforms/transforms-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
old mode 100755
new mode 100644
diff --git a/basis/state-parser/state-parser-tests.factor b/basis/state-parser/state-parser-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/structs/authors.txt b/basis/structs/authors.txt
deleted file mode 100755
index 7c1b2f2279..0000000000
--- a/basis/structs/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/basis/structs/structs.factor b/basis/structs/structs.factor
deleted file mode 100644
index f54917dc47..0000000000
--- a/basis/structs/structs.factor
+++ /dev/null
@@ -1,12 +0,0 @@
-USING: alien.c-types alien.syntax kernel math ;
-IN: structs
-
-C-STRUCT: timeval
- { "long" "sec" }
- { "long" "usec" } ;
-
-: make-timeval ( ms -- timeval )
- 1000 /mod 1000 *
- "timeval" <c-object>
- [ set-timeval-usec ] keep
- [ set-timeval-sec ] keep ;
diff --git a/basis/structs/summary.txt b/basis/structs/summary.txt
deleted file mode 100644
index 86d6ad349e..0000000000
--- a/basis/structs/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Cross-platform C structs
diff --git a/basis/symbols/symbols-tests.factor b/basis/symbols/symbols-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/symbols/symbols.factor b/basis/symbols/symbols.factor
old mode 100755
new mode 100644
diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/crossref/test/foo.factor b/basis/tools/crossref/test/foo.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor
old mode 100755
new mode 100644
index cb899f4b87..a0565c6bab
--- a/basis/tools/deploy/backend/backend.factor
+++ b/basis/tools/deploy/backend/backend.factor
@@ -10,13 +10,15 @@ io.encodings.utf8 destructors accessors ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name extension -- vm )
- [ prepend-path ] dip append vm over copy-file ;
+ [ prepend-path ] dip append vm over copy-file ;
: copy-fonts ( name dir -- )
- append-path "resource:fonts/" swap copy-tree-into ;
+ deploy-ui? get [
+ append-path "resource:fonts/" swap copy-tree-into
+ ] [ 2drop ] if ;
: image-name ( vocab bundle-name -- str )
- prepend-path ".image" append ;
+ prepend-path ".image" append ;
: copy-lines ( -- )
readln [ print flush copy-lines ] when* ;
diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor
old mode 100755
new mode 100644
index 1d5b59bf0c..db4255cdb1
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/basis/tools/deploy/deploy-tests.factor
@@ -66,7 +66,7 @@ http.server.responses http.server.static io.servers.connection ;
SINGLETON: quit-responder
M: quit-responder call-responder*
- 2drop stop-server "Goodbye" "text/html" <content> ;
+ 2drop stop-this-server "Goodbye" "text/html" <content> ;
: add-quot-responder ( responder -- responder )
quit-responder "quit" add-responder ;
diff --git a/basis/tools/deploy/deploy.factor b/basis/tools/deploy/deploy.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor
old mode 100755
new mode 100644
index ee60ce3982..d3464993e1
--- a/basis/tools/deploy/macosx/macosx.factor
+++ b/basis/tools/deploy/macosx/macosx.factor
@@ -4,7 +4,7 @@ USING: io io.files kernel namespaces make sequences
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
io.backend cocoa.application cocoa.classes cocoa.plists
-qualified ;
+qualified combinators ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
@@ -30,12 +30,26 @@ IN: tools.deploy.macosx
"Contents/Info.plist" append-path
write-plist ;
+: copy-dll ( bundle-name -- )
+ "Frameworks/libfactor.dylib" copy-bundle-dir ;
+
+: copy-freetype ( bundle-name -- )
+ deploy-ui? get [ "Frameworks" copy-bundle-dir ] [ drop ] if ;
+
+: copy-nib ( bundle-name -- )
+ deploy-ui? get [
+ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
+ ] [ drop ] if ;
+
: create-app-dir ( vocab bundle-name -- vm )
[
- nip
- [ "Frameworks" copy-bundle-dir ]
- [ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir ]
- [ "Contents/Resources/" copy-fonts ] tri
+ nip {
+ [ copy-dll ]
+ [ copy-freetype ]
+ [ copy-nib ]
+ [ "Contents/Resources/" copy-fonts ]
+ [ "Contents/Resources" append-path make-directories ]
+ } cleave
]
[ create-app-plist ]
[ "Contents/MacOS/" append-path "" copy-vm ] 2tri ;
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index f8b0862c9d..d9348bedd5 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -1,20 +1,18 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors qualified io.streams.c init fry namespaces make
-assocs kernel parser lexer strings.parser tools.deploy.config
-vocabs sequences words words.private memory kernel.private
-continuations io prettyprint vocabs.loader debugger system
-strings sets vectors quotations byte-arrays sorting ;
+USING: accessors qualified io.backend io.streams.c init fry
+namespaces make assocs kernel parser lexer strings.parser
+tools.deploy.config vocabs sequences words words.private memory
+kernel.private continuations io prettyprint vocabs.loader
+debugger system strings sets vectors quotations byte-arrays
+sorting compiler.units definitions ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: compiler.errors.private
-QUALIFIED: compiler.units
QUALIFIED: continuations
QUALIFIED: definitions
QUALIFIED: init
-QUALIFIED: io.backend
-QUALIFIED: io.thread
QUALIFIED: layouts
QUALIFIED: listener
QUALIFIED: prettyprint.config
@@ -87,8 +85,8 @@ IN: tools.deploy.shaker
] change-props drop
] each
] [
- "Remaining word properties:" print
- [ props>> keys ] gather .
+ "Remaining word properties:\n" show
+ [ props>> keys ] gather unparse show
] [
H{ } clone '[
[ [ _ [ ] cache ] map ] change-props drop
@@ -198,11 +196,6 @@ IN: tools.deploy.shaker
strip-word-names? [ dup strip-word-names ] when
2drop ;
-: 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 swap diff ;
@@ -220,20 +213,21 @@ IN: tools.deploy.shaker
continuations:restarts
listener:error-hook
init:init-hooks
- io.thread:io-thread
source-files:source-files
input-stream
output-stream
error-stream
} %
+ "io-thread" "io.thread" lookup ,
+
"mallocs" "libc.private" lookup ,
deploy-threads? [
"initial-thread" "threads" lookup ,
] unless
- strip-io? [ io.backend:io-backend , ] when
+ strip-io? [ io-backend , ] when
{ } {
"alarms"
@@ -260,9 +254,9 @@ IN: tools.deploy.shaker
command-line:main-vocab-hook
compiled-crossref
compiled-generic-crossref
- compiler.units:recompile-hook
- compiler.units:update-tuples-hook
- compiler.units:definition-observers
+ recompile-hook
+ update-tuples-hook
+ definition-observers
definitions:crossref
interactive-vocabs
layouts:num-tags
@@ -326,6 +320,14 @@ IN: tools.deploy.shaker
21 setenv
] [ drop ] if ;
+: strip-c-io ( -- )
+ deploy-io get 2 = os windows? or [
+ [
+ c-io-backend forget
+ "io.streams.c" forget-vocab
+ ] with-compilation-unit
+ ] unless ;
+
: compress ( pred string -- )
"Compressing " prepend show
instances
@@ -358,22 +360,29 @@ SYMBOL: deploy-vocab
init-hooks get values concat %
,
strip-io? [ \ flush , ] unless
- ] [ ] make "Boot quotation: " write dup . flush
+ ] [ ] make "Boot quotation: " show dup unparse show
set-boot-quot ;
+: init-stripper ( -- )
+ t "quiet" set-global
+ f output-stream set-global ;
+
: strip ( -- )
+ init-stripper
strip-libc
strip-cocoa
strip-debugger
- strip-recompile-hook
strip-init-hooks
+ strip-c-io
+ f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main set-boot-quot*
stripped-word-props >r
stripped-globals strip-globals
r> strip-words
compress-byte-arrays
compress-quotations
- compress-strings ;
+ compress-strings
+ H{ } clone classes:next-method-quot-cache set-global ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave
diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor
old mode 100755
new mode 100644
index 2cf803e270..d5249dc20c
--- a/basis/tools/deploy/shaker/strip-cocoa.factor
+++ b/basis/tools/deploy/shaker/strip-cocoa.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
namespaces kernel kernel.private words compiler.units sequences
-ui ui.cocoa init ;
+init vocabs ;
IN: tools.deploy.shaker.cocoa
: pool ( obj -- obj' ) \ pool get [ ] cache ;
@@ -23,9 +23,12 @@ IN: cocoa.application
H{ } clone \ pool [
global [
- stop-after-last-window? set
+ "stop-after-last-window?" "ui" lookup set
- [ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
+ "ui.cocoa" vocab [
+ [ "MiniFactor.nib" load-nib ]
+ "cocoa-init-hook" "ui.cocoa" lookup set-global
+ ] when
! Only keeps those methods that we actually call
sent-messages get super-sent-messages get assoc-union
diff --git a/basis/tools/deploy/shaker/strip-debugger.factor b/basis/tools/deploy/shaker/strip-debugger.factor
old mode 100755
new mode 100644
index 2302b61715..bdcc6c237e
--- a/basis/tools/deploy/shaker/strip-debugger.factor
+++ b/basis/tools/deploy/shaker/strip-debugger.factor
@@ -1,8 +1,14 @@
-USING: kernel threads threads.private ;
+USING: compiler.units words vocabs kernel threads.private ;
IN: debugger
: print-error ( error -- ) die drop ;
: error. ( error -- ) die drop ;
-M: thread error-in-thread ( error thread -- ) die 2drop ;
+"threads" vocab [
+ [
+ "error-in-thread" "threads" lookup
+ [ die 2drop ]
+ define
+ ] with-compilation-unit
+] when
diff --git a/basis/tools/deploy/shaker/strip-libc.factor b/basis/tools/deploy/shaker/strip-libc.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/test/1/1.factor b/basis/tools/deploy/test/1/1.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/test/2/2.factor b/basis/tools/deploy/test/2/2.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/test/3/3.factor b/basis/tools/deploy/test/3/3.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor
index 410bb770be..e7d3764d39 100644
--- a/basis/tools/deploy/test/6/deploy.factor
+++ b/basis/tools/deploy/test/6/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-threads? f }
- { deploy-ui? f }
- { deploy-io 1 }
- { deploy-c-types? f }
- { deploy-name "tools.deploy.test.6" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ deploy-word-props? f }
+ { deploy-io 1 }
+ { deploy-name "tools.deploy.test.6" }
+ { deploy-math? t }
+ { deploy-random? f }
+ { deploy-compiler? t }
+ { deploy-ui? f }
+ { deploy-c-types? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
- { deploy-random? f }
- { deploy-math? f }
+ { deploy-threads? f }
}
diff --git a/basis/tools/deploy/windows/windows-tests.factor b/basis/tools/deploy/windows/windows-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor
index e0ce2c268a..ad1b3cbd84 100755
--- a/basis/tools/deploy/windows/windows.factor
+++ b/basis/tools/deploy/windows/windows.factor
@@ -5,16 +5,23 @@ tools.deploy.backend tools.deploy.config assocs hashtables
prettyprint combinators windows.shell32 windows.user32 ;
IN: tools.deploy.windows
-: copy-dlls ( bundle-name -- )
- {
- "resource:freetype6.dll"
- "resource:zlib1.dll"
- "resource:factor.dll"
- } swap copy-files-into ;
+: copy-dll ( bundle-name -- )
+ "resource:factor.dll" swap copy-file-into ;
+
+: copy-freetype ( bundle-name -- )
+ deploy-ui? get [
+ {
+ "resource:freetype6.dll"
+ "resource:zlib1.dll"
+ } swap copy-files-into
+ ] [ drop ] if ;
: create-exe-dir ( vocab bundle-name -- vm )
- dup copy-dlls
- dup "" copy-fonts
+ deploy-ui? get [
+ dup copy-dll
+ dup copy-freetype
+ dup "" copy-fonts
+ ] when
".exe" copy-vm ;
M: winnt deploy*
diff --git a/basis/tools/disassembler/disassembler-docs.factor b/basis/tools/disassembler/disassembler-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/disassembler/disassembler-tests.factor b/basis/tools/disassembler/disassembler-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/memory/memory-docs.factor b/basis/tools/memory/memory-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/scaffold/scaffold-docs.factor b/basis/tools/scaffold/scaffold-docs.factor
index 479b636fcf..d2989d3cac 100644
--- a/basis/tools/scaffold/scaffold-docs.factor
+++ b/basis/tools/scaffold/scaffold-docs.factor
@@ -5,7 +5,7 @@ IN: tools.scaffold
HELP: developer-name
{ $description "Set this symbol to hold your name so that the scaffold tools can generate the correct file header for copyright. Setting this variable in your .factor-boot-rc file is recommended." }
-{ $unchecked-example "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ;
+{ $code "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ;
HELP: help.
{ $values
diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/test/ui/ui.factor b/basis/tools/test/ui/ui.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/time/time-docs.factor b/basis/tools/time/time-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/vocabs/browser/browser-docs.factor b/basis/tools/vocabs/browser/browser-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/vocabs/browser/browser-tests.factor b/basis/tools/vocabs/browser/browser-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/tools/vocabs/monitor/monitor.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/vocabs/vocabs-docs.factor b/basis/tools/vocabs/vocabs-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/walker/debug/debug.factor b/basis/tools/walker/debug/debug.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor
old mode 100755
new mode 100644
diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/cocoa/tools/tools.factor b/basis/ui/cocoa/tools/tools.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/freetype/freetype-docs.factor b/basis/ui/freetype/freetype-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/books/books-docs.factor b/basis/ui/gadgets/books/books-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/books/books-tests.factor b/basis/ui/gadgets/books/books-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/books/books.factor b/basis/ui/gadgets/books/books.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/canvas/canvas-tests.factor b/basis/ui/gadgets/canvas/canvas-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/frames/frames-docs.factor b/basis/ui/gadgets/frames/frames-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/gadgets-docs.factor b/basis/ui/gadgets/gadgets-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/grid-lines/grid-lines-docs.factor b/basis/ui/gadgets/grid-lines/grid-lines-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/grids/grids-docs.factor b/basis/ui/gadgets/grids/grids-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/incremental/incremental-docs.factor b/basis/ui/gadgets/incremental/incremental-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/labelled/labelled-docs.factor b/basis/ui/gadgets/labelled/labelled-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/labels/labels-docs.factor b/basis/ui/gadgets/labels/labels-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/lists/lists-docs.factor b/basis/ui/gadgets/lists/lists-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/packs/packs-docs.factor b/basis/ui/gadgets/packs/packs-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/panes/panes-docs.factor b/basis/ui/gadgets/panes/panes-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/presentations/presentations-docs.factor b/basis/ui/gadgets/presentations/presentations-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/theme/theme.factor b/basis/ui/gadgets/theme/theme.factor
index 46fa0105a3..5e4a2fbf4c 100644
--- a/basis/ui/gadgets/theme/theme.factor
+++ b/basis/ui/gadgets/theme/theme.factor
@@ -2,7 +2,8 @@
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors accessors ;
+colors colors.gray qualified accessors ;
+QUALIFIED: colors
IN: ui.gadgets.theme
: solid-interior ( gadget color -- gadget )
@@ -12,7 +13,7 @@ IN: ui.gadgets.theme
<solid> >>boundary ; inline
: faint-boundary ( gadget -- gadget )
- gray solid-boundary ; inline
+ colors:gray solid-boundary ; inline
: selection-color ( -- color ) light-purple ;
diff --git a/basis/ui/gadgets/tracks/tracks-docs.factor b/basis/ui/gadgets/tracks/tracks-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/viewports/viewports-docs.factor b/basis/ui/gadgets/viewports/viewports-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/operations/operations-tests.factor b/basis/ui/operations/operations-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/render/render-docs.factor b/basis/ui/render/render-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/browser/browser-tests.factor b/basis/ui/tools/browser/browser-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/debugger/debugger-docs.factor b/basis/ui/tools/debugger/debugger-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/deploy/deploy-docs.factor b/basis/ui/tools/deploy/deploy-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/interactor/interactor-docs.factor b/basis/ui/tools/interactor/interactor-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/interactor/interactor-tests.factor b/basis/ui/tools/interactor/interactor-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/search/search-tests.factor b/basis/ui/tools/search/search-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/tools-tests.factor b/basis/ui/tools/tools-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/walker/walker-tests.factor b/basis/ui/tools/walker/walker-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/workspace/workspace-tests.factor b/basis/ui/tools/workspace/workspace-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/traverse/traverse-tests.factor b/basis/ui/traverse/traverse-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor
old mode 100755
new mode 100644
diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor
old mode 100755
new mode 100644
diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor
old mode 100755
new mode 100644
index 6aa3e60647..0f2e12119d
--- a/basis/unicode/breaks/breaks.factor
+++ b/basis/unicode/breaks/breaks.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit unicode.categories kernel math
combinators splitting sequences math.parser io.files io assocs
arrays namespaces make math.ranges unicode.normalize values
diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor
old mode 100755
new mode 100644
index 5e961e2d67..3def7b5f48
--- a/basis/unicode/case/case.factor
+++ b/basis/unicode/case/case.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences sequences.next namespaces make
unicode.normalize math unicode.categories combinators
assocs strings splitting kernel accessors ;
@@ -70,17 +72,6 @@ SYMBOL: locale ! Just casing locale, or overall?
: final-sigma ( string -- string )
HEX: 3A3 over member? [ sigma-map ] when ;
-! : map-case ( string string-quot char-quot -- case )
-! [
-! rot [
-! -rot [
-! rot dup special-casing at
-! [ -rot drop call % ]
-! [ -rot nip call , ] ?if
-! ] 2keep
-! ] each 2drop
-! ] "" make ; inline
-
: map-case ( string string-quot char-quot -- case )
[
[
diff --git a/basis/unicode/categories/categories.factor b/basis/unicode/categories/categories.factor
index 4ba96fb9c4..0464e31b12 100644
--- a/basis/unicode/categories/categories.factor
+++ b/basis/unicode/categories/categories.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: unicode.syntax ;
IN: unicode.categories
diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor
old mode 100755
new mode 100644
index bf87c6b7da..be6af2d920
--- a/basis/unicode/collation/collation-tests.factor
+++ b/basis/unicode/collation/collation-tests.factor
@@ -11,11 +11,7 @@ IN: unicode.collation.tests
: test-two ( str1 str2 -- )
[ +lt+ ] -rot [ string<=> ] 2curry unit-test ;
-: failures
- parse-test dup 2 <clumps>
- [ string<=> +lt+ = not ] assoc-filter dup assoc-size ;
-
-: test-equality
+: test-equality ( str1 str2 -- )
{ primary= secondary= tertiary= quaternary= }
[ execute ] with with each ;
diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor
old mode 100755
new mode 100644
index 8e9e2963a8..7f445b8513
--- a/basis/unicode/collation/collation.factor
+++ b/basis/unicode/collation/collation.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit sequences io.files
io.encodings.ascii kernel values splitting accessors math.parser
ascii io assocs strings math namespaces make sorting combinators
@@ -100,8 +102,8 @@ ducet insert-helpers
] { } map-as concat ;
: append-weights ( weights quot -- )
- swap [ ignorable?>> not ] filter
- swap map [ zero? not ] filter % 0 , ;
+ [ [ ignorable?>> not ] filter ] dip
+ map [ zero? not ] filter % 0 , ; inline
: variable-weight ( weight -- )
dup ignorable?>> [ primary>> ] [ drop HEX: FFFF ] if , ;
@@ -135,7 +137,7 @@ PRIVATE>
<PRIVATE
: insensitive= ( str1 str2 levels-removed -- ? )
[
- swap collation-key swap
+ [ collation-key ] dip
[ [ 0 = not ] trim-right but-last ] times
] curry bi@ = ;
PRIVATE>
@@ -158,8 +160,7 @@ PRIVATE>
PRIVATE>
: sort-strings ( strings -- sorted )
- [ w/collation-key ] map
- natural-sort values ;
+ [ w/collation-key ] map natural-sort values ;
: string<=> ( str1 str2 -- <=> )
[ w/collation-key ] compare ;
diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor
old mode 100755
new mode 100644
index cd54b93f2a..31d0be799f
--- a/basis/unicode/data/data.factor
+++ b/basis/unicode/data/data.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit assocs math kernel sequences
io.files hashtables quotations splitting grouping arrays
math.parser hash2 math.order byte-arrays words namespaces words
diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor
old mode 100755
new mode 100644
index 53a38faed4..8d6f6e888a
--- a/basis/unicode/normalize/normalize.factor
+++ b/basis/unicode/normalize/normalize.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces make unicode.data kernel math arrays
locals sorting.insertion accessors ;
IN: unicode.normalize
diff --git a/basis/unicode/script/script-docs.factor b/basis/unicode/script/script-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/unicode/script/script-tests.factor b/basis/unicode/script/script-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/unicode/script/script.factor b/basis/unicode/script/script.factor
old mode 100755
new mode 100644
index 103beb4d2a..9691797128
--- a/basis/unicode/script/script.factor
+++ b/basis/unicode/script/script.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors values kernel sequences assocs io.files
io.encodings ascii math.ranges io splitting math.parser
namespaces make byte-arrays locals math sets io.encodings.ascii
diff --git a/basis/unicode/syntax/syntax.factor b/basis/unicode/syntax/syntax.factor
old mode 100755
new mode 100644
index 1ba76fd380..bf4610ab0d
--- a/basis/unicode/syntax/syntax.factor
+++ b/basis/unicode/syntax/syntax.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data kernel math sequences parser lexer
bit-arrays namespaces make sequences.private arrays quotations
assocs classes.predicate math.order eval ;
diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor
old mode 100755
new mode 100644
diff --git a/basis/unix/linux/ifreq/ifreq.factor b/basis/unix/linux/ifreq/ifreq.factor
old mode 100755
new mode 100644
diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor
old mode 100755
new mode 100644
index 0c08cf0f2b..457d96c7d8
--- a/basis/unix/linux/linux.factor
+++ b/basis/unix/linux/linux.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: unix
USING: alien.syntax ;
+IN: unix
! Linux.
diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor
old mode 100755
new mode 100644
diff --git a/basis/unix/stat/freebsd/32/32.factor b/basis/unix/stat/freebsd/32/32.factor
index a81fc4f02e..3692dea0c0 100644
--- a/basis/unix/stat/freebsd/32/32.factor
+++ b/basis/unix/stat/freebsd/32/32.factor
@@ -12,9 +12,9 @@ C-STRUCT: stat
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
@@ -27,4 +27,4 @@ C-STRUCT: stat
{ "__uint32_t" "pad1" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
\ No newline at end of file
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
diff --git a/basis/unix/stat/freebsd/64/64.factor b/basis/unix/stat/freebsd/64/64.factor
index 75d51cd6ae..73ba676701 100644
--- a/basis/unix/stat/freebsd/64/64.factor
+++ b/basis/unix/stat/freebsd/64/64.factor
@@ -12,9 +12,9 @@ C-STRUCT: stat
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor
index ed53fab86b..3f6c6ba0e0 100644
--- a/basis/unix/stat/linux/32/32.factor
+++ b/basis/unix/stat/linux/32/32.factor
@@ -18,9 +18,9 @@ C-STRUCT: stat
{ "off_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt_t" "st_blocks" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "ulong" "unused4" }
{ "ulong" "unused5" } ;
@@ -30,4 +30,4 @@ FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
: stat ( pathname buf -- int ) 3 -rot __xstat ;
-: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
\ No newline at end of file
+: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor
index a374551385..088ab8d339 100644
--- a/basis/unix/stat/linux/64/64.factor
+++ b/basis/unix/stat/linux/64/64.factor
@@ -17,9 +17,9 @@ C-STRUCT: stat
{ "off_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt_t" "st_blocks" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "long" "__unused0" }
{ "long" "__unused1" }
{ "long" "__unused2" } ;
diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor
index 4d84e38399..b2574b474d 100644
--- a/basis/unix/stat/macosx/macosx.factor
+++ b/basis/unix/stat/macosx/macosx.factor
@@ -1,21 +1,21 @@
-
USING: kernel alien.syntax math ;
-
IN: unix.stat
! Mac OS X ppc
+! stat64 structure
C-STRUCT: stat
{ "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
+ { "ino64_t" "st_ino" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
+ { "timespec" "st_birthtimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
@@ -25,9 +25,8 @@ C-STRUCT: stat
{ "__int64_t" "st_qspare0" }
{ "__int64_t" "st_qspare1" } ;
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
+FUNCTION: int stat64 ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat64 ( char* pathname, stat* buf ) ;
-: stat-st_atim ( stat -- timespec ) stat-st_atimespec ;
-: stat-st_mtim ( stat -- timespec ) stat-st_mtimespec ;
-: stat-st_ctim ( stat -- timespec ) stat-st_ctimespec ;
+: stat ( path buf -- n ) stat64 ;
+: lstat ( path buf -- n ) lstat64 ;
diff --git a/basis/unix/stat/netbsd/32/32.factor b/basis/unix/stat/netbsd/32/32.factor
index 55f5108c70..d6a60ba5c8 100644
--- a/basis/unix/stat/netbsd/32/32.factor
+++ b/basis/unix/stat/netbsd/32/32.factor
@@ -11,10 +11,10 @@ C-STRUCT: stat
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
- { "timespec" "st_birthtim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
+ { "timespec" "st_birthtimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
diff --git a/basis/unix/stat/netbsd/64/64.factor b/basis/unix/stat/netbsd/64/64.factor
index 163695b524..1a1f97507c 100644
--- a/basis/unix/stat/netbsd/64/64.factor
+++ b/basis/unix/stat/netbsd/64/64.factor
@@ -11,16 +11,16 @@ C-STRUCT: stat
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "uint32_t" "st_flags" }
{ "uint32_t" "st_gen" }
{ "uint32_t" "st_spare0" }
- { "timespec" "st_birthtim" } ;
+ { "timespec" "st_birthtimespec" } ;
FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ;
diff --git a/basis/unix/stat/openbsd/openbsd.factor b/basis/unix/stat/openbsd/openbsd.factor
index decfb0dbb1..f76d4c6e18 100644
--- a/basis/unix/stat/openbsd/openbsd.factor
+++ b/basis/unix/stat/openbsd/openbsd.factor
@@ -12,16 +12,16 @@ C-STRUCT: stat
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "int32_t" "st_lspare0" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "int64_t" "st_blocks" }
{ "u_int32_t" "st_blksize" }
{ "u_int32_t" "st_flags" }
{ "u_int32_t" "st_gen" }
{ "int32_t" "st_lspare1" }
- { "timespec" "st_birthtim" }
+ { "timespec" "st_birthtimespec" }
{ { "int64_t" 2 } "st_qspare" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor
index 2bc60105b4..062ad7e1bb 100644
--- a/basis/unix/stat/stat.factor
+++ b/basis/unix/stat/stat.factor
@@ -1,12 +1,8 @@
-
USING: kernel system combinators alien.syntax alien.c-types
- math io.unix.backend vocabs.loader unix ;
-
+math io.unix.backend vocabs.loader unix ;
IN: unix.stat
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! File Types
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: S_IFMT OCT: 170000 ; ! These bits determine file type.
@@ -18,54 +14,38 @@ IN: unix.stat
: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
: S_IFSOCK OCT: 140000 ; inline ! Socket.
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! File Access Permissions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Read, write, execute/search by owner
-: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
+: S_ISUID OCT: 0004000 ; inline
+: S_ISGID OCT: 0002000 ; inline
+: S_ISVTX OCT: 0001000 ; inline
: S_IRUSR OCT: 0000400 ; inline ! r owner
: S_IWUSR OCT: 0000200 ; inline ! w owner
: S_IXUSR OCT: 0000100 ; inline ! x owner
-! Read, write, execute/search by group
-: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
: S_IRGRP OCT: 0000040 ; inline ! r group
: S_IWGRP OCT: 0000020 ; inline ! w group
: S_IXGRP OCT: 0000010 ; inline ! x group
-! Read, write, execute/search by others
-: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
: S_IROTH OCT: 0000004 ; inline ! r other
: S_IWOTH OCT: 0000002 ; inline ! w other
: S_IXOTH OCT: 0000001 ; inline ! x other
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
FUNCTION: int chmod ( char* path, mode_t mode ) ;
-
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
-
FUNCTION: int mkdir ( char* path, mode_t mode ) ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-<<
- os
- {
+<< os {
{ linux [ "unix.stat.linux" require ] }
{ macosx [ "unix.stat.macosx" require ] }
{ freebsd [ "unix.stat.freebsd" require ] }
{ netbsd [ "unix.stat.netbsd" require ] }
{ openbsd [ "unix.stat.openbsd" require ] }
- }
- case
->>
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+} case >>
: file-status ( pathname -- stat )
- "stat" <c-object> dup >r
- [ stat ] unix-system-call drop
- r> ;
+ "stat" <c-object> [
+ [ stat ] unix-system-call drop
+ ] keep ;
: link-status ( pathname -- stat )
- "stat" <c-object> dup >r
- [ lstat ] unix-system-call drop
- r> ;
+ "stat" <c-object> [
+ [ lstat ] unix-system-call drop
+ ] keep ;
diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor
index 4fbb20dca0..c664aa3bfb 100644
--- a/basis/unix/time/time.factor
+++ b/basis/unix/time/time.factor
@@ -1,9 +1,27 @@
-
-USING: kernel alien.syntax alien.c-types math ;
-
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien.syntax alien.c-types math unix.types ;
IN: unix.time
-TYPEDEF: uint time_t
+C-STRUCT: timeval
+ { "long" "sec" }
+ { "long" "usec" } ;
+
+C-STRUCT: timespec
+ { "time_t" "sec" }
+ { "long" "nsec" } ;
+
+: make-timeval ( ms -- timeval )
+ 1000 /mod 1000 *
+ "timeval" <c-object>
+ [ set-timeval-usec ] keep
+ [ set-timeval-sec ] keep ;
+
+: make-timespec ( ms -- timespec )
+ 1000 /mod 1000000 *
+ "timespec" <c-object>
+ [ set-timespec-nsec ] keep
+ [ set-timespec-sec ] keep ;
C-STRUCT: tm
{ "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
@@ -18,16 +36,6 @@ C-STRUCT: tm
{ "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
{ "char*" "zone" } ;
-C-STRUCT: timespec
- { "time_t" "sec" }
- { "long" "nsec" } ;
-
-: make-timespec ( ms -- timespec )
- 1000 /mod 1000000 *
- "timespec" <c-object>
- [ set-timespec-nsec ] keep
- [ set-timespec-sec ] keep ;
-
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ;
diff --git a/basis/unix/types/freebsd/freebsd.factor b/basis/unix/types/freebsd/freebsd.factor
old mode 100755
new mode 100644
diff --git a/basis/unix/types/macosx/macosx.factor b/basis/unix/types/macosx/macosx.factor
index 8f9c5082df..156e756641 100644
--- a/basis/unix/types/macosx/macosx.factor
+++ b/basis/unix/types/macosx/macosx.factor
@@ -22,6 +22,7 @@ TYPEDEF: __uint32_t uid_t
TYPEDEF: __uint32_t gid_t
TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __int64_t ino64_t
TYPEDEF: __int32_t blksize_t
TYPEDEF: long ssize_t
TYPEDEF: __int32_t pid_t
diff --git a/basis/unix/types/netbsd/32/32.factor b/basis/unix/types/netbsd/32/32.factor
old mode 100755
new mode 100644
diff --git a/basis/unix/types/netbsd/64/64.factor b/basis/unix/types/netbsd/64/64.factor
old mode 100755
new mode 100644
diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor
old mode 100755
new mode 100644
diff --git a/basis/unix/types/openbsd/openbsd.factor b/basis/unix/types/openbsd/openbsd.factor
old mode 100755
new mode 100644
diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor
old mode 100755
new mode 100644
index 2011fa0dcb..a68274f09b
--- a/basis/unix/unix.factor
+++ b/basis/unix/unix.factor
@@ -1,12 +1,10 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: alien alien.c-types alien.syntax kernel libc structs sequences
- continuations byte-arrays strings
- math namespaces system combinators vocabs.loader qualified
- accessors stack-checker macros locals generalizations
- unix.types debugger io prettyprint ;
-
+USING: alien alien.c-types alien.syntax kernel libc
+sequences continuations byte-arrays strings math namespaces
+system combinators vocabs.loader qualified accessors
+stack-checker macros locals generalizations unix.types
+debugger io prettyprint ;
IN: unix
TYPEDEF: uint in_addr_t
@@ -109,8 +107,12 @@ FUNCTION: uid_t geteuid ;
FUNCTION: gid_t getgid ;
FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ;
+FUNCTION: passwd* getpwent ( ) ;
FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ;
FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
+FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ;
+
+FUNCTION: group* getgrent ;
FUNCTION: int gethostname ( char* name, int len ) ;
FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
diff --git a/basis/urls/secure/secure.factor b/basis/urls/secure/secure.factor
new file mode 100644
index 0000000000..d2fa55f7f3
--- /dev/null
+++ b/basis/urls/secure/secure.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: urls urls.private io.sockets io.sockets.secure ;
+IN: urls.secure
+
+M: abstract-inet >secure-addr <secure> ;
diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor
index 03ffaded05..b423e6b751 100644
--- a/basis/urls/urls-docs.factor
+++ b/basis/urls/urls-docs.factor
@@ -135,6 +135,12 @@ HELP: relative-url
}
} ;
+HELP: relative-url?
+{ $values
+ { "url" url }
+ { "?" "a boolean" } }
+{ $description "Tests whether a URL is relative." } ;
+
HELP: secure-protocol?
{ $values { "protocol" string } { "?" "a boolean" } }
{ $description "Tests if protocol connections must be made with secure sockets (SSL/TLS)." }
diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index 5cc8c9693b..597cdfdb7f 100644
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit
sequences splitting fry namespaces make assocs arrays strings
-io.sockets io.sockets.secure io.encodings.string
+io.sockets io.encodings.string
io.encodings.utf8 math math.parser accessors parser
strings.parser lexer prettyprint.backend hashtables present
peg.ebnf urls.encoding ;
@@ -155,10 +155,18 @@ PRIVATE>
f >>host
f >>port ;
+: relative-url? ( url -- ? ) protocol>> not ;
+
! Half-baked stuff follows
: secure-protocol? ( protocol -- ? )
"https" = ;
+<PRIVATE
+
+GENERIC: >secure-addr ( addrspec -- addrspec' )
+
+PRIVATE>
+
: url-addr ( url -- addr )
[
[ host>> ]
@@ -166,7 +174,7 @@ PRIVATE>
[ protocol>> protocol-port ]
tri or <inet>
] [ protocol>> ] bi
- secure-protocol? [ <secure> ] when ;
+ secure-protocol? [ >secure-addr ] when ;
: ensure-port ( url -- url )
dup protocol>> '[ _ protocol-port or ] change-port ;
diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/values/values-tests.factor b/basis/values/values-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/values/values.factor b/basis/values/values.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/com/syntax/syntax-docs.factor b/basis/windows/com/syntax/syntax-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/com/wrapper/wrapper-docs.factor b/basis/windows/com/wrapper/wrapper-docs.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/messages/messages.factor b/basis/windows/messages/messages.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor
old mode 100755
new mode 100644
diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor
old mode 100755
new mode 100644
index 3c4230e21e..4ca07ce850
--- a/basis/windows/winsock/winsock.factor
+++ b/basis/windows/winsock/winsock.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
-
+! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors structs windows math.bitwise alias ;
+windows.errors windows math.bitwise alias ;
IN: windows.winsock
USE: libc
@@ -138,6 +138,10 @@ C-STRUCT: addrinfo
{ "sockaddr*" "addr" }
{ "addrinfo*" "next" } ;
+C-STRUCT: timeval
+ { "long" "sec" }
+ { "long" "usec" } ;
+
: hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
LIBRARY: winsock
@@ -440,4 +444,3 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
: init-winsock ( -- )
HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
-
diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor
old mode 100755
new mode 100644
diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor
old mode 100755
new mode 100644
diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor
old mode 100755
new mode 100644
diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor
old mode 100755
new mode 100644
diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor
old mode 100755
new mode 100644
diff --git a/basis/xml/char-classes/char-classes.factor b/basis/xml/char-classes/char-classes.factor
old mode 100755
new mode 100644
diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor
old mode 100755
new mode 100644
diff --git a/basis/xml/errors/errors-tests.factor b/basis/xml/errors/errors-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/xml/tests/soap.factor b/basis/xml/tests/soap.factor
old mode 100755
new mode 100644
diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/code2html/responder/responder.factor b/basis/xmode/code2html/responder/responder.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/marker/marker-tests.factor b/basis/xmode/marker/marker-tests.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/marker/state/state.factor b/basis/xmode/marker/state/state.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/rules/rules.factor b/basis/xmode/rules/rules.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/tokens/tokens.factor b/basis/xmode/tokens/tokens.factor
old mode 100755
new mode 100644
diff --git a/basis/xmode/utilities/utilities-tests.factor b/basis/xmode/utilities/utilities-tests.factor
old mode 100755
new mode 100644
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
old mode 100755
new mode 100644
diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor
old mode 100755
new mode 100644
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
old mode 100755
new mode 100644
diff --git a/core/arrays/arrays-docs.factor b/core/arrays/arrays-docs.factor
old mode 100755
new mode 100644
diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor
old mode 100755
new mode 100644
diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor
old mode 100755
new mode 100644
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
old mode 100755
new mode 100644
diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
old mode 100755
new mode 100644
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
old mode 100755
new mode 100644
diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor
old mode 100755
new mode 100644
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
old mode 100755
new mode 100644
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
old mode 100755
new mode 100644
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
old mode 100755
new mode 100644
diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor
old mode 100755
new mode 100644
diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor
old mode 100755
new mode 100644
diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
old mode 100755
new mode 100644
diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor
old mode 100755
new mode 100644
diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor
old mode 100755
new mode 100644
diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor
old mode 100755
new mode 100644
diff --git a/core/checksums/crc32/crc32.factor b/core/checksums/crc32/crc32.factor
old mode 100755
new mode 100644
diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor
old mode 100755
new mode 100644
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
old mode 100755
new mode 100644
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
old mode 100755
new mode 100644
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
old mode 100755
new mode 100644
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
old mode 100755
new mode 100644
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
old mode 100755
new mode 100644
diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor
old mode 100755
new mode 100644
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
old mode 100755
new mode 100644
diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor
old mode 100755
new mode 100644
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
old mode 100755
new mode 100644
diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor
old mode 100755
new mode 100644
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
old mode 100755
new mode 100644
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
old mode 100755
new mode 100644
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
old mode 100755
new mode 100644
diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor
old mode 100755
new mode 100644
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
old mode 100755
new mode 100644
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
old mode 100755
new mode 100644
diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor
old mode 100755
new mode 100644
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
old mode 100755
new mode 100644
diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor
old mode 100755
new mode 100644
diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor
old mode 100755
new mode 100644
diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor
old mode 100755
new mode 100644
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
old mode 100755
new mode 100644
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
old mode 100755
new mode 100644
diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor
old mode 100755
new mode 100644
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
old mode 100755
new mode 100644
diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor
old mode 100755
new mode 100644
diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
old mode 100755
new mode 100644
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
old mode 100755
new mode 100644
diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor
old mode 100755
new mode 100644
diff --git a/core/destructors/destructors-tests.factor b/core/destructors/destructors-tests.factor
old mode 100755
new mode 100644
diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor
old mode 100755
new mode 100644
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
old mode 100755
new mode 100644
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
old mode 100755
new mode 100644
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
old mode 100755
new mode 100644
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
old mode 100755
new mode 100644
diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor
old mode 100755
new mode 100644
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
old mode 100755
new mode 100644
diff --git a/core/growable/growable-docs.factor b/core/growable/growable-docs.factor
old mode 100755
new mode 100644
diff --git a/core/growable/growable-tests.factor b/core/growable/growable-tests.factor
old mode 100755
new mode 100644
diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor
old mode 100755
new mode 100644
diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor
old mode 100755
new mode 100644
diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
old mode 100755
new mode 100644
diff --git a/core/init/init.factor b/core/init/init.factor
old mode 100755
new mode 100644
diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor
old mode 100755
new mode 100644
diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
old mode 100755
new mode 100644
index 0760063f0d..0c13277106
--- a/core/io/backend/backend.factor
+++ b/core/io/backend/backend.factor
@@ -6,6 +6,10 @@ IN: io.backend
SYMBOL: io-backend
+SINGLETON: c-io-backend
+
+c-io-backend io-backend set-global
+
HOOK: init-io io-backend ( -- )
HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor
old mode 100755
new mode 100644
diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor
old mode 100755
new mode 100644
diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor
old mode 100755
new mode 100644
diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor
old mode 100755
new mode 100644
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
old mode 100755
new mode 100644
diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor
old mode 100755
new mode 100644
diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor
old mode 100755
new mode 100644
diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor
old mode 100755
new mode 100644
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
old mode 100755
new mode 100644
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
old mode 100755
new mode 100644
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
old mode 100755
new mode 100644
index 1634b7a3f1..bc84aa5d21
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -153,7 +153,7 @@ PRIVATE>
"." last-split1 nip ;
! File info
-TUPLE: file-info type size permissions modified ;
+TUPLE: file-info type size permissions created modified accessed ;
HOOK: file-info io-backend ( path -- info )
diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
old mode 100755
new mode 100644
diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor
old mode 100755
new mode 100644
diff --git a/core/io/io.factor b/core/io/io.factor
old mode 100755
new mode 100644
diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor
old mode 100755
new mode 100644
diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor
old mode 100755
new mode 100644
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
old mode 100755
new mode 100644
index 780d892d2e..1e12d7e956
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -54,26 +54,28 @@ M: c-reader stream-read-until
M: c-reader dispose*
handle>> fclose ;
-M: object init-io ;
+M: c-io-backend init-io ;
: stdin-handle 11 getenv ;
: stdout-handle 12 getenv ;
: stderr-handle 61 getenv ;
-M: object (init-stdio)
+: init-c-stdio ( -- stdin stdout stderr )
stdin-handle <c-reader>
stdout-handle <c-writer>
stderr-handle <c-writer> ;
-M: object io-multiplex 60 60 * 1000 * or (sleep) ;
+M: c-io-backend (init-stdio) init-c-stdio ;
-M: object (file-reader)
+M: c-io-backend io-multiplex 60 60 * 1000 * or (sleep) ;
+
+M: c-io-backend (file-reader)
"rb" fopen <c-reader> ;
-M: object (file-writer)
+M: c-io-backend (file-writer)
"wb" fopen <c-writer> ;
-M: object (file-appender)
+M: c-io-backend (file-appender)
"ab" fopen <c-writer> ;
: show ( msg -- )
diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor
old mode 100755
new mode 100644
diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor
old mode 100755
new mode 100644
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
old mode 100755
new mode 100644
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
old mode 100755
new mode 100644
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
old mode 100755
new mode 100644
diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor
old mode 100755
new mode 100644
diff --git a/core/layouts/layouts-tests.factor b/core/layouts/layouts-tests.factor
old mode 100755
new mode 100644
diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor
old mode 100755
new mode 100644
diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor
old mode 100755
new mode 100644
diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor
old mode 100755
new mode 100644
diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor
old mode 100755
new mode 100644
diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor
old mode 100755
new mode 100644
diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor
old mode 100755
new mode 100644
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
old mode 100755
new mode 100644
diff --git a/core/math/math.factor b/core/math/math.factor
old mode 100755
new mode 100644
diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor
old mode 100755
new mode 100644
diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor
old mode 100755
new mode 100644
diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor
old mode 100755
new mode 100644
diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor
old mode 100755
new mode 100644
diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor
old mode 100755
new mode 100644
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
old mode 100755
new mode 100644
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
old mode 100755
new mode 100644
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
old mode 100755
new mode 100644
diff --git a/core/parser/test/assert-depth.factor b/core/parser/test/assert-depth.factor
old mode 100755
new mode 100644
diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor
old mode 100755
new mode 100644
diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor
old mode 100755
new mode 100644
diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor
old mode 100755
new mode 100644
diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor
old mode 100755
new mode 100644
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
old mode 100755
new mode 100644
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
old mode 100755
new mode 100644
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
old mode 100755
new mode 100644
index 267238a502..63cc14d1d7
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -27,7 +27,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
-: empty? ( seq -- ? ) length zero? ; inline
+: empty? ( seq -- ? ) length 0 = ; inline
: if-empty ( seq quot1 quot2 -- )
[ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
@@ -362,7 +362,7 @@ PRIVATE>
prepose curry ; inline
: (interleave) ( n elt between quot -- )
- roll zero? [ nip ] [ swapd 2slip ] if call ; inline
+ roll 0 = [ nip ] [ swapd 2slip ] if call ; inline
PRIVATE>
@@ -530,7 +530,7 @@ M: sequence <=>
[ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
: sequence= ( seq1 seq2 -- ? )
- 2dup [ length ] bi@ number=
+ 2dup [ length ] bi@ =
[ mismatch not ] [ 2drop f ] if ; inline
: sequence-hashcode-step ( oldhash newpart -- newhash )
@@ -547,7 +547,7 @@ M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: move ( to from seq -- )
- 2over number=
+ 2over =
[ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
<PRIVATE
@@ -582,7 +582,7 @@ PRIVATE>
<PRIVATE
: move-backward ( shift from to seq -- )
- 2over number= [
+ 2over = [
2drop 2drop
] [
[ >r 2over + pick r> move >r 1+ r> ] keep
@@ -590,7 +590,7 @@ PRIVATE>
] if ;
: move-forward ( shift from to seq -- )
- 2over number= [
+ 2over = [
2drop 2drop
] [
[ >r pick >r dup dup r> + swap r> move 1- ] keep
@@ -607,7 +607,7 @@ PRIVATE>
PRIVATE>
: open-slice ( shift from seq -- )
- pick zero? [
+ pick 0 = [
3drop
] [
pick over length + over >r >r
@@ -680,7 +680,7 @@ PRIVATE>
: padding ( seq n elt quot -- newseq )
[
- [ over length [-] dup zero? [ drop ] ] dip
+ [ over length [-] dup 0 = [ drop ] ] dip
[ <repetition> ] curry
] dip compose if ; inline
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
old mode 100755
new mode 100644
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
old mode 100755
new mode 100644
diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor
old mode 100755
new mode 100644
diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor
old mode 100755
new mode 100644
diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor
old mode 100755
new mode 100644
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
old mode 100755
new mode 100644
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
old mode 100755
new mode 100644
diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor
old mode 100755
new mode 100644
diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor
old mode 100755
new mode 100644
diff --git a/core/strings/strings.factor b/core/strings/strings.factor
old mode 100755
new mode 100644
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
old mode 100755
new mode 100644
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
old mode 100755
new mode 100644
diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
old mode 100755
new mode 100644
diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor
old mode 100755
new mode 100644
diff --git a/core/system/system.factor b/core/system/system.factor
old mode 100755
new mode 100644
index 3c207c4ab5..6c9d838fa4
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -11,7 +11,7 @@ SINGLETON: ppc
UNION: x86 x86.32 x86.64 ;
-: cpu ( -- class ) \ cpu get ;
+: cpu ( -- class ) \ cpu get-global ; foldable
SINGLETON: winnt
SINGLETON: wince
@@ -29,7 +29,7 @@ UNION: bsd freebsd netbsd openbsd macosx ;
UNION: unix bsd solaris linux ;
-: os ( -- class ) \ os get ;
+: os ( -- class ) \ os get-global ; foldable
<PRIVATE
diff --git a/core/vectors/vectors-docs.factor b/core/vectors/vectors-docs.factor
old mode 100755
new mode 100644
diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor
old mode 100755
new mode 100644
diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor
old mode 100755
new mode 100644
diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor
old mode 100755
new mode 100644
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
old mode 100755
new mode 100644
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
old mode 100755
new mode 100644
diff --git a/core/vocabs/loader/test/a/a.factor b/core/vocabs/loader/test/a/a.factor
old mode 100755
new mode 100644
diff --git a/core/vocabs/loader/test/b/b.factor b/core/vocabs/loader/test/b/b.factor
old mode 100755
new mode 100644
diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor
old mode 100755
new mode 100644
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
old mode 100755
new mode 100644
diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
old mode 100755
new mode 100644
diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor
old mode 100755
new mode 100644
diff --git a/core/words/words.factor b/core/words/words.factor
old mode 100755
new mode 100644
diff --git a/extra/benchmark/mandel/colors/colors.factor b/extra/benchmark/mandel/colors/colors.factor
index 7bbb25a47d..218f566eda 100644
--- a/extra/benchmark/mandel/colors/colors.factor
+++ b/extra/benchmark/mandel/colors/colors.factor
@@ -1,10 +1,11 @@
USING: math math.order kernel arrays byte-arrays sequences
-colors.hsv benchmark.mandel.params ;
+colors.hsv benchmark.mandel.params accessors colors ;
IN: benchmark.mandel.colors
: scale 255 * >fixnum ; inline
-: scale-rgb ( r g b -- n ) [ scale ] tri@ 3byte-array ;
+: scale-rgb ( rgba -- n )
+ [ red>> scale ] [ green>> scale ] [ blue>> scale ] tri 3byte-array ;
: sat 0.85 ; inline
: val 0.85 ; inline
@@ -12,7 +13,7 @@ IN: benchmark.mandel.colors
: <color-map> ( nb-cols -- map )
dup [
360 * swap 1+ / sat val
- 3array hsv>rgb first3 scale-rgb
+ 1 <hsva> >rgba scale-rgb
] with map ;
: color-map ( -- map )
diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
index 4a0c148145..6ed8c1220c 100755
--- a/extra/color-picker/color-picker.factor
+++ b/extra/color-picker/color-picker.factor
@@ -23,7 +23,7 @@ M: color-preview model-changed
swap value>> >>interior relayout-1 ;
: <color-model> ( model -- model )
- [ [ 256 /f ] map 1 suffix first4 rgba boa <solid> ] <filter> ;
+ [ first3 [ 256 /f ] tri@ 1 <rgba> <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
3 [ 0 0 0 255 <range> ] replicate
diff --git a/extra/crypto/barrett/barrett-tests.factor b/extra/crypto/barrett/barrett-tests.factor
index be52240372..01163f730f 100644
--- a/extra/crypto/barrett/barrett-tests.factor
+++ b/extra/crypto/barrett/barrett-tests.factor
@@ -1,4 +1,7 @@
+! Copyright (C) 2008 DoDoug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: crypto.barrett kernel math namespaces tools.test ;
+IN: crypto.barrett.tests
[ HEX: 1f63edfb7e838622c7412eafaf0439cf0cdf3aae8bdd09e2de69b509a53883a83560d5ce50ea039e4 ] [ HEX: 827c67f31b2b46afa49ed95d7f7a3011e5875f7052d4c55437ce726d3c6ce0dc9c445fda63b6dc4e 16 barrett-mu ] unit-test
diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor
index 4a070190e3..25e67d01ce 100644
--- a/extra/crypto/barrett/barrett.factor
+++ b/extra/crypto/barrett/barrett.factor
@@ -1,14 +1,12 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions ;
IN: crypto.barrett
: barrett-mu ( n size -- mu )
#! Calculates Barrett's reduction parameter mu
#! size = word size in bits (8, 16, 32, 64, ...)
- ! over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
- [
- [ log2 1+ ] [ / 2 * ] bi*
- ] [
- 2^ rot ^ swap /i
- ] 2bi ;
+ [ [ log2 1+ ] [ / 2 * ] bi* ]
+ [ 2^ rot ^ swap /i ] 2bi ;
diff --git a/extra/crypto/common/authors.txt b/extra/crypto/common/authors.txt
deleted file mode 100755
index 7c1b2f2279..0000000000
--- a/extra/crypto/common/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor
deleted file mode 100644
index 61cc11f959..0000000000
--- a/extra/crypto/common/common.factor
+++ /dev/null
@@ -1,17 +0,0 @@
-USING: arrays kernel io io.binary sbufs splitting grouping
-strings sequences namespaces math math.parser parser
-hints math.bitwise assocs ;
-IN: crypto.common
-
-: (nth-int) ( string n -- int )
- 2 shift dup 4 + rot <slice> ; inline
-
-: nth-int ( string n -- int ) (nth-int) le> ; inline
-
-: update ( num var -- ) [ w+ ] change ; inline
-
-SYMBOL: big-endian?
-
-: mod-nth ( n seq -- elt )
- #! 5 "abcd" -> b
- [ length mod ] [ nth ] bi ;
diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor
index 6e30f19775..d98e8a9798 100755
--- a/extra/crypto/hmac/hmac.factor
+++ b/extra/crypto/hmac/hmac.factor
@@ -1,4 +1,4 @@
-USING: arrays combinators crypto.common checksums checksums.md5
+USING: arrays combinators checksums checksums.md5
checksums.sha1 checksums.md5.private io io.binary io.files
io.streams.byte-array kernel math math.vectors memoize sequences
io.encodings.binary ;
diff --git a/extra/crypto/random.factor b/extra/crypto/random.factor
deleted file mode 100755
index f2d3b0555a..0000000000
--- a/extra/crypto/random.factor
+++ /dev/null
@@ -1,40 +0,0 @@
-USING: kernel math math-contrib sequences namespaces errors
-hashtables words arrays parser compiler syntax io ;
-IN: crypto
-: make-bits ( quot numbits -- n | quot: -- 0/1 )
- 0 -rot [ drop dup call rot 1 shift bitor swap ] each drop ;
-
-: random-bytes ( m -- n )
- >r [ 2 random ] r> 8 * make-bits ;
-
-! DEFER: random-bits
-: add-bit ( bit integer -- integer ) 1 shift bitor ;
-: append-bits ( inta intb nbits -- int ) swapd shift bitor ;
-: large-random-bits ( n -- int )
- #! random number with high bit and low bit enabled (odd)
- 2 swap ^ [ random ] keep -1 shift 1 bitor bitor ;
-! : next-double ( -- f ) 53 random-bits 9007199254740992 /f ;
-
-: 0count ( integer -- n ) 0 swap [ 0 = [ 1+ ] when ] each-bit ;
-: 1count ( integer -- n ) 0 swap [ 1 = [ 1+ ] when ] each-bit ;
-
-: bit-reverse-table
-{
- HEX: 00 HEX: 80 HEX: 40 HEX: C0 HEX: 20 HEX: A0 HEX: 60 HEX: E0 HEX: 10 HEX: 90 HEX: 50 HEX: D0 HEX: 30 HEX: B0 HEX: 70 HEX: F0
- HEX: 08 HEX: 88 HEX: 48 HEX: C8 HEX: 28 HEX: A8 HEX: 68 HEX: E8 HEX: 18 HEX: 98 HEX: 58 HEX: D8 HEX: 38 HEX: B8 HEX: 78 HEX: F8
- HEX: 04 HEX: 84 HEX: 44 HEX: C4 HEX: 24 HEX: A4 HEX: 64 HEX: E4 HEX: 14 HEX: 94 HEX: 54 HEX: D4 HEX: 34 HEX: B4 HEX: 74 HEX: F4
- HEX: 0C HEX: 8C HEX: 4C HEX: CC HEX: 2C HEX: AC HEX: 6C HEX: EC HEX: 1C HEX: 9C HEX: 5C HEX: DC HEX: 3C HEX: BC HEX: 7C HEX: FC
- HEX: 02 HEX: 82 HEX: 42 HEX: C2 HEX: 22 HEX: A2 HEX: 62 HEX: E2 HEX: 12 HEX: 92 HEX: 52 HEX: D2 HEX: 32 HEX: B2 HEX: 72 HEX: F2
- HEX: 0A HEX: 8A HEX: 4A HEX: CA HEX: 2A HEX: AA HEX: 6A HEX: EA HEX: 1A HEX: 9A HEX: 5A HEX: DA HEX: 3A HEX: BA HEX: 7A HEX: FA
- HEX: 06 HEX: 86 HEX: 46 HEX: C6 HEX: 26 HEX: A6 HEX: 66 HEX: E6 HEX: 16 HEX: 96 HEX: 56 HEX: D6 HEX: 36 HEX: B6 HEX: 76 HEX: F6
- HEX: 0E HEX: 8E HEX: 4E HEX: CE HEX: 2E HEX: AE HEX: 6E HEX: EE HEX: 1E HEX: 9E HEX: 5E HEX: DE HEX: 3E HEX: BE HEX: 7E HEX: FE
- HEX: 01 HEX: 81 HEX: 41 HEX: C1 HEX: 21 HEX: A1 HEX: 61 HEX: E1 HEX: 11 HEX: 91 HEX: 51 HEX: D1 HEX: 31 HEX: B1 HEX: 71 HEX: F1
- HEX: 09 HEX: 89 HEX: 49 HEX: C9 HEX: 29 HEX: A9 HEX: 69 HEX: E9 HEX: 19 HEX: 99 HEX: 59 HEX: D9 HEX: 39 HEX: B9 HEX: 79 HEX: F9
- HEX: 05 HEX: 85 HEX: 45 HEX: C5 HEX: 25 HEX: A5 HEX: 65 HEX: E5 HEX: 15 HEX: 95 HEX: 55 HEX: D5 HEX: 35 HEX: B5 HEX: 75 HEX: F5
- HEX: 0D HEX: 8D HEX: 4D HEX: CD HEX: 2D HEX: AD HEX: 6D HEX: ED HEX: 1D HEX: 9D HEX: 5D HEX: DD HEX: 3D HEX: BD HEX: 7D HEX: FD
- HEX: 03 HEX: 83 HEX: 43 HEX: C3 HEX: 23 HEX: A3 HEX: 63 HEX: E3 HEX: 13 HEX: 93 HEX: 53 HEX: D3 HEX: 33 HEX: B3 HEX: 73 HEX: F3
- HEX: 0B HEX: 8B HEX: 4B HEX: CB HEX: 2B HEX: AB HEX: 6B HEX: EB HEX: 1B HEX: 9B HEX: 5B HEX: DB HEX: 3B HEX: BB HEX: 7B HEX: FB
- HEX: 07 HEX: 87 HEX: 47 HEX: C7 HEX: 27 HEX: A7 HEX: 67 HEX: E7 HEX: 17 HEX: 97 HEX: 57 HEX: D7 HEX: 37 HEX: B7 HEX: 77 HEX: F7
- HEX: 0F HEX: 8F HEX: 4F HEX: CF HEX: 2F HEX: AF HEX: 6F HEX: EF HEX: 1F HEX: 9F HEX: 5F HEX: DF HEX: 3F HEX: BF HEX: 7F HEX: FF
-} ; inline
-
diff --git a/extra/crypto/rsa/rsa-tests.factor b/extra/crypto/rsa/rsa-tests.factor
index 7de6bed76f..03aca0578b 100644
--- a/extra/crypto/rsa/rsa-tests.factor
+++ b/extra/crypto/rsa/rsa-tests.factor
@@ -1,4 +1,5 @@
USING: kernel math namespaces crypto.rsa tools.test ;
+IN: crypto.rsa.tests
[ 123456789 ] [ 128 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
[ 123456789 ] [ 129 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor
index 5d3228db10..b1eb907547 100644
--- a/extra/crypto/rsa/rsa.factor
+++ b/extra/crypto/rsa/rsa.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: math.miller-rabin kernel math math.functions namespaces
sequences accessors ;
IN: crypto.rsa
diff --git a/extra/crypto/summary.txt b/extra/crypto/summary.txt
index edd7c44333..0421c07ca0 100644
--- a/extra/crypto/summary.txt
+++ b/extra/crypto/summary.txt
@@ -1 +1 @@
-Cryptographic algorithms implemented in Factor, such as MD5 and SHA1
+HMAC, XOR, Barrett, RSA, Timing
diff --git a/extra/crypto/xor/xor-tests.factor b/extra/crypto/xor/xor-tests.factor
index ef781b9f25..f3a13e086f 100644
--- a/extra/crypto/xor/xor-tests.factor
+++ b/extra/crypto/xor/xor-tests.factor
@@ -2,23 +2,24 @@ USING: continuations crypto.xor kernel strings tools.test ;
IN: crypto.xor.tests
! No key
-[ "" dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
-[ { } dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
-[ V{ } dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
-[ "" "asdf" dupd xor-crypt xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
+[ "" dup xor-crypt ] [ T{ empty-xor-key } = ] must-fail-with
+[ { } dup xor-crypt ] [ T{ empty-xor-key } = ] must-fail-with
+[ V{ } dup xor-crypt ] [ T{ empty-xor-key } = ] must-fail-with
+[ "" "asdf" dupd xor-crypt xor-crypt ] [ T{ empty-xor-key } = ] must-fail-with
! a xor a = 0
[ "\0\0\0\0\0\0\0" ] [ "abcdefg" dup xor-crypt ] unit-test
[ { 15 15 15 15 } ] [ { 10 10 10 10 } { 5 5 5 5 } xor-crypt ] unit-test
-[ "asdf" ] [ "key" "asdf" dupd xor-crypt xor-crypt >string ] unit-test
-[ "" ] [ "key" "" xor-crypt >string ] unit-test
+[ "asdf" ] [ "asdf" "key" [ xor-crypt ] [ xor-crypt ] bi >string ] unit-test
+[ "" ] [ "" "key" xor-crypt >string ] unit-test
[ "a longer message...!" ] [
- "."
- "a longer message...!" dupd xor-crypt xor-crypt >string
+ "a longer message...!"
+ "." [ xor-crypt ] [ xor-crypt ] bi >string
] unit-test
[ "a longer message...!" ] [
+ "a longer message...!"
"a very long key, longer than the message even."
- "a longer message...!" dupd xor-crypt xor-crypt >string
+ [ xor-crypt ] [ xor-crypt ] bi >string
] unit-test
diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor
index 247387ebdf..6e3a605f5c 100644
--- a/extra/crypto/xor/xor.factor
+++ b/extra/crypto/xor/xor.factor
@@ -1,8 +1,12 @@
-USING: crypto.common kernel math sequences ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences fry ;
IN: crypto.xor
-ERROR: no-xor-key ;
+: mod-nth ( n seq -- elt ) [ length mod ] [ nth ] bi ;
-: xor-crypt ( key seq -- seq' )
- over empty? [ no-xor-key ] when
- dup length rot [ mod-nth bitxor ] curry 2map ;
+ERROR: empty-xor-key ;
+
+: xor-crypt ( seq key -- seq' )
+ dup empty? [ empty-xor-key ] when
+ [ dup length ] dip '[ _ mod-nth bitxor ] 2map ;
diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor
index 4b40747e9f..d02983d7fd 100755
--- a/extra/descriptive/descriptive.factor
+++ b/extra/descriptive/descriptive.factor
@@ -1,4 +1,4 @@
-USING: words kernel sequences combinators.lib locals
+USING: words kernel sequences locals
locals.private accessors parser namespaces continuations
summary definitions generalizations arrays ;
IN: descriptive
diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor
index 1ab348e434..c0636c5fd7 100644
--- a/extra/faq/faq.factor
+++ b/extra/faq/faq.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: xml kernel sequences xml.utilities combinators.lib
-math xml.data arrays assocs xml.generator xml.writer namespaces
+USING: xml kernel sequences xml.utilities math xml.data
+arrays assocs xml.generator xml.writer namespaces
make math.parser io accessors ;
IN: faq
diff --git a/extra/hexdump/hexdump-docs.factor b/extra/hexdump/hexdump-docs.factor
index adf31d3787..a83f64e8db 100644
--- a/extra/hexdump/hexdump-docs.factor
+++ b/extra/hexdump/hexdump-docs.factor
@@ -1,12 +1,22 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
IN: hexdump
HELP: hexdump.
-{ $values { "seq" "a sequence" } }
+{ $values { "sequence" "a sequence" } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
HELP: hexdump
-{ $values { "seq" "a sequence" } { "str" "a string" } }
+{ $values { "sequence" "a sequence" } { "string" "a string" } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
{ $see-also hexdump. } ;
+ARTICLE: "hexdump" "Hexdump"
+"The " { $vocab-link "hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
+"Write hexdump to string:"
+{ $subsection hexdump }
+"Write the hexdump to the output stream:"
+{ $subsection hexdump. } ;
+
+ABOUT: "hexdump"
diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor
index f444f5a4f2..618ed00802 100644
--- a/extra/hexdump/hexdump.factor
+++ b/extra/hexdump/hexdump.factor
@@ -1,5 +1,8 @@
-USING: arrays io io.streams.string kernel math math.parser namespaces
-prettyprint sequences sequences.lib splitting grouping strings ascii ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays io io.streams.string kernel math math.parser
+namespaces prettyprint sequences splitting grouping strings
+ascii ;
IN: hexdump
<PRIVATE
@@ -21,11 +24,12 @@ IN: hexdump
nl ;
PRIVATE>
-: hexdump ( seq -- str )
+
+: hexdump ( sequence -- string )
[
dup length header.
16 <sliced-groups> [ line. ] each-index
] with-string-writer ;
-: hexdump. ( seq -- )
+: hexdump. ( sequence -- )
hexdump write ;
diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor
index fb4f6d3a6d..58b3518edd 100755
--- a/extra/io/paths/paths.factor
+++ b/extra/io/paths/paths.factor
@@ -1,14 +1,16 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel sequences accessors
-dlists deques arrays sequences.lib ;
+dlists deques arrays ;
IN: io.paths
TUPLE: directory-iterator path bfs queue ;
: qualified-directory ( path -- seq )
- dup directory [ first2 >r append-path r> 2array ] with map ;
+ dup directory [ first2 [ append-path ] dip 2array ] with map ;
: push-directory ( path iter -- )
- >r qualified-directory r> [
+ [ qualified-directory ] dip [
dup queue>> swap bfs>>
[ push-front ] [ push-back ] if
] curry each ;
@@ -24,27 +26,24 @@ TUPLE: directory-iterator path bfs queue ;
] if ;
: iterate-directory ( iter quot -- obj )
- 2dup >r >r >r next-file dup [
- r> call dup [
- r> r> 2drop
- ] [
- drop r> r> iterate-directory
- ] if
+ over next-file [
+ over call
+ [ 2drop ] [ iterate-directory ] if
] [
- drop r> r> r> 3drop f
- ] if ; inline
+ 2drop f
+ ] if* ; inline recursive
: find-file ( path bfs? quot -- path/f )
- >r <directory-iterator> r>
+ [ <directory-iterator> ] dip
[ keep and ] curry iterate-directory ; inline
: each-file ( path bfs? quot -- )
- >r <directory-iterator> r>
+ [ <directory-iterator> ] dip
[ f ] compose iterate-directory drop ; inline
: find-all-files ( path bfs? quot -- paths )
- >r <directory-iterator> r>
- pusher >r [ f ] compose iterate-directory drop r> ; inline
+ [ <directory-iterator> ] dip
+ pusher [ [ f ] compose iterate-directory drop ] dip ; inline
: recursive-directory ( path bfs? -- paths )
- [ ] accumulator >r each-file r> ;
+ [ ] accumulator [ each-file ] dip ;
diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor
index 6bb6a6328e..6d4fae9b83 100644
--- a/extra/irc/client/client-docs.factor
+++ b/extra/irc/client/client-docs.factor
@@ -1,62 +1,57 @@
USING: help.markup help.syntax quotations kernel irc.messages ;
IN: irc.client
-HELP: irc-client "IRC Client object"
-"blah" ;
+HELP: irc-client "IRC Client object" ;
-HELP: irc-server-listener "Listener for server messages unmanaged by other listeners"
-"blah" ;
+HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
-HELP: irc-channel-listener "Listener for irc channels"
-"blah" ;
+HELP: irc-channel-chat "Chat for irc channels" ;
-HELP: irc-nick-listener "Listener for irc users"
-"blah" ;
+HELP: irc-nick-chat "Chat for irc users" ;
-HELP: irc-profile "IRC Client profile object"
-"blah" ;
+HELP: irc-profile "IRC Client profile object" ;
HELP: connect-irc "Connecting to an irc server"
{ $values { "irc-client" "an irc client object" } }
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
-HELP: add-listener "Listening to irc channels/users/etc"
-{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
-{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ;
+HELP: attach-chat "Chatting with irc channels/users/etc"
+{ $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } }
+{ $description "Registers " { $snippet "irc-chat" } " with " { $snippet "irc-client" } " and starts listening." } ;
-HELP: remove-listener "Stop an unregister listener"
-{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
-{ $description "Unregisters " { $snippet "irc-listener" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ;
+HELP: detach-chat "Stop an unregister chat"
+{ $values { "irc-chat" "an irc chat object" } }
+{ $description "Unregisters " { $snippet "irc-chat" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ;
HELP: terminate-irc "Terminates an irc client"
{ $values { "irc-client" "an irc client object" } }
-{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ;
+{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying chats." } ;
-HELP: write-message "Sends a message through a listener"
-{ $values { "message" "a string or irc message object" } { "irc-listener" "an irc listener object" } }
-{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-listener" } ". Strings are automatically promoted to privmsg objects." } ;
+HELP: speak "Sends a message through a chat"
+{ $values { "message" "a string or irc message object" } { "irc-chat" "an irc chat object" } }
+{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-chat" } ". Strings are automatically promoted to privmsg objects." } ;
-HELP: read-message "Reads a message from a listener"
-{ $values { "irc-listener" "an irc listener object" } { "message" "an irc message object" } }
-{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-listener" } "." } ;
+HELP: hear "Reads a message from a chat"
+{ $values { "irc-chat" "an irc chat object" } { "message" "an irc message object" } }
+{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-chat" } "." } ;
ARTICLE: "irc.client" "IRC Client"
"An IRC Client library"
{ $heading "IRC objects:" }
{ $subsection irc-client }
-{ $heading "Listener objects:" }
-{ $subsection irc-server-listener }
-{ $subsection irc-channel-listener }
-{ $subsection irc-nick-listener }
+{ $heading "Chat objects:" }
+{ $subsection irc-server-chat }
+{ $subsection irc-channel-chat }
+{ $subsection irc-nick-chat }
{ $heading "Setup objects:" }
{ $subsection irc-profile }
{ $heading "Words:" }
{ $subsection connect-irc }
{ $subsection terminate-irc }
-{ $subsection add-listener }
-{ $subsection remove-listener }
-{ $subsection read-message }
-{ $subsection write-message }
+{ $subsection attach-chat }
+{ $subsection detach-chat }
+{ $subsection hear }
+{ $subsection speak }
{ $heading "IRC messages" }
"Some of the RFC defined irc messages as objects:"
{ $table
@@ -77,28 +72,29 @@ ARTICLE: "irc.client" "IRC Client"
{ $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server."
{ $table
- { { $link irc-end } " sent when the client isn't running anymore, listeners should stop after this." }
- { { $link irc-disconnected } " sent to notify listeners that connection was lost." }
- { { $link irc-connected } " sent to notify listeners that a connection with the irc server was established." } }
+ { { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " }
+ { { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." }
+ { { $link irc-disconnected } " sent to notify chats that connection was lost." }
+ { { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } }
{ $heading "Example:" }
{ $code
- "USING: irc.client concurrency.mailboxes ;"
+ "USING: irc.client ;"
"SYMBOL: bot"
"SYMBOL: mychannel"
"! Create the profile and client objects"
"\"irc.freenode.org\" irc-port \"mybot123\" f <irc-profile> <irc-client> bot set"
"! Connect to the server"
"bot get connect-irc"
- "! Create a channel listener"
- "\"#mychannel123\" <irc-channel-listener> mychannel set"
- "! Register and start listener (this joins the channel)"
- "mychannel get bot get add-listener"
+ "! Create a channel chat"
+ "\"#mychannel123\" <irc-channel-chat> mychannel set"
+ "! Register and start chat (this joins the channel)"
+ "mychannel get bot get attach-chat"
"! Send a message to the channel"
- "\"what's up?\" mychannel get write-message"
+ "\"what's up?\" mychannel get speak"
"! Read a message from the channel"
- "mychannel get read-message"
+ "mychannel get hear"
}
;
-ABOUT: "irc.client"
\ No newline at end of file
+ABOUT: "irc.client"
diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor
index c768c1a82e..fe85d6c375 100644
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@@ -1,5 +1,5 @@
USING: kernel tools.test accessors arrays sequences qualified
- io io.streams.duplex namespaces threads
+ io io.streams.duplex namespaces threads destructors
calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ;
EXCLUDE: irc.messages => join ;
@@ -19,20 +19,23 @@ M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
M: mb-writer stream-nl ( mb-writer -- )
[ [ last-line>> concat ] [ lines>> ] bi push ] keep
V{ } clone >>last-line drop ;
+M: mb-reader dispose drop ;
+M: mb-writer dispose drop ;
: spawn-client ( -- irc-client )
"someserver" irc-port "factorbot" f <irc-profile>
<irc-client>
+ t >>is-ready
t >>is-running
<test-stream> >>stream
dup [ spawn-irc yield ] with-irc-client ;
! to be used inside with-irc-client quotations
-: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
-: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
+: %add-named-chat ( chat -- ) irc> attach-chat ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
+: %join ( channel -- ) <irc-channel-chat> irc> attach-chat ;
-: read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
+: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
[ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
: with-irc ( quot: ( -- ) -- )
@@ -42,9 +45,9 @@ M: mb-writer stream-nl ( mb-writer -- )
! TESTS
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-[ { t } [ irc> profile>> nickname>> me? ] unit-test
+[ { t } [ irc> nick>> me? ] unit-test
- { "factorbot" } [ irc> profile>> nickname>> ] unit-test
+ { "factorbot" } [ irc> nick>> ] unit-test
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
@@ -58,30 +61,46 @@ M: mb-writer stream-nl ( mb-writer -- )
! Test login and nickname set
[ { "factorbot2" } [
":some.where 001 factorbot2 :Welcome factorbot2" %push-line
- irc> profile>> nickname>>
+ irc> nick>>
+ ] unit-test
+] with-irc
+
+! Test connect
+{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
+ "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+ [ 2drop <test-stream> t ] >>connect
+ [ connect-irc ] keep
+ stream>> [ in>> [ f ] dip push-line ] [ out>> lines>> ] bi
+] unit-test
+
+! Test join
+[ { "JOIN #factortest" } [
+ "#factortest" %join
+ irc> stream>> out>> lines>> pop
] unit-test
] with-irc
[ { join_ "#factortest" } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} [ %push-line ] each
- irc> join-messages>> 0.1 seconds mailbox-get-timeout
+ in-messages>> 0.1 seconds mailbox-get-timeout
[ class ] [ trailing>> ] bi
] unit-test
] with-irc
[ { T{ participant-changed f "somebody" +join+ } } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where JOIN :#factortest" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
[ { privmsg "#factortest" "hello" } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
[ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri
@@ -89,90 +108,90 @@ M: mb-writer stream-nl ( mb-writer -- )
] with-irc
[ { privmsg "factorbot" "hello" } [
- "somedude" <irc-nick-listener> [ %add-named-listener ] keep
- ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line
+ "ircuser" <irc-nick-chat> [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri
] unit-test
] with-irc
[ { mode } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net MODE #factortest +ns" %push-line
[ mode? ] read-matching-message class
] unit-test
] with-irc
! Participant lists tests
-[ { H{ { "somedude" +normal+ } } } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
- ":somedude!n=user@isp.net JOIN :#factortest" %push-line
+[ { H{ { "ircuser" +normal+ } } } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net JOIN :#factortest" %push-line
participants>>
] unit-test
] with-irc
-[ { H{ { "somedude2" +normal+ } } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user@isp.net PART #factortest" %push-line
+[ { H{ { "ircuser2" +normal+ } } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser2" +normal+ }
+ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net PART #factortest" %push-line
participants>>
] unit-test
] with-irc
-[ { H{ { "somedude2" +normal+ } } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user@isp.net QUIT" %push-line
+[ { H{ { "ircuser2" +normal+ } } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser2" +normal+ }
+ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net QUIT" %push-line
participants>>
] unit-test
] with-irc
-[ { H{ { "somedude2" +normal+ } } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line
+[ { H{ { "ircuser2" +normal+ } } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser2" +normal+ }
+ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
participants>>
] unit-test
] with-irc
-[ { H{ { "somedude2" +normal+ } } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+[ { H{ { "ircuser2" +normal+ } } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
participants>>
] unit-test
] with-irc
! Namelist change notification
[ { T{ participant-changed f f f f } } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
-[ { T{ participant-changed f "somedude" +part+ f } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user@isp.net QUIT" %push-line
+[ { T{ participant-changed f "ircuser" +part+ f } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net QUIT" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
-[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 569f6c4bf7..ce7a6e5373 100755
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -17,17 +17,24 @@ IN: irc.client
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
-TUPLE: irc-client profile stream in-messages out-messages join-messages
- listeners is-running connect reconnect-time ;
-: <irc-client> ( profile -- irc-client )
- f <mailbox> <mailbox> <mailbox> H{ } clone f
- [ <inet> latin1 <client> ] 15 seconds irc-client boa ;
+TUPLE: irc-client profile stream in-messages out-messages
+ chats is-running nick connect reconnect-time is-ready ;
-TUPLE: irc-listener in-messages out-messages ;
-TUPLE: irc-server-listener < irc-listener ;
-TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
-TUPLE: irc-nick-listener < irc-listener name ;
-SYMBOL: +server-listener+
+: <irc-client> ( profile -- irc-client )
+ irc-client new
+ swap >>profile
+ <mailbox> >>in-messages
+ <mailbox> >>out-messages
+ H{ } clone >>chats
+ dup profile>> nickname>> >>nick
+ [ <inet> latin1 <client> ] >>connect
+ 15 seconds >>reconnect-time ;
+
+TUPLE: irc-chat in-messages client ;
+TUPLE: irc-server-chat < irc-chat ;
+TUPLE: irc-channel-chat < irc-chat name password timeout participants ;
+TUPLE: irc-nick-chat < irc-chat name ;
+SYMBOL: +server-chat+
! participant modes
SYMBOL: +operator+
@@ -43,18 +50,16 @@ SYMBOL: +part+
SYMBOL: +mode+
SYMBOL: +nick+
-! listener objects
-: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
+! chat objects
+: <irc-server-chat> ( -- irc-server-chat )
+ <mailbox> f irc-server-chat boa ;
-: <irc-server-listener> ( -- irc-server-listener )
- <mailbox> <mailbox> irc-server-listener boa ;
+: <irc-channel-chat> ( name -- irc-channel-chat )
+ [ <mailbox> f ] dip f 60 seconds H{ } clone
+ irc-channel-chat boa ;
-: <irc-channel-listener> ( name -- irc-channel-listener )
- [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
- irc-channel-listener boa ;
-
-: <irc-nick-listener> ( name -- irc-nick-listener )
- [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
+: <irc-nick-chat> ( name -- irc-nick-chat )
+ [ <mailbox> f ] dip irc-nick-chat boa ;
! ======================================
! Message objects
@@ -63,22 +68,17 @@ SYMBOL: +nick+
TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed
-SINGLETON: irc-listener-end ! send to a listener to stop its execution
+SINGLETON: irc-chat-end ! sent to a chat to stop its execution
SINGLETON: irc-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
-<PRIVATE
-: end-loops ( irc-client -- )
- [ listeners>> values [ out-messages>> ] map ]
- [ in-messages>> ]
- [ out-messages>> ] tri 2array prepend
- [ irc-end swap mailbox-put ] each ;
-PRIVATE>
-
: terminate-irc ( irc-client -- )
[ is-running>> ] keep and [
- [ end-loops ] [ [ f ] dip (>>is-running) ] bi
+ f >>is-running
+ [ stream>> dispose ] keep
+ [ in-messages>> ] [ out-messages>> ] bi 2array
+ [ irc-end swap mailbox-put ] each
] when* ;
<PRIVATE
@@ -90,74 +90,68 @@ SYMBOL: current-irc-client
! ======================================
: irc> ( -- irc-client ) current-irc-client get ;
-: irc-stream> ( -- stream ) irc> stream>> ;
-: irc-write ( s -- ) irc-stream> stream-write ;
-: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
+: irc-write ( s -- ) irc> stream>> stream-write ;
+: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
-: listener> ( name -- listener/f ) irc> listeners>> at ;
+: chat> ( name -- chat/f ) irc> chats>> at ;
: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
-: me? ( string -- ? ) irc> profile>> nickname>> = ;
+: me? ( string -- ? ) irc> nick>> = ;
-GENERIC: to-listener ( message obj -- )
+GENERIC: to-chat ( message obj -- )
-M: string to-listener ( message string -- )
- listener> [ +server-listener+ listener> ] unless*
- [ to-listener ] [ drop ] if* ;
+M: string to-chat
+ chat> [ +server-chat+ chat> ] unless*
+ [ to-chat ] [ drop ] if* ;
-M: irc-listener to-listener ( message irc-listener -- )
- in-messages>> mailbox-put ;
+M: irc-chat to-chat in-messages>> mailbox-put ;
-: unregister-listener ( name -- )
- irc> listeners>>
- [ at [ irc-listener-end ] dip to-listener ]
+: unregister-chat ( name -- )
+ irc> chats>>
+ [ at [ irc-chat-end ] dip to-chat ]
[ delete-at ]
2bi ;
-: (remove-participant) ( nick listener -- )
+: (remove-participant) ( nick chat -- )
[ participants>> delete-at ]
- [ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
+ [ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
: remove-participant ( nick channel -- )
- listener> [ (remove-participant) ] [ drop ] if* ;
+ chat> [ (remove-participant) ] [ drop ] if* ;
-: listeners-with-participant ( nick -- seq )
- irc> listeners>> values
- [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
+: chats-with-participant ( nick -- seq )
+ irc> chats>> values
+ [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
with filter ;
-: to-listeners-with-participant ( message nickname -- )
- listeners-with-participant [ to-listener ] with each ;
+: to-chats-with-participant ( message nickname -- )
+ chats-with-participant [ to-chat ] with each ;
: remove-participant-from-all ( nick -- )
- dup listeners-with-participant [ (remove-participant) ] with each ;
+ dup chats-with-participant [ (remove-participant) ] with each ;
-: notify-rename ( newnick oldnick listener -- )
+: notify-rename ( newnick oldnick chat -- )
[ participant-changed new +nick+ >>action
- [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ;
+ [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
-: rename-participant ( newnick oldnick listener -- )
- [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ]
+: rename-participant ( newnick oldnick chat -- )
+ [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
[ notify-rename ] 3bi ;
: rename-participant-in-all ( oldnick newnick -- )
- swap dup listeners-with-participant [ rename-participant ] with with each ;
+ swap dup chats-with-participant [ rename-participant ] with with each ;
: add-participant ( mode nick channel -- )
- listener>
+ chat>
[ participants>> set-at ]
- [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi ;
+ [ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
: change-participant-mode ( channel mode nick -- )
- rot listener>
+ rot chat>
[ participants>> set-at ]
- [ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME
+ [ [ [ +mode+ ] dip <participant-changed> ] dip to-chat ] 3bi ; ! FIXME
DEFER: me?
-: maybe-forward-join ( join -- )
- [ irc-message-sender me? ] keep and
- [ irc> join-messages>> mailbox-put ] when* ;
-
! ======================================
! IRC client messages
! ======================================
@@ -184,64 +178,57 @@ DEFER: me?
! Server message handling
! ======================================
+GENERIC: initialize-chat ( chat -- )
+M: irc-chat initialize-chat drop ;
+M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
+
GENERIC: forward-name ( irc-message -- name )
-M: join forward-name ( join -- name ) trailing>> ;
-M: part forward-name ( part -- name ) channel>> ;
-M: kick forward-name ( kick -- name ) channel>> ;
-M: mode forward-name ( mode -- name ) name>> ;
-M: privmsg forward-name ( privmsg -- name )
- dup name>> me? [ irc-message-sender ] [ name>> ] if ;
+M: join forward-name trailing>> ;
+M: part forward-name channel>> ;
+M: kick forward-name channel>> ;
+M: mode forward-name name>> ;
+M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
UNION: single-forward join part kick mode privmsg ;
UNION: multiple-forward nick quit ;
UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
GENERIC: forward-message ( irc-message -- )
-M: irc-message forward-message ( irc-message -- )
- +server-listener+ listener> [ to-listener ] [ drop ] if* ;
+M: irc-message forward-message
+ +server-chat+ chat> [ to-chat ] [ drop ] if* ;
-M: single-forward forward-message ( forward-single -- )
- dup forward-name to-listener ;
+M: single-forward forward-message dup forward-name to-chat ;
-M: multiple-forward forward-message ( multiple-forward -- )
- dup irc-message-sender to-listeners-with-participant ;
-
-M: join forward-message ( join -- )
- [ maybe-forward-join ] [ call-next-method ] bi ;
-
-M: broadcast-forward forward-message ( irc-broadcasted-message -- )
- irc> listeners>> values [ to-listener ] with each ;
+M: multiple-forward forward-message
+ dup irc-message-sender to-chats-with-participant ;
+
+M: broadcast-forward forward-message
+ irc> chats>> values [ to-chat ] with each ;
GENERIC: process-message ( irc-message -- )
+M: object process-message drop ;
+M: logged-in process-message
+ name>> f irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
+ values [ initialize-chat ] each ;
+M: ping process-message trailing>> /PONG ;
+M: nick-in-use process-message name>> "_" append /NICK ;
-M: object process-message ( object -- )
- drop ;
-
-M: logged-in process-message ( logged-in -- )
- name>> irc> profile>> (>>nickname) ;
-
-M: ping process-message ( ping -- )
- trailing>> /PONG ;
-
-M: nick-in-use process-message ( nick-in-use -- )
- name>> "_" append /NICK ;
-
-M: join process-message ( join -- )
+M: join process-message
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
- dup listener> [ add-participant ] [ 3drop ] if ;
+ dup chat> [ add-participant ] [ 3drop ] if ;
-M: part process-message ( part -- )
+M: part process-message
[ irc-message-sender ] [ channel>> ] bi remove-participant ;
-M: kick process-message ( kick -- )
+M: kick process-message
[ [ who>> ] [ channel>> ] bi remove-participant ]
- [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+ [ dup who>> me? [ unregister-chat ] [ drop ] if ]
bi ;
-M: quit process-message ( quit -- )
+M: quit process-message
irc-message-sender remove-participant-from-all ;
-M: nick process-message ( nick -- )
+M: nick process-message
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
! M: mode process-message ( mode -- )
@@ -257,10 +244,10 @@ M: nick process-message ( nick -- )
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
-M: names-reply process-message ( names-reply -- )
- [ names-reply>participants ] [ channel>> listener> ] bi [
+M: names-reply process-message
+ [ names-reply>participants ] [ channel>> chat> ] bi [
[ (>>participants) ]
- [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
+ [ [ f f f <participant-changed> ] dip name>> to-chat ] bi
] [ drop ] if* ;
! ======================================
@@ -268,9 +255,8 @@ M: names-reply process-message ( names-reply -- )
! ======================================
GENERIC: handle-outgoing-irc ( irc-message -- ? )
-M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ;
-M: irc-message handle-outgoing-irc ( irc-message -- ? )
- irc-message>client-line irc-print t ;
+M: irc-end handle-outgoing-irc drop f ;
+M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
! ======================================
! Reader/Writer
@@ -285,12 +271,12 @@ DEFER: (connect-irc)
irc>
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
[ dup reconnect-time>> sleep (connect-irc) ]
- [ profile>> nickname>> /LOGIN ]
+ [ nick>> /LOGIN ]
tri ;
! FIXME: do something with the exception, store somewhere to help debugging
-: handle-disconnect ( error -- )
- drop irc> is-running>> [ (handle-disconnect) ] when ;
+: handle-disconnect ( error -- ? )
+ drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
: (reader-loop) ( -- ? )
irc> stream>> [
@@ -302,7 +288,7 @@ DEFER: (connect-irc)
] with-destructors ;
: reader-loop ( -- ? )
- [ (reader-loop) ] [ handle-disconnect t ] recover ;
+ [ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- ? )
irc> out-messages>> mailbox-get handle-outgoing-irc ;
@@ -324,16 +310,11 @@ DEFER: (connect-irc)
[ nip ]
} cond ;
-GENERIC: handle-listener-out ( irc-message -- ? )
-M: irc-end handle-listener-out ( irc-end -- ? ) drop f ;
-M: irc-message handle-listener-out ( irc-message -- ? )
- irc> out-messages>> mailbox-put t ;
-
-: listener-loop ( name -- ? )
- dup listener> [
- out-messages>> mailbox-get
- maybe-annotate-with-name handle-listener-out
- ] [ drop f ] if* ;
+GENERIC: annotate-message ( chat object -- object )
+M: object annotate-message nip ;
+M: part annotate-message swap name>> >>channel ;
+M: privmsg annotate-message swap name>> >>name ;
+M: string annotate-message [ name>> ] dip strings>privmsg ;
: spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-server
@@ -341,48 +322,35 @@ M: irc-message handle-listener-out ( irc-message -- ? )
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ;
-! ======================================
-! Listener join request handling
-! ======================================
+GENERIC: (attach-chat) ( irc-chat -- )
+USE: prettyprint
+M: irc-chat (attach-chat)
+ [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
+ [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]
+ bi ;
-: set+run-listener ( name irc-listener -- )
- over irc> listeners>> set-at
- '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ;
+M: irc-server-chat (attach-chat)
+ irc> >>client +server-chat+ irc> chats>> set-at ;
-GENERIC: (add-listener) ( irc-listener -- )
+GENERIC: (remove-chat) ( irc-chat -- )
-M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
- [ [ name>> ] [ password>> ] bi /JOIN ]
- [ [ [ drop irc> join-messages>> ]
- [ timeout>> ]
- [ name>> '[ trailing>> _ = ] ]
- tri mailbox-get-timeout? trailing>> ] keep set+run-listener
- ] bi ;
+M: irc-nick-chat (remove-chat)
+ name>> unregister-chat ;
-M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
- [ name>> ] keep set+run-listener ;
+M: irc-channel-chat (remove-chat)
+ [ part new annotate-message irc> out-messages>> mailbox-put ] keep
+ name>> unregister-chat ;
-M: irc-server-listener (add-listener) ( irc-server-listener -- )
- [ +server-listener+ ] dip set+run-listener ;
-
-GENERIC: (remove-listener) ( irc-listener -- )
-
-M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
- name>> unregister-listener ;
-
-M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
- [ [ name>> ] [ out-messages>> ] bi
- [ [ part new ] dip >>channel ] dip mailbox-put ] keep
- name>> unregister-listener ;
-
-M: irc-server-listener (remove-listener) ( irc-server-listener -- )
- drop +server-listener+ unregister-listener ;
+M: irc-server-chat (remove-chat)
+ drop +server-chat+ unregister-chat ;
: (connect-irc) ( irc-client -- )
- [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
- swap >>stream
- t >>is-running
- in-messages>> [ irc-connected ] dip mailbox-put ;
+ {
+ [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
+ [ (>>stream) ]
+ [ t swap (>>is-running) ]
+ [ in-messages>> [ irc-connected ] dip mailbox-put ]
+ } cleave ;
: with-irc-client ( irc-client quot: ( -- ) -- )
[ \ current-irc-client ] dip with-variable ; inline
@@ -390,15 +358,14 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
PRIVATE>
: connect-irc ( irc-client -- )
- [ irc>
- [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
- spawn-irc ] with-irc-client ;
+ dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
-: add-listener ( irc-listener irc-client -- )
- swap '[ _ (add-listener) ] with-irc-client ;
+: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
-: remove-listener ( irc-listener irc-client -- )
- swap '[ _ (remove-listener) ] with-irc-client ;
+: detach-chat ( irc-chat -- )
+ [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
-: write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
-: read-message ( irc-listener -- message ) in-messages>> mailbox-get ;
+: speak ( message irc-chat -- )
+ [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
+
+: hear ( irc-chat -- message ) in-messages>> mailbox-get ;
diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor
index b61dd16448..41272a43f2 100644
--- a/extra/irc/messages/messages-tests.factor
+++ b/extra/irc/messages/messages-tests.factor
@@ -62,4 +62,14 @@ IN: irc.messages.tests
{ parameters { } }
{ trailing "someuser2" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
+ parse-irc-line f >>timestamp ] unit-test
+
+{ T{ nick-in-use
+ { line ":ircserver.net 433 * nickname :Nickname is already in use" }
+ { prefix "ircserver.net" }
+ { command "433" }
+ { parameters { "*" "nickname" } }
+ { name "nickname" }
+ { trailing "Nickname is already in use" } } }
+[ ":ircserver.net 433 * nickname :Nickname is already in use"
parse-irc-line f >>timestamp ] unit-test
\ No newline at end of file
diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor
index 9201f822da..32533c102a 100755
--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@@ -4,7 +4,6 @@ USING: kernel fry splitting ascii calendar accessors combinators qualified
arrays classes.tuple math.order ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
-EXCLUDE: inverse => _ ;
IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ;
@@ -17,15 +16,18 @@ TUPLE: nick < irc-message ;
TUPLE: privmsg < irc-message name ;
TUPLE: kick < irc-message channel who ;
TUPLE: roomlist < irc-message channel names ;
-TUPLE: nick-in-use < irc-message asterisk name ;
+TUPLE: nick-in-use < irc-message name ;
TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name mode parameter ;
TUPLE: names-reply < irc-message who channel ;
TUPLE: unhandled < irc-message ;
: <irc-client-message> ( command parameters trailing -- irc-message )
- irc-message new now >>timestamp
- [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
+ irc-message new
+ now >>timestamp
+ swap >>trailing
+ swap >>parameters
+ swap >>command ;
<PRIVATE
@@ -57,22 +59,38 @@ M: kick command-parameters>> ( kick -- seq )
M: mode command-parameters>> ( mode -- seq )
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
-GENERIC: (>>command-parameters) ( params irc-message -- )
+GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
-M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ;
-M: logged-in (>>command-parameters) ( params part -- ) [ first ] dip (>>name) ;
-M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ;
-M: notice (>>command-parameters) ( params notice -- ) [ first ] dip (>>type) ;
-M: part (>>command-parameters) ( params part -- )
- [ first ] dip (>>channel) ;
-M: kick (>>command-parameters) ( params kick -- )
- [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ;
-M: names-reply (>>command-parameters) ( params names-reply -- )
- [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
-M: mode (>>command-parameters) ( params mode -- )
- { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] }
- { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
- } switch ;
+M: irc-message >>command-parameters ( irc-message params -- irc-message )
+ drop ;
+
+M: logged-in >>command-parameters ( part params -- part )
+ first >>name ;
+
+M: privmsg >>command-parameters ( privmsg params -- privmsg )
+ first >>name ;
+
+M: notice >>command-parameters ( notice params -- notice )
+ first >>type ;
+
+M: part >>command-parameters ( part params -- part )
+ first >>channel ;
+
+M: kick >>command-parameters ( kick params -- kick )
+ first2 [ >>channel ] [ >>who ] bi* ;
+
+M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
+ second >>name ;
+
+M: names-reply >>command-parameters ( names-reply params -- names-reply )
+ first3 nip [ >>who ] [ >>channel ] bi* ;
+
+M: mode >>command-parameters ( mode params -- mode )
+ dup length 3 = [
+ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
+ ] [
+ first2 [ >>name ] [ >>mode ] bi*
+ ] if ;
PRIVATE>
@@ -90,6 +108,7 @@ M: irc-message irc-message>server-line ( irc-message -- string )
drop "not implemented yet" ;
<PRIVATE
+
! ======================================
! Message parsing
! ======================================
@@ -97,28 +116,28 @@ M: irc-message irc-message>server-line ( irc-message -- string )
: split-at-first ( seq separators -- before after )
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
-: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+: remove-heading-: ( seq -- seq )
+ ":" ?head drop ;
: parse-name ( string -- string )
remove-heading-: "!" split-at-first drop ;
: split-prefix ( string -- string/f string )
dup ":" head?
- [ remove-heading-: " " split1 ]
- [ f swap ]
- if ;
+ [ remove-heading-: " " split1 ] [ f swap ] if ;
: split-trailing ( string -- string string/f )
":" split1 ;
-: copy-message-in ( origin dest -- )
- { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ]
- [ [ line>> ] dip (>>line) ]
- [ [ prefix>> ] dip (>>prefix) ]
- [ [ command>> ] dip (>>command) ]
- [ [ trailing>> ] dip (>>trailing) ]
- [ [ timestamp>> ] dip (>>timestamp) ]
- } 2cleave ;
+: copy-message-in ( command irc-message -- command )
+ {
+ [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
+ [ line>> >>line ]
+ [ prefix>> >>prefix ]
+ [ command>> >>command ]
+ [ trailing>> >>trailing ]
+ [ timestamp>> >>timestamp ]
+ } cleave ;
PRIVATE>
@@ -132,20 +151,24 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
[ [ blank? ] trim " " split unclip swap ] dip
now irc-message boa ;
+: irc-message>command ( irc-message -- command )
+ [
+ command>> {
+ { "PING" [ ping ] }
+ { "NOTICE" [ notice ] }
+ { "001" [ logged-in ] }
+ { "433" [ nick-in-use ] }
+ { "353" [ names-reply ] }
+ { "JOIN" [ join ] }
+ { "PART" [ part ] }
+ { "NICK" [ nick ] }
+ { "PRIVMSG" [ privmsg ] }
+ { "QUIT" [ quit ] }
+ { "MODE" [ mode ] }
+ { "KICK" [ kick ] }
+ [ drop unhandled ]
+ } case new
+ ] keep copy-message-in ;
+
: parse-irc-line ( string -- message )
- string>irc-message
- dup command>> {
- { "PING" [ ping ] }
- { "NOTICE" [ notice ] }
- { "001" [ logged-in ] }
- { "433" [ nick-in-use ] }
- { "353" [ names-reply ] }
- { "JOIN" [ join ] }
- { "PART" [ part ] }
- { "NICK" [ nick ] }
- { "PRIVMSG" [ privmsg ] }
- { "QUIT" [ quit ] }
- { "MODE" [ mode ] }
- { "KICK" [ kick ] }
- [ drop unhandled ]
- } case new [ copy-message-in ] keep ;
+ string>irc-message irc-message>command ;
diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor
index 184a2b4de8..4bb77e7490 100755
--- a/extra/irc/ui/commands/commands.factor
+++ b/extra/irc/ui/commands/commands.factor
@@ -8,7 +8,7 @@ IN: irc.ui.commands
: say ( string -- )
irc-tab get
[ window>> client>> profile>> nickname>> <own-message> print-irc ]
- [ listener>> write-message ] 2bi ;
+ [ chat>> speak ] 2bi ;
: join ( string -- )
irc-tab get window>> join-channel ;
@@ -18,7 +18,7 @@ IN: irc.ui.commands
: whois ( string -- )
"WHOIS" swap { } clone swap <irc-client-message>
- irc-tab get listener>> write-message ;
+ irc-tab get listener>> speak ;
: quote ( string -- )
drop ; ! THIS WILL CHANGE
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index 1e4bcf35f8..e854d285b7 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -15,7 +15,7 @@ RENAME: join sequences => sjoin
IN: irc.ui
-SYMBOL: listener
+SYMBOL: chat
SYMBOL: client
@@ -24,7 +24,7 @@ TUPLE: ui-window < tabbed client ;
M: ui-window ungraft*
client>> terminate-irc ;
-TUPLE: irc-tab < frame listener client window ;
+TUPLE: irc-tab < frame chat client window ;
: write-color ( str color -- )
foreground associate format ;
@@ -117,7 +117,7 @@ M: irc-disconnected write-irc
M: irc-connected write-irc
drop "* Connected" dark-green write-color ;
-M: irc-listener-end write-irc
+M: irc-chat-end write-irc
drop ;
M: irc-message write-irc
@@ -135,7 +135,7 @@ M: object time-happened drop now ;
: send-message ( message -- )
[ print-irc ]
- [ listener get write-message ] bi ;
+ [ chat get speak ] bi ;
GENERIC: handle-inbox ( tab message -- )
@@ -150,7 +150,7 @@ M: object handle-inbox
: display ( stream tab -- )
'[ _ [ [ t ]
- [ _ dup listener>> read-message handle-inbox ]
+ [ _ dup chat>> hear handle-inbox ]
[ ] while ] with-output-stream ] "ircv" spawn drop ;
: <irc-pane> ( tab -- tab pane )
@@ -175,28 +175,28 @@ irc-editor "general" f {
{ T{ key-down f f "ENTER" } editor-send }
} define-command-map
-: new-irc-tab ( listener ui-window class -- irc-tab )
+: new-irc-tab ( chat ui-window class -- irc-tab )
new-frame
swap >>window
- swap >>listener
+ swap >>chat
<irc-pane> [ <scroller> @center grid-add ] keep
<irc-editor> <scroller> @bottom grid-add ;
M: irc-tab graft*
- [ listener>> ] [ window>> client>> ] bi add-listener ;
+ [ chat>> ] [ window>> client>> ] bi attach-chat ;
M: irc-tab ungraft*
- [ listener>> ] [ window>> client>> ] bi remove-listener ;
+ chat>> detach-chat ;
TUPLE: irc-channel-tab < irc-tab userlist ;
-: <irc-channel-tab> ( listener ui-window -- irc-tab )
+: <irc-channel-tab> ( chat ui-window -- irc-tab )
irc-channel-tab new-irc-tab
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
: update-participants ( tab -- )
[ userlist>> [ clear-gadget ] keep ]
- [ listener>> participants>> ] bi
+ [ chat>> participants>> ] bi
[ +operator+ value-labels dark-green add-gadget-color ]
[ +voice+ value-labels blue add-gadget-color ]
[ +normal+ value-labels black add-gadget-color ] tri drop ;
@@ -206,22 +206,22 @@ M: participant-changed handle-inbox
TUPLE: irc-server-tab < irc-tab ;
-: <irc-server-tab> ( listener -- irc-tab )
+: <irc-server-tab> ( chat -- irc-tab )
f irc-server-tab new-irc-tab ;
-: <irc-nick-tab> ( listener ui-window -- irc-tab )
+: <irc-nick-tab> ( chat ui-window -- irc-tab )
irc-tab new-irc-tab ;
M: irc-tab pref-dim*
drop { 480 480 } ;
: join-channel ( name ui-window -- )
- [ dup <irc-channel-listener> ] dip
+ [ dup <irc-channel-chat> ] dip
[ <irc-channel-tab> swap ] keep
add-page ;
: query-nick ( nick ui-window -- )
- [ dup <irc-nick-listener> ] dip
+ [ dup <irc-nick-chat> ] dip
[ <irc-nick-tab> swap ] keep
add-page ;
@@ -232,8 +232,8 @@ M: irc-tab pref-dim*
: ui-connect ( profile -- ui-window )
<irc-client>
- { [ [ <irc-server-listener> ] dip add-listener ]
- [ listeners>> +server-listener+ swap at <irc-server-tab> dup
+ { [ [ <irc-server-chat> ] dip attach-chat ]
+ [ chats>> +server-chat+ swap at <irc-server-tab> dup
"Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]
[ >>client ]
[ connect-irc ] } cleave ;
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index 2866e63c69..e60529caab 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg sequences arrays strings combinators.lib
+USING: kernel peg sequences arrays strings
namespaces combinators math locals locals.private locals.backend accessors
-vectors syntax lisp.parser assocs parser sequences.lib words
+vectors syntax lisp.parser assocs parser words
quotations fry lists summary combinators.short-circuit continuations multiline ;
IN: lisp
@@ -180,4 +180,4 @@ M: no-such-var summary drop "No such variable" ;
: <LISP
"LISP>" parse-multiline-string define-lisp-builtins
- lisp-string>factor parsed \ call parsed ; parsing
\ No newline at end of file
+ lisp-string>factor parsed \ call parsed ; parsing
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 1b14f5bb34..72344fd0dc 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg peg.ebnf math.parser sequences arrays strings
-combinators.lib math fry accessors lists combinators.short-circuit ;
+math fry accessors lists combinators.short-circuit ;
IN: lisp.parser
@@ -36,4 +36,4 @@ atom = number
| string
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
list-item = _ ( atom | s-expression ) _ => [[ second ]]
-;EBNF
\ No newline at end of file
+;EBNF
diff --git a/extra/math/algebra/algebra.factor b/extra/math/algebra/algebra.factor
index 8bb8420d1a..8cccded26a 100644
--- a/extra/math/algebra/algebra.factor
+++ b/extra/math/algebra/algebra.factor
@@ -1,8 +1,10 @@
! Copyright (c) 2007 Samuel Tardieu
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences ;
+USING: kernel math math.functions sequences fry ;
IN: math.algebra
: chinese-remainder ( aseq nseq -- x )
dup product
- [ [ over / [ swap gcd drop ] keep * * ] curry 2map sum ] keep rem ; foldable
+ [
+ '[ _ over / [ swap gcd drop ] keep * * ] 2map sum
+ ] keep rem ; foldable
diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor
index a41281d779..7da1c96b61 100755
--- a/extra/math/analysis/analysis.factor
+++ b/extra/math/analysis/analysis.factor
@@ -1,5 +1,7 @@
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.constants math.functions math.intervals
-math.vectors namespaces sequences ;
+math.vectors namespaces sequences combinators.short-circuit ;
IN: math.analysis
<PRIVATE
@@ -20,8 +22,8 @@ IN: math.analysis
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1)
- dup 0.5 + dup gamma-g6 + dup >r log * r> -
- swap 6 gamma-z gamma-p6 v. log + ;
+ [ 0.5 + dup gamma-g6 + dup [ log * ] dip - ]
+ [ 6 gamma-z gamma-p6 v. log ] bi + ;
: gamma-lanczos6 ( x -- gamma[x] )
#! gamma(x) = gamma(x+1) / x
@@ -39,7 +41,7 @@ PRIVATE>
: gamma ( x -- y )
#! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
#! gamma(n+1) = n! for n > 0
- dup 0.0 <= over 1.0 mod zero? and [
+ dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
drop 1./0.
] [
dup abs gamma-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
@@ -55,7 +57,7 @@ PRIVATE>
] if ;
: nth-root ( n x -- y )
- over 0 = [ "0th root is undefined" throw ] when >r recip r> swap ^ ;
+ [ recip ] dip swap ^ ;
! Forth Scientific Library Algorithm #1
!
diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor
index a0c6df083b..b1c49b8ab5 100644
--- a/extra/math/combinatorics/combinatorics.factor
+++ b/extra/math/combinatorics/combinatorics.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.order math.ranges mirrors
-namespaces make sequences sequences.lib sorting ;
+namespaces sequences sorting fry ;
IN: math.combinatorics
<PRIVATE
@@ -13,7 +13,7 @@ IN: math.combinatorics
2dup - dupd > [ dupd - ] when ; inline
! See this article for explanation of the factoradic-based permutation methodology:
-! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
+! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
: factoradic ( n -- factoradic )
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
@@ -39,13 +39,10 @@ PRIVATE>
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
- tuck permutation-indices swap nths ;
+ [ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq )
- [
- [ length factorial ] keep [ permutation , ] curry each
- ] { } make ;
+ [ length factorial ] keep '[ _ permutation ] map ;
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;
-
diff --git a/extra/math/compare/compare.factor b/extra/math/compare/compare.factor
index 28a8eadc81..d19dac3d2b 100644
--- a/extra/math/compare/compare.factor
+++ b/extra/math/compare/compare.factor
@@ -19,4 +19,3 @@ IN: math.compare
: clamp ( a value b -- x )
min max ;
-
diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor
index ad8d944bfe..b7612e112b 100644
--- a/extra/math/derivatives/derivatives.factor
+++ b/extra/math/derivatives/derivatives.factor
@@ -1,4 +1,3 @@
-
USING: kernel continuations combinators sequences math
math.order math.ranges accessors float-arrays ;
@@ -7,11 +6,11 @@ IN: math.derivatives
TUPLE: state x func h err i j errt fac hh ans a done ;
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
-: ntab ( -- val ) 8 ;
-: con ( -- val ) 1.6 ;
-: con2 ( -- val ) con con * ;
-: big ( -- val ) largest-float ;
-: safe ( -- val ) 2.0 ;
+: ntab ( -- val ) 8 ; inline
+: con ( -- val ) 1.6 ; inline
+: con2 ( -- val ) con con * ; inline
+: big ( -- val ) largest-float ; inline
+: safe ( -- val ) 2.0 ; inline
! Yes, this was ported from C code.
: a[i][i] ( state -- elt ) [ i>> ] [ i>> ] [ a>> ] tri nth nth ;
@@ -120,4 +119,4 @@ TUPLE: state x func h err i j errt fac hh ans a done ;
bi ;
: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
-: derivative-func ( func -- der ) [ derivative ] curry ;
\ No newline at end of file
+: derivative-func ( func -- der ) [ derivative ] curry ;
diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor
index f836d71a99..4c6675e8f1 100644
--- a/extra/math/erato/erato.factor
+++ b/extra/math/erato/erato.factor
@@ -11,8 +11,8 @@ TUPLE: erato limit bits latest ;
: ind ( n -- i )
2/ 1- ; inline
-: is-prime ( n erato -- bool )
- >r ind r> bits>> nth ; inline
+: is-prime ( n limit -- bool )
+ [ ind ] [ bits>> ] bi* nth ; inline
: indices ( n erato -- range )
limit>> ind over 3 * ind swap rot <range> ;
diff --git a/extra/math/fft/fft.factor b/extra/math/fft/fft.factor
index 682d2a49db..b82ecb6b2c 100644
--- a/extra/math/fft/fft.factor
+++ b/extra/math/fft/fft.factor
@@ -9,7 +9,7 @@ IN: math.fft
: odd ( seq -- seq ) 2 group 1 <column> ;
DEFER: fft
: two ( seq -- seq ) fft 2 v/n dup append ;
-: omega ( n -- n ) recip -2 pi i* * * exp ;
+: omega ( n -- n' ) recip -2 pi i* * * exp ;
: twiddle ( seq -- seq ) dup length dup omega swap n^v v* ;
: (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ;
: fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ;
diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor
index f1953340db..45665c701d 100755
--- a/extra/math/miller-rabin/miller-rabin.factor
+++ b/extra/math/miller-rabin/miller-rabin.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators combinators.lib io locals kernel math
math.functions math.ranges namespaces random sequences
hashtables sets ;
diff --git a/extra/math/newtons-method/newtons-method.factor b/extra/math/newtons-method/newtons-method.factor
index 5bf71deac8..269eae2538 100644
--- a/extra/math/newtons-method/newtons-method.factor
+++ b/extra/math/newtons-method/newtons-method.factor
@@ -1,11 +1,17 @@
! Copyright � 2008 Reginald Keith Ford II
+! See http://factorcode.org/license.txt for BSD license.
! Newton's Method of approximating roots
-
USING: kernel math math.derivatives ;
IN: math.newtons-method
<PRIVATE
-: newton-step ( x function -- x2 ) dupd [ call ] [ derivative ] 2bi / - ;
-: newton-precision ( -- n ) 13 ;
+
+: newton-step ( x function -- x2 )
+ dupd [ call ] [ derivative ] 2bi / - ; inline
+
+: newton-precision ( -- n ) 13 ; inline
+
PRIVATE>
-: newtons-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ;
+
+: newtons-method ( guess function -- x )
+ newton-precision [ [ newton-step ] keep ] times drop ;
diff --git a/extra/math/numerical-integration/numerical-integration.factor b/extra/math/numerical-integration/numerical-integration.factor
index 798d3a5e71..dfaa618b53 100644
--- a/extra/math/numerical-integration/numerical-integration.factor
+++ b/extra/math/numerical-integration/numerical-integration.factor
@@ -1,18 +1,20 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences namespaces make math math.ranges
math.vectors vectors ;
IN: math.numerical-integration
SYMBOL: num-steps 180 num-steps set-global
+
: setup-simpson-range ( from to -- frange )
2dup swap - num-steps get / <range> ;
: generate-simpson-weights ( seq -- seq )
- [
- { 1 4 } % length 2 / 2 - { 2 4 } <repetition> concat % 1 ,
- ] { } make ;
+ { 1 4 }
+ swap length 2 / 2 - { 2 4 } <repetition> concat
+ { 1 } 3append ;
: integrate-simpson ( from to f -- x )
- >r setup-simpson-range r>
- dupd map dup generate-simpson-weights
+ [ setup-simpson-range dup ] dip
+ map dup generate-simpson-weights
v. swap [ third ] keep first - 6 / * ;
-
diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor
index 8662bbb089..51512ca2e3 100644
--- a/extra/math/polynomials/polynomials.factor
+++ b/extra/math/polynomials/polynomials.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences vectors math math.vectors
namespaces make shuffle splitting sequences.lib math.order ;
IN: math.polynomials
@@ -82,5 +84,5 @@ PRIVATE>
: polyval ( p x -- p[x] )
#! Evaluate a polynomial.
- >r dup length r> powers v. ;
+ [ dup length ] dip powers v. ;
diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor
index f3a515e72b..feb60c555d 100644
--- a/extra/math/primes/primes.factor
+++ b/extra/math/primes/primes.factor
@@ -8,44 +8,45 @@ IN: math.primes
<PRIVATE
: find-prime-miller-rabin ( n -- p )
- dup miller-rabin [ 2 + find-prime-miller-rabin ] unless ; foldable
+ dup miller-rabin [ 2 + find-prime-miller-rabin ] unless ; foldable
PRIVATE>
: next-prime ( n -- p )
- dup 999983 < [
- primes-under-million [ natural-search drop 1+ ] keep nth
- ] [
- next-odd find-prime-miller-rabin
- ] if ; foldable
+ dup 999983 < [
+ primes-under-million [ natural-search drop 1+ ] keep nth
+ ] [
+ next-odd find-prime-miller-rabin
+ ] if ; foldable
: prime? ( n -- ? )
- dup 1000000 < [
- dup primes-under-million natural-search nip =
- ] [
- miller-rabin
- ] if ; foldable
+ dup 1000000 < [
+ dup primes-under-million natural-search nip =
+ ] [
+ miller-rabin
+ ] if ; foldable
: lprimes ( -- list )
- 0 primes-under-million seq>list
- 1000003 [ 2 + find-prime-miller-rabin ] lfrom-by
- lappend ;
+ 0 primes-under-million seq>list
+ 1000003 [ 2 + find-prime-miller-rabin ] lfrom-by
+ lappend ;
: lprimes-from ( n -- list )
- dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
+ dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
: primes-upto ( n -- seq )
- {
- { [ dup 2 < ] [ drop { } ] }
- { [ dup 1000003 < ]
- [ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice> ] }
- [ primes-under-million 1000003 lprimes-from
- rot [ <= ] curry lwhile list>array append ]
- } cond ; foldable
+ {
+ { [ dup 2 < ] [ drop { } ] }
+ { [ dup 1000003 < ] [
+ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice>
+ ] }
+ [ primes-under-million 1000003 lprimes-from
+ rot [ <= ] curry lwhile list>array append ]
+ } cond ; foldable
: primes-between ( low high -- seq )
- primes-upto
- [ 1- next-prime ] dip
- [ natural-search drop ] keep [ length ] keep <slice> ; foldable
+ primes-upto
+ [ 1- next-prime ] dip
+ [ natural-search drop ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor
index 3c450f1c05..65f18d3568 100755
--- a/extra/math/quaternions/quaternions.factor
+++ b/extra/math/quaternions/quaternions.factor
@@ -28,7 +28,7 @@ PRIVATE>
: qconjugate ( u -- u' )
#! Quaternion conjugate.
- first2 neg >r conjugate r> 2array ;
+ first2 [ conjugate ] [ neg ] bi* 2array ;
: qrecip ( u -- 1/u )
#! Quaternion inverse.
diff --git a/extra/math/secant-method/secant-method.factor b/extra/math/secant-method/secant-method.factor
index e039b42bbd..ad52c0cd4a 100644
--- a/extra/math/secant-method/secant-method.factor
+++ b/extra/math/secant-method/secant-method.factor
@@ -1,14 +1,26 @@
! Copyright © 2008 Reginald Keith Ford II
+! See http://factorcode.org/license.txt for BSD license.
! Secant Method of approximating roots
-
USING: kernel math math.function-tools math.points math.vectors ;
IN: math.secant-method
<PRIVATE
-: secant-solution ( x1 x2 function -- solution ) [ eval ] curry bi@ linear-solution ;
-: secant-step ( x1 x2 func -- x2 x3 func ) 2dup [ secant-solution ] 2dip swapd ;
-: secant-precision ( -- n ) 15 ;
+
+: secant-solution ( x1 x2 function -- solution )
+ [ eval ] curry bi@ linear-solution ;
+
+: secant-step ( x1 x2 func -- x2 x3 func )
+ [ secant-solution ] 2keep swapd ;
+
+: secant-precision ( -- n ) 15 ; inline
+
PRIVATE>
-: secant-method ( left right function -- x ) secant-precision [ secant-step ] times drop + 2 / ;
+
+: secant-method ( left right function -- x )
+ secant-precision [ secant-step ] times drop + 2 / ;
+
! : close-enough? ( a b -- t/f ) - abs tiny-amount < ;
-! : secant-method2 ( left right function -- x ) 2over close-enough? [ drop average ] [ secant-step secant-method ] if ;
\ No newline at end of file
+
+! : secant-method2 ( left right function -- x )
+ ! 2over close-enough?
+ ! [ drop average ] [ secant-step secant-method ] if ;
diff --git a/extra/math/statistics/statistics.factor b/extra/math/statistics/statistics.factor
index 28cc05151b..8cd6d26c1c 100644
--- a/extra/math/statistics/statistics.factor
+++ b/extra/math/statistics/statistics.factor
@@ -1,5 +1,7 @@
+! Copyright (C) 2008 Doug Coleman, Michael Judge.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.analysis math.functions math.vectors sequences
- sequences.lib sorting ;
+sequences.lib sorting ;
IN: math.statistics
: mean ( seq -- n )
@@ -18,7 +20,7 @@ IN: math.statistics
: median ( seq -- n )
#! middle number if odd, avg of two middle numbers if even
natural-sort dup length dup even? [
- 1- 2 / swap [ nth ] [ >r 1+ r> nth ] 2bi + 2 /
+ 1- 2 / swap [ nth ] [ [ 1+ ] dip nth ] 2bi + 2 /
] [
2 / swap nth
] if ;
diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor
index 387be4d791..439d0a75fe 100755
--- a/extra/math/text/english/english.factor
+++ b/extra/math/text/english/english.factor
@@ -1,8 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.parser namespaces
- sequences splitting grouping sequences.lib
- combinators.short-circuit ;
+sequences splitting grouping combinators.short-circuit ;
IN: math.text.english
<PRIVATE
@@ -86,14 +85,10 @@ SYMBOL: and-needed?
] if ;
: (number>text) ( n -- str )
- dup negative-text swap abs 3digit-groups recombine append ;
+ [ negative-text ] [ abs 3digit-groups recombine ] bi append ;
PRIVATE>
: number>text ( n -- str )
- dup zero? [
- small-numbers
- ] [
- [ (number>text) ] with-scope
- ] if ;
+ dup zero? [ small-numbers ] [ [ (number>text) ] with-scope ] if ;
diff --git a/extra/math/trig/trig.factor b/extra/math/trig/trig.factor
index be9ec6a56c..3d9428adda 100644
--- a/extra/math/trig/trig.factor
+++ b/extra/math/trig/trig.factor
@@ -1,6 +1,6 @@
-
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
USING: math math.constants ;
-
IN: math.trig
: deg>rad pi * 180 / ; inline
diff --git a/extra/money/money.factor b/extra/money/money.factor
index 76bc2bae18..5fa76d5f53 100644
--- a/extra/money/money.factor
+++ b/extra/money/money.factor
@@ -1,6 +1,6 @@
USING: io kernel math math.functions math.parser parser lexer
namespaces make sequences splitting grouping combinators
-continuations sequences.lib ;
+continuations ;
IN: money
: dollars/cents ( dollars -- dollars cents )
diff --git a/extra/parser-combinators/regexp/regexp.factor b/extra/parser-combinators/regexp/regexp.factor
index 40d4603fb6..b13321d991 100755
--- a/extra/parser-combinators/regexp/regexp.factor
+++ b/extra/parser-combinators/regexp/regexp.factor
@@ -1,6 +1,6 @@
USING: arrays combinators kernel lists math math.parser
namespaces parser lexer parser-combinators parser-combinators.simple
-promises quotations sequences combinators.lib strings math.order
+promises quotations sequences strings math.order
assocs prettyprint.backend memoize unicode.case unicode.categories
combinators.short-circuit accessors make io ;
IN: parser-combinators.regexp
diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor
index fcbc956de8..dc0c060b22 100644
--- a/extra/project-euler/014/014.factor
+++ b/extra/project-euler/014/014.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.lib combinators.short-circuit kernel
+USING: arrays combinators.short-circuit kernel
math math.ranges namespaces make sequences sorting ;
IN: project-euler.014
diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor
index cf58e88ffe..5f6541873a 100644
--- a/extra/project-euler/017/017.factor
+++ b/extra/project-euler/017/017.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.ranges math.text.english sequences sequences.lib strings
+USING: kernel math.ranges math.text.english sequences strings
ascii combinators.short-circuit ;
IN: project-euler.017
diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor
index b29495f913..9482b337bb 100644
--- a/extra/project-euler/019/019.factor
+++ b/extra/project-euler/019/019.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar combinators kernel math math.ranges namespaces sequences
- sequences.lib math.order ;
+ math.order ;
IN: project-euler.019
! http://projecteuler.net/index.php?section=problems&id=19
@@ -32,7 +32,7 @@ IN: project-euler.019
: euler019 ( -- answer )
1901 2000 [a,b] [
- 12 [1,b] [ 1 zeller-congruence ] map-with
+ 12 [1,b] [ 1 zeller-congruence ] with map
] map concat [ zero? ] count ;
! [ euler019 ] 100 ave-time
diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor
index 9ae5f6af10..af6bb3270b 100644
--- a/extra/project-euler/021/021.factor
+++ b/extra/project-euler/021/021.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib combinators.short-circuit kernel math math.functions
- math.ranges namespaces project-euler.common sequences sequences.lib ;
+USING: combinators.short-circuit kernel math math.functions
+ math.ranges namespaces project-euler.common sequences ;
IN: project-euler.021
! http://projecteuler.net/index.php?section=problems&id=21
diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor
index 82054ce014..a508ddea6c 100644
--- a/extra/project-euler/022/022.factor
+++ b/extra/project-euler/022/022.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: ascii io.encodings.ascii io.files kernel math project-euler.common
- sequences sequences.lib sorting splitting ;
+ sequences sorting splitting ;
IN: project-euler.022
! http://projecteuler.net/index.php?section=problems&id=22
diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor
index 53d6b199fb..250494c0dc 100644
--- a/extra/project-euler/030/030.factor
+++ b/extra/project-euler/030/030.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions project-euler.common sequences sequences.lib ;
+USING: kernel math math.functions project-euler.common sequences ;
IN: project-euler.030
! http://projecteuler.net/index.php?section=problems&id=30
diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor
index 8a54c595a9..f9667c75fe 100755
--- a/extra/project-euler/032/032.factor
+++ b/extra/project-euler/032/032.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib hashtables kernel math math.combinatorics math.functions
+USING: hashtables kernel math math.combinatorics math.functions
math.parser math.ranges project-euler.common sequences sets ;
IN: project-euler.032
diff --git a/extra/project-euler/034/034.factor b/extra/project-euler/034/034.factor
index cf73ee828b..28c4fa5dc7 100644
--- a/extra/project-euler/034/034.factor
+++ b/extra/project-euler/034/034.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.ranges project-euler.common sequences sequences.lib ;
+USING: kernel math.ranges project-euler.common sequences ;
IN: project-euler.034
! http://projecteuler.net/index.php?section=problems&id=34
diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor
index cec9bc6957..8e8b654d28 100755
--- a/extra/project-euler/035/035.factor
+++ b/extra/project-euler/035/035.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.combinatorics math.parser math.primes
- project-euler.common sequences sequences.lib sets ;
+ project-euler.common sequences sets ;
IN: project-euler.035
! http://projecteuler.net/index.php?section=problems&id=35
diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor
index f3a9f738bf..fc9df9a8fe 100644
--- a/extra/project-euler/036/036.factor
+++ b/extra/project-euler/036/036.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib combinators.short-circuit kernel math.parser math.ranges
+USING: combinators.short-circuit kernel math.parser math.ranges
project-euler.common sequences ;
IN: project-euler.036
diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor
index 7a9f51f1d3..d0caa6d0e4 100755
--- a/extra/project-euler/039/039.factor
+++ b/extra/project-euler/039/039.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.lib kernel math math.ranges
+USING: arrays kernel math math.ranges
namespaces project-euler.common sequences ;
IN: project-euler.039
diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor
index da26e34927..8ae95d6db7 100644
--- a/extra/project-euler/042/042.factor
+++ b/extra/project-euler/042/042.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: ascii io.files kernel math math.functions namespaces make
- project-euler.common sequences sequences.lib splitting io.encodings.ascii ;
+ project-euler.common sequences splitting io.encodings.ascii ;
IN: project-euler.042
! http://projecteuler.net/index.php?section=problems&id=42
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index a2f4ad5c61..84ed7a830f 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -1,8 +1,8 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib combinators.short-circuit hashtables kernel math
+USING: combinators.short-circuit hashtables kernel math
math.combinatorics math.parser math.ranges project-euler.common sequences
- sequences.lib sorting sets ;
+ sorting sets ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor
index e59ca56f39..87a1387887 100644
--- a/extra/project-euler/047/047.factor
+++ b/extra/project-euler/047/047.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.lib kernel math math.primes math.primes.factors
+USING: arrays kernel math math.primes math.primes.factors
math.ranges namespaces sequences ;
IN: project-euler.047
diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor
index aec8015f94..3f562baa85 100644
--- a/extra/project-euler/052/052.factor
+++ b/extra/project-euler/052/052.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib combinators.short-circuit kernel math
+USING: combinators.short-circuit kernel math
project-euler.common sequences sorting ;
IN: project-euler.052
diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor
index 289f3a002a..bf1dd43b97 100644
--- a/extra/project-euler/055/055.factor
+++ b/extra/project-euler/055/055.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser project-euler.common sequences sequences.lib ;
+USING: kernel math math.parser project-euler.common sequences ;
IN: project-euler.055
! http://projecteuler.net/index.php?section=problems&id=55
@@ -49,8 +49,8 @@ IN: project-euler.055
: (lychrel?) ( n iteration -- ? )
dup 50 < [
- >r add-reverse dup palindrome?
- [ r> 2drop f ] [ r> 1+ (lychrel?) ] if
+ [ add-reverse ] dip over palindrome?
+ [ 2drop f ] [ 1+ (lychrel?) ] if
] [
2drop t
] if ;
diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor
index f209b50a46..e3ab9762d8 100644
--- a/extra/project-euler/059/059.factor
+++ b/extra/project-euler/059/059.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
- math.parser namespaces make sequences sequences.lib sequences.private sorting
+ math.parser namespaces make sequences sequences.private sorting
splitting grouping strings sets accessors ;
IN: project-euler.059
diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor
index 8e5b849de5..76f2a2a26e 100755
--- a/extra/project-euler/075/075.factor
+++ b/extra/project-euler/075/075.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.lib kernel math math.ranges
- namespaces project-euler.common sequences sequences.lib ;
+USING: arrays kernel math math.ranges
+ namespaces project-euler.common sequences ;
IN: project-euler.075
! http://projecteuler.net/index.php?section=problems&id=75
diff --git a/extra/project-euler/116/116.factor b/extra/project-euler/116/116.factor
index 5e2059ad9a..0e3633dc9a 100644
--- a/extra/project-euler/116/116.factor
+++ b/extra/project-euler/116/116.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences sequences.lib ;
+USING: kernel math math.ranges sequences ;
IN: project-euler.116
! http://projecteuler.net/index.php?section=problems&id=116
diff --git a/extra/project-euler/148/148.factor b/extra/project-euler/148/148.factor
index 49fd9a4895..0509936e52 100644
--- a/extra/project-euler/148/148.factor
+++ b/extra/project-euler/148/148.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences sequences.lib ;
+USING: kernel math math.functions sequences ;
IN: project-euler.148
! http://projecteuler.net/index.php?section=problems&id=148
diff --git a/extra/project-euler/151/151.factor b/extra/project-euler/151/151.factor
index b64ae3d49f..7913cf9540 100644
--- a/extra/project-euler/151/151.factor
+++ b/extra/project-euler/151/151.factor
@@ -1,7 +1,6 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs combinators kernel math math.order namespaces sequences
- sequences.lib ;
+USING: assocs combinators kernel math math.order namespaces sequences ;
IN: project-euler.151
! http://projecteuler.net/index.php?section=problems&id=151
diff --git a/extra/project-euler/186/186.factor b/extra/project-euler/186/186.factor
index 5308662daf..7504e09a81 100644
--- a/extra/project-euler/186/186.factor
+++ b/extra/project-euler/186/186.factor
@@ -1,5 +1,5 @@
USING: circular disjoint-sets kernel math math.ranges
- sequences sequences.lib ;
+sequences ;
IN: project-euler.186
: (generator) ( k -- n )
diff --git a/extra/project-euler/190/190.factor b/extra/project-euler/190/190.factor
index 35b9344362..c0b7cb577f 100644
--- a/extra/project-euler/190/190.factor
+++ b/extra/project-euler/190/190.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences sequences.lib math math.functions math.ranges locals ;
+USING: kernel sequences math math.functions math.ranges locals ;
IN: project-euler.190
! http://projecteuler.net/index.php?section=problems&id=190
diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor
index a44d41d98a..509d9b1432 100755
--- a/extra/sequences/lib/lib-tests.factor
+++ b/extra/sequences/lib/lib-tests.factor
@@ -47,13 +47,6 @@ IN: sequences.lib.tests
[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test
-[ f ] [ { } ?first ] unit-test
-[ f ] [ { } ?fourth ] unit-test
-[ 1 ] [ { 1 2 3 } ?first ] unit-test
-[ 2 ] [ { 1 2 3 } ?second ] unit-test
-[ 3 ] [ { 1 2 3 } ?third ] unit-test
-[ f ] [ { 1 2 3 } ?fourth ] unit-test
-
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index fe9d9bb587..ed7f40598c 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -131,15 +131,6 @@ PRIVATE>
: power-set ( seq -- subsets )
2 over length exact-number-strings swap [ switches ] curry map ;
-: ?first ( seq -- first/f ) 0 swap ?nth ; inline
-: ?second ( seq -- second/f ) 1 swap ?nth ; inline
-: ?third ( seq -- third/f ) 2 swap ?nth ; inline
-: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
-
-: ?first2 ( seq -- 1st/f 2nd/f ) dup ?first swap ?second ; inline
-: ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline
-: ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline
-
USE: continuations
: ?subseq ( from to seq -- subseq )
>r >r 0 max r> r>
diff --git a/extra/spider/spider-docs.factor b/extra/spider/spider-docs.factor
index 5f820ca368..41dd13e918 100644
--- a/extra/spider/spider-docs.factor
+++ b/extra/spider/spider-docs.factor
@@ -16,7 +16,7 @@ HELP: run-spider
{ "spider" spider } }
{ $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ;
-HELP: slurp-heap-when
+HELP: slurp-heap-while
{ $values
{ "heap" "a heap" } { "quot1" quotation } { "quot2" quotation } }
{ $description "Removes values from a heap that match the predicate quotation " { $snippet "quot1" } " and processes them with " { $snippet "quot2" } " until the predicate quotation no longer matches." } ;
diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index 64ee081ecc..bd5b2668be 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -9,7 +9,6 @@ IN: spider
TUPLE: spider base count max-count sleep max-depth initial-links
filters spidered todo nonmatching quiet ;
-! secure? agent page-timeout data-timeout overall-timeout
TUPLE: spider-result url depth headers fetch-time parsed-html
links processing-time timestamp ;
@@ -27,8 +26,6 @@ links processing-time timestamp ;
<PRIVATE
-: relative-url? ( url -- ? ) protocol>> not ;
-
: apply-filters ( links spider -- links' )
filters>> [ '[ _ 1&& ] filter ] when* ;
@@ -82,10 +79,10 @@ links processing-time timestamp ;
[ initial-links>> normalize-hrefs 0 ] keep
[ add-todo ] keep ;
-: slurp-heap-when ( heap quot1 quot2: ( value key -- ) -- )
+: slurp-heap-while ( heap quot1 quot2: ( value key -- ) -- )
pick heap-empty? [ 3drop ] [
[ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
- [ roll [ slurp-heap-when ] [ 3drop ] if ] 3bi
+ [ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi
] if ; inline recursive
PRIVATE>
@@ -98,7 +95,7 @@ PRIVATE>
'[
_ <= spider get
[ count>> ] [ max-count>> ] bi < and
- ] [ spider-page spider-sleep ] slurp-heap-when
+ ] [ spider-page spider-sleep ] slurp-heap-while
spider get
] with-variable
] with-logging ;
diff --git a/extra/taxes/usa/federal/federal.factor b/extra/taxes/usa/federal/federal.factor
new file mode 100644
index 0000000000..b71b831ca6
--- /dev/null
+++ b/extra/taxes/usa/federal/federal.factor
@@ -0,0 +1,59 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs kernel math math.intervals
+namespaces sequences money math.order taxes.usa.fica
+taxes.usa.medicare taxes.usa taxes.usa.w4 ;
+IN: taxes.usa.federal
+
+! http://www.irs.gov/pub/irs-pdf/p15.pdf
+! Table 7 ANNUAL Payroll Period
+
+: federal-single ( -- triples )
+ {
+ { 0 2650 DECIMAL: 0 }
+ { 2650 10300 DECIMAL: .10 }
+ { 10300 33960 DECIMAL: .15 }
+ { 33960 79725 DECIMAL: .25 }
+ { 79725 166500 DECIMAL: .28 }
+ { 166500 359650 DECIMAL: .33 }
+ { 359650 1/0. DECIMAL: .35 }
+ } ;
+
+: federal-married ( -- triples )
+ {
+ { 0 8000 DECIMAL: 0 }
+ { 8000 23550 DECIMAL: .10 }
+ { 23550 72150 DECIMAL: .15 }
+ { 72150 137850 DECIMAL: .25 }
+ { 137850 207700 DECIMAL: .28 }
+ { 207700 365100 DECIMAL: .33 }
+ { 365100 1/0. DECIMAL: .35 }
+ } ;
+
+SINGLETON: federal
+: <federal> ( -- obj )
+ federal federal-single federal-married <tax-table> ;
+
+: federal-tax ( salary w4 tax-table -- n )
+ [ adjust-allowances ] 2keep marriage-table tax ;
+
+M: federal adjust-allowances* ( salary w4 collector entity -- newsalary )
+ 2drop calculate-w4-allowances - ;
+
+M: federal withholding* ( salary w4 tax-table entity -- x )
+ drop
+ [ federal-tax ] 3keep drop
+ [ fica-tax ] 2keep
+ medicare-tax + + ;
+
+: total-withholding ( salary w4 tax-table -- x )
+ dup entity>> dup federal = [
+ withholding*
+ ] [
+ drop
+ [ drop <federal> federal withholding* ]
+ [ dup entity>> withholding* ] 3bi +
+ ] if ;
+
+: net ( salary w4 collector -- x )
+ >r dupd r> total-withholding - ;
diff --git a/extra/taxes/usa/fica/fica.factor b/extra/taxes/usa/fica/fica.factor
new file mode 100644
index 0000000000..c1e85b75b4
--- /dev/null
+++ b/extra/taxes/usa/fica/fica.factor
@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs.lib math math.order money ;
+IN: taxes.usa.fica
+
+: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline
+
+ERROR: fica-base-unknown year ;
+
+: fica-base-rate ( year -- x )
+ H{
+ { 2008 102000 }
+ { 2007 97500 }
+ } [ fica-base-unknown ] unless-at ;
+
+: fica-tax ( salary w4 -- x )
+ year>> fica-base-rate min fica-tax-rate * ;
diff --git a/extra/taxes/usa/futa/futa.factor b/extra/taxes/usa/futa/futa.factor
new file mode 100644
index 0000000000..7368aef825
--- /dev/null
+++ b/extra/taxes/usa/futa/futa.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs kernel math math.intervals
+namespaces sequences money math.order ;
+IN: taxes.usa.futa
+
+! Employer tax only, not withheld
+: futa-tax-rate ( -- x ) DECIMAL: .062 ; inline
+: futa-base-rate ( -- x ) 7000 ; inline
+: futa-tax-offset-credit ( -- x ) DECIMAL: .054 ; inline
+
+: futa-tax ( salary w4 -- x )
+ drop futa-base-rate min
+ futa-tax-rate futa-tax-offset-credit -
+ * ;
diff --git a/extra/taxes/usa/medicare/medicare.factor b/extra/taxes/usa/medicare/medicare.factor
new file mode 100644
index 0000000000..ea95224456
--- /dev/null
+++ b/extra/taxes/usa/medicare/medicare.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math money ;
+IN: taxes.usa.medicare
+
+! No base rate for medicare; all wages subject
+: medicare-tax-rate ( -- x ) DECIMAL: .0145 ; inline
+: medicare-tax ( salary w4 -- x ) drop medicare-tax-rate * ;
diff --git a/extra/taxes/usa/mn/mn.factor b/extra/taxes/usa/mn/mn.factor
new file mode 100644
index 0000000000..8bb629efcd
--- /dev/null
+++ b/extra/taxes/usa/mn/mn.factor
@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs kernel math math.intervals
+namespaces sequences money math.order usa-cities
+taxes.usa taxes.usa.w4 ;
+IN: taxes.usa.mn
+
+! Minnesota
+: mn-single ( -- triples )
+ {
+ { 0 1950 DECIMAL: 0 }
+ { 1950 23750 DECIMAL: .0535 }
+ { 23750 73540 DECIMAL: .0705 }
+ { 73540 1/0. DECIMAL: .0785 }
+ } ;
+
+: mn-married ( -- triples )
+ {
+ { 0 7400 DECIMAL: 0 }
+ { 7400 39260 DECIMAL: .0535 }
+ { 39260 133980 DECIMAL: .0705 }
+ { 133980 1/0. DECIMAL: .0785 }
+ } ;
+
+: <mn> ( -- obj )
+ MN mn-single mn-married <tax-table> ;
+
+M: MN adjust-allowances* ( salary w4 collector entity -- newsalary )
+ 2drop calculate-w4-allowances - ;
+
+M: MN withholding* ( salary w4 collector entity -- x )
+ drop
+ [ adjust-allowances ] 2keep marriage-table tax ;
diff --git a/unmaintained/taxes/taxes-tests.factor b/extra/taxes/usa/usa-tests.factor
similarity index 56%
rename from unmaintained/taxes/taxes-tests.factor
rename to extra/taxes/usa/usa-tests.factor
index 17d1998f67..a529762c81 100644
--- a/unmaintained/taxes/taxes-tests.factor
+++ b/extra/taxes/usa/usa-tests.factor
@@ -1,5 +1,7 @@
-USING: kernel money taxes tools.test ;
-IN: taxes.tests
+USING: kernel money tools.test
+taxes.usa taxes.usa.federal taxes.usa.mn
+taxes.utils taxes.usa.w4 usa-cities ;
+IN: taxes.usa.tests
[
426 23
@@ -42,14 +44,14 @@ IN: taxes.tests
[
780 81
] [
- 24000 2008 3 f <w4> <minnesota> net biweekly
+ 24000 2008 3 f <w4> <mn> net biweekly
dollars/cents
] unit-test
[
818 76
] [
- 24000 2008 3 t <w4> <minnesota> net biweekly
+ 24000 2008 3 t <w4> <mn> net biweekly
dollars/cents
] unit-test
@@ -57,14 +59,14 @@ IN: taxes.tests
[
2124 39
] [
- 78250 2008 3 f <w4> <minnesota> net biweekly
+ 78250 2008 3 f <w4> <mn> net biweekly
dollars/cents
] unit-test
[
2321 76
] [
- 78250 2008 3 t <w4> <minnesota> net biweekly
+ 78250 2008 3 t <w4> <mn> net biweekly
dollars/cents
] unit-test
@@ -72,45 +74,45 @@ IN: taxes.tests
[
2612 63
] [
- 100000 2008 3 f <w4> <minnesota> net biweekly
+ 100000 2008 3 f <w4> <mn> net biweekly
dollars/cents
] unit-test
[
22244 52
] [
- 1000000 2008 3 f <w4> <minnesota> net biweekly
+ 1000000 2008 3 f <w4> <mn> net biweekly
dollars/cents
] unit-test
[
578357 40
] [
- 1000000 2008 3 f <w4> <minnesota> net
+ 1000000 2008 3 f <w4> <mn> net
dollars/cents
] unit-test
[
588325 41
] [
- 1000000 2008 3 t <w4> <minnesota> net
+ 1000000 2008 3 t <w4> <mn> net
dollars/cents
] unit-test
[ 30 97 ] [
- 24000 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
+ 24000 2008 2 f <w4> <mn> MN withholding* biweekly dollars/cents
] unit-test
[ 173 66 ] [
- 78250 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
+ 78250 2008 2 f <w4> <mn> MN withholding* biweekly dollars/cents
] unit-test
[ 138 69 ] [
- 24000 2008 2 f <w4> <federal> withholding biweekly dollars/cents
+ 24000 2008 2 f <w4> <federal> total-withholding biweekly dollars/cents
] unit-test
[ 754 72 ] [
- 78250 2008 2 f <w4> <federal> withholding biweekly dollars/cents
+ 78250 2008 2 f <w4> <federal> total-withholding biweekly dollars/cents
] unit-test
diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor
new file mode 100644
index 0000000000..27ff4aef98
--- /dev/null
+++ b/extra/taxes/usa/usa.factor
@@ -0,0 +1,32 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs kernel math math.intervals
+namespaces sequences money math.order taxes.usa.w4 ;
+IN: taxes.usa
+
+! Withhold: FICA, Medicare, Federal (FICA is social security)
+
+TUPLE: tax-table entity single married ;
+C: <tax-table> tax-table
+
+GENERIC: adjust-allowances* ( salary w4 tax-table entity -- newsalary )
+GENERIC: withholding* ( salary w4 tax-table entity -- x )
+
+: adjust-allowances ( salary w4 tax-table -- newsalary )
+ dup entity>> adjust-allowances* ;
+
+: withholding ( salary w4 tax-table -- x )
+ dup entity>> withholding* ;
+
+: tax-bracket-range ( pair -- n ) first2 swap - ;
+
+: tax-bracket ( tax salary triples -- tax salary )
+ [ [ tax-bracket-range min ] keep third * + ] 2keep
+ tax-bracket-range [-] ;
+
+: tax ( salary triples -- x )
+ 0 -rot [ tax-bracket ] each drop ;
+
+: marriage-table ( w4 tax-table -- triples )
+ swap married?>>
+ [ married>> ] [ single>> ] if ;
diff --git a/extra/taxes/usa/w4/w4.factor b/extra/taxes/usa/w4/w4.factor
new file mode 100644
index 0000000000..aad3773220
--- /dev/null
+++ b/extra/taxes/usa/w4/w4.factor
@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math ;
+IN: taxes.usa.w4
+
+! Each employee fills out a w4
+TUPLE: w4 year allowances married? ;
+C: <w4> w4
+
+: allowance ( -- x ) 3500 ; inline
+
+: calculate-w4-allowances ( w4 -- x ) allowances>> allowance * ;
+
diff --git a/extra/taxes/utils/utils.factor b/extra/taxes/utils/utils.factor
new file mode 100644
index 0000000000..a5c2240625
--- /dev/null
+++ b/extra/taxes/utils/utils.factor
@@ -0,0 +1,10 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math ;
+IN: taxes.utils
+
+: monthly ( x -- y ) 12 / ;
+: semimonthly ( x -- y ) 24 / ;
+: biweekly ( x -- y ) 26 / ;
+: weekly ( x -- y ) 52 / ;
+: daily ( x -- y ) 360 / ;
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 00d843573c..6c097d7faa 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -195,5 +195,5 @@ posting "POSTINGS"
<boilerplate>
{ planet "planet-common" } >>template ;
-: start-update-task ( db params -- )
- '[ _ _ [ update-cached-postings ] with-db ] 10 minutes every drop ;
+: start-update-task ( db -- )
+ '[ _ [ update-cached-postings ] with-db ] 10 minutes every drop ;
diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor
index 5553fda740..d7fdfa2460 100644
--- a/extra/websites/concatenative/concatenative.factor
+++ b/extra/websites/concatenative/concatenative.factor
@@ -26,7 +26,7 @@ webapps.user-admin
webapps.help ;
IN: websites.concatenative
-: test-db ( -- params db ) "resource:test.db" sqlite-db ;
+: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
: init-factor-db ( -- )
test-db [
diff --git a/unmaintained/assoc-heaps/assoc-heaps-tests.factor b/unmaintained/assoc-heaps/assoc-heaps-tests.factor
deleted file mode 100644
index 24a7730847..0000000000
--- a/unmaintained/assoc-heaps/assoc-heaps-tests.factor
+++ /dev/null
@@ -1,55 +0,0 @@
-USING: assocs assoc-heaps heaps heaps.private kernel tools.test ;
-IN: temporary
-
-[
-T{
- assoc-heap
- f
- H{ { 2 1 } }
- T{ min-heap T{ heap f V{ { 1 2 } } } }
-}
-] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push ] unit-test
-
-[
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
-}
-] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push 0 1 pick heap-push ] unit-test
-
-[ T{ assoc-heap f H{ } T{ min-heap T{ heap f V{ } } } } ]
-[
- H{ } clone <assoc-min-heap>
- 1 2 pick heap-push 0 1 pick heap-push
- dup heap-pop 2drop dup heap-pop 2drop
-] unit-test
-
-
-[ 0 1 ] [
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
-} heap-pop
-] unit-test
-
-[ 1 2 ] [
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } }
-} heap-pop
-] unit-test
-
-[
-T{
- assoc-heap
- f
- H{ { 1 2 } { 3 4 } }
- T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } } } }
-}
-] [ H{ { 1 2 } { 3 4 } } H{ } clone <assoc-min-heap> [ heap-push-all ] keep ] unit-test
diff --git a/unmaintained/assoc-heaps/assoc-heaps.factor b/unmaintained/assoc-heaps/assoc-heaps.factor
deleted file mode 100755
index 55a5aa7f62..0000000000
--- a/unmaintained/assoc-heaps/assoc-heaps.factor
+++ /dev/null
@@ -1,45 +0,0 @@
-USING: assocs heaps kernel sequences ;
-IN: assoc-heaps
-
-TUPLE: assoc-heap assoc heap ;
-
-INSTANCE: assoc-heap assoc
-INSTANCE: assoc-heap priority-queue
-
-C: <assoc-heap> assoc-heap
-
-: <assoc-min-heap> ( assoc -- obj ) <min-heap> <assoc-heap> ;
-: <assoc-max-heap> ( assoc -- obj ) <max-heap> <assoc-heap> ;
-
-M: assoc-heap at* ( key assoc-heap -- value ? )
- assoc-heap-assoc at* ;
-
-M: assoc-heap assoc-size ( assoc-heap -- n )
- assoc-heap-assoc assoc-size ;
-
-TUPLE: assoc-heap-key-exists ;
-
-: check-key-exists ( key assoc-heap -- )
- assoc-heap-assoc key?
- [ \ assoc-heap-key-exists construct-empty throw ] when ;
-
-M: assoc-heap set-at ( value key assoc-heap -- )
- [ check-key-exists ] 2keep
- [ assoc-heap-assoc set-at ] 3keep
- assoc-heap-heap swapd heap-push ;
-
-M: assoc-heap heap-empty? ( assoc-heap -- ? )
- assoc-heap-assoc assoc-empty? ;
-
-M: assoc-heap heap-length ( assoc-heap -- n )
- assoc-heap-assoc assoc-size ;
-
-M: assoc-heap heap-peek ( assoc-heap -- value key )
- assoc-heap-heap heap-peek ;
-
-M: assoc-heap heap-push ( value key assoc-heap -- )
- set-at ;
-
-M: assoc-heap heap-pop ( assoc-heap -- value key )
- dup assoc-heap-heap heap-pop swap
- rot dupd assoc-heap-assoc delete-at ;
diff --git a/unmaintained/assoc-heaps/authors.txt b/unmaintained/assoc-heaps/authors.txt
deleted file mode 100755
index 7c1b2f2279..0000000000
--- a/unmaintained/assoc-heaps/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/unmaintained/assoc-heaps/summary.txt b/unmaintained/assoc-heaps/summary.txt
deleted file mode 100755
index 07ae2e33f8..0000000000
--- a/unmaintained/assoc-heaps/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Priority search queues
diff --git a/unmaintained/lint/lint.factor b/unmaintained/lint/lint.factor
index 644346d29e..ab1a67a83e 100644
--- a/unmaintained/lint/lint.factor
+++ b/unmaintained/lint/lint.factor
@@ -3,14 +3,15 @@
USING: accessors alien alien.accessors arrays assocs
combinators.lib io kernel macros math namespaces prettyprint
quotations sequences vectors vocabs words html.elements sets
-slots.private combinators.short-circuit ;
+slots.private combinators.short-circuit math.order hashtables
+sequences.deep ;
IN: lint
SYMBOL: def-hash
SYMBOL: def-hash-keys
: set-hash-vector ( val key hash -- )
- 2dup at -rot >r >r ?push r> r> set-at ;
+ 2dup at -rot [ ?push ] 2dip set-at ;
: add-word-def ( word quot -- )
dup callable? [
@@ -67,7 +68,7 @@ def-hash get-global [
! Remove constants [ 1 ]
[
- drop dup length 1 = swap first number? and not
+ drop { [ length 1 = ] [ first number? ] } 1&& not
] assoc-filter
! Remove set-alien-cell, etc.
@@ -80,6 +81,13 @@ def-hash get-global [
drop trivial-defs member? not
] assoc-filter
+[
+ drop {
+ [ [ wrapper? ] deep-contains? ]
+ [ [ hashtable? ] deep-contains? ]
+ } 1|| not
+] assoc-filter
+
! Remove n m shift defs
[
drop dup length 3 = [
diff --git a/unmaintained/taxes/authors.txt b/unmaintained/taxes/authors.txt
deleted file mode 100644
index 7c1b2f2279..0000000000
--- a/unmaintained/taxes/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/unmaintained/taxes/summary.txt b/unmaintained/taxes/summary.txt
deleted file mode 100644
index e983139ccb..0000000000
--- a/unmaintained/taxes/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Calculate federal and state tax withholdings
diff --git a/unmaintained/taxes/tags.txt b/unmaintained/taxes/tags.txt
deleted file mode 100644
index 2964ef21b1..0000000000
--- a/unmaintained/taxes/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-taxes
diff --git a/unmaintained/taxes/taxes.factor b/unmaintained/taxes/taxes.factor
deleted file mode 100644
index 5e2a395c40..0000000000
--- a/unmaintained/taxes/taxes.factor
+++ /dev/null
@@ -1,145 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs kernel math math.intervals
-namespaces sequences combinators.lib money math.order ;
-IN: taxes
-
-: monthly ( x -- y ) 12 / ;
-: semimonthly ( x -- y ) 24 / ;
-: biweekly ( x -- y ) 26 / ;
-: weekly ( x -- y ) 52 / ;
-: daily ( x -- y ) 360 / ;
-
-! Each employee fills out a w4
-TUPLE: w4 year allowances married? ;
-C: <w4> w4
-
-: allowance ( -- x ) 3500 ; inline
-
-: calculate-w4-allowances ( w4 -- x ) allowances>> allowance * ;
-
-! Withhold: FICA, Medicare, Federal (FICA is social security)
-: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline
-
-! Base rate -- income over this rate is not taxed
-ERROR: fica-base-unknown ;
-: fica-base-rate ( year -- x )
- H{
- { 2008 102000 }
- { 2007 97500 }
- } at* [ fica-base-unknown ] unless ;
-
-: fica-tax ( salary w4 -- x )
- year>> fica-base-rate min fica-tax-rate * ;
-
-! Employer tax only, not withheld
-: futa-tax-rate ( -- x ) DECIMAL: .062 ; inline
-: futa-base-rate ( -- x ) 7000 ; inline
-: futa-tax-offset-credit ( -- x ) DECIMAL: .054 ; inline
-
-: futa-tax ( salary w4 -- x )
- drop futa-base-rate min
- futa-tax-rate futa-tax-offset-credit -
- * ;
-
-! No base rate for medicare; all wages subject
-: medicare-tax-rate ( -- x ) DECIMAL: .0145 ; inline
-: medicare-tax ( salary w4 -- x ) drop medicare-tax-rate * ;
-
-MIXIN: collector
-GENERIC: adjust-allowances ( salary w4 collector -- newsalary )
-GENERIC: withholding ( salary w4 collector -- x )
-
-TUPLE: tax-table single married ;
-
-: <tax-table> ( single married class -- obj )
- >r tax-table boa r> construct-delegate ;
-
-: tax-bracket-range ( pair -- n ) dup second swap first - ;
-
-: tax-bracket ( tax salary triples -- tax salary )
- [ [ tax-bracket-range min ] keep third * + ] 2keep
- tax-bracket-range [-] ;
-
-: tax ( salary triples -- x )
- 0 -rot [ tax-bracket ] each drop ;
-
-: marriage-table ( w4 tax-table -- triples )
- swap married?>> [ married>> ] [ single>> ] if ;
-
-: federal-tax ( salary w4 tax-table -- n )
- [ adjust-allowances ] 2keep marriage-table tax ;
-
-! http://www.irs.gov/pub/irs-pdf/p15.pdf
-! Table 7 ANNUAL Payroll Period
-
-: federal-single ( -- triples )
- {
- { 0 2650 DECIMAL: 0 }
- { 2650 10300 DECIMAL: .10 }
- { 10300 33960 DECIMAL: .15 }
- { 33960 79725 DECIMAL: .25 }
- { 79725 166500 DECIMAL: .28 }
- { 166500 359650 DECIMAL: .33 }
- { 359650 1/0. DECIMAL: .35 }
- } ;
-
-: federal-married ( -- triples )
- {
- { 0 8000 DECIMAL: 0 }
- { 8000 23550 DECIMAL: .10 }
- { 23550 72150 DECIMAL: .15 }
- { 72150 137850 DECIMAL: .25 }
- { 137850 207700 DECIMAL: .28 }
- { 207700 365100 DECIMAL: .33 }
- { 365100 1/0. DECIMAL: .35 }
- } ;
-
-TUPLE: federal ;
-INSTANCE: federal collector
-: <federal> ( -- obj )
- federal-single federal-married federal <tax-table> ;
-
-M: federal adjust-allowances ( salary w4 collector -- newsalary )
- drop calculate-w4-allowances - ;
-
-M: federal withholding ( salary w4 tax-table -- x )
- [ federal-tax ] 3keep drop
- [ fica-tax ] 2keep
- medicare-tax + + ;
-
-
-! Minnesota
-: minnesota-single ( -- triples )
- {
- { 0 1950 DECIMAL: 0 }
- { 1950 23750 DECIMAL: .0535 }
- { 23750 73540 DECIMAL: .0705 }
- { 73540 1/0. DECIMAL: .0785 }
- } ;
-
-: minnesota-married ( -- triples )
- {
- { 0 7400 DECIMAL: 0 }
- { 7400 39260 DECIMAL: .0535 }
- { 39260 133980 DECIMAL: .0705 }
- { 133980 1/0. DECIMAL: .0785 }
- } ;
-
-TUPLE: minnesota ;
-INSTANCE: minnesota collector
-: <minnesota> ( -- obj )
- minnesota-single minnesota-married minnesota <tax-table> ;
-
-M: minnesota adjust-allowances ( salary w4 collector -- newsalary )
- drop calculate-w4-allowances - ;
-
-M: minnesota withholding ( salary w4 collector -- x )
- [ adjust-allowances ] 2keep marriage-table tax ;
-
-: employer-withhold ( salary w4 collector -- x )
- [ withholding ] 3keep
- dup federal? [ 3drop ] [ drop <federal> withholding + ] if ;
-
-: net ( salary w4 collector -- x )
- >r dupd r> employer-withhold - ;
diff --git a/unmaintained/webapps/help/help.factor b/unmaintained/webapps/help/help.factor
deleted file mode 100644
index 28d73607ba..0000000000
--- a/unmaintained/webapps/help/help.factor
+++ /dev/null
@@ -1,89 +0,0 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel furnace furnace.validator http.server.responders
- help help.topics html splitting sequences words strings
- quotations macros vocabs tools.browser combinators
- arrays io.files ;
-IN: webapps.help
-
-! : string>topic ( string -- topic )
- ! " " split dup length 1 = [ first ] when ;
-
-: show-help ( topic -- )
- serving-html
- dup article-title [
- [ help ] with-html-stream
- ] simple-html-document ;
-
-\ show-help {
- { "topic" }
-} define-action
-\ show-help { { "topic" "handbook" } } default-values
-
-M: link browser-link-href
- link-name
- dup word? over f eq? or [
- browser-link-href
- ] [
- dup array? [ " " join ] when
- [ show-help ] curry quot-link
- ] if ;
-
-: show-word ( word vocab -- )
- lookup show-help ;
-
-\ show-word {
- { "word" }
- { "vocab" }
-} define-action
-\ show-word { { "word" "call" } { "vocab" "kernel" } } default-values
-
-M: f browser-link-href
- drop \ f browser-link-href ;
-
-M: word browser-link-href
- dup word-name swap word-vocabulary
- [ show-word ] 2curry quot-link ;
-
-: show-vocab ( vocab -- )
- f >vocab-link show-help ;
-
-\ show-vocab {
- { "vocab" }
-} define-action
-
-\ show-vocab { { "vocab" "kernel" } } default-values
-
-M: vocab-spec browser-link-href
- vocab-name [ show-vocab ] curry quot-link ;
-
-: show-vocabs-tagged ( tag -- )
- <vocab-tag> show-help ;
-
-\ show-vocabs-tagged {
- { "tag" }
-} define-action
-
-M: vocab-tag browser-link-href
- vocab-tag-name [ show-vocabs-tagged ] curry quot-link ;
-
-: show-vocabs-by ( author -- )
- <vocab-author> show-help ;
-
-\ show-vocabs-by {
- { "author" }
-} define-action
-
-M: vocab-author browser-link-href
- vocab-author-name [ show-vocabs-by ] curry quot-link ;
-
-"help" "show-help" "extra/webapps/help" web-app
-
-! Hard-coding for factorcode.org
-PREDICATE: pathname resource-pathname
- pathname-string "resource:" head? ;
-
-M: resource-pathname browser-link-href
- pathname-string
- "resource:" ?head drop
- "/responder/source/" swap append ;
diff --git a/unmaintained/webapps/pastebin/annotate-paste.furnace b/unmaintained/webapps/pastebin/annotate-paste.furnace
deleted file mode 100755
index 14a424f776..0000000000
--- a/unmaintained/webapps/pastebin/annotate-paste.furnace
+++ /dev/null
@@ -1,47 +0,0 @@
-<% USING: io math math.parser namespaces furnace ; %>
-
-<h1>Annotate</h1>
-
-<form method="POST" action="/responder/pastebin/annotate-paste">
-
-<table>
-
-<tr>
-<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
-<td align="left" class="error"><% "summary" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
-<td class="error"><% "author" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">File type:</th>
-<td><% "modes" render-template %></td>
-</tr>
-
-<!--
-<tr>
-<th align="right">Channel:</th>
-<td><input type="TEXT" name="channel" value="#concatenative" /></td>
-</tr>
--->
-
-<tr>
-<td></td>
-<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right" valign="top">Content:</th>
-<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
-</tr>
-</table>
-
-<input type="hidden" name="n" value="<% "n" get number>string write %>" />
-<input type="hidden" name="furnace-form-submitted" value="annotate-paste"/>
-<input type="SUBMIT" value="Annotate" />
-</form>
diff --git a/unmaintained/webapps/pastebin/annotation.furnace b/unmaintained/webapps/pastebin/annotation.furnace
deleted file mode 100755
index e59db32484..0000000000
--- a/unmaintained/webapps/pastebin/annotation.furnace
+++ /dev/null
@@ -1,11 +0,0 @@
-<% USING: namespaces io furnace calendar ; %>
-
-<h2>Annotation: <% "summary" get write %></h2>
-
-<table>
-<tr><th align="right">Annotation by:</th><td><% "author" get write %></td></tr>
-<tr><th align="right">File type:</th><td><% "mode" get write %></td></tr>
-<tr><th align="right">Created:</th><td><% "date" get timestamp>string write %></td></tr>
-</table>
-
-<% "syntax" render-template %>
diff --git a/unmaintained/webapps/pastebin/footer.furnace b/unmaintained/webapps/pastebin/footer.furnace
deleted file mode 100644
index 15b90110a0..0000000000
--- a/unmaintained/webapps/pastebin/footer.furnace
+++ /dev/null
@@ -1,3 +0,0 @@
-</body>
-
-</html>
diff --git a/unmaintained/webapps/pastebin/header.furnace b/unmaintained/webapps/pastebin/header.furnace
deleted file mode 100644
index 2c8e79a18d..0000000000
--- a/unmaintained/webapps/pastebin/header.furnace
+++ /dev/null
@@ -1,23 +0,0 @@
-<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
- <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
-
- <title><% "title" get write %></title>
- <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <% default-stylesheet %>
- <link rel="alternate" type="application/atom+xml" title="Pastebin - Atom" href="feed.xml" />
-</head>
-
-<body id="index">
-
- <div class="navbar">
- <% [ paste-list ] "Paste list" render-link %> |
- <% [ new-paste ] "New paste" render-link %> |
- <% [ feed.xml ] "Syndicate" render-link %>
- </div>
- <h1 class="pastebin-title"><% "title" get write %></h1>
diff --git a/unmaintained/webapps/pastebin/modes.furnace b/unmaintained/webapps/pastebin/modes.furnace
deleted file mode 100644
index 18bbec180a..0000000000
--- a/unmaintained/webapps/pastebin/modes.furnace
+++ /dev/null
@@ -1,7 +0,0 @@
-<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %>
-
-<select name="mode">
- <% modes keys natural-sort [
- <option dup "mode" session-var = [ "true" =selected ] when option> write </option>
- ] each %>
-</select>
diff --git a/unmaintained/webapps/pastebin/new-paste.furnace b/unmaintained/webapps/pastebin/new-paste.furnace
deleted file mode 100755
index b21e19734d..0000000000
--- a/unmaintained/webapps/pastebin/new-paste.furnace
+++ /dev/null
@@ -1,51 +0,0 @@
-<% USING: continuations furnace namespaces ; %>
-
-<%
- "New paste" "title" set
- "header" render-template
-%>
-
-<form method="POST" action="/responder/pastebin/submit-paste">
-
-<table>
-
-<tr>
-<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
-<td align="left" class="error"><% "summary" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
-<td class="error"><% "author" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">File type:</th>
-<td><% "modes" render-template %></td>
-</tr>
-
-<!--
-<tr>
-<th align="right">Channel:</th>
-<td><input type="TEXT" name="channel" value="#concatenative" /></td>
-</tr>
--->
-
-<tr>
-<td></td>
-<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right" valign="top">Content:</th>
-<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
-</tr>
-</table>
-
-<input type="hidden" name="furnace-form-submitted" value="new-paste"/>
-<input type="SUBMIT" value="Submit paste" />
-</form>
-
-<% "footer" render-template %>
diff --git a/unmaintained/webapps/pastebin/paste-list.furnace b/unmaintained/webapps/pastebin/paste-list.furnace
deleted file mode 100644
index 51813ecf97..0000000000
--- a/unmaintained/webapps/pastebin/paste-list.furnace
+++ /dev/null
@@ -1,33 +0,0 @@
-<% USING: namespaces furnace sequences ; %>
-
-<%
- "Pastebin" "title" set
- "header" render-template
-%>
-
-<table width="100%" cellspacing="10">
- <tr>
- <td valign="top">
- <table width="100%">
- <tr align="left" class="pastebin-headings">
- <th width="50%">Summary:</th>
- <th width="100">Paste by:</th>
- <th width="200">Date:</th>
- </tr>
- <% "pastes" get <reversed> [ "paste-summary" render-component ] each %>
- </table>
- </td>
- <td valign="top" width="25%">
- <div class="infobox">
- <p>This pastebin is written in <a href="http://factorcode.org/">Factor</a>. It is inspired by <a href="http://paste.lisp.org">lisppaste</a>.
- </p>
- <p>It can be used for collaborative development over IRC. You can post code for review, and annotate other people's code. Syntax highlighting for over a hundred file types is supported.
- </p>
- <p>
- <% "webapps.pastebin" browse-webapp-source %></p>
- </div>
- </td>
- </tr>
-</table>
-
-<% "footer" render-template %>
diff --git a/unmaintained/webapps/pastebin/paste-summary.furnace b/unmaintained/webapps/pastebin/paste-summary.furnace
deleted file mode 100644
index dc25fe1924..0000000000
--- a/unmaintained/webapps/pastebin/paste-summary.furnace
+++ /dev/null
@@ -1,12 +0,0 @@
-<% USING: continuations namespaces io kernel math math.parser
-furnace webapps.pastebin calendar sequences ; %>
-
-<tr>
- <td>
- <a href="<% model get paste-link write %>">
- <% "summary" get write %>
- </a>
- </td>
- <td><% "author" get write %></td>
- <td><% "date" get timestamp>string write %></td>
-</tr>
diff --git a/unmaintained/webapps/pastebin/pastebin.factor b/unmaintained/webapps/pastebin/pastebin.factor
deleted file mode 100755
index 36a72795db..0000000000
--- a/unmaintained/webapps/pastebin/pastebin.factor
+++ /dev/null
@@ -1,119 +0,0 @@
-USING: calendar furnace furnace.validator io.files kernel
-namespaces sequences http.server.responders html math.parser rss
-xml.writer xmode.code2html math calendar.format ;
-IN: webapps.pastebin
-
-TUPLE: pastebin pastes ;
-
-: <pastebin> ( -- pastebin )
- V{ } clone pastebin construct-boa ;
-
-<pastebin> pastebin set-global
-
-TUPLE: paste
-summary author channel mode contents date
-annotations n ;
-
-: <paste> ( summary author channel mode contents -- paste )
- f V{ } clone f paste construct-boa ;
-
-TUPLE: annotation summary author mode contents ;
-
-C: <annotation> annotation
-
-: get-paste ( n -- paste )
- pastebin get pastebin-pastes nth ;
-
-: show-paste ( n -- )
- serving-html
- get-paste
- [ "show-paste" render-component ] with-html-stream ;
-
-\ show-paste { { "n" v-number } } define-action
-
-: new-paste ( -- )
- serving-html
- [ "new-paste" render-template ] with-html-stream ;
-
-\ new-paste { } define-action
-
-: paste-list ( -- )
- serving-html
- [
- [ show-paste ] "show-paste-quot" set
- [ new-paste ] "new-paste-quot" set
- pastebin get "paste-list" render-component
- ] with-html-stream ;
-
-\ paste-list { } define-action
-
-: paste-link ( paste -- link )
- paste-n number>string [ show-paste ] curry quot-link ;
-
-: safe-head ( seq n -- seq' )
- over length min head ;
-
-: paste-feed ( -- entries )
- pastebin get pastebin-pastes <reversed> 20 safe-head [
- {
- paste-summary
- paste-link
- paste-date
- } get-slots timestamp>rfc3339 f swap <entry>
- ] map ;
-
-: feed.xml ( -- )
- "text/xml" serving-content
- "pastebin"
- "http://pastebin.factorcode.org"
- paste-feed <feed> feed>xml write-xml ;
-
-\ feed.xml { } define-action
-
-: add-paste ( paste pastebin -- )
- >r now over set-paste-date r>
- pastebin-pastes 2dup length swap set-paste-n push ;
-
-: submit-paste ( summary author channel mode contents -- )
- <paste> [ pastebin get add-paste ] keep
- paste-link permanent-redirect ;
-
-\ new-paste
-\ submit-paste {
- { "summary" v-required }
- { "author" v-required }
- { "channel" }
- { "mode" v-required }
- { "contents" v-required }
-} define-form
-
-\ new-paste {
- { "channel" "#concatenative" }
- { "mode" "factor" }
-} default-values
-
-: annotate-paste ( n summary author mode contents -- )
- <annotation> swap get-paste
- [ paste-annotations push ] keep
- paste-link permanent-redirect ;
-
-[ "n" show-paste ]
-\ annotate-paste {
- { "n" v-required v-number }
- { "summary" v-required }
- { "author" v-required }
- { "mode" v-required }
- { "contents" v-required }
-} define-form
-
-\ show-paste {
- { "mode" "factor" }
-} default-values
-
-: style.css ( -- )
- "text/css" serving-content
- "style.css" send-resource ;
-
-\ style.css { } define-action
-
-"pastebin" "paste-list" "extra/webapps/pastebin" web-app
diff --git a/unmaintained/webapps/pastebin/show-paste.furnace b/unmaintained/webapps/pastebin/show-paste.furnace
deleted file mode 100755
index 30129eda24..0000000000
--- a/unmaintained/webapps/pastebin/show-paste.furnace
+++ /dev/null
@@ -1,21 +0,0 @@
-<% USING: namespaces io furnace sequences xmode.code2html calendar ; %>
-
-<%
- "Paste: " "summary" get append "title" set
- "header" render-template
-%>
-
-<table>
-<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
-<!-- <tr><th>Channel:</th><td><% "channel" get write %></td></tr> -->
-<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
-<tr><th>File type:</th><td><% "mode" get write %></td></tr>
-</table>
-
-<% "syntax" render-template %>
-
-<% "annotations" get [ "annotation" render-component ] each %>
-
-<% model get "annotate-paste" render-component %>
-
-<% "footer" render-template %>
diff --git a/unmaintained/webapps/pastebin/style.css b/unmaintained/webapps/pastebin/style.css
deleted file mode 100644
index 4a469f92cb..0000000000
--- a/unmaintained/webapps/pastebin/style.css
+++ /dev/null
@@ -1,41 +0,0 @@
-body {
- font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#888;
-}
-
-h1.pastebin-title {
- font-size:300%;
-}
-
-a {
- color:#222;
- border-bottom:1px dotted #ccc;
- text-decoration:none;
-}
-
-a:hover {
- border-bottom:1px solid #ccc;
-}
-
-pre.code {
- border:1px dashed #ccc;
- background-color:#f5f5f5;
- padding:5px;
- font-size:150%;
- color:#000000;
-}
-
-.navbar {
- background-color:#eeeeee;
- padding:5px;
- border:1px solid #ccc;
-}
-
-.infobox {
- border: 1px solid #C1DAD7;
- padding: 10px;
-}
-
-.error {
- color: red;
-}
diff --git a/unmaintained/webapps/pastebin/syntax.furnace b/unmaintained/webapps/pastebin/syntax.furnace
deleted file mode 100755
index 17b64b920b..0000000000
--- a/unmaintained/webapps/pastebin/syntax.furnace
+++ /dev/null
@@ -1,3 +0,0 @@
-<% USING: xmode.code2html splitting namespaces ; %>
-
-<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>
diff --git a/unmaintained/webapps/planet/authors.txt b/unmaintained/webapps/planet/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/unmaintained/webapps/planet/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/unmaintained/webapps/planet/planet.factor b/unmaintained/webapps/planet/planet.factor
deleted file mode 100755
index 9a5f8eeb97..0000000000
--- a/unmaintained/webapps/planet/planet.factor
+++ /dev/null
@@ -1,129 +0,0 @@
-USING: sequences rss arrays concurrency.combinators kernel
-sorting html.elements io assocs namespaces math threads vocabs
-html furnace http.server.templating calendar math.parser
-splitting continuations debugger system http.server.responders
-xml.writer prettyprint logging calendar.format ;
-IN: webapps.planet
-
-: print-posting-summary ( posting -- )
- <p "news" =class p>
- <b> dup entry-title write </b> <br/>
- <a entry-link =href "more" =class a>
- "Read More..." write
- </a>
- </p> ;
-
-: print-posting-summaries ( postings -- )
- [ print-posting-summary ] each ;
-
-: print-blogroll ( blogroll -- )
- <ul "description" =class ul>
- [
- <li> <a dup third =href a> first write </a> </li>
- ] each
- </ul> ;
-
-: format-date ( date -- string )
- rfc3339>timestamp timestamp>string ;
-
-: print-posting ( posting -- )
- <h2 "posting-title" =class h2>
- <a dup entry-link =href a>
- dup entry-title write-html
- </a>
- </h2>
- <p "posting-body" =class p>
- dup entry-description write-html
- </p>
- <p "posting-date" =class p>
- entry-pub-date format-date write
- </p> ;
-
-: print-postings ( postings -- )
- [ print-posting ] each ;
-
-SYMBOL: default-blogroll
-SYMBOL: cached-postings
-
-: safe-head ( seq n -- seq' )
- over length min head ;
-
-: mini-planet-factor ( -- )
- cached-postings get 4 safe-head print-posting-summaries ;
-
-: planet-factor ( -- )
- serving-html [ "planet" render-template ] with-html-stream ;
-
-\ planet-factor { } define-action
-
-: planet-feed ( -- feed )
- "[ planet-factor ]"
- "http://planet.factorcode.org"
- cached-postings get 30 safe-head <feed> ;
-
-: feed.xml ( -- )
- "text/xml" serving-content
- planet-feed feed>xml write-xml ;
-
-\ feed.xml { } define-action
-
-: style.css ( -- )
- "text/css" serving-content
- "style.css" send-resource ;
-
-\ style.css { } define-action
-
-SYMBOL: last-update
-
-: <posting> ( author entry -- entry' )
- clone
- [ ": " swap entry-title 3append ] keep
- [ set-entry-title ] keep ;
-
-: fetch-feed ( url -- feed )
- download-feed feed-entries ;
-
-\ fetch-feed DEBUG add-error-logging
-
-: fetch-blogroll ( blogroll -- entries )
- dup 0 <column> swap 1 <column>
- [ fetch-feed ] parallel-map
- [ [ <posting> ] with map ] 2map concat ;
-
-: sort-entries ( entries -- entries' )
- [ [ entry-pub-date ] compare ] sort <reversed> ;
-
-: update-cached-postings ( -- )
- default-blogroll get
- fetch-blogroll sort-entries
- cached-postings set-global ;
-
-: update-thread ( -- )
- millis last-update set-global
- [ update-cached-postings ] "RSS feed update slave" spawn drop
- 10 60 * 1000 * sleep
- update-thread ;
-
-: start-update-thread ( -- )
- [
- "webapps.planet" [
- update-thread
- ] with-logging
- ] "RSS feed update master" spawn drop ;
-
-"planet" "planet-factor" "extra/webapps/planet" web-app
-
-{
- { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
- { "Chris Double" "http://www.blogger.com/feeds/18561009/posts/full/-/factor" "http://www.bluishcoder.co.nz/" }
- { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
- { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
- { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
- { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
- { "Kio M. Smallwood"
- "http://sekenre.wordpress.com/feed/atom/"
- "http://sekenre.wordpress.com/" }
- { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
- { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
- { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
-} default-blogroll set-global
diff --git a/unmaintained/webapps/planet/planet.furnace b/unmaintained/webapps/planet/planet.furnace
deleted file mode 100644
index 4c6676c0a2..0000000000
--- a/unmaintained/webapps/planet/planet.furnace
+++ /dev/null
@@ -1,45 +0,0 @@
-<% USING: namespaces html.elements webapps.planet sequences
-furnace ; %>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
- <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
-
- <title>planet-factor</title>
- <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <link rel="alternate" type="application/atom+xml" title="Planet Factor - Atom" href="feed.xml" />
-</head>
-
-<body id="index">
- <h1 class="planet-title">[ planet-factor ]</h1>
- <table width="100%" cellpadding="10">
- <tr>
- <td> <% cached-postings get 20 safe-head print-postings %> </td>
- <td valign="top" width="25%" class="infobox">
- <p>
- <b>planet-factor</b> is an Atom/RSS aggregator that collects the
- contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It is inspired by
- <a href="http://planet.lisp.org">Planet Lisp</a>.
- </p>
- <p>
- <img src="http://planet.lisp.org/feed-icon-14x14.png" />
- <a href="feed.xml"> Syndicate </a>
- </p>
- <p>
- This webapp is written in <a href="http://factorcode.org/">Factor</a>.<br/>
- <% "webapps.planet" browse-webapp-source %>
- </p>
- <h2 class="blogroll-title">Blogroll</h2>
- <% default-blogroll get print-blogroll %>
- <p>
- If you want your weblog added to the blogroll, <a href="http://factorcode.org/gethelp.fhtml">just ask</a>.
- </p>
- </td>
- </tr>
- </table>
-</body>
-
-</html>
diff --git a/unmaintained/webapps/planet/style.css b/unmaintained/webapps/planet/style.css
deleted file mode 100644
index 7a66d8d495..0000000000
--- a/unmaintained/webapps/planet/style.css
+++ /dev/null
@@ -1,45 +0,0 @@
-body {
- font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#888;
-}
-
-h1.planet-title {
- font-size:300%;
-}
-
-a {
- color:#222;
- border-bottom:1px dotted #ccc;
- text-decoration:none;
-}
-
-a:hover {
- border-bottom:1px solid #ccc;
-}
-
-.posting-title {
- background-color:#f5f5f5;
-}
-
-pre, code {
- color:#000000;
- font-size:120%;
-}
-
-.infobox {
- border-left: 1px solid #C1DAD7;
-}
-
-.posting-date {
- text-align: right;
- font-size:90%;
-}
-
-a.more {
- display:block;
- padding:0 0 5px 0;
- color:#333;
- text-decoration:none;
- text-align:right;
- border:none;
-}
diff --git a/unmaintained/wee-url/load.factor b/unmaintained/wee-url/load.factor
deleted file mode 100644
index 96d27164e8..0000000000
--- a/unmaintained/wee-url/load.factor
+++ /dev/null
@@ -1,4 +0,0 @@
-REQUIRES: apps/http-server libs/store ;
-
-PROVIDE: apps/wee-url
-{ +files+ { "responder.factor" } } ;
diff --git a/unmaintained/wee-url/responder.factor b/unmaintained/wee-url/responder.factor
deleted file mode 100644
index 4d7b076cb6..0000000000
--- a/unmaintained/wee-url/responder.factor
+++ /dev/null
@@ -1,91 +0,0 @@
-! Copyright (C) 2006 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic assocs help html httpd
-io kernel math namespaces prettyprint sequences store strings ;
-IN: wee-url-responder
-
-SYMBOL: wee-shortcuts
-SYMBOL: wee-store
-
-"wee-url.store" load-store wee-store set-global
-H{ } clone wee-shortcuts wee-store get store-variable
-
-: responder-url "responder-url" get ;
-
-: wee-url ( string -- url )
- [
- "http://" %
- host %
- responder-url %
- %
- ] "" make ;
-
-: letter-bank
- "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" ;
-
-: random-letter letter-bank length random letter-bank nth ;
-
-: random-url ( -- string )
- 6 random 1+ [ drop random-letter ] map >string
- dup wee-shortcuts get key? [ drop random-url ] when ;
-
-: prepare-wee-url ( url -- url )
- CHAR: : over member? [ "http://" swap append ] unless ;
-
-: set-symmetric-hash ( obj1 obj2 hash -- )
- 3dup set-at swapd set-at ;
-
-: add-shortcut ( url-long -- url-short )
- dup wee-shortcuts get at* [
- nip
- ] [
- drop
- random-url [ wee-shortcuts get set-symmetric-hash ] keep
- wee-store get save-store
- ] if ;
-
-: url-prompt ( -- )
- serving-html
- "wee-url.com - wee URLs since 2007" [
- <form "get" =method responder-url =action form>
- "URL: " write
- <input "text" =type "url" =name input/>
- <input "submit" =type "Submit" =value input/>
- </form>
- ] simple-html-document ;
-
-: url-submitted ( url-long url-short -- )
- "URL Submitted" [
- "URL: " write write nl
- "wee-url: " write
- <a dup wee-url =href a> wee-url write </a> nl
- "Back to " write
- <a responder-url =href a> "wee-url" write </a> nl
- ] simple-html-document ;
-
-: url-submit ( url -- )
- serving-html
- prepare-wee-url [ add-shortcut ] keep url-submitted ;
-
-: url-error ( -- )
- serving-html
- "wee-url error" [
- "No such link." write
- ] simple-html-document ;
-
-: wee-url-responder ( url -- )
- "url" query-param [
- url-submit drop
- ] [
- dup empty? [
- drop url-prompt
- ] [
- wee-shortcuts get at*
- [ permanent-redirect ] [ drop url-error ] if
- ] if
- ] if* ;
-
-[
- "wee-url" "responder" set
- [ wee-url-responder ] "get" set
-] make-responder
diff --git a/unmaintained/wee-url/wee-url.factor b/unmaintained/wee-url/wee-url.factor
deleted file mode 100644
index ead2ee8976..0000000000
--- a/unmaintained/wee-url/wee-url.factor
+++ /dev/null
@@ -1,89 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs furnace html html.elements http.server
-http.server.responders io kernel math math.ranges
-namespaces random sequences store strings ;
-IN: webapps.wee-url
-
-SYMBOL: shortcuts
-SYMBOL: store
-
-! "wee-url.store" load-store store set-global
-! H{ } clone shortcuts store get store-variable
-
-: set-at-once ( value key assoc -- ? )
- 2dup key? [ 3drop f ] [ set-at t ] if ;
-
-: responder-url "responder/wee-url" ;
-
-: wee-url ( string -- url )
- [
- "http://" %
- host %
- responder-url %
- %
- ] "" make ;
-
-: letter-bank
- "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" ; inline
-
-: random-url ( -- string )
- 1 6 [a,b] random [ drop letter-bank random ] "" map-as
- dup shortcuts get key? [ drop random-url ] when ;
-
-: add-shortcut ( url-long url-short -- url-short )
- shortcuts get set-at-once [
- store get save-store
- ] [
- drop
- ] if ;
-
-: show-submit ( -- )
- serving-html
- "wee-url.com - wee URLs since 2007" [
- <form "get" =method "url-submit" =action form>
- "URL: " write
- <input "text" =type "url" =name input/>
- <input "submit" =type "Submit" =value input/>
- </form>
- ] simple-html-document ;
-
-\ show-submit { } define-action
-
-: url-submitted ( url-long url-short -- )
- "URL Submitted" [
- "URL: " write write nl
- "wee-url: " write
- <a dup wee-url =href a> wee-url write </a> nl
- "Back to " write
- <a responder-url =href a> "wee-url" write </a> nl
- ] simple-html-document ;
-
-: url-submit ( url -- )
- [ add-shortcut ] keep
- url-submitted ;
-
-\ url-submit {
- { "url" }
-} define-action
-
-: url-error ( -- )
- serving-html
- "wee-url error" [
- "No such link." write
- ] simple-html-document ;
-
-: wee-url-responder ( url -- )
- "url" query-param [
- url-submit drop
- ] [
- dup empty? [
- drop show-submit
- ] [
- shortcuts get at*
- [ permanent-redirect ] [ drop url-error ] if
- ] if
- ] if* ;
-
-! "wee-url" "wee-url-responder" "extra/webapps/wee-url" web-app
-~