From 93eb74476e776f044283ce61354852037a5c0cb1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 6 Feb 2008 20:04:46 -0600
Subject: [PATCH 01/46] add with-file-in docs, update a couple of usages
---
core/io/files/files-docs.factor | 15 +++++++++++++++
extra/tar/tar.factor | 5 ++---
extra/tools/browser/browser.factor | 4 ++--
3 files changed, 19 insertions(+), 5 deletions(-)
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index 0b9a748eb8..99f2d42542 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -52,6 +52,21 @@ HELP: <file-appender>
{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
+HELP: with-file-in
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file is unreadable." } ;
+
+HELP: with-file-out
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
+HELP: with-file-appender
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
index 20e997185d..e15d9511a3 100755
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -236,10 +236,9 @@ TUPLE: unimplemented-typeflag header ;
] when* ;
: parse-tar ( path -- obj )
- <file-reader> [
+ [
"tar-test" resource-path base-dir set
global [ nl nl nl "Starting to parse .tar..." print flush ] bind
global [ "Expanding to: " write base-dir get . flush ] bind
(parse-tar)
- ] with-stream ;
-
+ ] with-file-out ;
diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor
index 7aefbc8aaa..167c238069 100755
--- a/extra/tools/browser/browser.factor
+++ b/extra/tools/browser/browser.factor
@@ -10,7 +10,7 @@ IN: tools.browser
MEMO: (vocab-file-contents) ( path -- lines )
?resource-path dup exists?
- [ <file-reader> lines ] [ drop f ] if ;
+ [ file-lines ] [ drop f ] if ;
: vocab-file-contents ( vocab name -- seq )
vocab-path+ dup [ (vocab-file-contents) ] when ;
@@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-path+ [
?resource-path
- <file-writer> [ [ print ] each ] with-stream
+ [ [ print ] each ] with-file-out
] [
"The " swap vocab-name
" vocabulary was not loaded from the file system"
From 122be5b48ec22a69dd1afd0d2f441aacb9e4ed97 Mon Sep 17 00:00:00 2001
From: Matthew Willis <yuuki@kotatsu.local>
Date: Sat, 9 Feb 2008 00:17:24 -0800
Subject: [PATCH 02/46] Added set-fullscreen? and fullscreen? hooks along with
their cocoa implementations.
---
extra/cocoa/cocoa.factor | 1 +
extra/ui/backend/backend.factor | 4 ++++
extra/ui/cocoa/cocoa.factor | 14 +++++++++++++-
extra/ui/gadgets/worlds/worlds-docs.factor | 9 +++++++++
4 files changed, 27 insertions(+), 1 deletion(-)
diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor
index cbc6c9d762..c94984f00b 100755
--- a/extra/cocoa/cocoa.factor
+++ b/extra/cocoa/cocoa.factor
@@ -58,6 +58,7 @@ SYMBOL: super-sent-messages
"NSPasteboard"
"NSResponder"
"NSSavePanel"
+ "NSScreen"
"NSView"
"NSWindow"
"NSWorkspace"
diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor
index a0646f35b0..cc1f5f7d05 100755
--- a/extra/ui/backend/backend.factor
+++ b/extra/ui/backend/backend.factor
@@ -7,6 +7,10 @@ SYMBOL: ui-backend
HOOK: set-title ui-backend ( string world -- )
+HOOK: set-fullscreen? ui-backend ( ? world -- )
+
+HOOK: fullscreen? ui-backend ( world -- ? )
+
HOOK: (open-window) ui-backend ( world -- )
HOOK: (close-window) ui-backend ( handle -- )
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index 1e46544180..184e6fd856 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays cocoa cocoa.application command-line
+USING: math arrays cocoa cocoa.application command-line
kernel memory namespaces cocoa.messages cocoa.runtime
cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows
cocoa.classes cocoa.application sequences system ui ui.backend
@@ -53,6 +53,18 @@ M: pasteboard set-clipboard-contents
M: cocoa-ui-backend set-title ( string world -- )
world-handle second swap <NSString> -> setTitle: ;
+: enter-fullscreen ( world -- )
+ world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ;
+
+: exit-fullscreen ( world -- )
+ world-handle first f -> exitFullScreenModeWithOptions: ;
+
+M: cocoa-ui-backend set-fullscreen? ( ? world -- )
+ swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+
+M: cocoa-ui-backend fullscreen? ( world -- ? )
+ world-handle first -> isInFullScreenMode zero? not ;
+
: auto-position ( world -- )
dup world-loc { 0 0 } = [
world-handle second -> center
diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor
index a47717329d..8a64750751 100755
--- a/extra/ui/gadgets/worlds/worlds-docs.factor
+++ b/extra/ui/gadgets/worlds/worlds-docs.factor
@@ -13,6 +13,15 @@ HELP: set-title
{ $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
+HELP: set-fullscreen?
+{ $values { "?" "a boolean" } { "world" world } }
+{ $description "Sets and unsets fullscreen mode for the world." }
+{ $notes "Find a world using " { $link find-world } "." } ;
+
+HELP: fullscreen?
+{ $values { "world" world } { "?" "a boolean" } }
+{ $description "Queries the world to see if it is running in fullscreen mode." } ;
+
HELP: raise-window
{ $values { "world" world } }
{ $description "Makes the native window containing the given world the front-most window." }
From 5ca99b0105c82b881ccb023fee8b502e5a2651ba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 14:17:15 -0600
Subject: [PATCH 03/46] Fix 'class' in early bootstrap
---
core/classes/classes.factor | 4 +++-
core/generic/math/math.factor | 2 +-
core/generic/standard/standard.factor | 2 +-
3 files changed, 5 insertions(+), 3 deletions(-)
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 151429bf69..345676e106 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -20,7 +20,9 @@ PREDICATE: class tuple-class
: classes ( -- seq ) class<map get keys ;
-: type>class ( n -- class ) builtins get nth ;
+: type>class ( n -- class ) builtins get-global nth ;
+
+: bootstrap-type>class ( n -- class ) builtins get nth ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 8cf83b0ba7..21a7857646 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ;
: math-vtable* ( picker max quot -- quot )
[
rot , \ tag ,
- [ >r [ type>class ] map r> map % ] { } make ,
+ [ >r [ bootstrap-type>class ] map r> map % ] { } make ,
\ dispatch ,
] [ ] make ; inline
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 88f6a05bc2..7f4f423d8b 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -97,7 +97,7 @@ TUPLE: no-method object generic ;
[ small-generic ] picker class-hash-dispatch-quot ;
: vtable-class ( n -- class )
- type>class [ hi-tag bootstrap-word ] unless* ;
+ bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
: group-methods ( assoc -- vtable )
#! Input is a predicate -> method association.
From ee912c5996e9342d921c51051cd71001d94b2048 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 14:17:40 -0600
Subject: [PATCH 04/46] Walker cleanup
---
extra/ui/tools/walker/walker.factor | 18 +++++++++---------
1 file changed, 9 insertions(+), 9 deletions(-)
diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor
index 4740ff86d4..a23345d214 100755
--- a/extra/ui/tools/walker/walker.factor
+++ b/extra/ui/tools/walker/walker.factor
@@ -21,21 +21,21 @@ TUPLE: walker model interpreter history ;
: walker-active? ( walker -- ? )
walker-interpreter interpreter-continuation >boolean ;
-: walker-command ( gadget quot -- )
- over walker-active? [ with-walker ] [ 2drop ] if ; inline
-
: save-interpreter ( walker -- )
dup walker-interpreter interpreter-continuation clone
swap walker-history push ;
-: com-step ( walker -- )
- dup save-interpreter [ step ] walker-command ;
+: walker-command ( gadget quot -- )
+ over walker-active? [
+ over save-interpreter
+ with-walker
+ ] [ 2drop ] if ; inline
-: com-into ( walker -- )
- dup save-interpreter [ step-into ] walker-command ;
+: com-step ( walker -- ) [ step ] walker-command ;
-: com-out ( walker -- )
- dup save-interpreter [ step-out ] walker-command ;
+: com-into ( walker -- ) [ step-into ] walker-command ;
+
+: com-out ( walker -- ) [ step-out ] walker-command ;
: com-back ( walker -- )
dup walker-history
From ef63333980d03f963bb50b076ec52c10923cbcff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 18:12:07 -0600
Subject: [PATCH 05/46] Fix another bug with futures
---
extra/concurrency/concurrency-tests.factor | 5 +++++
extra/concurrency/concurrency.factor | 6 +++---
2 files changed, 8 insertions(+), 3 deletions(-)
diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor
index 1a19ce7096..8908506d51 100755
--- a/extra/concurrency/concurrency-tests.factor
+++ b/extra/concurrency/concurrency-tests.factor
@@ -133,4 +133,9 @@ SYMBOL: value
[ 3 3 ] [
[ 3 ] future
dup ?future swap ?future
+] unit-test
+
+! Another race
+[ 3 ] [
+ [ 3 yield ] future ?future
] unit-test
\ No newline at end of file
diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor
index a8e0bc6eeb..1c5f6322a8 100755
--- a/extra/concurrency/concurrency.factor
+++ b/extra/concurrency/concurrency.factor
@@ -273,14 +273,14 @@ TUPLE: future value processes ;
: future ( quot -- future )
#! Spawn a process to call the quotation and immediately return.
- \ future construct-empty [
+ f V{ } clone \ future construct-boa [
[
>r [ t 2array ] compose [ f 2array ] recover r>
notify-future
] 2curry spawn drop
] keep ;
-
- : ?future ( future -- result )
+
+: ?future ( future -- result )
#! Block the process until the future has completed and then
#! place the result on the stack. Return the result
#! immediately if the future has completed.
From f655a25762173982ee894d61f7ca755524127aa1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:08:47 -0600
Subject: [PATCH 06/46] Fixing compiler test
---
core/bootstrap/compiler/compiler.factor | 11 +++++++++++
core/compiler/test/simple/simple-tests.factor | 4 +++-
2 files changed, 14 insertions(+), 1 deletion(-)
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index ff9d5c5e1e..2b278ac458 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -77,3 +77,14 @@ nl
[ compiled-usages recompile ] recompile-hook set-global
" done" print flush
+
+! Load empty test vocabs
+USE: compiler.test.curry
+USE: compiler.test.float
+USE: compiler.test.intrinsics
+USE: compiler.test.redefine
+USE: compiler.test.simple
+USE: compiler.test.stack-trace
+USE: compiler.test.templates
+USE: compiler.test.templates-early
+USE: compiler.test.tuples
diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple/simple-tests.factor
index 3f4f6451a3..743fb713d9 100755
--- a/core/compiler/test/simple/simple-tests.factor
+++ b/core/compiler/test/simple/simple-tests.factor
@@ -1,6 +1,6 @@
USING: compiler tools.test kernel kernel.private
combinators.private math.private math combinators strings
-alien arrays ;
+alien arrays memory ;
IN: temporary
! Test empty word
@@ -48,6 +48,8 @@ IN: temporary
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
+[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
+
! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline
From 93e10566bef56950add23087e64af1e3da3f2575 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:12:00 -0600
Subject: [PATCH 07/46] Simpler compilation of dispatch
---
core/cpu/architecture/architecture.factor | 4 +-
core/cpu/ppc/architecture/architecture.factor | 23 +++++------
core/cpu/x86/architecture/architecture.factor | 39 ++++++++++---------
core/generator/generator.factor | 29 +++++++++-----
4 files changed, 50 insertions(+), 45 deletions(-)
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 4da22ff38a..4bb10b23a2 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- )
-HOOK: %call-dispatch compiler-backend ( -- label )
-
-HOOK: %jump-dispatch compiler-backend ( -- )
+HOOK: %dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- )
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index 7444c21a8c..1daf3ac622 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ;
M: ppc-backend %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
-: (%dispatch) ( len -- )
- 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
- "offset" operand "n" operand 1 SRAWI
- 11 11 "offset" operand ADD
- 11 dup rot cells LWZ ;
-
-M: ppc-backend %call-dispatch ( word-table# -- )
- [ 7 (%dispatch) (%call) <label> dup B ] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "offset" } } }
- } with-template ;
-
-M: ppc-backend %jump-dispatch ( -- )
- [ %epilogue-later 6 (%dispatch) (%jump) ] H{
+M: ppc-backend %dispatch ( -- )
+ [
+ %epilogue-later
+ 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
+ "offset" operand "n" operand 1 SRAWI
+ 11 11 "offset" operand ADD
+ 11 dup 6 cells LWZ
+ (%jump)
+ ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 8c5d5c1dc0..20564bbde3 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -77,26 +77,29 @@ M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
-: (%dispatch) ( n -- operand )
- ! Load jump table base. We use a temporary register
- ! since on AMD64 we have to load a 64-bit immediate. On
- ! x86, this is redundant.
- ! Untag and multiply to get a jump table offset
- "n" operand fixnum>slot@
- ! Add jump table base
- "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
- "n" operand "offset" operand ADD
- "n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
+: code-alignment ( -- n )
+ building get length dup cell align swap - ;
-M: x86-backend %call-dispatch ( word-table# -- )
- [ 5 (%dispatch) CALL <label> dup JMP ] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "offset" } } }
- { +clobber+ { "n" } }
- } with-template ;
+: align-code ( n -- )
+ 0 <repetition> % ;
-M: x86-backend %jump-dispatch ( -- )
- [ %epilogue-later 0 (%dispatch) JMP ] H{
+M: x86-backend %dispatch ( -- )
+ [
+ %epilogue-later
+ ! Load jump table base. We use a temporary register
+ ! since on AMD64 we have to load a 64-bit immediate. On
+ ! x86, this is redundant.
+ ! Untag and multiply to get a jump table offset
+ "n" operand fixnum>slot@
+ ! Add jump table base
+ "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
+ "n" operand "offset" operand ADD
+ "n" operand HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ code-alignment dup bootstrap-cell 8 = 14 9 ? +
+ building get dup pop* push
+ align-code
+ ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index 3883fb6e35..d8164fdce7 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -56,13 +56,16 @@ GENERIC: generate-node ( node -- next )
: generate-nodes ( node -- )
[ node@ generate-node ] iterate-nodes end-basic-block ;
+: init-generate-nodes ( -- )
+ init-templates
+ %save-word-xt
+ %prologue-later
+ current-label-start define-label
+ current-label-start resolve-label ;
+
: generate ( word label node -- )
[
- init-templates
- %save-word-xt
- %prologue-later
- current-label-start define-label
- current-label-start resolve-label
+ init-generate-nodes
[ generate-nodes ] with-node-iterator
] generate-1 ;
@@ -168,17 +171,23 @@ M: #if generate-node
] if %dispatch-label
] each ;
+: generate-dispatch ( node -- )
+ %dispatch dispatch-branches init-templates ;
+
M: #dispatch generate-node
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
- %jump-dispatch dispatch-branches
+ generate-dispatch iterate-next
] [
- 0 frame-required
- %call-dispatch >r dispatch-branches r> resolve-label
- ] if
- init-templates iterate-next ;
+ compiling-word get gensym [
+ rot [
+ init-generate-nodes
+ generate-dispatch
+ ] generate-1
+ ] keep generate-call
+ ] if ;
! #call
: define-intrinsics ( word intrinsics -- )
From 9d1977eeee3ffd71bf7f7de6a59e6c56eb333bdc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:12:21 -0600
Subject: [PATCH 08/46] Obsolete file
---
core/compiler/compiler-tests.factor | 7 -------
1 file changed, 7 deletions(-)
delete mode 100755 core/compiler/compiler-tests.factor
diff --git a/core/compiler/compiler-tests.factor b/core/compiler/compiler-tests.factor
deleted file mode 100755
index 7e4e79437d..0000000000
--- a/core/compiler/compiler-tests.factor
+++ /dev/null
@@ -1,7 +0,0 @@
-IN: temporary
-USING: tools.browser tools.test kernel sequences vocabs ;
-
-"compiler.test" child-vocabs empty? [
- "compiler.test" load-children
- "compiler.test" test
-] when
From c8f042aef4c9e9d41eb9d81fab7ad2a074f0037e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:34:42 -0600
Subject: [PATCH 09/46] Redo timeouts
---
core/inference/inference-tests.factor | 3 +-
core/io/io-docs.factor | 9 +--
core/io/io.factor | 1 -
core/io/streams/duplex/duplex.factor | 5 --
extra/delegate/protocols/protocols.factor | 2 +-
extra/http/client/client.factor | 4 +-
extra/http/server/server.factor | 2 +-
extra/io/launcher/launcher.factor | 26 +++++---
extra/io/nonblocking/nonblocking-docs.factor | 2 -
extra/io/nonblocking/nonblocking.factor | 56 ++++------------
extra/io/streams/null/null.factor | 4 +-
extra/io/timeouts/timeouts.factor | 67 ++++++++++++++++++++
extra/io/unix/backend/backend.factor | 4 +-
extra/io/windows/ce/sockets/sockets.factor | 2 +-
extra/io/windows/nt/backend/backend.factor | 2 +-
extra/io/windows/nt/files/files.factor | 12 ++--
extra/io/windows/nt/monitors/monitors.factor | 7 +-
extra/io/windows/nt/sockets/sockets.factor | 6 +-
extra/smtp/server/server.factor | 4 +-
extra/smtp/smtp.factor | 9 +--
20 files changed, 129 insertions(+), 98 deletions(-)
create mode 100755 extra/io/timeouts/timeouts.factor
mode change 100644 => 100755 extra/smtp/server/server.factor
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index c5bc3b5fda..2691be8c3a 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -4,7 +4,8 @@ math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
prettyprint io inspector tuples classes.union classes.predicate
-debugger threads.private io.streams.string combinators.private ;
+debugger threads.private io.streams.string io.timeouts
+combinators.private ;
IN: temporary
{ 0 2 } [ 2 "Hello" ] must-infer-as
diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
index 208e2a2ba7..aff2c6d099 100755
--- a/core/io/io-docs.factor
+++ b/core/io/io-docs.factor
@@ -21,9 +21,7 @@ $nl
{ $subsection make-span-stream }
{ $subsection make-block-stream }
{ $subsection make-cell-stream }
-{ $subsection stream-write-table }
-"Optional word for network streams:"
-{ $subsection set-timeout } ;
+{ $subsection stream-write-table } ;
ARTICLE: "stdio" "The default stream"
"Various words take an implicit stream parameter from a variable to reduce stack shuffling."
@@ -73,11 +71,6 @@ ARTICLE: "streams" "Streams"
ABOUT: "streams"
-HELP: set-timeout
-{ $values { "n" "an integer" } { "stream" "a stream" } }
-{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
-{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
-
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" string } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
diff --git a/core/io/io.factor b/core/io/io.factor
index e0c890c0e3..2d927d088a 100755
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
continuations assocs io.styles sbufs ;
IN: io
-GENERIC: set-timeout ( n stream -- )
GENERIC: stream-readln ( stream -- str )
GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f )
diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor
index 86660b2752..97e60b4a60 100755
--- a/core/io/streams/duplex/duplex.factor
+++ b/core/io/streams/duplex/duplex.factor
@@ -74,8 +74,3 @@ M: duplex-stream dispose
[ dup duplex-stream-out dispose ]
[ dup duplex-stream-in dispose ] [ ] cleanup
] unless drop ;
-
-M: duplex-stream set-timeout
- 2dup
- duplex-stream-in set-timeout
- duplex-stream-out set-timeout ;
diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor
index 1121883b7c..37f3812d2d 100755
--- a/extra/delegate/protocols/protocols.factor
+++ b/extra/delegate/protocols/protocols.factor
@@ -18,7 +18,7 @@ PROTOCOL: stream-protocol
stream-read1 stream-read stream-read-until
stream-flush stream-write1 stream-write stream-format
stream-nl make-span-stream make-block-stream stream-readln
- make-cell-stream stream-write-table set-timeout ;
+ make-cell-stream stream-write-table ;
PROTOCOL: definition-protocol
where set-where forget uses redefined*
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index 109bf17c40..679d603708 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
-io io.sockets io.streams.string io.files strings splitting
-continuations assocs.lib ;
+io io.sockets io.streams.string io.files io.timeouts strings
+splitting continuations assocs.lib ;
IN: http.client
: parse-host ( url -- host port )
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index eca2253e2a..957a82d09f 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel namespaces io strings splitting
+USING: assocs kernel namespaces io io.timeouts strings splitting
threads http http.server.responders sequences prettyprint
io.server logging ;
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 4a6bbf46fb..efcecd50bc 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.backend system kernel namespaces strings hashtables
-sequences assocs combinators vocabs.loader init threads
-continuations math ;
+USING: io io.backend io.timeouts system kernel namespaces
+strings hashtables sequences assocs combinators vocabs.loader
+init threads continuations math ;
IN: io.launcher
! Non-blocking process exit notification facility
@@ -10,14 +10,14 @@ SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
-TUPLE: process handle status ;
+TUPLE: process handle status killed? lapse ;
HOOK: register-process io-backend ( process -- )
M: object register-process drop ;
: <process> ( handle -- process )
- f process construct-boa
+ f f <lapse> process construct-boa
V{ } clone over processes get set-at
dup register-process ;
@@ -25,6 +25,8 @@ M: process equal? 2drop f ;
M: process hashcode* process-handle hashcode* ;
+: process-running? ( process -- ? ) process-status not ;
+
SYMBOL: +command+
SYMBOL: +arguments+
SYMBOL: +detached+
@@ -34,6 +36,7 @@ SYMBOL: +stdin+
SYMBOL: +stdout+
SYMBOL: +stderr+
SYMBOL: +closed+
+SYMBOL: +timeout+
SYMBOL: +prepend-environment+
SYMBOL: +replace-environment+
@@ -72,13 +75,17 @@ M: assoc >descriptor >hashtable ;
HOOK: run-process* io-backend ( desc -- handle )
: wait-for-process ( process -- status )
- dup process-handle [
- dup [ processes get at push stop ] curry callcc0
- ] when process-status ;
+ [
+ dup process-handle
+ [ dup [ processes get at push stop ] curry callcc0 ] when
+ dup process-killed?
+ [ "Process was killed" throw ] [ process-status ] if
+ ] with-timeout ;
: run-process ( desc -- process )
>descriptor
dup run-process*
+ +timeout+ pick at [ over set-timeout ] when*
+detached+ rot at [ dup wait-for-process drop ] unless ;
: run-detached ( desc -- process )
@@ -96,8 +103,11 @@ TUPLE: process-failed code ;
HOOK: kill-process* io-backend ( handle -- )
: kill-process ( process -- )
+ t over set-process-killed?
process-handle [ kill-process* ] when* ;
+M: process timed-out kill-process ;
+
HOOK: process-stream* io-backend ( desc -- stream process )
TUPLE: process-stream process ;
diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor
index af73a47030..d8d2cf5479 100755
--- a/extra/io/nonblocking/nonblocking-docs.factor
+++ b/extra/io/nonblocking/nonblocking-docs.factor
@@ -38,8 +38,6 @@ $nl
{ $list
{ { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
{ { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
- { { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." }
- { { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" }
{ { $link port-type } " - a symbol identifying the port's intended purpose" }
{ { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
} } ;
diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor
index 5dbd3d1490..4d8634bde9 100755
--- a/extra/io/nonblocking/nonblocking.factor
+++ b/extra/io/nonblocking/nonblocking.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
IN: io.nonblocking
-USING: math kernel io sequences io.buffers generic sbufs system
-io.streams.lines io.streams.plain io.streams.duplex io.backend
-continuations debugger classes byte-arrays namespaces splitting
-dlists assocs ;
+USING: math kernel io sequences io.buffers io.timeouts generic
+sbufs system io.streams.lines io.streams.plain io.streams.duplex
+io.backend continuations debugger classes byte-arrays namespaces
+splitting dlists assocs ;
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
@@ -13,9 +13,12 @@ SYMBOL: default-buffer-size
TUPLE: port
handle
error
-timeout-entry timeout cutoff
+lapse
type eof? ;
+! Ports support the lapse protocol
+M: port lapse port-lapse ;
+
SYMBOL: closed
PREDICATE: port input-port port-type input-port eq? ;
@@ -26,12 +29,11 @@ GENERIC: close-handle ( handle -- )
: <port> ( handle buffer type -- port )
pick init-handle
- 0 0 {
+ <lapse> {
set-port-handle
set-delegate
set-port-type
- set-port-timeout
- set-port-cutoff
+ set-port-lapse
} port construct ;
: <buffered-port> ( handle type -- port )
@@ -48,50 +50,14 @@ GENERIC: close-handle ( handle -- )
[ >r <reader> r> <duplex-stream> ] [ ] [ dispose ]
cleanup ;
-: timeout? ( port -- ? )
- port-cutoff dup zero? not swap millis < and ;
-
: pending-error ( port -- )
dup port-error f rot set-port-error [ throw ] when* ;
-SYMBOL: timeout-queue
-
-timeout-queue global [ [ <dlist> ] unless* ] change-at
-
-: unqueue-timeout ( port -- )
- port-timeout-entry [
- timeout-queue get-global swap delete-node
- ] when* ;
-
-: queue-timeout ( port -- )
- dup timeout-queue get-global push-front*
- swap set-port-timeout-entry ;
-
HOOK: cancel-io io-backend ( port -- )
M: object cancel-io drop ;
-: expire-timeouts ( -- )
- timeout-queue get-global dup dlist-empty? [ drop ] [
- dup peek-back timeout?
- [ pop-back cancel-io expire-timeouts ] [ drop ] if
- ] if ;
-
-: begin-timeout ( port -- )
- dup port-timeout dup zero? [
- 2drop
- ] [
- millis + over set-port-cutoff
- dup unqueue-timeout queue-timeout
- ] if ;
-
-: end-timeout ( port -- )
- unqueue-timeout ;
-
-: with-port-timeout ( port quot -- )
- over begin-timeout keep end-timeout ; inline
-
-M: port set-timeout set-port-timeout ;
+M: port timed-out cancel-io ;
GENERIC: (wait-to-read) ( port -- )
diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor
index f76b0cbce3..d747fa0a29 100755
--- a/extra/io/streams/null/null.factor
+++ b/extra/io/streams/null/null.factor
@@ -1,12 +1,12 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.null
-USING: kernel io continuations ;
+USING: kernel io io.timeouts continuations ;
TUPLE: null-stream ;
M: null-stream dispose drop ;
-M: null-stream set-timeout 2drop ;
+M: null-stream set-timeout drop ;
M: null-stream stream-readln drop f ;
M: null-stream stream-read1 drop f ;
M: null-stream stream-read-until 2drop f f ;
diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor
new file mode 100755
index 0000000000..67bc3a4783
--- /dev/null
+++ b/extra/io/timeouts/timeouts.factor
@@ -0,0 +1,67 @@
+! Copyright (C) 2008 Slava Pestov, Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math system dlists namespaces assocs init threads
+io.streams.duplex ;
+IN: io.timeouts
+
+TUPLE: lapse entry timeout cutoff ;
+
+: <lapse> f 0 0 \ lapse construct-boa ;
+
+GENERIC: lapse ( obj -- lapse )
+GENERIC: set-timeout ( ms obj -- )
+
+M: object set-timeout lapse set-lapse-timeout ;
+
+M: duplex-stream set-timeout
+ 2dup
+ duplex-stream-in set-timeout
+ duplex-stream-out set-timeout ;
+
+: timeout ( obj -- ms ) lapse lapse-timeout ;
+: entry ( obj -- dlist-node ) lapse lapse-entry ;
+: set-entry ( dlist-node -- obj ) lapse set-lapse-entry ;
+: cutoff ( obj -- ms ) lapse lapse-cutoff ;
+: set-cutoff ( ms obj -- ) lapse set-lapse-cutoff ;
+
+SYMBOL: timeout-queue
+
+: timeout? ( lapse -- ? )
+ cutoff dup zero? not swap millis < and ;
+
+timeout-queue global [ [ <dlist> ] unless* ] change-at
+
+: unqueue-timeout ( obj -- )
+ entry [
+ timeout-queue get-global swap delete-node
+ ] when* ;
+
+: queue-timeout ( obj -- )
+ dup timeout-queue get-global push-front*
+ swap set-entry ;
+
+GENERIC: timed-out ( obj -- )
+
+M: object timed-out drop ;
+
+: expire-timeouts ( -- )
+ timeout-queue get-global dup dlist-empty? [ drop ] [
+ dup peek-back timeout?
+ [ pop-back timed-out expire-timeouts ] [ drop ] if
+ ] if ;
+
+: begin-timeout ( obj -- )
+ dup timeout dup zero? [
+ 2drop
+ ] [
+ millis + over set-cutoff
+ dup unqueue-timeout queue-timeout
+ ] if ;
+
+: with-timeout ( obj quot -- )
+ over begin-timeout keep unqueue-timeout ; inline
+
+: expiry-thread ( -- )
+ expire-timeouts 5000 sleep expire-timeouts ;
+
+[ expiry-thread ] "io.timeouts" add-init-hook
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 7112c48551..1547ecec65 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -61,7 +61,7 @@ M: mx register-io-task ( task mx -- )
mx get-global register-io-task stop ;
: with-port-continuation ( port quot -- port )
- [ callcc0 ] curry with-port-timeout ; inline
+ [ callcc0 ] curry with-timeout ; inline
M: mx unregister-io-task ( task mx -- )
fd/container delete-at drop ;
@@ -178,7 +178,7 @@ M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix-io io-multiplex ( ms -- )
- expire-timeouts mx get-global wait-for-events ;
+ mx get-global wait-for-events ;
M: unix-io init-stdio ( -- )
0 1 handle>duplex-stream io:stdio set-global
diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor
index 9114dceb75..e9ca6220af 100755
--- a/extra/io/windows/ce/sockets/sockets.factor
+++ b/extra/io/windows/ce/sockets/sockets.factor
@@ -55,7 +55,7 @@ M: windows-ce-io accept ( server -- client )
] keep
] keep server-port-addr parse-sockaddr swap
<win32-socket> dup handle>duplex-stream <client-stream>
- ] with-port-timeout ;
+ ] with-timeout ;
M: windows-ce-io <datagram> ( addrspec -- datagram )
[
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index 760bcec457..597bc99be2 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -91,7 +91,7 @@ M: windows-nt-io cancel-io
port-handle win32-file-handle CancelIo drop ;
M: windows-nt-io io-multiplex ( ms -- )
- expire-timeouts drain-overlapped ;
+ drain-overlapped ;
M: windows-nt-io init-io ( -- )
<master-completion-port> master-completion-port set-global
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index a1c331816c..ecc989530e 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -1,8 +1,8 @@
USING: continuations destructors io.buffers io.files io.backend
-io.nonblocking io.windows io.windows.nt.backend kernel libc math
-threads windows windows.kernel32 alien.c-types alien.arrays
-sequences combinators combinators.lib sequences.lib ascii
-splitting alien strings ;
+io.timeouts io.nonblocking io.windows io.windows.nt.backend
+kernel libc math threads windows windows.kernel32 alien.c-types
+alien.arrays sequences combinators combinators.lib sequences.lib
+ascii splitting alien strings ;
IN: io.windows.nt.files
M: windows-nt-io cwd
@@ -98,7 +98,7 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
] if ;
: flush-output ( port -- )
- [ [ (flush-output) ] with-port-timeout ] with-destructors ;
+ [ [ (flush-output) ] with-timeout ] with-destructors ;
M: port port-flush
dup buffer-empty? [ dup flush-output ] unless drop ;
@@ -122,4 +122,4 @@ M: port port-flush
] [ 2drop ] if ;
M: input-port (wait-to-read) ( port -- )
- [ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ;
+ [ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor
index a593e829fe..a7a1e2f485 100755
--- a/extra/io/windows/nt/monitors/monitors.factor
+++ b/extra/io/windows/nt/monitors/monitors.factor
@@ -3,8 +3,9 @@
USING: alien.c-types destructors io.windows
io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations
-io.monitors io.monitors.private io.nonblocking io.buffers io.files
-io sequences hashtables sorting arrays combinators ;
+io.monitors io.monitors.private io.nonblocking io.buffers
+io.files io.timeouts io sequences hashtables sorting arrays
+combinators ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
@@ -52,7 +53,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
swap [ save-callback ] 2keep
dup check-monitor ! we may have closed it...
get-overlapped-result
- ] with-port-timeout
+ ] with-timeout
] with-destructors ;
: parse-action ( action -- changed )
diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor
index 77249df9f1..eef7476dd5 100755
--- a/extra/io/windows/nt/sockets/sockets.factor
+++ b/extra/io/windows/nt/sockets/sockets.factor
@@ -1,6 +1,6 @@
USING: alien alien.accessors alien.c-types byte-arrays
-continuations destructors io.nonblocking io io.sockets
-io.sockets.impl namespaces io.streams.duplex io.windows
+continuations destructors io.nonblocking io.timeouts io.sockets
+io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
threads tuples.lib ;
IN: io.windows.nt.sockets
@@ -139,7 +139,7 @@ M: windows-nt-io accept ( server -- client )
AcceptEx-args-port pending-error
dup duplex-stream-in pending-error
dup duplex-stream-out pending-error
- ] with-port-timeout
+ ] with-timeout
] with-destructors ;
M: windows-nt-io <server> ( addrspec -- server )
diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor
old mode 100644
new mode 100755
index 2cfc1e65e4..275deee994
--- a/extra/smtp/server/server.factor
+++ b/extra/smtp/server/server.factor
@@ -27,8 +27,8 @@
! bye
! Connection closed by foreign host.
-USING: combinators kernel prettyprint io io.server sequences
-namespaces io.sockets continuations ;
+USING: combinators kernel prettyprint io io.timeouts io.server
+sequences namespaces io.sockets continuations ;
SYMBOL: data-mode
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index 211fbbcabd..27aac1202e 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -1,8 +1,9 @@
-! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov.
+! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
+! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces io kernel logging io.sockets sequences
-combinators sequences.lib splitting assocs strings math.parser
-random system calendar ;
+USING: namespaces io io.timeouts kernel logging io.sockets
+sequences combinators sequences.lib splitting assocs strings
+math.parser random system calendar ;
IN: smtp
From dd8e38a7f01e8531bcca8fd1e63d7097d5b63d00 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 21:56:50 -0600
Subject: [PATCH 10/46] Fixing some issues
---
extra/io/launcher/launcher.factor | 2 ++
extra/io/nonblocking/nonblocking.factor | 2 +-
extra/io/timeouts/timeouts.factor | 18 +++++++++---------
3 files changed, 12 insertions(+), 10 deletions(-)
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index efcecd50bc..17a3e6fd23 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -106,6 +106,8 @@ HOOK: kill-process* io-backend ( handle -- )
t over set-process-killed?
process-handle [ kill-process* ] when* ;
+M: process get-lapse process-lapse ;
+
M: process timed-out kill-process ;
HOOK: process-stream* io-backend ( desc -- stream process )
diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor
index 4d8634bde9..72507f26b6 100755
--- a/extra/io/nonblocking/nonblocking.factor
+++ b/extra/io/nonblocking/nonblocking.factor
@@ -17,7 +17,7 @@ lapse
type eof? ;
! Ports support the lapse protocol
-M: port lapse port-lapse ;
+M: port get-lapse port-lapse ;
SYMBOL: closed
diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor
index 67bc3a4783..ddc92a4bdd 100755
--- a/extra/io/timeouts/timeouts.factor
+++ b/extra/io/timeouts/timeouts.factor
@@ -8,21 +8,21 @@ TUPLE: lapse entry timeout cutoff ;
: <lapse> f 0 0 \ lapse construct-boa ;
-GENERIC: lapse ( obj -- lapse )
+GENERIC: get-lapse ( obj -- lapse )
GENERIC: set-timeout ( ms obj -- )
-M: object set-timeout lapse set-lapse-timeout ;
+M: object set-timeout get-lapse set-lapse-timeout ;
M: duplex-stream set-timeout
2dup
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;
-: timeout ( obj -- ms ) lapse lapse-timeout ;
-: entry ( obj -- dlist-node ) lapse lapse-entry ;
-: set-entry ( dlist-node -- obj ) lapse set-lapse-entry ;
-: cutoff ( obj -- ms ) lapse lapse-cutoff ;
-: set-cutoff ( ms obj -- ) lapse set-lapse-cutoff ;
+: timeout ( obj -- ms ) get-lapse lapse-timeout ;
+: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
+: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;
+: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
+: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
SYMBOL: timeout-queue
@@ -62,6 +62,6 @@ M: object timed-out drop ;
over begin-timeout keep unqueue-timeout ; inline
: expiry-thread ( -- )
- expire-timeouts 5000 sleep expire-timeouts ;
+ expire-timeouts 5000 sleep expiry-thread ;
-[ expiry-thread ] "io.timeouts" add-init-hook
+[ [ expiry-thread ] in-thread ] "io.timeouts" add-init-hook
From be28fbd45dbd46b8c1393bdaf64947cd67c50d7e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 22:28:22 -0600
Subject: [PATCH 11/46] Document io.timeouts
---
core/io/io-docs.factor | 3 +-
extra/help/handbook/handbook.factor | 3 +-
extra/io/launcher/launcher-docs.factor | 40 +++++++++++++-------------
extra/io/launcher/launcher.factor | 12 +++++---
extra/io/timeouts/timeouts-docs.factor | 32 +++++++++++++++++++++
extra/io/unix/linux/linux.factor | 9 +++---
6 files changed, 69 insertions(+), 30 deletions(-)
create mode 100755 extra/io/timeouts/timeouts-docs.factor
diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
index aff2c6d099..9c73a3b2b1 100755
--- a/core/io/io-docs.factor
+++ b/core/io/io-docs.factor
@@ -21,7 +21,8 @@ $nl
{ $subsection make-span-stream }
{ $subsection make-block-stream }
{ $subsection make-cell-stream }
-{ $subsection stream-write-table } ;
+{ $subsection stream-write-table }
+{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "The default stream"
"Various words take an implicit stream parameter from a variable to reduce stack shuffling."
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index d6b4ec7ffe..9472e1f519 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -157,7 +157,8 @@ ARTICLE: "io" "Input and output"
"Advanced features:"
{ $subsection "io.launcher" }
{ $subsection "io.mmap" }
-{ $subsection "io.monitors" } ;
+{ $subsection "io.monitors" }
+{ $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.annotations" }
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index e414d98d65..4f5a85244b 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -76,6 +76,9 @@ HELP: +append-environment+
$nl
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
+HELP: +timeout+
+{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
+
HELP: default-descriptor
{ $description "Association storing default values for launch descriptor keys." } ;
@@ -94,22 +97,16 @@ HELP: run-process*
HELP: >descriptor
{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
-{ $description "Creates a launch descriptor from an object, which must be one of the following:"
- { $list
- { "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" }
- { "a sequence of strings -- this is wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
- { "an association, used to set launch parameters for additional control" }
- }
-} ;
+{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ;
HELP: run-process
{ $values { "desc" "a launch descriptor" } { "process" process } }
-{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
+{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
HELP: run-detached
{ $values { "desc" "a launch descriptor" } { "process" process } }
-{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
+{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
{ $notes
"This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
$nl
@@ -162,25 +159,27 @@ HELP: wait-for-process
{ $values { "process" process } { "status" integer } }
{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
-ARTICLE: "io.launcher" "Launching OS processes"
-"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
-$nl
-"Words which launch processes can take either a command line string, a sequence of command line arguments, or a launch descriptor:"
+ARTICLE: "io.launcher.descriptors" "Launch descriptors"
+"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:"
{ $list
- { "strings are wrapped in a launch descriptor with a single " { $link +command+ } " key" }
- { "sequences of strings are wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
- { "launch descriptors are associations, which can set extra launch parameters for finer control" }
+ { "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
+ { "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
+ { "associations can be passed in, which allows finer control over launch parameters" }
}
-"A launch descriptor is an association containing keys from the below set:"
+"The associations can contain the following keys:"
{ $subsection +command+ }
{ $subsection +arguments+ }
{ $subsection +detached+ }
{ $subsection +environment+ }
{ $subsection +environment-mode+ }
-"Redirecting standard input and output to files:"
+{ $subsection +timeout+ }
{ $subsection +stdin+ }
{ $subsection +stdout+ }
-{ $subsection +stderr+ }
+{ $subsection +stderr+ } ;
+
+ARTICLE: "io.launcher" "Launching OS processes"
+"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
+{ $subsection "io.launcher.descriptors" }
"The following words are used to launch processes:"
{ $subsection run-process }
{ $subsection run-detached }
@@ -193,6 +192,7 @@ $nl
"A class representing an active or finished process:"
{ $subsection process }
"Waiting for a process to end, or getting the exit code of a finished process:"
-{ $subsection wait-for-process } ;
+{ $subsection wait-for-process }
+"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
ABOUT: "io.launcher"
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 17a3e6fd23..350743affa 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -66,11 +66,15 @@ SYMBOL: +append-environment+
{ +replace-environment+ [ ] }
} case ;
-GENERIC: >descriptor ( desc -- desc )
+: string-array? ( obj -- ? )
+ dup sequence? [ [ string? ] all? ] [ drop f ] if ;
-M: string >descriptor +command+ associate ;
-M: sequence >descriptor +arguments+ associate ;
-M: assoc >descriptor >hashtable ;
+: >descriptor ( desc -- desc )
+ {
+ { [ dup string? ] [ +command+ associate ] }
+ { [ dup string-array? ] [ +arguments+ associate ] }
+ { [ dup assoc? ] [ >hashtable ] }
+ } cond ;
HOOK: run-process* io-backend ( desc -- handle )
diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor
new file mode 100755
index 0000000000..a704e3473a
--- /dev/null
+++ b/extra/io/timeouts/timeouts-docs.factor
@@ -0,0 +1,32 @@
+IN: io.timeouts
+USING: help.markup help.syntax math kernel ;
+
+HELP: get-lapse
+{ $values { "obj" object } { "lapse" lapse } }
+{ $contract "Outputs an object's timeout lapse descriptor." } ;
+
+HELP: set-timeout
+{ $values { "ms" integer } { "obj" object } }
+{ $contract "Sets an object's timeout, in milliseconds." }
+{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ;
+
+HELP: timed-out
+{ $values { "obj" object } }
+{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
+
+HELP: with-timeout
+{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
+
+ARTICLE: "io.timeouts" "I/O timeout protocol"
+"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
+{ $subsection set-timeout }
+"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
+{ $subsection get-lapse }
+{ $subsection timed-out }
+"A combinator to be used in operations which can time out:"
+{ $subsection with-timeout }
+{ $see-also "stream-protocol" "io.launcher" }
+;
+
+ABOUT: "io.timeouts"
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 55f5f01abc..b3bd2eee4e 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.backend io.monitors io.monitors.private io.files
-io.buffers io.nonblocking io.unix.backend io.unix.select
-io.unix.launcher unix.linux.inotify assocs namespaces threads
-continuations init math alien.c-types alien vocabs.loader ;
+USING: kernel io.backend io.monitors io.monitors.private
+io.files io.buffers io.nonblocking io.timeouts io.unix.backend
+io.unix.select io.unix.launcher unix.linux.inotify assocs
+namespaces threads continuations init math alien.c-types alien
+vocabs.loader ;
IN: io.unix.linux
TUPLE: linux-io ;
From b02f42e0d30261bf5706e8b4b16d2f3e633e39c5 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@joy.internal.stack-effects.com>
Date: Sat, 9 Feb 2008 17:18:57 -0600
Subject: [PATCH 12/46] Fix load issue on Unix
---
extra/io/unix/backend/backend.factor | 2 +-
extra/io/unix/unix.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 1547ecec65..7d9f76c686 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -3,7 +3,7 @@
USING: alien generic assocs kernel kernel.private math
io.nonblocking sequences strings structs sbufs threads unix
vectors io.buffers io.backend io.streams.duplex math.parser
-continuations system libc qualified namespaces ;
+continuations system libc qualified namespaces io.timeouts ;
QUALIFIED: io
IN: io.unix.backend
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 7dc66a05ad..9013df29aa 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -1,4 +1,4 @@
-USING: io.unix.backend io.unix.files io.unix.sockets
+USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader ;
From 72313d0b4fd72f6260e1ad705131ed0905436c19 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 10 Feb 2008 00:35:18 -0600
Subject: [PATCH 13/46] io.unix.launcher: Fix io bug which caused problems
during bootstrap
---
extra/io/unix/launcher/launcher.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 93278e2b1a..c0861788b6 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -49,7 +49,7 @@ MEMO: 'arguments' ( -- parser )
: redirect ( obj mode fd -- )
{
- { [ pick not ] [ 3drop ] }
+ { [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
{ [ pick +closed+ eq? ] [ close 2drop ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
From e0a19714aecd1e5395b166a8ea8425b4aacd20f0 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 10 Feb 2008 01:04:14 -0600
Subject: [PATCH 14/46] builder: refactor
---
extra/builder/builder.factor | 132 +++++++++++++++++++----------------
1 file changed, 71 insertions(+), 61 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 1c5f5ff3fd..7f69f3ef00 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -1,8 +1,9 @@
-USING: kernel io io.files io.launcher hashtables
+USING: kernel io io.files io.launcher io.sockets hashtables
system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client
- combinators bootstrap.image bootstrap.image.download ;
+ combinators bootstrap.image bootstrap.image.download
+ combinators.cleave ;
IN: builder
@@ -29,16 +30,32 @@ IN: builder
SYMBOL: builder-recipients
+: tag-subject ( str -- str ) `{ "builder@" ,[ host-name ] ": " , } concat ;
+
+: email-string ( subject -- )
+ `{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
+ [ ] with-process-stream drop ;
+
: email-file ( subject file -- )
`{
{ +stdin+ , }
- { +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } }
+ { +arguments+
+ { "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } }
}
>hashtable run-process drop ;
-: email-string ( subject -- )
- `{ "mutt" "-s" , %[ builder-recipients get ] }
- [ ] with-process-stream drop ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-or-notify ( desc message -- )
+ [ [ try-process ] curry ]
+ [ [ email-string throw ] curry ]
+ bi*
+ recover ;
+
+: run-or-send-file ( desc message file -- )
+ >r >r [ try-process ] curry
+ r> r> [ email-string throw ] 2curry
+ recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -59,71 +76,44 @@ VAR: stamp
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-SYMBOL: build-status
-
-: build ( -- )
-
- "running" build-status set-global
-
- datestamp >stamp
-
- "/builds/factor" cd
-
+: git-pull ( -- desc )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
- }
- run-process process-status
- 0 =
- [ ]
- [
- "builder: git pull" email-string
- "builder: git pull" throw
- ]
- if
+ } ;
- {
- "git" "pull" "--no-summary"
- "http://dharmatech.onigirihouse.com/factor.git" "master"
- } run-process drop
+: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
- "/builds/" stamp> append make-directory
- "/builds/" stamp> append cd
-
- { "git" "clone" "../factor" } run-process drop
-
- "factor" cd
+: enter-build-dir ( -- )
+ datestamp >stamp
+ "/builds" cd
+ stamp> make-directory
+ stamp> cd ;
+: record-git-id ( -- )
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second
- "../git-id" log-object
+ "../git-id" log-object ;
- { "make" "clean" } run-process drop
-
- ! "vm" build-status set-global
+: make-clean ( -- desc ) { "make" "clean" } ;
+: make-vm ( -- )
`{
{ +arguments+ { "make" ,[ target ] } }
{ +stdout+ "../compile-log" }
{ +stderr+ +stdout+ }
}
- >hashtable run-process process-status
- 0 =
- [ ]
- [
- "builder: vm compile" "../compile-log" email-file
- "builder: vm compile" throw
- ] if
+ >hashtable ;
+: retrieve-boot-image ( -- )
[ my-arch download-image ]
[ ]
[ "builder: image download" email-string ]
- cleanup
-
- ! "bootstrap" build-status set-global
+ cleanup ;
+: bootstrap ( -- desc )
`{
{ +arguments+ {
,[ factor-binary ]
@@ -133,17 +123,39 @@ SYMBOL: build-status
{ +stdout+ "../boot-log" }
{ +stderr+ +stdout+ }
}
- >hashtable [ run-process ] "../boot-time" log-runtime process-status
- 0 =
- [ ]
- [
- "builder: bootstrap" "../boot-log" email-file
- "builder: bootstrap" throw
- ] if
+ >hashtable ;
- ! "test" build-status set-global
+: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- `{ ,[ factor-binary ] "-run=builder.test" } run-process drop
+SYMBOL: build-status
+
+: build ( -- )
+
+ "running" build-status set-global
+
+ "/builds/factor" cd
+
+ git-pull "git pull error" run-or-notify
+
+ enter-build-dir
+
+ git-clone "git clone error" run-or-notify
+
+ "factor" cd
+
+ record-git-id
+
+ make-clean "make clean error" run-or-notify
+
+ make-vm "vm compile error" "../compile-log" run-or-send-file
+
+ retrieve-boot-image
+
+ bootstrap "bootstrap error" "../boot-log" run-or-send-file
+
+ builder-test "builder.test fatal error" run-or-notify
"../load-everything-log" exists?
[ "builder: load-everything" "../load-everything-log" email-file ]
@@ -153,9 +165,7 @@ SYMBOL: build-status
[ "builder: failing tests" "../failing-tests" email-file ]
when
- ! "ready" build-status set-global
-
- ;
+ "ready" build-status set-global ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 4231bdb55849cac662d7d762511f17e833e087cc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 9 Feb 2008 23:13:55 -0800
Subject: [PATCH 15/46] Fix 64-bit port
---
core/cpu/x86/64/64.factor | 3 ++-
core/cpu/x86/architecture/architecture.factor | 2 +-
2 files changed, 3 insertions(+), 2 deletions(-)
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index 745b6efd2d..2996a3feeb 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
-alien alien.compiler alien.structs slots splitting assocs ;
+alien alien.accessors alien.compiler alien.structs slots
+splitting assocs ;
IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 20564bbde3..49b05ea48f 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -96,7 +96,7 @@ M: x86-backend %dispatch ( -- )
"n" operand "offset" operand ADD
"n" operand HEX: 7f [+] JMP
! Fix up the displacement above
- code-alignment dup bootstrap-cell 8 = 14 9 ? +
+ code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code
] H{
From ce1602bc2c989fe6257998a61af0cba61624c502 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:34:16 -0600
Subject: [PATCH 16/46] Fix 64-bit bootstrap
---
core/bootstrap/image/image.factor | 11 +++++++----
1 file changed, 7 insertions(+), 4 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 7452e31cf8..9fb80da948 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -135,8 +135,10 @@ SYMBOL: undefined-quot
: here-as ( tag -- pointer ) here swap bitor ;
+USE: continuations
+
: align-here ( -- )
- here 8 mod 4 = [ 0 emit ] when ;
+ here 8 mod 4 = [ break heap-size drop 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
@@ -177,6 +179,7 @@ GENERIC: ' ( obj -- ptr )
[ dup bignum-bits neg shift swap bignum-radix bitand ]
[ ] unfold nip ;
+USE: continuations
: emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
dup length 1+ emit-fixnum
@@ -215,8 +218,8 @@ M: f '
: -1, -1 >bignum ' -1-offset fixup ;
! Beginning of the image
-
-: begin-image ( -- ) emit-header t, 0, 1, -1, ;
+: begin-image ( -- )
+ emit-header t, 0, 1, -1, ;
! Words
@@ -426,8 +429,8 @@ PRIVATE>
: make-image ( arch -- )
architecture [
prepare-image
- begin-image
"resource:/core/bootstrap/stage1.factor" run-file
+ begin-image
end-image
image get
architecture get boot-image-name resource-path
From 765f9bfb43f122210e93ab27e82a3ceb0141be80 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:34:26 -0600
Subject: [PATCH 17/46] Fix regression
---
core/inference/backend/backend.factor | 1 +
core/inference/inference-tests.factor | 5 +++++
2 files changed, 6 insertions(+)
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index b839b047d6..ba65d2508c 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -370,6 +370,7 @@ TUPLE: effect-error word effect ;
init-inference
dependencies off
dup word-def over dup infer-quot-recursive
+ end-infer
finish-word
current-effect
] with-scope
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index 2691be8c3a..7a4176abfb 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -537,3 +537,8 @@ TUPLE: custom-error ;
! This was a false trigger of the undecidable quotation
! recursion bug
{ 2 1 } [ find-last-sep ] must-infer-as
+
+! Regression
+: missing->r-check >r ;
+
+[ [ missing->r-check ] infer ] must-fail
From 6bf808172b707e8b13a295796db6bdf9f807e335 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:38:51 -0600
Subject: [PATCH 18/46] Add watch-vars
---
extra/tools/annotations/annotations.factor | 13 ++++++++++++-
1 file changed, 12 insertions(+), 1 deletion(-)
diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor
index 6dee51cbc0..eed23e8bc1 100755
--- a/extra/tools/annotations/annotations.factor
+++ b/extra/tools/annotations/annotations.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
-prettyprint continuations effects definitions compiler.units ;
+prettyprint continuations effects definitions compiler.units
+namespaces assocs ;
IN: tools.annotations
: reset ( word -- )
@@ -49,6 +50,16 @@ IN: tools.annotations
: watch ( word -- )
dup [ (watch) ] annotate ;
+: (watch-vars) ( quot word vars -- newquot )
+ [
+ "--- Entering: " write swap .
+ "--- Variable values:" print
+ [ dup get ] H{ } map>assoc describe
+ ] 2curry swap compose ;
+
+: watch-vars ( word vars -- )
+ dupd [ (watch-vars) ] 2curry annotate ;
+
: breakpoint ( word -- )
[ \ break add* ] annotate ;
From f052852a274092f89cd682e2174b6173004946b2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:38:58 -0600
Subject: [PATCH 19/46] Fix must-fail-with
---
extra/tools/test/test.factor | 8 +-------
1 file changed, 1 insertion(+), 7 deletions(-)
diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor
index 0b5e436e44..5673e41c62 100755
--- a/extra/tools/test/test.factor
+++ b/extra/tools/test/test.factor
@@ -40,14 +40,8 @@ SYMBOL: this-test
dup word? [ 1quotation ] when
[ infer drop ] curry [ ] swap unit-test ;
-TUPLE: expected-error ;
-
-M: expected-error summary
- drop
- "The unit test expected the quotation to throw an error" ;
-
: must-fail-with ( quot pred -- )
- >r [ expected-error construct-empty throw ] compose r>
+ >r [ f ] compose r>
[ recover ] 2curry
[ t ] swap unit-test ;
From b120abcee28427e014800ea50825d66e632fa260 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:39:21 -0600
Subject: [PATCH 20/46] Fix duplex-stream set-timeout
---
extra/io/timeouts/timeouts.factor | 19 ++++++++++++++-----
1 file changed, 14 insertions(+), 5 deletions(-)
diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor
index ddc92a4bdd..001f59368e 100755
--- a/extra/io/timeouts/timeouts.factor
+++ b/extra/io/timeouts/timeouts.factor
@@ -8,15 +8,14 @@ TUPLE: lapse entry timeout cutoff ;
: <lapse> f 0 0 \ lapse construct-boa ;
+! Won't need this with new slot accessors
GENERIC: get-lapse ( obj -- lapse )
+
GENERIC: set-timeout ( ms obj -- )
-M: object set-timeout get-lapse set-lapse-timeout ;
+M: object set-timeout get-lapse set-timeout ;
-M: duplex-stream set-timeout
- 2dup
- duplex-stream-in set-timeout
- duplex-stream-out set-timeout ;
+M: lapse set-timeout set-lapse-timeout ;
: timeout ( obj -- ms ) get-lapse lapse-timeout ;
: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
@@ -24,6 +23,16 @@ M: duplex-stream set-timeout
: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
+! Won't need this with inheritance
+TUPLE: duplex-stream-lapse stream ;
+
+M: duplex-stream-lapse set-timeout
+ duplex-stream-lapse-stream 2dup
+ duplex-stream-in set-timeout
+ duplex-stream-out set-timeout ;
+
+M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;
+
SYMBOL: timeout-queue
: timeout? ( lapse -- ? )
From 619d676af6baae569e33ff4fa981d997bdc130a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:39:37 -0600
Subject: [PATCH 21/46] logging.server fixes
---
extra/logging/insomniac/insomniac.factor | 2 +-
extra/logging/logging.factor | 10 +++++++---
extra/logging/server/server.factor | 2 +-
3 files changed, 9 insertions(+), 5 deletions(-)
diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor
index d79eca3495..09c6763657 100755
--- a/extra/logging/insomniac/insomniac.factor
+++ b/extra/logging/insomniac/insomniac.factor
@@ -42,7 +42,7 @@ SYMBOL: insomniac-recipients
: email-log-report ( service word-names -- )
"logging.insomniac" [ (email-log-report) ] with-logging ;
-: schedule-insomniac ( alist -- )
+: schedule-insomniac ( service word-names -- )
{ 25 } { 6 } f f f <when> -rot [
[ email-log-report ] assoc-each rotate-logs
] 2curry schedule ;
diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor
index d4f0bd1fbf..fec0c3660f 100755
--- a/extra/logging/logging.factor
+++ b/extra/logging/logging.factor
@@ -4,7 +4,7 @@ USING: logging.server sequences namespaces concurrency
words kernel arrays shuffle tools.annotations
prettyprint.config prettyprint debugger io.streams.string
splitting continuations effects arrays.lib parser strings
-combinators.lib ;
+combinators.lib quotations ;
IN: logging
SYMBOL: DEBUG
@@ -112,9 +112,13 @@ PRIVATE>
: log-critical ( error word -- ) CRITICAL (log-error) ;
+: stack-balancer ( effect word -- quot )
+ >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
+ swap effect-out length f <repetition> append >quotation ;
+
: error-logging-quot ( quot word -- quot' )
- dup stack-effect effect-in length
- [ >r log-error r> ndrop ] 2curry
+ [ [ log-error ] curry ] keep
+ [ stack-effect ] keep stack-balancer compose
[ recover ] 2curry ;
: add-error-logging ( word level -- )
diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor
index 198ae47a79..05029df1d0 100755
--- a/extra/logging/server/server.factor
+++ b/extra/logging/server/server.factor
@@ -84,7 +84,7 @@ SYMBOL: log-files
(close-logs)
log-root directory [ drop rotate-log ] assoc-each ;
-: log-server-loop
+: log-server-loop ( -- )
[
receive unclip {
{ "log-message" [ (log-message) ] }
From 4514971c7bc8d9d4aa6a40a774ab4c5fcf8de73b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:39:48 -0600
Subject: [PATCH 22/46] webapps.planet fix
---
extra/webapps/planet/planet.factor | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index a9fd443fe6..3e008d049d 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -86,8 +86,8 @@ SYMBOL: last-update
\ fetch-feed DEBUG add-error-logging
: fetch-blogroll ( blogroll -- entries )
- dup 0 <column>
- swap [ fetch-feed ] parallel-map
+ dup 0 <column> swap 1 <column>
+ [ fetch-feed ] parallel-map
[ [ <posting> ] with map ] 2map concat ;
: sort-entries ( entries -- entries' )
@@ -120,9 +120,6 @@ SYMBOL: last-update
{ "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/" }
- { "Kevin Marshall"
- "http://blog.botfu.com/?cat=9&feed=atom"
- "http://blog.botfu.com/" }
{ "Kio M. Smallwood"
"http://sekenre.wordpress.com/feed/atom/"
"http://sekenre.wordpress.com/" }
From ab63c7254cf44275f216dc048905158fcc1b3bca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:40:02 -0600
Subject: [PATCH 23/46] Improved left/right arrow keys in editor gadget
---
extra/ui/gadgets/editors/editors.factor | 16 ++++++++++++++--
1 file changed, 14 insertions(+), 2 deletions(-)
diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor
index e2df6a343b..a6674aef5f 100755
--- a/extra/ui/gadgets/editors/editors.factor
+++ b/extra/ui/gadgets/editors/editors.factor
@@ -363,9 +363,21 @@ editor "clipboard" f {
{ T{ cut-action } cut }
} define-command-map
-: previous-character T{ char-elt } editor-prev ;
+: previous-character ( editor -- )
+ dup gadget-selection? [
+ dup selection-start/end drop
+ over set-caret mark>caret
+ ] [
+ T{ char-elt } editor-prev
+ ] if ;
-: next-character T{ char-elt } editor-next ;
+: next-character ( editor -- )
+ dup gadget-selection? [
+ dup selection-start/end nip
+ over set-caret mark>caret
+ ] [
+ T{ char-elt } editor-next
+ ] if ;
: previous-line T{ line-elt } editor-prev ;
From 2ecd1ba127ab1144448c553aef6984bef89d6219 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:40:17 -0600
Subject: [PATCH 24/46] Improve ratio syntax
---
core/math/parser/parser.factor | 11 +++++++----
extra/math/ratios/ratios-tests.factor | 2 +-
2 files changed, 8 insertions(+), 5 deletions(-)
diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor
index 64ce296a0b..68c4768c87 100755
--- a/core/math/parser/parser.factor
+++ b/core/math/parser/parser.factor
@@ -41,6 +41,9 @@ DEFER: base>
<PRIVATE
SYMBOL: radix
+SYMBOL: negative?
+
+: sign negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
radix swap with-variable ; inline
@@ -48,7 +51,7 @@ SYMBOL: radix
: (base>) ( str -- n ) radix get base> ;
: whole-part ( str -- m n )
- "+" split1 >r (base>) r>
+ sign split1 >r (base>) r>
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
@@ -70,7 +73,7 @@ PRIVATE>
: base> ( str radix -- n/f )
[
- "-" ?head >r
+ "-" ?head dup negative? set >r
{
{ [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] }
@@ -114,9 +117,9 @@ M: integer >base
M: ratio >base
[
[
- dup 0 < [ "-" % neg ] when
+ dup 0 < dup negative? set [ "-" % neg ] when
1 /mod
- >r dup zero? [ drop ] [ (>base) % "+" % ] if r>
+ >r dup zero? [ drop ] [ (>base) % sign % ] if r>
dup numerator (>base) %
"/" %
denominator (>base) %
diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor
index 858a7b0544..4dba49b908 100755
--- a/extra/math/ratios/ratios-tests.factor
+++ b/extra/math/ratios/ratios-tests.factor
@@ -107,6 +107,6 @@ unit-test
unit-test
[ 3 ] [ "1+1/2" string>number 2 * ] unit-test
-[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test
+[ -3 ] [ "-1-1/2" string>number 2 * ] unit-test
[ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test
[ "1/8" ] [ 1 8 / number>string ] unit-test
From 125e949200e296865587036f3afa154d85714885 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:40:51 -0600
Subject: [PATCH 25/46] Add new "refs" command to FEP, finds references to an
object
---
vm/debug.c | 91 +++++++++++++++++++++++++++++++++++++++--------------
vm/debug.h | 2 +-
vm/factor.c | 4 +--
3 files changed, 70 insertions(+), 27 deletions(-)
mode change 100644 => 100755 vm/debug.h
diff --git a/vm/debug.c b/vm/debug.c
index 01e1ab0f43..a080a6cab2 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -21,7 +21,7 @@ void print_word(F_WORD* word, CELL nesting)
else
{
printf("#<not a string: ");
- print_nested_obj(word->name,nesting - 1);
+ print_nested_obj(word->name,nesting);
printf(">");
}
}
@@ -44,13 +44,13 @@ void print_array(F_ARRAY* array, CELL nesting)
for(i = 0; i < length; i++)
{
printf(" ");
- print_nested_obj(array_nth(array,i),nesting - 1);
+ print_nested_obj(array_nth(array,i),nesting);
}
}
-void print_nested_obj(CELL obj, CELL nesting)
+void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
- if(nesting == 0)
+ if(nesting <= 0)
{
printf(" ... ");
return;
@@ -204,7 +204,7 @@ void dump_objects(F_FIXNUM type)
if(type == -1 || type_of(obj) == type)
{
printf("%lx ",obj);
- print_nested_obj(obj,1);
+ print_nested_obj(obj,2);
printf("\n");
}
}
@@ -213,36 +213,58 @@ void dump_objects(F_FIXNUM type)
gc_off = false;
}
-CELL obj;
-CELL look_for;
-
-void find_references_step(CELL *scan)
+void find_data_references(CELL look_for)
{
- if(look_for == *scan)
+ CELL obj;
+
+ void find_references_step(CELL *scan)
{
- printf("%lx ",obj);
- print_nested_obj(obj,1);
- printf("\n");
+ if(look_for == *scan)
+ {
+ printf("%lx ",obj);
+ print_nested_obj(obj,2);
+ printf("\n");
+ }
}
-}
-
-void find_references(CELL look_for_)
-{
- look_for = look_for_;
begin_scan();
- CELL obj_;
- while((obj_ = next_object()) != F)
- {
- obj = obj_;
- do_slots(obj_,find_references_step);
- }
+ while((obj = next_object()) != F)
+ do_slots(UNTAG(obj),find_references_step);
/* end scan */
gc_off = false;
}
+void find_code_references(CELL look_for)
+{
+ void find_references_step(F_COMPILED *compiled, CELL code_start,
+ CELL reloc_start, CELL literals_start)
+ {
+ CELL scan;
+ CELL literal_end = literals_start + compiled->literals_length;
+
+ for(scan = literals_start; scan < literal_end; scan += CELLS)
+ {
+ CELL code_start = (CELL)(compiled + 1);
+ CELL literal_start = code_start
+ + compiled->code_length
+ + compiled->reloc_length;
+
+ CELL obj = get(literal_start);
+
+ if(look_for == get(scan))
+ {
+ printf("%lx ",obj);
+ print_nested_obj(obj,2);
+ printf("\n");
+ }
+ }
+ }
+
+ iterate_code_heap(find_references_step);
+}
+
void factorbug(void)
{
reset_stdio();
@@ -265,6 +287,9 @@ void factorbug(void)
printf("addr <card> -- print address containing card\n");
printf("data -- data heap dump\n");
printf("words -- words dump\n");
+ printf("tuples -- tuples dump\n");
+ printf("refs <addr> -- find data heap references to object\n");
+ printf("push <addr> -- push object on data stack - NOT SAFE\n");
printf("code -- code heap dump\n");
for(;;)
@@ -335,8 +360,26 @@ void factorbug(void)
save_image(STR_FORMAT("fep.image"));
else if(strcmp(cmd,"data") == 0)
dump_objects(-1);
+ else if(strcmp(cmd,"refs") == 0)
+ {
+ CELL addr;
+ scanf("%lx",&addr);
+ printf("Data heap references:\n");
+ find_data_references(addr);
+ printf("Code heap references:\n");
+ find_code_references(addr);
+ printf("\n");
+ }
else if(strcmp(cmd,"words") == 0)
dump_objects(WORD_TYPE);
+ else if(strcmp(cmd,"tuples") == 0)
+ dump_objects(TUPLE_TYPE);
+ else if(strcmp(cmd,"push") == 0)
+ {
+ CELL addr;
+ scanf("%lx",&addr);
+ dpush(addr);
+ }
else if(strcmp(cmd,"code") == 0)
dump_heap(&code_heap);
else
diff --git a/vm/debug.h b/vm/debug.h
old mode 100644
new mode 100755
index cfd928bb51..ff8075c457
--- a/vm/debug.h
+++ b/vm/debug.h
@@ -1,5 +1,5 @@
void print_obj(CELL obj);
-void print_nested_obj(CELL obj, CELL nesting);
+void print_nested_obj(CELL obj, F_FIXNUM nesting);
void dump_generations(void);
void factorbug(void);
diff --git a/vm/factor.c b/vm/factor.c
index 0754067b95..826ad65324 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -154,6 +154,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
init_factor(&p);
+ nest_stacks();
+
F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
for(i = 1; i < argc; i++)
@@ -173,8 +175,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
userenv[EXECUTABLE_ENV] = tag_object(from_native_string(executable_path));
userenv[EMBEDDED_ENV] = (embedded ? T : F);
- nest_stacks();
-
if(p.console)
open_console();
From d8edd7b0d4e3360ded930d2d8ab78d9aa02b8723 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 01:49:27 -0600
Subject: [PATCH 26/46] Clean up bootstrap.image
---
core/bootstrap/image/image.factor | 41 +++++++++++++------------------
1 file changed, 17 insertions(+), 24 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 9fb80da948..4468ecf7d1 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -135,10 +135,8 @@ SYMBOL: undefined-quot
: here-as ( tag -- pointer ) here swap bitor ;
-USE: continuations
-
: align-here ( -- )
- here 8 mod 4 = [ break heap-size drop 0 emit ] when ;
+ here 8 mod 4 = [ heap-size drop 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
@@ -217,10 +215,6 @@ M: f '
: 1, 1 >bignum ' 1-offset fixup ;
: -1, -1 >bignum ' -1-offset fixup ;
-! Beginning of the image
-: begin-image ( -- )
- emit-header t, 0, 1, -1, ;
-
! Words
: emit-word ( word -- )
@@ -388,7 +382,10 @@ M: curry '
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
-: end-image ( -- )
+: build-image ( -- image )
+ 800000 <vector> image set
+ 20000 <hashtable> objects set
+ emit-header t, 0, 1, -1,
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
@@ -403,7 +400,8 @@ M: curry '
fixup-header
"Image length: " write image get length .
"Object cache size: " write objects get assoc-size .
- \ word global delete-at ;
+ \ word global delete-at
+ image get ;
! Image output
@@ -414,28 +412,23 @@ M: curry '
[ >le write ] curry each
] if ;
-: write-image ( image filename -- )
- "Writing image to " write dup write "..." print flush
+: write-image ( image -- )
+ "Writing image to " write
+ architecture get boot-image-name resource-path
+ dup write "..." print flush
<file-writer> [ (write-image) ] with-stream ;
-: prepare-image ( -- )
- bootstrapping? on
- load-help? off
- 800000 <vector> image set
- 20000 <hashtable> objects set ;
-
PRIVATE>
: make-image ( arch -- )
- architecture [
- prepare-image
+ [
+ architecture set
+ bootstrapping? on
+ load-help? off
"resource:/core/bootstrap/stage1.factor" run-file
- begin-image
- end-image
- image get
- architecture get boot-image-name resource-path
+ build-image
write-image
- ] with-variable ;
+ ] with-scope ;
: make-images ( -- )
images [ make-image ] each ;
From ad7ec00c29bcf298b6ad0a8e7f4ac0de55e6527e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 10 Feb 2008 03:01:20 -0600
Subject: [PATCH 27/46] builder: use base portion of hostname
---
extra/builder/builder.factor | 8 +++++---
1 file changed, 5 insertions(+), 3 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 7f69f3ef00..8f44093141 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -30,7 +30,9 @@ IN: builder
SYMBOL: builder-recipients
-: tag-subject ( str -- str ) `{ "builder@" ,[ host-name ] ": " , } concat ;
+: host-name* ( -- name ) host-name "." split first ;
+
+: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ;
: email-string ( subject -- )
`{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] }
@@ -158,11 +160,11 @@ SYMBOL: build-status
builder-test "builder.test fatal error" run-or-notify
"../load-everything-log" exists?
- [ "builder: load-everything" "../load-everything-log" email-file ]
+ [ "load-everything" "../load-everything-log" email-file ]
when
"../failing-tests" exists?
- [ "builder: failing tests" "../failing-tests" email-file ]
+ [ "failing tests" "../failing-tests" email-file ]
when
"ready" build-status set-global ;
From e7bf56ad57398e586e109b51b20a1e576d866d27 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 10 Feb 2008 03:05:34 -0600
Subject: [PATCH 28/46] builder: fix run-or-send-file bug
---
extra/builder/builder.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 8f44093141..a17afb9d55 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -56,7 +56,7 @@ SYMBOL: builder-recipients
: run-or-send-file ( desc message file -- )
>r >r [ try-process ] curry
- r> r> [ email-string throw ] 2curry
+ r> r> [ email-file throw ] 2curry
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 3eda26ca0b1b330842db444938640a6038876f6a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 03:12:44 -0600
Subject: [PATCH 29/46] Fix unit tests
---
extra/http/server/server-tests.factor | 7 ++-----
extra/io/streams/null/null.factor | 2 +-
extra/smtp/smtp-tests.factor | 26 +++++++-------------------
3 files changed, 10 insertions(+), 25 deletions(-)
mode change 100644 => 100755 extra/http/server/server-tests.factor
diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor
old mode 100644
new mode 100755
index f72e12f927..18edd94f12
--- a/extra/http/server/server-tests.factor
+++ b/extra/http/server/server-tests.factor
@@ -1,15 +1,12 @@
USING: webapps.file http.server.responders http
-http.server namespaces io tools.test strings io.server ;
+http.server namespaces io tools.test strings io.server
+logging ;
IN: temporary
[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test
[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
-[ ] [
- f [ "unit/test" log-responder ] with-logging
-] unit-test
-
[ "index.html" ]
[ "http://www.jedit.org/index.html" url>path ] unit-test
diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor
index d747fa0a29..eee66239be 100755
--- a/extra/io/streams/null/null.factor
+++ b/extra/io/streams/null/null.factor
@@ -6,7 +6,7 @@ USING: kernel io io.timeouts continuations ;
TUPLE: null-stream ;
M: null-stream dispose drop ;
-M: null-stream set-timeout drop ;
+M: null-stream set-timeout 2drop ;
M: null-stream stream-readln drop f ;
M: null-stream stream-read1 drop f ;
M: null-stream stream-read-until 2drop f f ;
diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor
index eda8d7cc1f..aa3641417b 100755
--- a/extra/smtp/smtp-tests.factor
+++ b/extra/smtp/smtp-tests.factor
@@ -1,5 +1,5 @@
USING: smtp tools.test io.streams.string threads
-smtp.server kernel sequences namespaces ;
+smtp.server kernel sequences namespaces logging ;
IN: temporary
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
@@ -15,34 +15,22 @@ IN: temporary
{ "hello" "world" } [ send-body ] string-out
] unit-test
-[
- [
- "500 syntax error" check-response
- ] with-log-stdio
-] must-fail
+[ "500 syntax error" check-response ] must-fail
-[ ] [
- [
- "220 success" check-response
- ] with-log-stdio
-] unit-test
+[ ] [ "220 success" check-response ] unit-test
[ "220 success" ] [
"220 success" [ receive-response ] string-in
] unit-test
[ "220 the end" ] [
- [
- "220-a multiline response\r\n250-another line\r\n220 the end"
- [ receive-response ] string-in
- ] with-log-stdio
+ "220-a multiline response\r\n250-another line\r\n220 the end"
+ [ receive-response ] string-in
] unit-test
[ ] [
- [
- "220-a multiline response\r\n250-another line\r\n220 the end"
- [ get-ok ] string-in
- ] with-log-stdio
+ "220-a multiline response\r\n250-another line\r\n220 the end"
+ [ get-ok ] string-in
] unit-test
[
From a228072862ef59f2c029544fd4de8ba466012162 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 20:32:10 -0600
Subject: [PATCH 30/46] Logging parser now parses the timestamps
---
extra/logging/parser/parser.factor | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor
index f9bf97a442..b4c7e12772 100755
--- a/extra/logging/parser/parser.factor
+++ b/extra/logging/parser/parser.factor
@@ -11,8 +11,10 @@ IN: logging.parser
SYMBOL: multiline
: 'date'
- multiline-header token [ drop multiline ] <@
- [ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|>
+ [ "]" member? not ] string-of [
+ dup multiline-header =
+ [ drop multiline ] [ rfc3339>timestamp ] if
+ ] <@
"[" "]" surrounded-by ;
: 'log-level'
From a4e5bc11b5166b5259115437b19e71a666d31add Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 20:32:26 -0600
Subject: [PATCH 31/46] Editor gadget fix for CS+LEFT/RIGHT
---
extra/ui/gadgets/editors/editors.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor
index a6674aef5f..507dc932a4 100755
--- a/extra/ui/gadgets/editors/editors.factor
+++ b/extra/ui/gadgets/editors/editors.factor
@@ -448,8 +448,8 @@ editor "selection" f {
{ T{ key-down f { S+ } "RIGHT" } select-next-character }
{ T{ key-down f { S+ } "UP" } select-previous-line }
{ T{ key-down f { S+ } "DOWN" } select-next-line }
- { T{ key-down f { S+ C+ } "LEFT" } select-previous-line }
- { T{ key-down f { S+ C+ } "RIGHT" } select-next-line }
+ { T{ key-down f { S+ C+ } "LEFT" } select-previous-word }
+ { T{ key-down f { S+ C+ } "RIGHT" } select-next-word }
{ T{ key-down f { S+ } "HOME" } select-start-of-line }
{ T{ key-down f { S+ } "END" } select-end-of-line }
{ T{ key-down f { S+ C+ } "HOME" } select-start-of-document }
From 637600011ca60df31d1fefe47be9ee01ee452d09 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 20:32:48 -0600
Subject: [PATCH 32/46] FFI compile errors now reported separately; new kill
literals phase design
---
core/alien/compiler/compiler.factor | 19 ++++-
core/compiler/errors/errors-docs.factor | 29 ++++----
core/compiler/errors/errors.factor | 69 +++++++++++-------
core/inference/backend/backend.factor | 14 ++--
core/inference/class/class-tests.factor | 10 +++
core/inference/class/class.factor | 33 +++++----
core/inference/dataflow/dataflow.factor | 22 ++++++
core/optimizer/backend/backend.factor | 70 +++++++------------
core/optimizer/def-use/def-use.factor | 63 ++++++++++++++---
core/optimizer/known-words/known-words.factor | 2 +-
core/optimizer/optimizer.factor | 5 +-
11 files changed, 213 insertions(+), 123 deletions(-)
mode change 100644 => 100755 core/optimizer/def-use/def-use.factor
diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 51240a66d9..54348e47f9 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words
inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
-kernel.private threads continuations.private libc combinators ;
+kernel.private threads continuations.private libc combinators
+compiler.errors continuations ;
IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect
@@ -207,9 +208,21 @@ M: alien-invoke-error summary
swap alien-node-parameters parameter-sizes drop
number>string 3append ;
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+ drop "Library not found" ;
+
+: no-such-library ( name -- )
+ \ no-such-library +linkage+ (inference-error) ;
+
: (alien-invoke-dlsym) ( node -- symbol dll )
dup alien-invoke-function
- swap alien-invoke-library load-library ;
+ swap alien-invoke-library [
+ load-library
+ ] [
+ 2drop no-such-library
+ ] recover ;
TUPLE: no-such-symbol ;
@@ -217,7 +230,7 @@ M: no-such-symbol summary
drop "Symbol not found" ;
: no-such-symbol ( -- )
- \ no-such-symbol inference-error ;
+ \ no-such-symbol +linkage+ (inference-error) ;
: alien-invoke-dlsym ( node -- symbol dll )
dup (alien-invoke-dlsym) 2dup dlsym [
diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor
index 13fc0d3103..678face309 100755
--- a/core/compiler/errors/errors-docs.factor
+++ b/core/compiler/errors/errors-docs.factor
@@ -1,14 +1,15 @@
IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
-quotations ;
+quotations compiler.errors.private ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"The compiler saves compile warnings and errors in a global variable:"
+"The compiler saves various notifications in a global variable:"
{ $subsection compiler-errors }
-"The warnings and errors can be viewed later:"
-{ $subsection :warnings }
+"These notifications can be viewed later:"
{ $subsection :errors }
-"Normally, all warnings and errors are displayed at the end of a batch compilation, such as a call to " { $link require } " or " { $link refresh-all } ". This can be controlled with a combinator:"
+{ $subsection :warnings }
+{ $subsection :linkage }
+"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
{ $link with-compiler-errors } ;
HELP: compiler-errors
@@ -16,7 +17,7 @@ HELP: compiler-errors
HELP: compiler-error
{ $values { "error" "an error" } { "word" word } }
-{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } " and " { $link :warnings } ", otherwise ignores the error." } ;
+{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
HELP: compiler-error.
{ $values { "error" "an error" } { "word" word } }
@@ -25,24 +26,18 @@ HELP: compiler-error.
HELP: compiler-errors.
{ $values { "errors" "an assoc mapping words to errors" } }
{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ;
-
-HELP: (:errors)
-{ $values { "seq" "an alist" } }
-{ $description "Outputs all serious compiler errors from the most recent compile." } ;
-
HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
-HELP: (:warnings)
-{ $values { "seq" "an alist" } }
-{ $description "Outputs all ignorable compiler warnings from the most recent compile." } ;
-
HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
-{ :errors (:errors) :warnings (:warnings) } related-words
+HELP: :linkage
+{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
+
+{ :errors :warnings } related-words
HELP: with-compiler-errors
{ $values { "quot" quotation } }
-{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :warnings } " and " { $link :errors } "." }
+{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;
diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor
index 363c13c478..b7b599e5a9 100755
--- a/core/compiler/errors/errors.factor
+++ b/core/compiler/errors/errors.factor
@@ -4,51 +4,66 @@ USING: kernel namespaces assocs prettyprint io sequences
sorting continuations debugger math math.parser ;
IN: compiler.errors
+SYMBOL: +error+
+SYMBOL: +warning+
+SYMBOL: +linkage+
+
+GENERIC: compiler-error-type ( error -- ? )
+
+M: object compiler-error-type drop +error+ ;
+
+<PRIVATE
+
SYMBOL: compiler-errors
SYMBOL: with-compiler-errors?
-: compiler-error ( error word -- )
- with-compiler-errors? get [
- compiler-errors get pick
- [ set-at ] [ delete-at drop ] if
- ] [ 2drop ] if ;
-
: compiler-error. ( error word -- )
nl
"While compiling " write pprint ": " print
nl
print-error ;
-: compiler-errors. ( assoc -- )
- >alist sort-keys [ swap compiler-error. ] assoc-each ;
-
-GENERIC: compiler-warning? ( error -- ? )
-
-M: object compiler-warning? drop f ;
-
-: (:errors) ( -- assoc )
+: errors-of-type ( type -- assoc )
compiler-errors get-global
- [ nip compiler-warning? not ] assoc-subset ;
+ swap [ >r nip compiler-error-type r> eq? ] curry
+ assoc-subset ;
-: :errors (:errors) compiler-errors. ;
+: compiler-errors. ( type -- )
+ errors-of-type >alist sort-keys
+ [ swap compiler-error. ] assoc-each ;
-: (:warnings) ( -- seq )
- compiler-errors get-global
- [ nip compiler-warning? ] assoc-subset ;
-
-: :warnings (:warnings) compiler-errors. ;
-
-: (compiler-report) ( what assoc -- )
- length dup zero? [ 2drop ] [
+: (compiler-report) ( what type word -- )
+ over errors-of-type assoc-empty? [ 3drop ] [
[
- ":" % over % " - print " % # " compiler " % % "." %
+ ":" %
+ %
+ " - print " %
+ errors-of-type assoc-size #
+ " " %
+ %
+ "." %
] "" make print
] if ;
: compiler-report ( -- )
- "errors" (:errors) (compiler-report)
- "warnings" (:warnings) (compiler-report) ;
+ "semantic errors" +error+ "errors" (compiler-report)
+ "semantic warnings" +warning+ "warnings" (compiler-report)
+ "linkage errors" +linkage+ "linkage" (compiler-report) ;
+
+PRIVATE>
+
+: compiler-error ( error word -- )
+ with-compiler-errors? get [
+ compiler-errors get pick
+ [ set-at ] [ delete-at drop ] if
+ ] [ 2drop ] if ;
+
+: :errors +error+ compiler-errors. ;
+
+: :warnings +warning+ compiler-errors. ;
+
+: :linkage +linkage+ compiler-errors. ;
: with-compiler-errors ( quot -- )
with-compiler-errors? get "quiet" get or [ call ] [
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index ba65d2508c..cadf326692 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -24,24 +24,24 @@ IN: inference.backend
: recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] with contains? ;
-TUPLE: inference-error rstate major? ;
+TUPLE: inference-error rstate type ;
-M: inference-error compiler-warning?
- inference-error-major? not ;
+M: inference-error compiler-error-type
+ inference-error-type ;
-: (inference-error) ( ... class important? -- * )
+: (inference-error) ( ... class type -- * )
>r construct-boa r>
recursive-state get {
set-delegate
- set-inference-error-major?
+ set-inference-error-type
set-inference-error-rstate
} \ inference-error construct throw ; inline
: inference-error ( ... class -- * )
- t (inference-error) ; inline
+ +error+ (inference-error) ; inline
: inference-warning ( ... class -- * )
- f (inference-error) ; inline
+ +warning+ (inference-error) ; inline
TUPLE: literal-expected ;
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 17cc3d3cf8..b77661b899 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -269,7 +269,17 @@ cell-bits 32 = [
\ number= inlined?
] unit-test
+[ t ] [
+ [ B{ 1 0 } *short 0 { number number } declare number= ]
+ \ number= inlined?
+] unit-test
+
[ t ] [
[ B{ 1 0 } *short 0 = ]
\ number= inlined?
] unit-test
+
+[ t ] [
+ [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
+ \ number= inlined?
+] unit-test
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index f6d5a36d3d..3555725c1f 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -73,17 +73,27 @@ SYMBOL: value-intervals
! Current value --> class mapping
SYMBOL: value-classes
+: value-interval* ( value -- interval/f )
+ value-intervals get at ;
+
: set-value-interval* ( interval value -- )
value-intervals get set-at ;
+: intersect-value-interval ( interval value -- )
+ [ value-interval* interval-intersect ] keep
+ set-value-interval* ;
+
M: interval-constraint apply-constraint
dup interval-constraint-interval
- swap interval-constraint-value set-value-interval* ;
+ swap interval-constraint-value intersect-value-interval ;
: set-class-interval ( class value -- )
>r "interval" word-prop dup
[ r> set-value-interval* ] [ r> 2drop ] if ;
+: value-class* ( value -- class )
+ value-classes get at object or ;
+
: set-value-class* ( class value -- )
over [
dup value-intervals get at [
@@ -93,9 +103,12 @@ M: interval-constraint apply-constraint
] when
value-classes get set-at ;
+: intersect-value-class ( class value -- )
+ [ value-class* class-and ] keep set-value-class* ;
+
M: class-constraint apply-constraint
dup class-constraint-class
- swap class-constraint-value set-value-class* ;
+ swap class-constraint-value intersect-value-class ;
: set-value-literal* ( literal value -- )
over class over set-value-class*
@@ -127,16 +140,10 @@ M: literal-constraint constraint-satisfied?
dup literal-constraint-value value-literal*
[ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
-: value-class* ( value -- class )
- value-classes get at object or ;
-
M: class-constraint constraint-satisfied?
dup class-constraint-value value-class*
swap class-constraint-class class< ;
-: value-interval* ( value -- interval/f )
- value-intervals get at ;
-
M: pair apply-constraint
first2 2dup constraints get set-at
constraint-satisfied? [ apply-constraint ] [ drop ] if ;
@@ -159,13 +166,10 @@ M: pair constraint-satisfied?
2drop ;
: intersect-classes ( classes values -- )
- [ [ value-class* class-and ] keep set-value-class* ] 2each ;
+ [ intersect-value-class ] 2each ;
: intersect-intervals ( intervals values -- )
- [
- [ value-interval* interval-intersect ] keep
- set-value-interval*
- ] 2each ;
+ [ intersect-value-interval ] 2each ;
: predicate-constraints ( class #call -- )
[
@@ -220,7 +224,8 @@ M: #dispatch child-constraints
] make-constraints ;
M: #declare infer-classes-before
- dup node-param swap node-in-d [ set-value-class* ] 2each ;
+ dup node-param swap node-in-d
+ [ intersect-value-class ] 2each ;
DEFER: (infer-classes)
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index 6a0be66bb1..71cb0eef65 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/core/inference/dataflow/dataflow.factor
@@ -256,6 +256,28 @@ SYMBOL: node-stack
] iterate-nodes drop
] with-node-iterator ; inline
+: change-children ( node quot -- )
+ over [
+ >r dup node-children dup r>
+ [ map swap set-node-children ] curry
+ [ 2drop ] if
+ ] [
+ 2drop
+ ] if ; inline
+
+: (transform-nodes) ( prev node quot -- )
+ dup >r call dup [
+ dup rot set-node-successor
+ dup node-successor r> (transform-nodes)
+ ] [
+ r> drop f swap set-node-successor drop
+ ] if ; inline
+
+: transform-nodes ( node quot -- new-node )
+ over [
+ [ call dup dup node-successor ] keep (transform-nodes)
+ ] [ drop ] if ; inline
+
: node-literal? ( node value -- ? )
dup value? >r swap node-literals key? r> or ;
diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor
index 788f862849..c64d1fd010 100755
--- a/core/optimizer/backend/backend.factor
+++ b/core/optimizer/backend/backend.factor
@@ -52,13 +52,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
DEFER: optimize-nodes
: optimize-children ( node -- )
- [
- dup node-children dup [
- [ optimize-nodes ] map swap set-node-children
- ] [
- 2drop
- ] if
- ] when* ;
+ [ optimize-nodes ] change-children ;
: optimize-node ( node -- node )
dup [
@@ -76,39 +70,17 @@ DEFER: optimize-nodes
M: f set-node-successor 2drop ;
-: (optimize-nodes) ( prev node -- )
- optimize-node [
- dup rot set-node-successor
- dup node-successor (optimize-nodes)
- ] [
- f swap set-node-successor
- ] if* ;
-
: optimize-nodes ( node -- newnode )
[
class-substitutions [ clone ] change
literal-substitutions [ clone ] change
- dup [
- optimize-node
- dup dup node-successor (optimize-nodes)
- ] when optimizer-changed get
+ [ optimize-node ] transform-nodes
+ optimizer-changed get
] with-scope optimizer-changed set ;
-: prune-if ( node quot -- successor/t )
- over >r call [ r> node-successor t ] [ r> drop t f ] if ;
- inline
-
! Generic nodes
M: node optimize-node* drop t f ;
-M: #shuffle optimize-node*
- [
- dup node-in-d empty? swap node-out-d empty? and
- ] prune-if ;
-
-M: #push optimize-node*
- [ node-out-d empty? ] prune-if ;
-
: cleanup-inlining ( node -- newnode changed? )
node-successor [ node-successor t ] [ t f ] if* ;
@@ -118,12 +90,6 @@ M: #return optimize-node* cleanup-inlining ;
! #values
M: #values optimize-node* cleanup-inlining ;
-! #>r
-M: #>r optimize-node* [ node-in-d empty? ] prune-if ;
-
-! #r>
-M: #r> optimize-node* [ node-in-r empty? ] prune-if ;
-
! Some utilities for splicing in dataflow IR subtrees
: follow ( key assoc -- value )
2dup at* [ swap follow nip ] [ 2drop ] if ;
@@ -194,10 +160,8 @@ M: node remember-method*
! Constant branch folding
: fold-branch ( node branch# -- node )
- over drop-inputs >r
over node-children nth
- swap node-successor over substitute-node
- r> [ set-node-successor ] keep ;
+ swap node-successor over substitute-node ;
! #if
: known-boolean-value? ( node value -- value ? )
@@ -213,12 +177,18 @@ M: node remember-method*
] if ;
M: #if optimize-node*
- dup dup node-in-d first known-boolean-value?
- [ 0 1 ? fold-branch t ] [ 2drop t f ] if ;
+ dup dup node-in-d first known-boolean-value? [
+ over drop-inputs >r
+ 0 1 ? fold-branch
+ r> [ set-node-successor ] keep
+ t
+ ] [ 2drop t f ] if ;
M: #dispatch optimize-node*
dup dup node-in-d first 2dup node-literal? [
- node-literal fold-branch t
+ "Optimizing #dispatch" print
+ node-literal
+ over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
] [
3drop t f
] if ;
@@ -322,9 +292,19 @@ DEFER: (flat-length)
#! Make #shuffle -> #push -> #return -> successor
dupd literal-quot splice-quot ;
-: optimize-predicate ( #call -- node )
+: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
- dup node-class-first r> class< 1array inline-literals ;
+ node-class-first r> class< ;
+
+: optimize-predicate ( #call -- node )
+ dup evaluate-predicate swap
+ dup node-successor #if? [
+ dup drop-inputs >r
+ node-successor swap 0 1 ? fold-branch
+ r> [ set-node-successor ] keep
+ ] [
+ swap 1array inline-literals
+ ] if ;
: optimizer-hooks ( node -- conditions )
node-param "optimizer-hooks" word-prop ;
diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor
old mode 100644
new mode 100755
index 091f6524f0..9355b2bb70
--- a/core/optimizer/def-use/def-use.factor
+++ b/core/optimizer/def-use/def-use.factor
@@ -70,19 +70,66 @@ M: #branch node-def-use
#! #values node.
dup branch-def-use (node-def-use) ;
-: dead-literals ( -- values )
+! : dead-literals ( -- values )
+! def-use get [ >r value? r> empty? and ] assoc-subset ;
+!
+! : kill-node* ( node values -- )
+! [ swap remove-all ] curry modify-values ;
+!
+! : kill-node ( node values -- )
+! dup assoc-empty?
+! [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
+!
+! : kill-values ( node -- )
+! #! Remove literals which are not actually used anywhere.
+! dead-literals kill-node ;
+
+: compute-dead-literals ( -- values )
def-use get [ >r value? r> empty? and ] assoc-subset ;
-: kill-node* ( node values -- )
- [ swap remove-all ] curry modify-values ;
+DEFER: kill-nodes
+SYMBOL: dead-literals
-: kill-node ( node values -- )
- dup assoc-empty?
- [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
+GENERIC: kill-node* ( node -- node/t )
-: kill-values ( node -- )
+M: node kill-node* drop t ;
+
+: prune-if ( node quot -- successor/t )
+ over >r call [ r> node-successor ] [ r> drop t ] if ;
+ inline
+
+M: #shuffle kill-node*
+ [
+ dup node-in-d empty? swap node-out-d empty? and
+ ] prune-if ;
+
+M: #push kill-node*
+ [ node-out-d empty? ] prune-if ;
+
+M: #>r kill-node* [ node-in-d empty? ] prune-if ;
+
+M: #r> kill-node* [ node-in-r empty? ] prune-if ;
+
+: kill-node ( node -- node )
+ dup [
+ dup [ dead-literals get swap remove-all ] modify-values
+ dup kill-node* dup t eq? [
+ drop dup [ kill-nodes ] change-children
+ ] [
+ nip kill-node
+ ] if
+ ] when ;
+
+: kill-nodes ( node -- newnode )
+ [ kill-node ] transform-nodes ;
+
+: kill-values ( node -- new-node )
#! Remove literals which are not actually used anywhere.
- dead-literals kill-node ;
+ compute-dead-literals dup assoc-empty? [ drop ] [
+ dead-literals [ kill-nodes ] with-variable
+ ] if ;
+
+!
: sole-consumer ( #call -- node/f )
node-out-d first used-by
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 5820d8f5b2..43c0324611 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -98,7 +98,7 @@ float-arrays combinators.private combinators ;
[
num-types get swap [
[
- [ type>class 0 `input class, ] keep
+ [ type>class object or 0 `input class, ] keep
0 `output literal,
] set-constraints
] curry each
diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor
index 219b27197f..1674ecd782 100755
--- a/core/optimizer/optimizer.factor
+++ b/core/optimizer/optimizer.factor
@@ -4,13 +4,16 @@ USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math inference.class ;
IN: optimizer
+SYMBOL: optimize-count
+
: optimize-1 ( node -- newnode ? )
[
+ global [ optimize-count inc ] bind
H{ } clone class-substitutions set
H{ } clone literal-substitutions set
H{ } clone value-substitutions set
dup compute-def-use
- dup kill-values
+ kill-values
dup infer-classes
optimizer-changed off
optimize-nodes
From 262e9d3443ec9a6f00c6d82f2fd24e5e131917ce Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 Feb 2008 23:03:54 -0600
Subject: [PATCH 33/46] Clean up vocabs.loader and add littledan's unit test
feature
---
core/bootstrap/stage1.factor | 2 +-
.../curry-tests.factor => curry.factor} | 0
core/compiler/test/curry/curry.factor | 0
.../float-tests.factor => float.factor} | 0
core/compiler/test/float/float.factor | 0
...rinsics-tests.factor => intrinsics.factor} | 0
.../test/intrinsics/intrinsics.factor | 0
.../test/redefine/redefine-tests.factor | 287 ------------------
core/compiler/test/redefine/redefine.factor | 0
.../simple-tests.factor => simple.factor} | 0
core/compiler/test/simple/simple.factor | 0
...-trace-tests.factor => stack-trace.factor} | 0
.../test/stack-trace/stack-trace.factor | 0
...ly-tests.factor => templates-early.factor} | 0
.../templates-early/templates-early.factor | 0
...emplates-tests.factor => templates.factor} | 0
core/compiler/test/templates/templates.factor | 0
.../tuples-tests.factor => tuples.factor} | 0
core/compiler/test/tuples/tuples.factor | 0
core/io/files/files.factor | 3 +
core/optimizer/optimizer.factor | 3 -
core/parser/parser.factor | 2 +-
core/source-files/source-files.factor | 2 +-
core/vocabs/loader/loader.factor | 116 ++++---
core/vocabs/vocabs.factor | 12 +-
extra/furnace/furnace.factor | 2 +-
extra/tools/browser/browser.factor | 17 +-
extra/tools/test/test-docs.factor | 7 +-
extra/tools/test/test.factor | 18 +-
29 files changed, 90 insertions(+), 381 deletions(-)
rename core/compiler/test/{curry/curry-tests.factor => curry.factor} (100%)
delete mode 100644 core/compiler/test/curry/curry.factor
rename core/compiler/test/{float/float-tests.factor => float.factor} (100%)
delete mode 100644 core/compiler/test/float/float.factor
rename core/compiler/test/{intrinsics/intrinsics-tests.factor => intrinsics.factor} (100%)
delete mode 100644 core/compiler/test/intrinsics/intrinsics.factor
delete mode 100755 core/compiler/test/redefine/redefine-tests.factor
delete mode 100644 core/compiler/test/redefine/redefine.factor
rename core/compiler/test/{simple/simple-tests.factor => simple.factor} (100%)
delete mode 100644 core/compiler/test/simple/simple.factor
rename core/compiler/test/{stack-trace/stack-trace-tests.factor => stack-trace.factor} (100%)
delete mode 100644 core/compiler/test/stack-trace/stack-trace.factor
rename core/compiler/test/{templates-early/templates-early-tests.factor => templates-early.factor} (100%)
delete mode 100644 core/compiler/test/templates-early/templates-early.factor
rename core/compiler/test/{templates/templates-tests.factor => templates.factor} (100%)
delete mode 100644 core/compiler/test/templates/templates.factor
rename core/compiler/test/{tuples/tuples-tests.factor => tuples.factor} (100%)
delete mode 100644 core/compiler/test/tuples/tuples.factor
mode change 100644 => 100755 extra/furnace/furnace.factor
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index cc328e9760..4f5bf6d69e 100755
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -38,7 +38,7 @@ vocabs.loader system ;
[
"resource:core/bootstrap/stage2.factor"
- dup ?resource-path exists? [
+ dup resource-exists? [
run-file
] [
"Cannot find " write write "." print
diff --git a/core/compiler/test/curry/curry-tests.factor b/core/compiler/test/curry.factor
similarity index 100%
rename from core/compiler/test/curry/curry-tests.factor
rename to core/compiler/test/curry.factor
diff --git a/core/compiler/test/curry/curry.factor b/core/compiler/test/curry/curry.factor
deleted file mode 100644
index e69de29bb2..0000000000
diff --git a/core/compiler/test/float/float-tests.factor b/core/compiler/test/float.factor
similarity index 100%
rename from core/compiler/test/float/float-tests.factor
rename to core/compiler/test/float.factor
diff --git a/core/compiler/test/float/float.factor b/core/compiler/test/float/float.factor
deleted file mode 100644
index e69de29bb2..0000000000
diff --git a/core/compiler/test/intrinsics/intrinsics-tests.factor b/core/compiler/test/intrinsics.factor
similarity index 100%
rename from core/compiler/test/intrinsics/intrinsics-tests.factor
rename to core/compiler/test/intrinsics.factor
diff --git a/core/compiler/test/intrinsics/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics.factor
deleted file mode 100644
index e69de29bb2..0000000000
diff --git a/core/compiler/test/redefine/redefine-tests.factor b/core/compiler/test/redefine/redefine-tests.factor
deleted file mode 100755
index 9eaf2d1263..0000000000
--- a/core/compiler/test/redefine/redefine-tests.factor
+++ /dev/null
@@ -1,287 +0,0 @@
-USING: compiler definitions generic assocs inference math
-namespaces parser tools.test words kernel sequences arrays io
-effects tools.test compiler.units inference.state ;
-IN: temporary
-
-DEFER: x-1
-DEFER: x-2
-
-[ [ f ] { } map>assoc modify-code-heap ] recompile-hook [
- "IN: temporary USE: math GENERIC: x-1 ( x -- y ) M: integer x-1 ;" eval
- "IN: temporary : x-2 3 x-1 ;" eval
-
- [ t ] [
- { x-2 } compile
-
- \ x-2 word-xt
-
- { x-1 } compile
-
- \ x-2 word-xt =
- ] unit-test
-] with-variable
-
-DEFER: b
-DEFER: c
-
-[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test
-
-[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test
-
-{ 0 4 } [ b ] must-infer-as
-
-[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
-
-[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
-
-{ 0 6 } [ b ] must-infer-as
-
-\ b word-xt "b-xt" set
-
-[ ] [ "IN: temporary : c b ;" eval ] unit-test
-
-[ t ] [ "b-xt" get \ b word-xt = ] unit-test
-
-\ c word-xt "c-xt" set
-
-[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test
-
-[ t ] [ "c-xt" get \ c word-xt = ] unit-test
-
-[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test
-
-[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test
-
-{ 0 4 } [ c ] must-infer-as
-
-[ f ] [ "c-xt" get \ c word-xt = ] unit-test
-
-[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test
-
-[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : e d d ;" eval ] unit-test
-
-[ 3 3 ] [ "USE: temporary e" eval ] unit-test
-
-[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test
-
-[ 4 4 ] [ "USE: temporary e" eval ] unit-test
-
-DEFER: x-3
-
-[ ] [ "IN: temporary : x-3 3 ;" eval ] unit-test
-
-DEFER: x-4
-
-[ ] [ "IN: temporary : x-4 x-3 ;" eval ] unit-test
-
-[ t ] [ \ x-4 compiled? ] unit-test
-
-[ ] [ "IN: temporary USE: sequences : x-3 { } [ ] each ;" eval ] unit-test
-
-[ f ] [ \ x-3 compiled? ] unit-test
-
-[ f ] [ \ x-4 compiled? ] unit-test
-
-[ ] [ "IN: temporary USING: kernel sequences ; : x-3 { } [ drop ] each ;" eval ] unit-test
-
-[ t ] [ \ x-3 compiled? ] unit-test
-
-[ t ] [ \ x-4 compiled? ] unit-test
-
-[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
-
-DEFER: g-test-1
-
-DEFER: g-test-3
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-2 ( -- y ) 3 g-test-1 ;" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-3 ( -- y ) g-test-2 ;" eval ] unit-test
-
-[ 25 ] [ 5 g-test-1 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 ;" eval ] unit-test
-
-[ 5 ] [ 5 g-test-1 ] unit-test
-
-[ t ] [
- \ g-test-3 word-xt
-
- "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval
-
- \ g-test-3 word-xt =
-] unit-test
-
-DEFER: g-test-5
-
-[ ] [ "IN: temporary : g-test-4 ( -- y ) 3 g-test-1 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : g-test-5 ( -- y ) g-test-4 ;" eval ] unit-test
-
-[ 6 ] [ g-test-5 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 10 + ;" eval ] unit-test
-
-[ 13 ] [ g-test-5 ] unit-test
-
-DEFER: g-test-6
-
-[ ] [ "IN: temporary USING: arrays kernel ; GENERIC: g-test-6 ( x -- y ) M: array g-test-6 drop 123 g-test-1 ;" eval ] unit-test
-
-DEFER: g-test-7
-
-[ ] [ "IN: temporary : g-test-7 { } g-test-6 ;" eval ] unit-test
-
-[ 133 ] [ g-test-7 ] unit-test
-
-[ ] [ "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 15 + ;" eval ] unit-test
-
-[ 138 ] [ g-test-7 ] unit-test
-
-USE: macros
-
-DEFER: macro-test-3
-
-[ ] [ "IN: temporary USING: macros math ; : macro-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary USING: macros arrays quotations ; MACRO: macro-test-2 ( n word -- quot ) <array> >quotation ;" eval ] unit-test
-
-[ ] [ "IN: temporary : macro-test-3 2 \\ macro-test-1 macro-test-2 ;" eval ] unit-test
-
-[ 625 ] [ 5 macro-test-3 ] unit-test
-
-[ ] [ "IN: temporary USING: macros arrays quotations kernel math ; MACRO: macro-test-2 ( n word -- quot ) 2drop [ 3 + ] ;" eval ] unit-test
-
-[ 8 ] [ 5 macro-test-3 ] unit-test
-
-USE: hints
-
-DEFER: hints-test-2
-
-[ ] [ "IN: temporary USING: math hints ; : hints-test-1 3 + ; HINTS: hints-test-1 fixnum ;" eval ] unit-test
-
-[ ] [ "IN: temporary : hints-test-2 5 hints-test-1 ;" eval ] unit-test
-
-[ 8 ] [ hints-test-2 ] unit-test
-
-[ ] [ "IN: temporary USE: math : hints-test-1 5 + ;" eval ] unit-test
-
-[ 10 ] [ hints-test-2 ] unit-test
-
-DEFER: inline-then-not-inline-test-1
-DEFER: inline-then-not-inline-test-2
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-2 inline-then-not-inline-test-1 ;" eval ] unit-test
-
-[ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test
-
-\ inline-then-not-inline-test-2 word-xt "a" set
-
-[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 6 9 ;" eval ] unit-test
-
-[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test
-
-[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
-
-DEFER: generic-then-not-generic-test-1
-DEFER: generic-then-not-generic-test-2
-
-[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test
-
-[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test
-
-[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test
-
-[ 9 ] [ generic-then-not-generic-test-2 ] unit-test
-
-[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
-
-[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
-
-DEFER: foldable-test-1
-DEFER: foldable-test-2
-
-[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test
-
-[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test
-
-[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test
-
-[ 3 ] [ foldable-test-2 ] unit-test
-
-[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test
-
-[ 4 ] [ foldable-test-2 ] unit-test
-
-DEFER: flushable-test-2
-
-[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test
-
-[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test
-
-[ V{ } ] [ flushable-test-2 ] unit-test
-
-[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test
-
-[ V{ 3 } ] [ flushable-test-2 ] unit-test
-
-: ax ;
-: bx ax ;
-[ \ bx forget ] with-compilation-unit
-
-[ f ] [ \ bx \ ax compiled-usage key? ] unit-test
-
-DEFER: defer-redefine-test-2
-
-[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test
-
-[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
-
-[ defer-redefine-test-2 ] must-fail
-
-[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
-
-[ 2 1 ] [ defer-redefine-test-2 ] unit-test
-
-! Cross-referencing issue
-: compiled-xref-a ;
-
-: compiled-xref-c ; inline
-
-GENERIC: compiled-xref-b ( a -- b )
-
-TUPLE: c-1 ;
-
-M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ;
-
-TUPLE: c-2 ;
-
-M: c-2 compiled-xref-b drop 3 ;
-
-[ t ] [
- \ compiled-xref-a compiled-crossref get key?
-] unit-test
-
-[ ] [
- [
- \ compiled-xref-a forget
- ] with-compilation-unit
-] unit-test
-
-[ f ] [
- \ compiled-xref-a compiled-crossref get key?
-] unit-test
-
-[ ] [
- "IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval
-] unit-test
-
-[ f ] [
- \ compiled-xref-a compiled-crossref get key?
-] unit-test
diff --git a/core/compiler/test/redefine/redefine.factor b/core/compiler/test/redefine/redefine.factor
deleted file mode 100644
index e69de29bb2..0000000000
diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple.factor
similarity index 100%
rename from core/compiler/test/simple/simple-tests.factor
rename to core/compiler/test/simple.factor
diff --git a/core/compiler/test/simple/simple.factor b/core/compiler/test/simple/simple.factor
deleted file mode 100644
index e69de29bb2..0000000000
diff --git a/core/compiler/test/stack-trace/stack-trace-tests.factor b/core/compiler/test/stack-trace.factor
similarity index 100%
rename from core/compiler/test/stack-trace/stack-trace-tests.factor
rename to core/compiler/test/stack-trace.factor
diff --git a/core/compiler/test/stack-trace/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace.factor
deleted file mode 100644
index e69de29bb2..0000000000
diff --git a/core/compiler/test/templates-early/templates-early-tests.factor b/core/compiler/test/templates-early.factor
similarity index 100%
rename from core/compiler/test/templates-early/templates-early-tests.factor
rename to core/compiler/test/templates-early.factor
diff --git a/core/compiler/test/templates-early/templates-early.factor b/core/compiler/test/templates-early/templates-early.factor
deleted file mode 100644
index e69de29bb2..0000000000
diff --git a/core/compiler/test/templates/templates-tests.factor b/core/compiler/test/templates.factor
similarity index 100%
rename from core/compiler/test/templates/templates-tests.factor
rename to core/compiler/test/templates.factor
diff --git a/core/compiler/test/templates/templates.factor b/core/compiler/test/templates/templates.factor
deleted file mode 100644
index e69de29bb2..0000000000
diff --git a/core/compiler/test/tuples/tuples-tests.factor b/core/compiler/test/tuples.factor
similarity index 100%
rename from core/compiler/test/tuples/tuples-tests.factor
rename to core/compiler/test/tuples.factor
diff --git a/core/compiler/test/tuples/tuples.factor b/core/compiler/test/tuples/tuples.factor
deleted file mode 100644
index e69de29bb2..0000000000
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 79b59cc364..aa9f8686ce 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -96,6 +96,9 @@ TUPLE: no-parent-directory path ;
: ?resource-path ( path -- newpath )
"resource:" ?head [ resource-path ] when ;
+: resource-exists? ( path -- ? )
+ ?resource-path exists? ;
+
: make-directories ( path -- )
normalize-pathname right-trim-separators {
{ [ dup "." = ] [ ] }
diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor
index 1674ecd782..1debf6c8cc 100755
--- a/core/optimizer/optimizer.factor
+++ b/core/optimizer/optimizer.factor
@@ -4,11 +4,8 @@ USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math inference.class ;
IN: optimizer
-SYMBOL: optimize-count
-
: optimize-1 ( node -- newnode ? )
[
- global [ optimize-count inc ] bind
H{ } clone class-substitutions set
H{ } clone literal-substitutions set
H{ } clone value-substitutions set
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 486c589134..7dee5e2212 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -479,7 +479,7 @@ SYMBOL: interactive-vocabs
[ [ parse-file call ] keep ] assert-depth drop ;
: ?run-file ( path -- )
- dup ?resource-path exists? [ run-file ] [ drop ] if ;
+ dup resource-exists? [ run-file ] [ drop ] if ;
: bootstrap-file ( path -- )
[ parse-file % ] [ run-file ] if-bootstrapping ;
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 7ddf6f02c0..c7539ad3eb 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -26,7 +26,7 @@ uses definitions ;
rot source-file-checksum
(source-modified?)
] [
- ?resource-path exists?
+ resource-exists?
] ?if ;
: record-modified ( source-file -- )
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index a1276341b3..ea3023a4f8 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces splitting sequences io.files kernel assocs
words vocabs definitions parser continuations inspector debugger
@@ -15,45 +15,59 @@ V{
"resource:work"
} clone vocab-roots set-global
-! No such thing as current directory on Windows CE
-wince? [ "." vocab-roots get push ] unless
+: vocab-dir ( vocab -- dir )
+ vocab-name "." split "/" join ;
: vocab-dir+ ( vocab str/f -- path )
>r vocab-name "." split r>
[ >r dup peek r> append add ] when*
"/" join ;
-: vocab-dir ( vocab -- dir )
- f vocab-dir+ ;
+: vocab-path+ ( vocab path -- newpath )
+ swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
-: vocab-source ( vocab -- path )
- ".factor" vocab-dir+ ;
+: vocab-source-path ( vocab -- path/f )
+ dup ".factor" vocab-dir+ vocab-path+ ;
-: vocab-docs ( vocab -- path )
- "-docs.factor" vocab-dir+ ;
+: vocab-docs-path ( vocab -- path/f )
+ dup "-docs.factor" vocab-dir+ vocab-path+ ;
-: vocab-tests ( vocab -- path )
- "-tests.factor" vocab-dir+ ;
+: vocab-dir? ( root name -- ? )
+ over [
+ ".factor" vocab-dir+ path+ resource-exists?
+ ] [
+ 2drop f
+ ] if ;
: find-vocab-root ( vocab -- path/f )
- vocab-dir vocab-roots get
- swap [ path+ ?resource-path exists? ] curry find nip ;
+ vocab-roots get swap [ vocab-dir? ] curry find nip ;
M: string vocab-root
dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
M: vocab-link vocab-root
- dup vocab-link-root [ ] [ vocab-link-name vocab-root ] ?if ;
+ vocab-link-root ;
+
+: vocab-tests ( vocab -- tests )
+ dup vocab-root [
+ [
+ f >vocab-link dup
+
+ dup "-tests.factor" vocab-dir+ vocab-path+
+ dup resource-exists? [ , ] [ drop ] if
+
+ dup vocab-dir "test" path+ vocab-path+ dup
+ ?resource-path directory keys [ ".factor" tail? ] subset
+ [ path+ , ] with each
+ ] { } make
+ ] [ drop f ] if ;
: vocab-files ( vocab -- seq )
- [
- dup vocab-root dup [
- swap
- 2dup vocab-source path+ ,
- 2dup vocab-docs path+ ,
- 2dup vocab-tests path+ ,
- ] when 2drop
- ] { } make [ ?resource-path exists? ] subset ;
+ f >vocab-link [
+ dup vocab-source-path [ , ] when*
+ dup vocab-docs-path [ , ] when*
+ vocab-tests %
+ ] { } make ;
TUPLE: no-vocab name ;
@@ -67,42 +81,36 @@ SYMBOL: load-help?
: source-wasn't-loaded f swap set-vocab-source-loaded? ;
-: load-source ( root name -- )
+: load-source ( vocab-link -- )
[ source-wasn't-loaded ] keep
- [ vocab-source path+ bootstrap-file ] keep
+ [ vocab-source-path bootstrap-file ] keep
source-was-loaded ;
: docs-were-loaded t swap set-vocab-docs-loaded? ;
: docs-weren't-loaded f swap set-vocab-docs-loaded? ;
-: load-docs ( root name -- )
+: load-docs ( vocab-link -- )
load-help? get [
[ docs-weren't-loaded ] keep
- [ vocab-docs path+ ?run-file ] keep
+ [ vocab-docs-path ?run-file ] keep
docs-were-loaded
- ] [ 2drop ] if ;
+ ] [ drop ] if ;
-: amend-vocab-from-root ( root name -- vocab )
- dup vocab-source-loaded? [ 2dup load-source ] unless
- dup vocab-docs-loaded? [ 2dup load-docs ] unless
- nip vocab ;
-
-: load-vocab-from-root ( root name -- )
- 2dup vocab-source path+ ?resource-path exists? [
- 2dup create-vocab set-vocab-root
- 2dup load-source load-docs
- ] [
- nip no-vocab
- ] if ;
+: create-vocab-with-root ( vocab-link -- vocab )
+ dup vocab-name create-vocab
+ swap vocab-root over set-vocab-root ;
: reload ( name -- )
[
- dup find-vocab-root dup [
- swap load-vocab-from-root
- ] [
- drop no-vocab
- ] if
+ f >vocab-link
+ dup vocab-root [
+ dup vocab-source-path resource-exists? [
+ create-vocab-with-root
+ dup load-source
+ load-docs
+ ] [ no-vocab ] if
+ ] [ no-vocab ] if
] with-compiler-errors ;
: require ( vocab -- )
@@ -122,18 +130,6 @@ SYMBOL: load-help?
[ nip ] assoc-subset
[ nip source-modified? ] assoc-subset keys ; inline
-: vocab-path+ ( vocab path -- newpath )
- swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
-
-: vocab-source-path ( vocab -- path/f )
- dup vocab-source vocab-path+ ;
-
-: vocab-tests-path ( vocab -- path/f )
- dup vocab-tests vocab-path+ ;
-
-: vocab-docs-path ( vocab -- path/f )
- dup vocab-docs vocab-path+ ;
-
: modified-sources ( vocabs -- seq )
[ vocab-source-path ] modified ;
@@ -151,7 +147,7 @@ SYMBOL: load-help?
: vocab-heading. ( vocab -- )
nl
"==== " write
- dup vocab-name swap f >vocab-link write-object ":" print
+ dup vocab-name swap vocab write-object ":" print
nl ;
: load-error. ( triple -- )
@@ -187,8 +183,10 @@ SYMBOL: load-help?
GENERIC: (load-vocab) ( name -- vocab )
M: vocab (load-vocab)
- dup vocab-root
- [ swap vocab-name amend-vocab-from-root ] when* ;
+ dup vocab-root [
+ dup vocab-source-loaded? [ dup load-source ] unless
+ dup vocab-docs-loaded? [ dup load-docs ] unless
+ ] when ;
M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ;
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 8db65e2eac..0717a6729c 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -96,8 +96,16 @@ M: vocab-link hashcode*
M: vocab-link vocab-name vocab-link-name ;
-: >vocab-link ( name root -- vocab )
- over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
+GENERIC# >vocab-link 1 ( name root -- vocab )
+
+M: vocab >vocab-link drop ;
+
+M: vocab-link >vocab-link drop ;
+
+M: string >vocab-link
+ over vocab dup [ 2nip ] [
+ drop [ dup vocab-root ] unless* <vocab-link>
+ ] if ;
UNION: vocab-spec vocab vocab-link ;
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
old mode 100644
new mode 100755
index 80419e9c8d..9b7a8a8aa5
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -189,7 +189,7 @@ SYMBOL: model
swap [ render-template ] with-slots ;
: browse-webapp-source ( vocab -- )
- <a f >vocab-link browser-link-href =href a>
+ <a vocab browser-link-href =href a>
"Browse source" write
</a> ;
diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor
index ae1901ff66..b91a6177b8 100755
--- a/extra/tools/browser/browser.factor
+++ b/extra/tools/browser/browser.factor
@@ -72,13 +72,6 @@ M: vocab-link summary vocab-summary ;
: set-vocab-authors ( authors vocab -- )
dup vocab-authors-path set-vocab-file-contents ;
-: vocab-dir? ( root name -- ? )
- over [
- vocab-source path+ ?resource-path exists?
- ] [
- 2drop f
- ] if ;
-
: subdirs ( dir -- dirs )
directory [ second ] subset keys natural-sort ;
@@ -96,10 +89,8 @@ M: vocab-link summary vocab-summary ;
vocabs-in-dir
] with each ;
-: sane-vocab-roots "." vocab-roots get remove ;
-
: all-vocabs ( -- assoc )
- sane-vocab-roots [
+ vocab-roots get [
dup [ "" vocabs-in-dir ] { } make
] { } map>assoc ;
@@ -153,9 +144,9 @@ MEMO: all-vocabs-seq ( -- seq )
[ vocab ] map ;
: all-child-vocabs ( prefix -- assoc )
- sane-vocab-roots [
- dup pick dupd (all-child-vocabs)
- [ swap >vocab-link ] with map
+ vocab-roots get [
+ over dupd dupd (all-child-vocabs)
+ swap [ >vocab-link ] curry map
] { } map>assoc
f rot unrooted-child-vocabs 2array add ;
diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor
index b756f9279e..ac561100f8 100755
--- a/extra/tools/test/test-docs.factor
+++ b/extra/tools/test/test-docs.factor
@@ -36,7 +36,12 @@ ARTICLE: "tools.test" "Unit testing"
$nl
"For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know."
$nl
-"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
+"Unit tests for a vocabulary are placed in test files in the same directory as the vocabulary source file (see " { $link "vocabs.loader" } "). Two possibilities are supported:"
+{ $list
+ { "Tests can be placed in a file named " { $snippet { $emphasis "vocab" } "-tests.factor" } "." }
+ { "Tests can be placed in files in the " { $snippet "test" } " subdirectory." }
+}
+"The latter is used for vocabularies with more extensive test suites."
$nl
"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run."
{ $subsection "tools.test.write" }
diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor
index 5673e41c62..62a4dab1eb 100755
--- a/extra/tools/test/test.factor
+++ b/extra/tools/test/test.factor
@@ -53,18 +53,12 @@ SYMBOL: this-test
: (run-test) ( vocab -- )
dup vocab-source-loaded? [
- vocab-tests-path dup [
- dup ?resource-path exists? [
- [
- "temporary" forget-vocab
- ] with-compilation-unit
- dup run-file
- [
- dup forget-source
- "temporary" forget-vocab
- ] with-compilation-unit
- ] when
- ] when
+ [ "temporary" forget-vocab ] with-compilation-unit
+ vocab-tests dup [ run-file ] each
+ [
+ dup [ forget-source ] each
+ "temporary" forget-vocab
+ ] with-compilation-unit
] when drop ;
: run-test ( vocab -- failures )
From b6cc47d2b3a64c84dc7afd2e9918ecb1088812a3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 10 Feb 2008 23:07:40 -0600
Subject: [PATCH 34/46] slight speedup in base64
---
extra/base64/base64-tests.factor | 2 +-
extra/base64/base64.factor | 4 ++--
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/base64/base64-tests.factor b/extra/base64/base64-tests.factor
index 23ea6e99ab..d867351f8b 100644
--- a/extra/base64/base64-tests.factor
+++ b/extra/base64/base64-tests.factor
@@ -1,4 +1,4 @@
-USING: tools.test base64 ;
+USING: kernel tools.test base64 strings ;
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
] unit-test
diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor
index 2c393c61e2..074640c536 100644
--- a/extra/base64/base64.factor
+++ b/extra/base64/base64.factor
@@ -35,13 +35,13 @@ PRIVATE>
#! pad string with = when not enough bits
dup length dup 3 mod - cut swap
[
- 3 group [ encode3 % ] each
+ 3 <groups> [ encode3 % ] each
dup empty? [ drop ] [ >base64-rem % ] if
] "" make ;
: base64> ( base64 -- str )
#! input length must be a multiple of 4
[
- [ 4 group [ decode4 % ] each ] keep [ CHAR: = = not ] count-end
+ [ 4 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end
] SBUF" " make swap [ dup pop* ] times >string ;
From 577e18b854c88a9f542fe75132344338f0bcc22d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 10 Feb 2008 23:09:13 -0600
Subject: [PATCH 35/46] 30% speedup of md5 by moving group -> <groups>
---
extra/crypto/md5/md5.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor
index c95b3f4477..fe215e32db 100644
--- a/extra/crypto/md5/md5.factor
+++ b/extra/crypto/md5/md5.factor
@@ -153,7 +153,7 @@ SYMBOL: old-d
dup S44 64 9 [ I ] BCDA ;
: (process-md5-block) ( block -- )
- 4 group [ le> ] map
+ 4 <groups> [ le> ] map
(process-md5-block-F)
(process-md5-block-G)
From afa71627ee8d38f1c6bb8714e7df01b43109ce24 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 10 Feb 2008 23:11:16 -0600
Subject: [PATCH 36/46] add db.types, db.tuples and some code in progress
create-sql works for a limited test case in sqlite
---
extra/db/db.factor | 25 +++++-
extra/db/mysql/mysql.factor | 1 -
extra/db/sqlite/ffi/ffi.factor | 4 +
extra/db/sqlite/lib/lib.factor | 3 -
extra/db/sqlite/sqlite.factor | 113 +++++++++++++++++++++++++--
extra/db/tuples/tuples-tests.factor | 37 +++++++++
extra/db/tuples/tuples.factor | 116 ++++++++++++++++++++++++++++
extra/db/types/types.factor | 70 +++++++++++++++++
8 files changed, 356 insertions(+), 13 deletions(-)
create mode 100644 extra/db/tuples/tuples-tests.factor
create mode 100644 extra/db/tuples/tuples.factor
create mode 100644 extra/db/types/types.factor
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 1c287cd871..effb971e9f 100644
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -4,12 +4,27 @@ USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words ;
IN: db
-TUPLE: db handle ;
-C: <db> db ( handle -- obj )
+TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
+: <db> ( handle -- obj )
+ H{ } clone
+ H{ } clone
+ H{ } clone
+ H{ } clone
+ db construct-boa ;
-! HOOK: db-create db ( str -- )
-! HOOK: db-drop db ( str -- )
GENERIC: db-open ( db -- )
+HOOK: db-close db ( handle -- )
+
+: dispose-statements [ dispose drop ] assoc-each ;
+
+: dispose-db ( db -- )
+ dup db [
+ dup db-insert-statements dispose-statements
+ dup db-update-statements dispose-statements
+ dup db-delete-statements dispose-statements
+ dup db-select-statements dispose-statements
+ db-handle db-close
+ ] with-variable ;
TUPLE: statement sql params handle bound? ;
@@ -43,6 +58,8 @@ GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- ? )
+HOOK: last-id db ( -- id )
+
: init-result-set ( result-set -- )
dup #rows over set-result-set-max
-1 swap set-result-set-n ;
diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor
index 941c25e1fa..040b87c977 100644
--- a/extra/db/mysql/mysql.factor
+++ b/extra/db/mysql/mysql.factor
@@ -14,7 +14,6 @@ M: mysql-db db-open ( mysql-db -- )
M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ;
-
M: mysql-db <simple-statement> ( str -- statement )
;
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index 609c597b35..47f42b7e0d 100644
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -106,6 +106,8 @@ IN: db.sqlite.ffi
TYPEDEF: void sqlite3
TYPEDEF: void sqlite3_stmt
+TYPEDEF: longlong sqlite3_int64
+TYPEDEF: ulonglong sqlite3_uint64
LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
@@ -116,7 +118,9 @@ FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
+FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index e5f8425d92..944fc14eef 100644
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -21,9 +21,6 @@ TUPLE: sqlite-error n message ;
: sqlite-close ( db -- )
sqlite3_close sqlite-check-result ;
-: sqlite-last-insert-rowid ( db -- rowid )
- sqlite3_last_insert_rowid ;
-
: sqlite-prepare ( db sql -- statement )
#! TODO: Support multiple statements in the SQL string.
dup length "void*" <c-object> "void*" <c-object>
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 73b93d404b..0f4529763a 100644
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -3,7 +3,8 @@
USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
-continuations db.sqlite.lib db.sqlite.ffi ;
+continuations db.sqlite.lib db.sqlite.ffi db.tuples
+words combinators.lib db.types ;
IN: db.sqlite
TUPLE: sqlite-db path ;
@@ -13,10 +14,10 @@ M: sqlite-db db-open ( db -- )
dup sqlite-db-path sqlite-open <db>
swap set-delegate ;
-M: sqlite-db dispose ( obj -- )
- dup db-handle sqlite-close
- f over set-db-handle
- f swap set-delegate ;
+M: sqlite-db db-close ( handle -- )
+ sqlite-close ;
+
+M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- )
>r <sqlite-db> r> with-db ; inline
@@ -72,3 +73,105 @@ M: sqlite-db commit-transaction ( -- )
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
+
+M: sqlite-db create-sql ( columns table -- sql )
+ [
+ "create table " % %
+ " (" % [ ", " % ] [
+ dup second % " " %
+ dup third >sql-type % " " %
+ sql-modifiers " " join %
+ ] interleave ")" %
+ ] "" make ;
+
+M: sqlite-db insert-sql* ( columns table -- sql )
+ [
+ "insert into " %
+ %
+ "(" %
+ dup [ ", " % ] [ second % ] interleave
+ ") " %
+ " values (" %
+ [ ", " % ] [ ":" % second % ] interleave
+ ")" %
+ ] "" make ;
+
+M: sqlite-db update-sql* ( columns table -- sql )
+ [
+ "update " %
+ %
+ " set " %
+ dup remove-id
+ [ ", " % ] [ second dup % " = :" % % ] interleave
+ " where " %
+ [ primary-key? ] find nip second dup % " = :" % %
+ ] "" make ;
+
+M: sqlite-db delete-sql* ( columns table -- sql )
+ [
+ break
+ "delete from " %
+ %
+ " where " %
+ first second dup % " = :" % %
+ ] "" make dup . ;
+
+M: sqlite-db select-sql* ( columns table -- sql )
+ [
+ "select ROWID, " %
+ swap [ ", " % ] [ second % ] interleave
+ " from " %
+ %
+ " where ROWID = :ID" %
+ ] "" make ;
+
+M: sqlite-db tuple>params ( columns tuple -- obj )
+ [
+ >r [ second ":" swap append ] keep first r> get-slot-named
+ number>string*
+ ] curry { } map>assoc ;
+
+M: sqlite-db last-id ( -- id )
+ db get db-handle sqlite3_last_insert_rowid ;
+
+
+: sqlite-db-modifiers ( -- hashtable )
+ H{
+ { +native-id+ "primary key" }
+ { +assigned-id+ "primary key" }
+ { +autoincrement+ "autoincrement" }
+ { +unique+ "unique" }
+ { +default+ "default" }
+ { +null+ "null" }
+ { +not-null+ "not null" }
+ } ;
+
+M: sqlite-db sql-modifiers* ( modifiers -- str )
+ sqlite-db-modifiers swap [
+ dup array? [
+ first2
+ >r swap at r> number>string*
+ " " swap 3append
+ ] [
+ swap at
+ ] if
+ ] with map [ ] subset ;
+
+: sqlite-type-hash ( -- assoc )
+ H{
+ { INTEGER "integer" }
+ { TEXT "text" }
+ { VARCHAR "text" }
+ } ;
+
+M: sqlite-db >sql-type ( obj -- str )
+ dup pair? [
+ first >sql-type
+ ] [
+ sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
+ ] if ;
+
+! HOOK: get-column-value ( n result-set type -- )
+! M: sqlite get-column-value { { "TEXT" get-text-column } {
+! "INTEGER" get-integer-column } ... } case ;
+
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
new file mode 100644
index 0000000000..7fc6fd3b97
--- /dev/null
+++ b/extra/db/tuples/tuples-tests.factor
@@ -0,0 +1,37 @@
+USING: io.files kernel tools.test db db.sqlite db.tuples ;
+IN: temporary
+
+TUPLE: person the-id the-name the-number ;
+: <person> ( name age -- person )
+ { set-person-the-name set-person-the-number } person construct ;
+
+person "PERSON"
+{
+ { "the-id" "ROWID" INTEGER +native-id+ }
+ { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+ { "the-number" "AGE" INTEGER { +default+ 0 } }
+} define-persistent
+
+
+: test-tuples ( -- )
+ f "billy" 100 person construct-boa dup insert-tuple
+
+ [ 1 ] [ dup person-id ] unit-test
+
+ 200 over set-person-the-number
+
+ [ ] [ dup update-tuple ] unit-test
+
+ [ ] [ delete-tuple ] unit-test ;
+
+: test-sqlite ( -- )
+ "tuples-test.db" resource-path <sqlite-db> [
+ test-tuples
+ ] with-db ;
+
+test-sqlite
+
+! : test-postgres ( -- )
+ ! resource-path <postgresql-db> [
+ ! test-tuples
+ ! ] with-db ;
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
new file mode 100644
index 0000000000..c08f359d5e
--- /dev/null
+++ b/extra/db/tuples/tuples.factor
@@ -0,0 +1,116 @@
+USING: arrays assocs classes db kernel namespaces
+tuples words sequences slots slots.private math
+math.parser io prettyprint db.types ;
+USE: continuations
+IN: db.tuples
+
+! only take a tuple if you have to extract things from it
+! otherwise take a class
+! primary-key vs primary-key-spec
+! define-persistent should enforce a primary key
+! in sqlite, defining a new primary key makes it an alias for rowid, _rowid_, and oid
+! -sql outputs sql code
+! table - string
+! columns - seq of column specifiers
+
+: db-columns ( class -- obj )
+ "db-columns" word-prop ;
+
+: db-table ( class -- obj )
+ "db-table" word-prop ;
+
+
+: slot-spec-named ( str class -- slot-spec )
+ "slots" word-prop [ slot-spec-name = ] with find nip ;
+
+: offset-of-slot ( str obj -- n )
+ class slot-spec-named slot-spec-offset ;
+
+: get-slot-named ( str obj -- value )
+ tuck offset-of-slot slot ;
+
+: set-slot-named ( value str obj -- )
+ tuck offset-of-slot set-slot ;
+
+
+: primary-key-spec ( class -- spec )
+ db-columns [ primary-key? ] find nip ;
+
+: primary-key ( tuple -- obj )
+ dup class primary-key-spec get-slot-named ;
+
+: set-primary-key ( obj tuple -- )
+ [ class primary-key-spec first ] keep
+ set-slot-named ;
+
+
+: cache-statement ( columns class assoc quot -- statement )
+ [ db-table dupd ] swap
+ [ <prepared-statement> ] 3compose cache nip ; inline
+
+HOOK: create-sql db ( columns table -- sql )
+HOOK: drop-sql db ( columns table -- sql )
+HOOK: insert-sql* db ( columns table -- sql )
+HOOK: update-sql* db ( columns table -- sql )
+HOOK: delete-sql* db ( columns table -- sql )
+HOOK: select-sql* db ( columns table -- sql )
+
+: insert-sql ( columns class -- statement )
+ db get db-insert-statements [ insert-sql* ] cache-statement ;
+
+: update-sql ( columns class -- statement )
+ db get db-update-statements [ update-sql* ] cache-statement ;
+
+: delete-sql ( columns class -- statement )
+ db get db-delete-statements [ delete-sql* ] cache-statement ;
+
+: select-sql ( columns class -- statement )
+ db get db-select-statements [ select-sql* ] cache-statement ;
+
+HOOK: tuple>params db ( columns tuple -- obj )
+
+: tuple-statement ( columns tuple quot -- statement )
+ >r [ tuple>params ] 2keep class r> call
+ [ bind-statement ] keep ;
+
+: do-tuple-statement ( tuple columns-quot statement-quot -- )
+ >r [ class db-columns ] swap compose keep
+ r> tuple-statement dup . execute-statement ;
+
+: create-table ( class -- )
+ dup db-columns swap db-table create-sql sql-command ;
+
+: insert-tuple ( tuple -- )
+ [
+ [ maybe-remove-id ] [ insert-sql ] do-tuple-statement
+ last-id
+ ] keep set-primary-key ;
+
+: update-tuple ( tuple -- )
+ [ ] [ update-sql ] do-tuple-statement ;
+
+: delete-tuple ( tuple -- )
+ [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
+
+! : select-tuple ( tuple -- )
+ ! [ select-sql ] bind-tuple do-query ;
+
+: persist ( tuple -- )
+ dup primary-key [ update-tuple ] [ insert-tuple ] if ;
+
+! PERSISTENT:
+
+: define-persistent ( class table columns -- )
+ >r dupd "db-table" set-word-prop r>
+ "db-columns" set-word-prop ;
+
+: define-relation ( spec -- )
+ drop ;
+
+
+
+
+
+
+
+
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
new file mode 100644
index 0000000000..b4785b7aa1
--- /dev/null
+++ b/extra/db/types/types.factor
@@ -0,0 +1,70 @@
+USING: arrays assocs db kernel math math.parser
+sequences continuations ;
+IN: db.types
+
+
+! id serial not null primary key,
+! ID is the Primary key
+SYMBOL: +native-id+
+SYMBOL: +assigned-id+
+
+: primary-key? ( spec -- ? )
+ [ { +native-id+ +assigned-id+ } member? ] contains? ;
+
+! Same concept, SQLite has autoincrement, PostgreSQL has serial
+SYMBOL: +autoincrement+
+SYMBOL: +serial+
+SYMBOL: +unique+
+
+SYMBOL: +default+
+SYMBOL: +null+
+SYMBOL: +not-null+
+SYMBOL: +has-many+
+
+! SQLite Types
+! http://www.sqlite.org/datatype3.html
+! SYMBOL: NULL
+! SYMBOL: INTEGER
+! SYMBOL: REAL
+! SYMBOL: TEXT
+! SYMBOL: BLOB
+
+SYMBOL: INTEGER
+SYMBOL: DOUBLE
+SYMBOL: BOOLEAN
+
+SYMBOL: TEXT
+SYMBOL: VARCHAR
+
+SYMBOL: TIMESTAMP
+SYMBOL: DATE
+
+SYMBOL: BIG_INTEGER
+
+! SYMBOL: LOCALE
+! SYMBOL: TIMEZONE
+! SYMBOL: CURRENCY
+
+
+! PostgreSQL Types
+! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+
+: number>string* ( num/str -- str )
+ dup number? [ number>string ] when ;
+
+TUPLE: no-sql-type ;
+HOOK: sql-modifiers* db ( modifiers -- str )
+HOOK: >sql-type db ( obj -- str )
+
+
+
+
+: maybe-remove-id ( columns -- obj )
+ [ +native-id+ swap member? not ] subset ;
+
+: remove-id ( columns -- obj )
+ [ primary-key? not ] subset ;
+
+: sql-modifiers ( spec -- seq )
+ 3 tail sql-modifiers* ;
From a423ca63f44e9f8c17e08b6e1b9250fc343e55d3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 00:14:40 -0600
Subject: [PATCH 37/46] Tiny cleanup of combinators.lib and sequences.lib
---
extra/combinators/lib/lib.factor | 114 +++++++++----------------------
extra/sequences/lib/lib.factor | 47 +++++++++++--
2 files changed, 73 insertions(+), 88 deletions(-)
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 9f0f7df1ce..9ccada1ec1 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -1,11 +1,9 @@
! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
! Eduardo Cavazos, Daniel Ehrenberg.
-!
! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators namespaces quotations hashtables sequences assocs
- arrays inference effects math math.ranges arrays.lib shuffle macros
- bake combinators.cleave ;
+USING: kernel combinators namespaces quotations hashtables
+sequences assocs arrays inference effects math math.ranges
+arrays.lib shuffle macros bake combinators.cleave ;
IN: combinators.lib
@@ -51,22 +49,6 @@ MACRO: napply ( n -- )
: dipd ( x y quot -- y ) 2 ndip ; inline
-! each-with
-
-: each-withn ( seq quot n -- ) nwith each ; inline
-
-: each-with ( seq quot -- ) with each ; inline
-
-: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
-
-! map-with
-
-: map-withn ( seq quot n -- newseq ) nwith map ; inline
-
-: map-with ( seq quot -- ) with map ; inline
-
-: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
-
: 2with ( param1 param2 obj quot -- obj curry )
with with ; inline
@@ -88,39 +70,23 @@ MACRO: napply ( n -- )
: assoc-map-with ( obj assoc quot -- assoc )
with* assoc-map ; inline
-
-MACRO: nfirst ( n -- )
- [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; inline
-
-: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! short circuiting words
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : short-circuit ( quots quot default -- quot )
-! >r { } map>assoc <reversed> r>
-! 1quotation swap alist>quot ;
-
: short-circuit ( quots quot default -- quot )
1quotation -rot { } map>assoc <reversed> alist>quot ;
-! : short-circuit ( quots quot default -- quot )
-! 1quotation -rot map>alist <reversed> alist>quot ;
-
-MACRO: && ( quots -- ? ) [ [ not ] append [ f ] ] t short-circuit ;
+MACRO: && ( quots -- ? )
+ [ [ not ] append [ f ] ] t short-circuit ;
MACRO: <-&& ( quots -- )
- [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
- [ nip ] append ;
+ [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
+ [ nip ] append ;
MACRO: <--&& ( quots -- )
- [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
- [ 2nip ] append ;
+ [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
+ [ 2nip ] append ;
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
@@ -129,25 +95,25 @@ MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: ifte ( quot quot quot -- )
- pick infer effect-in
- dup 1+ swap
- [ >r >r , nkeep , nrot r> r> if ]
- bake ;
+ pick infer effect-in
+ dup 1+ swap
+ [ >r >r , nkeep , nrot r> r> if ]
+ bake ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! switch
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: preserving ( predicate -- quot )
- dup infer effect-in
- dup 1+ spin
- [ , , nkeep , nrot ]
- bake ;
+ dup infer effect-in
+ dup 1+ spin
+ [ , , nkeep , nrot ]
+ bake ;
MACRO: switch ( quot -- )
- [ [ preserving ] [ ] bi* ] assoc-map
- [ , cond ]
- bake ;
+ [ [ preserving ] [ ] bi* ] assoc-map
+ [ , cond ]
+ bake ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -156,41 +122,34 @@ MACRO: switch ( quot -- )
! : pcall ( seq quots -- seq ) [ call ] 2map ;
MACRO: parallel-call ( quots -- )
- [ [ unclip % r> dup >r push ] bake ] map concat
- [ V{ } clone >r % drop r> >array ] bake ;
-
-! MACRO: parallel-call ( quots -- )
-! [ [ unclip ] swap append ] map
-! [ [ r> swap add >r ] append ] map
-! concat
-! [ { } >r ] swap append ! pre
-! [ drop r> ] append ; ! post
-
+ [ [ unclip % r> dup >r push ] bake ] map concat
+ [ V{ } clone >r % drop r> >array ] bake ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! map-call and friends
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (make-call-with) ( quots -- quot )
- [ [ keep ] curry ] map concat [ drop ] append ;
+ [ [ keep ] curry ] map concat [ drop ] append ;
MACRO: call-with ( quots -- )
- (make-call-with) ;
+ (make-call-with) ;
MACRO: map-call-with ( quots -- )
- [ (make-call-with) ] keep length [ narray ] curry compose ;
+ [ (make-call-with) ] keep length [ narray ] curry compose ;
: (make-call-with2) ( quots -- quot )
- [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
- [ 2drop ] append ;
+ [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
+ [ 2drop ] append ;
MACRO: call-with2 ( quots -- )
- (make-call-with2) ;
+ (make-call-with2) ;
MACRO: map-call-with2 ( quots -- )
- dup >r (make-call-with2) r> length [ narray ] curry append ;
+ [ (make-call-with2) ] keep length [ narray ] curry append ;
-MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ;
+MACRO: map-exec-with ( words -- )
+ [ 1quotation ] map [ map-call-with ] curry ;
MACRO: construct-slots ( assoc tuple-class -- tuple )
[ construct-empty ] curry swap [
@@ -208,14 +167,3 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
: and? ( obj quot1 quot2 -- ? )
>r keep r> rot [ call ] [ 2drop f ] if ; inline
-
-: prepare-index ( seq quot -- seq n quot )
- >r dup length r> ; inline
-
-: each-index ( seq quot -- )
- #! quot: ( elt index -- )
- prepare-index 2each ; inline
-
-: map-index ( seq quot -- )
- #! quot: ( elt index -- obj )
- prepare-index 2map ; inline
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index d89c5eec89..f7ac9c340d 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -1,8 +1,45 @@
+! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
+! Eduardo Cavazos, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
arrays math.parser sorting strings ascii ;
IN: sequences.lib
+: each-withn ( seq quot n -- ) nwith each ; inline
+
+: each-with ( seq quot -- ) with each ; inline
+
+: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
+
+: map-withn ( seq quot n -- newseq ) nwith map ; inline
+
+: map-with ( seq quot -- ) with map ; inline
+
+: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
+
+MACRO: nfirst ( n -- )
+ [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
+
+: prepare-index ( seq quot -- seq n quot )
+ >r dup length r> ; inline
+
+: each-index ( seq quot -- )
+ #! quot: ( elt index -- )
+ prepare-index 2each ; inline
+
+: map-index ( seq quot -- )
+ #! quot: ( elt index -- obj )
+ prepare-index 2map ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: sigma ( seq quot -- n )
+ [ rot slip + ] curry 0 swap reduce ; inline
+
+: count ( seq quot -- n )
+ [ 1 0 ? ] compose sigma ; inline
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: map-reduce ( seq map-quot reduce-quot -- result )
@@ -66,7 +103,7 @@ IN: sequences.lib
: split-around ( seq quot -- before elem after )
dupd find over [ "Element not found" throw ] unless
- >r cut-slice 1 tail r> swap ; inline
+ >r cut 1 tail r> swap ; inline
: (map-until) ( quot pred -- quot )
[ dup ] swap 3compose
@@ -149,7 +186,7 @@ PRIVATE>
! List the positions of obj in seq
: indices ( seq obj -- seq )
- >r dup length swap r>
- [ = [ ] [ drop f ] if ] curry
- 2map
- [ ] subset ;
+ >r dup length swap r>
+ [ = [ ] [ drop f ] if ] curry
+ 2map
+ [ ] subset ;
From 19154ce6db0a84800d3ed0dd05f4e1da5080879d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 00:15:47 -0600
Subject: [PATCH 38/46] Don't need this file
---
extra/xml/xml-tests.factor | 13 -------------
1 file changed, 13 deletions(-)
delete mode 100644 extra/xml/xml-tests.factor
diff --git a/extra/xml/xml-tests.factor b/extra/xml/xml-tests.factor
deleted file mode 100644
index 12923839bd..0000000000
--- a/extra/xml/xml-tests.factor
+++ /dev/null
@@ -1,13 +0,0 @@
-USING: io.files tools.test sequences namespaces kernel ;
-
-{
- "arithmetic"
- "errors"
- "soap"
- "templating"
- "test"
-}
-[
- "resource:extra/xml/test/" swap ".factor" 3append run-test
- failures get push-all
-] each
From bb429425e9edef2cb8fab98299681e4748696669 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 00:16:30 -0600
Subject: [PATCH 39/46] New split-reduce combinator
---
core/sequences/sequences.factor | 20 +++++++++++++++++---
core/sorting/sorting.factor | 10 ++--------
2 files changed, 19 insertions(+), 11 deletions(-)
mode change 100644 => 100755 core/sorting/sorting.factor
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 151777b0c7..5bb09d68dc 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -606,7 +606,21 @@ M: sequence <=>
] if ;
: cut-slice ( seq n -- before after )
- [ head ] 2keep tail-slice ;
+ [ head-slice ] 2keep tail-slice ;
+
+: midpoint@ ( seq -- n ) length 2/ ; inline
+
+: halves ( seq -- first second )
+ dup midpoint@ cut-slice ;
+
+: binary-reduce ( seq start quot -- value )
+ pick length {
+ { 0 [ drop nip ] }
+ { 1 [ 2drop first ] }
+ { 2 [ >r drop first2 r> call ] }
+ { 3 [ >r drop first3 r> 2apply ] }
+ [ drop >r >r halves r> r> [ [ split-reduce ] 2curry 2apply ] keep call ]
+ } case ; inline
: cut ( seq n -- before after )
[ head ] 2keep tail ;
@@ -657,8 +671,8 @@ PRIVATE>
: trim ( seq quot -- newseq )
[ left-trim ] keep right-trim ; inline
-: sum ( seq -- n ) 0 [ + ] reduce ;
-: product ( seq -- n ) 1 [ * ] reduce ;
+: sum ( seq -- n ) 0 [ + ] binary-reduce ;
+: product ( seq -- n ) 1 [ * ] binary-reduce ;
: infimum ( seq -- n ) dup first [ min ] reduce ;
: supremum ( seq -- n ) dup first [ max ] reduce ;
diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor
old mode 100644
new mode 100755
index 0269295433..25b8252ea1
--- a/core/sorting/sorting.factor
+++ b/core/sorting/sorting.factor
@@ -4,8 +4,6 @@ USING: arrays kernel math sequences vectors
sequences sequences.private growable ;
IN: sorting
-: midpoint@ ( seq -- n ) length 2/ ; inline
-
DEFER: sort
<PRIVATE
@@ -38,9 +36,6 @@ DEFER: sort
rot length rot length + <vector>
[ (merge) ] keep underlying ; inline
-: divide ( seq -- first second )
- dup midpoint@ [ head-slice ] 2keep tail-slice ;
-
: conquer ( first second quot -- result )
[ tuck >r >r sort r> r> sort ] keep merge ; inline
@@ -48,7 +43,7 @@ PRIVATE>
: sort ( seq quot -- sortedseq )
over length 1 <=
- [ drop ] [ over >r >r divide r> conquer r> like ] if ;
+ [ drop ] [ over >r >r halves r> conquer r> like ] if ;
inline
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
@@ -63,8 +58,7 @@ PRIVATE>
[ midpoint@ ] keep nth-unsafe ; inline
: partition ( seq n -- slice )
- >r dup midpoint@ r> 1 < [ head-slice ] [ tail-slice ] if ;
- inline
+ 1 < swap halves ? ; inline
: (binsearch) ( elt quot seq -- i )
dup length 1 <= [
From 81ac2f77f7f88419efdf3c3afa80fd13015369c4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 00:17:51 -0600
Subject: [PATCH 40/46] Fix name clash
---
core/compiler/{test => tests}/curry.factor | 0
core/compiler/{test => tests}/float.factor | 0
core/compiler/{test => tests}/intrinsics.factor | 0
core/compiler/{test => tests}/simple.factor | 0
core/compiler/{test => tests}/stack-trace.factor | 0
core/compiler/{test => tests}/templates-early.factor | 0
core/compiler/{test => tests}/templates.factor | 0
core/compiler/{test => tests}/tuples.factor | 0
core/vocabs/loader/loader.factor | 2 +-
extra/tools/test/test-docs.factor | 2 +-
extra/xml/{test => tests}/arithmetic.factor | 0
extra/xml/{test => tests}/authors.txt | 0
extra/xml/{test => tests}/errors.factor | 0
extra/xml/{test => tests}/soap.factor | 0
extra/xml/{test => tests}/soap.xml | 0
extra/xml/{test => tests}/templating.factor | 0
extra/xml/{test => tests}/test.factor | 0
extra/xml/{test => tests}/test.xml | 0
18 files changed, 2 insertions(+), 2 deletions(-)
rename core/compiler/{test => tests}/curry.factor (100%)
rename core/compiler/{test => tests}/float.factor (100%)
rename core/compiler/{test => tests}/intrinsics.factor (100%)
rename core/compiler/{test => tests}/simple.factor (100%)
rename core/compiler/{test => tests}/stack-trace.factor (100%)
rename core/compiler/{test => tests}/templates-early.factor (100%)
rename core/compiler/{test => tests}/templates.factor (100%)
rename core/compiler/{test => tests}/tuples.factor (100%)
rename extra/xml/{test => tests}/arithmetic.factor (100%)
rename extra/xml/{test => tests}/authors.txt (100%)
rename extra/xml/{test => tests}/errors.factor (100%)
rename extra/xml/{test => tests}/soap.factor (100%)
rename extra/xml/{test => tests}/soap.xml (100%)
rename extra/xml/{test => tests}/templating.factor (100%)
rename extra/xml/{test => tests}/test.factor (100%)
rename extra/xml/{test => tests}/test.xml (100%)
diff --git a/core/compiler/test/curry.factor b/core/compiler/tests/curry.factor
similarity index 100%
rename from core/compiler/test/curry.factor
rename to core/compiler/tests/curry.factor
diff --git a/core/compiler/test/float.factor b/core/compiler/tests/float.factor
similarity index 100%
rename from core/compiler/test/float.factor
rename to core/compiler/tests/float.factor
diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/tests/intrinsics.factor
similarity index 100%
rename from core/compiler/test/intrinsics.factor
rename to core/compiler/tests/intrinsics.factor
diff --git a/core/compiler/test/simple.factor b/core/compiler/tests/simple.factor
similarity index 100%
rename from core/compiler/test/simple.factor
rename to core/compiler/tests/simple.factor
diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/tests/stack-trace.factor
similarity index 100%
rename from core/compiler/test/stack-trace.factor
rename to core/compiler/tests/stack-trace.factor
diff --git a/core/compiler/test/templates-early.factor b/core/compiler/tests/templates-early.factor
similarity index 100%
rename from core/compiler/test/templates-early.factor
rename to core/compiler/tests/templates-early.factor
diff --git a/core/compiler/test/templates.factor b/core/compiler/tests/templates.factor
similarity index 100%
rename from core/compiler/test/templates.factor
rename to core/compiler/tests/templates.factor
diff --git a/core/compiler/test/tuples.factor b/core/compiler/tests/tuples.factor
similarity index 100%
rename from core/compiler/test/tuples.factor
rename to core/compiler/tests/tuples.factor
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index ea3023a4f8..30d7361898 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -56,7 +56,7 @@ M: vocab-link vocab-root
dup "-tests.factor" vocab-dir+ vocab-path+
dup resource-exists? [ , ] [ drop ] if
- dup vocab-dir "test" path+ vocab-path+ dup
+ dup vocab-dir "tests" path+ vocab-path+ dup
?resource-path directory keys [ ".factor" tail? ] subset
[ path+ , ] with each
] { } make
diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor
index ac561100f8..a8c7239922 100755
--- a/extra/tools/test/test-docs.factor
+++ b/extra/tools/test/test-docs.factor
@@ -39,7 +39,7 @@ $nl
"Unit tests for a vocabulary are placed in test files in the same directory as the vocabulary source file (see " { $link "vocabs.loader" } "). Two possibilities are supported:"
{ $list
{ "Tests can be placed in a file named " { $snippet { $emphasis "vocab" } "-tests.factor" } "." }
- { "Tests can be placed in files in the " { $snippet "test" } " subdirectory." }
+ { "Tests can be placed in files in the " { $snippet "tests" } " subdirectory." }
}
"The latter is used for vocabularies with more extensive test suites."
$nl
diff --git a/extra/xml/test/arithmetic.factor b/extra/xml/tests/arithmetic.factor
similarity index 100%
rename from extra/xml/test/arithmetic.factor
rename to extra/xml/tests/arithmetic.factor
diff --git a/extra/xml/test/authors.txt b/extra/xml/tests/authors.txt
similarity index 100%
rename from extra/xml/test/authors.txt
rename to extra/xml/tests/authors.txt
diff --git a/extra/xml/test/errors.factor b/extra/xml/tests/errors.factor
similarity index 100%
rename from extra/xml/test/errors.factor
rename to extra/xml/tests/errors.factor
diff --git a/extra/xml/test/soap.factor b/extra/xml/tests/soap.factor
similarity index 100%
rename from extra/xml/test/soap.factor
rename to extra/xml/tests/soap.factor
diff --git a/extra/xml/test/soap.xml b/extra/xml/tests/soap.xml
similarity index 100%
rename from extra/xml/test/soap.xml
rename to extra/xml/tests/soap.xml
diff --git a/extra/xml/test/templating.factor b/extra/xml/tests/templating.factor
similarity index 100%
rename from extra/xml/test/templating.factor
rename to extra/xml/tests/templating.factor
diff --git a/extra/xml/test/test.factor b/extra/xml/tests/test.factor
similarity index 100%
rename from extra/xml/test/test.factor
rename to extra/xml/tests/test.factor
diff --git a/extra/xml/test/test.xml b/extra/xml/tests/test.xml
similarity index 100%
rename from extra/xml/test/test.xml
rename to extra/xml/tests/test.xml
From f7b22faf0e3920bd9551255419830e526c83081d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 00:41:41 -0600
Subject: [PATCH 41/46] Patch from Yoshinori Tahara
---
extra/x11/xim/xim.factor | 14 ++++++++++----
extra/x11/xlib/xlib.factor | 19 +++++++++++++++++++
2 files changed, 29 insertions(+), 4 deletions(-)
diff --git a/extra/x11/xim/xim.factor b/extra/x11/xim/xim.factor
index 6fb6ada3ae..35e1906b2b 100755
--- a/extra/x11/xim/xim.factor
+++ b/extra/x11/xim/xim.factor
@@ -7,9 +7,15 @@ IN: x11.xim
SYMBOL: xim
+: (init-xim) ( classname medifier -- im )
+ XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
+ dpy get f rot dup XOpenIM ;
+
: init-xim ( classname -- )
- dpy get f rot dup XOpenIM
- [ "XOpenIM() failed" throw ] unless* xim set-global ;
+ dup "" (init-xim)
+ [ nip ]
+ [ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
+ xim set-global ;
: close-xim ( -- )
xim get-global XCloseIM drop f xim set-global ;
@@ -32,11 +38,11 @@ SYMBOL: keybuf
SYMBOL: keysym
: prepare-lookup ( -- )
- buf-size "ulong" <c-array> keybuf set
+ buf-size "uint" <c-array> keybuf set
0 <KeySym> keysym set ;
: finish-lookup ( len -- string keysym )
- keybuf get swap c-ulong-array> >string
+ keybuf get swap c-uint-array> >string
keysym get *KeySym ;
: lookup-string ( event xic -- string keysym )
diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor
index 70006c9f64..752c6c442e 100755
--- a/extra/x11/xlib/xlib.factor
+++ b/extra/x11/xlib/xlib.factor
@@ -1339,10 +1339,28 @@ FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_r
FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
+! !!! category of setlocale
+: LC_ALL 0 ; inline
+: LC_COLLATE 1 ; inline
+: LC_CTYPE 2 ; inline
+: LC_MONETARY 3 ; inline
+: LC_NUMERIC 4 ; inline
+: LC_TIME 5 ; inline
+
+FUNCTION: char* setlocale ( int category, char* name ) ;
+
+FUNCTION: Bool XSupportsLocale ( ) ;
+
+FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ;
+
SYMBOL: dpy
SYMBOL: scr
SYMBOL: root
+: init-locale ( -- )
+ LC_ALL "" setlocale [ "setlocale() failed" throw ] unless
+ XSupportsLocale [ "XSupportsLocale() failed" throw ] unless ;
+
: flush-dpy ( -- ) dpy get XFlush drop ;
: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ;
@@ -1353,6 +1371,7 @@ SYMBOL: root
] unless* ;
: initialize-x ( display-string -- )
+ init-locale
dup [ string>char-alien ] when
XOpenDisplay check-display dpy set-global
dpy get XDefaultScreen scr set-global
From 8672ede540c60243361b6ebeeeeea653e3f1b261 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 00:41:58 -0600
Subject: [PATCH 42/46] Fix compilation of VM on Mac OS X
---
vm/debug.c | 84 +++++++++++++++++++++++++++++-------------------------
1 file changed, 45 insertions(+), 39 deletions(-)
diff --git a/vm/debug.c b/vm/debug.c
index a080a6cab2..f15b387377 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -213,56 +213,62 @@ void dump_objects(F_FIXNUM type)
gc_off = false;
}
-void find_data_references(CELL look_for)
-{
- CELL obj;
+CELL look_for;
+CELL obj;
- void find_references_step(CELL *scan)
+void find_data_references_step(CELL *scan)
+{
+ if(look_for == *scan)
{
- if(look_for == *scan)
+ printf("%lx ",obj);
+ print_nested_obj(obj,2);
+ printf("\n");
+ }
+}
+
+void find_data_references(CELL look_for_)
+{
+ look_for = look_for_;
+
+ begin_scan();
+
+ while((obj = next_object()) != F)
+ do_slots(UNTAG(obj),find_data_references_step);
+
+ /* end scan */
+ gc_off = false;
+}
+
+CELL look_for;
+
+void find_code_references_step(F_COMPILED *compiled, CELL code_start,
+ CELL reloc_start, CELL literals_start)
+{
+ CELL scan;
+ CELL literal_end = literals_start + compiled->literals_length;
+
+ for(scan = literals_start; scan < literal_end; scan += CELLS)
+ {
+ CELL code_start = (CELL)(compiled + 1);
+ CELL literal_start = code_start
+ + compiled->code_length
+ + compiled->reloc_length;
+
+ CELL obj = get(literal_start);
+
+ if(look_for == get(scan))
{
printf("%lx ",obj);
print_nested_obj(obj,2);
printf("\n");
}
}
-
- begin_scan();
-
- while((obj = next_object()) != F)
- do_slots(UNTAG(obj),find_references_step);
-
- /* end scan */
- gc_off = false;
}
-void find_code_references(CELL look_for)
+void find_code_references(CELL look_for_)
{
- void find_references_step(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literals_start)
- {
- CELL scan;
- CELL literal_end = literals_start + compiled->literals_length;
-
- for(scan = literals_start; scan < literal_end; scan += CELLS)
- {
- CELL code_start = (CELL)(compiled + 1);
- CELL literal_start = code_start
- + compiled->code_length
- + compiled->reloc_length;
-
- CELL obj = get(literal_start);
-
- if(look_for == get(scan))
- {
- printf("%lx ",obj);
- print_nested_obj(obj,2);
- printf("\n");
- }
- }
- }
-
- iterate_code_heap(find_references_step);
+ look_for = look_for_;
+ iterate_code_heap(find_code_references_step);
}
void factorbug(void)
From 6c75da20f1f92713baaf3e02aec0f382331fd318 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 01:18:24 -0600
Subject: [PATCH 43/46] Fix bootstrap.help
---
extra/bootstrap/help/help.factor | 8 +-------
1 file changed, 1 insertion(+), 7 deletions(-)
diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor
index e88091105b..ade60d4457 100755
--- a/extra/bootstrap/help/help.factor
+++ b/extra/bootstrap/help/help.factor
@@ -13,13 +13,7 @@ IN: bootstrap.help
vocabs
[ vocab-root ] subset
[ vocab-source-loaded? ] subset
- [
- dup vocab-docs-loaded? [
- drop
- ] [
- dup vocab-root swap load-docs
- ] if
- ] each
+ [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
] with-variable
"help.handbook" require ;
From e66e6d70e40273bea4a2cda492f035d2bdf9ac3c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 01:19:53 -0600
Subject: [PATCH 44/46] Moved dispatch to sequences.private
---
core/bootstrap/image/image.factor | 2 +-
core/combinators/combinators-docs.factor | 2 +-
core/combinators/combinators.factor | 6 ---
core/compiler/tests/intrinsics.factor | 2 +-
core/compiler/tests/simple.factor | 2 +-
core/compiler/tests/templates.factor | 2 +-
core/generic/math/math.factor | 2 +-
core/generic/standard/standard.factor | 2 +-
core/inference/backend/backend-docs.factor | 2 +-
core/inference/inference-tests.factor | 2 +-
core/inference/known-words/known-words.factor | 2 +-
core/kernel/kernel.factor | 1 +
core/optimizer/known-words/known-words.factor | 2 +-
.../specializers/specializers.factor | 2 +-
core/sequences/sequences.factor | 26 +++++++++----
core/vocabs/loader/loader-docs.factor | 30 +-------------
extra/benchmark/dispatch4/dispatch4.factor | 2 +-
extra/combinators/lib/lib-docs.factor | 36 -----------------
extra/cpu/8080/emulator/emulator.factor | 2 +-
extra/icfp/2006/2006.factor | 2 +-
extra/inverse/inverse.factor | 2 +-
extra/optimizer/debugger/debugger.factor | 2 +-
extra/sequences/lib/lib-docs.factor | 39 +++++++++++++++++++
extra/sequences/lib/lib.factor | 2 +-
extra/space-invaders/space-invaders.factor | 2 +-
extra/state-machine/state-machine.factor | 2 +-
extra/tools/interpreter/interpreter.factor | 2 +-
27 files changed, 81 insertions(+), 99 deletions(-)
mode change 100644 => 100755 core/combinators/combinators-docs.factor
mode change 100644 => 100755 extra/benchmark/dispatch4/dispatch4.factor
mode change 100644 => 100755 extra/cpu/8080/emulator/emulator.factor
mode change 100644 => 100755 extra/icfp/2006/2006.factor
mode change 100644 => 100755 extra/inverse/inverse.factor
create mode 100755 extra/sequences/lib/lib-docs.factor
mode change 100644 => 100755 extra/state-machine/state-machine.factor
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 4468ecf7d1..7c12b3ea60 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts
splitting growable classes tuples words.private
io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private
-combinators.private combinators ;
+sequences.private combinators ;
IN: bootstrap.image
: my-arch ( -- arch )
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
old mode 100644
new mode 100755
index 4cea78bc97..d91c920def
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@@ -1,6 +1,6 @@
USING: arrays help.markup help.syntax strings sbufs vectors
kernel quotations generic generic.standard classes
-math assocs sequences combinators.private ;
+math assocs sequences sequences.private ;
IN: combinators
ARTICLE: "combinators-quot" "Quotation construction utilities"
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index f532f06293..0ba8b583be 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -4,12 +4,6 @@ IN: combinators
USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors ;
-<PRIVATE
-
-: dispatch ( n array -- ) array-nth (call) ;
-
-PRIVATE>
-
TUPLE: no-cond ;
: no-cond ( -- * ) \ no-cond construct-empty throw ;
diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor
index 679938b7f3..5dfe447443 100755
--- a/core/compiler/tests/intrinsics.factor
+++ b/core/compiler/tests/intrinsics.factor
@@ -4,7 +4,7 @@ math.private sequences strings tools.test words continuations
sequences.private hashtables.private byte-arrays strings.private
system random layouts vectors.private sbufs.private
strings.private slots.private alien alien.accessors
-alien.c-types alien.syntax namespaces libc combinators.private ;
+alien.c-types alien.syntax namespaces libc sequences.private ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor
index 743fb713d9..1ed43120d3 100755
--- a/core/compiler/tests/simple.factor
+++ b/core/compiler/tests/simple.factor
@@ -1,5 +1,5 @@
USING: compiler tools.test kernel kernel.private
-combinators.private math.private math combinators strings
+sequences.private math.private math combinators strings
alien arrays memory ;
IN: temporary
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index 08e1c98729..74e5ab80a4 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -2,7 +2,7 @@
USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
-combinators.private byte-arrays alien alien.accessors layouts
+sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units ;
IN: temporary
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 21a7857646..2cc28ac0d1 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
-combinators.private classes definitions ;
+sequences.private classes definitions ;
IN: generic.math
PREDICATE: class math-class ( object -- ? )
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 7f4f423d8b..49b003bd62 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
-hashtables layouts combinators combinators.private generic
+hashtables layouts combinators sequences.private generic
classes classes.private ;
IN: generic.standard
diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor
index 98e2e6bbcd..1d742e144a 100755
--- a/core/inference/backend/backend-docs.factor
+++ b/core/inference/backend/backend-docs.factor
@@ -1,6 +1,6 @@
USING: help.syntax help.markup words effects inference.dataflow
inference.state inference.backend kernel sequences
-kernel.private combinators combinators.private ;
+kernel.private combinators sequences.private ;
HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index 7a4176abfb..b841080c94 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -5,7 +5,7 @@ sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
prettyprint io inspector tuples classes.union classes.predicate
debugger threads.private io.streams.string io.timeouts
-combinators.private ;
+sequences.private ;
IN: temporary
{ 0 2 } [ 2 "Hello" ] must-infer-as
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 69e331a9bf..a1887e206b 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors arrays bit-arrays byte-arrays
-classes combinators.private continuations.private effects
+classes sequences.private continuations.private effects
float-arrays generic hashtables hashtables.private
inference.state inference.backend inference.dataflow io
io.backend io.files io.files.private io.streams.c kernel
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 7c4930f5a8..8d639aff78 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -17,6 +17,7 @@ IN: kernel
: clear ( -- ) { } set-datastack ;
! Combinators
+
: call ( callable -- ) uncurry (call) ;
DEFER: if
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 43c0324611..3dce9d8f82 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match
-float-arrays combinators.private combinators ;
+float-arrays sequences.private combinators ;
! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index 223ce18117..af8cd5b82e 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces sequences vectors words strings layouts combinators
-combinators.private classes generic.standard assocs ;
+sequences.private classes generic.standard assocs ;
IN: optimizer.specializers
: (make-specializer) ( class picker -- quot )
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 5bb09d68dc..967fcbbdc8 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
IN: sequences
USING: kernel kernel.private slots.private math math.private ;
@@ -77,6 +77,8 @@ PREDICATE: fixnum array-capacity
: set-array-nth ( elt n array -- )
swap 2 fixnum+fast set-slot ; inline
+: dispatch ( n array -- ) array-nth (call) ;
+
GENERIC: resize ( n seq -- newseq ) flushable
! Unsafe sequence protocol for inner loops
@@ -614,13 +616,21 @@ M: sequence <=>
dup midpoint@ cut-slice ;
: binary-reduce ( seq start quot -- value )
- pick length {
- { 0 [ drop nip ] }
- { 1 [ 2drop first ] }
- { 2 [ >r drop first2 r> call ] }
- { 3 [ >r drop first3 r> 2apply ] }
- [ drop >r >r halves r> r> [ [ split-reduce ] 2curry 2apply ] keep call ]
- } case ; inline
+ #! We can't use case here since combinators depends on
+ #! sequences
+ pick length dup 0 3 between? [
+ >fixnum {
+ [ drop nip ]
+ [ 2drop first ]
+ [ >r drop first2 r> call ]
+ [ >r drop first3 r> 2apply ]
+ } dispatch
+ ] [
+ drop
+ >r >r halves r> r>
+ [ [ binary-reduce ] 2curry 2apply ] keep
+ call
+ ] if ; inline
: cut ( seq n -- before after )
[ head ] 2keep tail ;
diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor
index 379b300eaa..a306efbd68 100755
--- a/core/vocabs/loader/loader-docs.factor
+++ b/core/vocabs/loader/loader-docs.factor
@@ -42,23 +42,9 @@ HELP: vocab-main
HELP: vocab-roots
{ $var-description "A sequence of pathname strings to search for vocabularies." } ;
-HELP: vocab-source
-{ $values { "vocab" "a vocabulary specifier" } { "path" string } }
-{ $description "Outputs a pathname relative to a vocabulary root where the source code for " { $snippet "vocab" } " might be found." } ;
-
-{ vocab-source vocab-source-path } related-words
-
-HELP: vocab-docs
-{ $values { "vocab" "a vocabulary specifier" } { "path" string } }
-{ $description "Outputs a pathname relative to a vocabulary root where the documentation for " { $snippet "vocab" } " might be found." } ;
-
-{ vocab-docs vocab-docs-path } related-words
-
HELP: vocab-tests
-{ $values { "vocab" "a vocabulary specifier" } { "path" string } }
-{ $description "Outputs a pathname relative to a vocabulary root where the unit tests for " { $snippet "vocab" } " might be found." } ;
-
-{ vocab-tests vocab-tests-path } related-words
+{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
+{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
HELP: find-vocab-root
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
@@ -86,14 +72,6 @@ HELP: load-docs
{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } }
{ $description "If " { $link load-help? } " is on, loads a vocabulary's documentation from the specified vocabulary root." } ;
-HELP: amend-vocab-from-root
-{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } { "vocab" vocab } }
-{ $description "Loads a vocabulary's source code and documentation if they have not already been loaded, and outputs the vocabulary." } ;
-
-HELP: load-vocab-from-root
-{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } }
-{ $description "Loads a vocabulary's source code and documentation." } ;
-
HELP: reload
{ $values { "name" "a vocabulary name" } }
{ $description "Loads it's source code and documentation." }
@@ -116,10 +94,6 @@ HELP: vocab-docs-path
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
{ $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
-HELP: vocab-tests-path
-{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
-{ $description "Outputs a pathname where the unit tests for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
-
HELP: refresh
{ $values { "prefix" string } }
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
diff --git a/extra/benchmark/dispatch4/dispatch4.factor b/extra/benchmark/dispatch4/dispatch4.factor
old mode 100644
new mode 100755
index a5bb983151..a92772a923
--- a/extra/benchmark/dispatch4/dispatch4.factor
+++ b/extra/benchmark/dispatch4/dispatch4.factor
@@ -1,5 +1,5 @@
USING: kernel.private kernel sequences math combinators
-combinators.private ;
+sequences.private ;
IN: benchmark.dispatch4
: foobar-1
diff --git a/extra/combinators/lib/lib-docs.factor b/extra/combinators/lib/lib-docs.factor
index 02c3556742..d850243bd0 100755
--- a/extra/combinators/lib/lib-docs.factor
+++ b/extra/combinators/lib/lib-docs.factor
@@ -47,42 +47,6 @@ HELP: nkeep
}
{ $see-also keep nslip } ;
-HELP: map-withn
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }
-{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "
-"passed to the quotation given to map-withn for each element in the sequence."
-}
-{ $examples
- { $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }
-}
-{ $see-also each-withn } ;
-
-HELP: each-withn
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
-{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "
-"passed to the quotation given to each-withn for each element in the sequence."
-}
-{ $see-also map-withn } ;
-
-HELP: sigma
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
-{ $description "Like map sum, but without creating an intermediate sequence." }
-{ $example
- "! Find the sum of the squares [0,99]"
- "USING: math.ranges combinators.lib ;"
- "100 [1,b] [ sq ] sigma ."
- "338350"
-} ;
-
-HELP: count
-{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }
-{ $description "Efficiently returns the number of elements that the predicate quotation matches." }
-{ $example
- "USING: math.ranges combinators.lib ;"
- "100 [1,b] [ even? ] count ."
- "50"
-} ;
-
HELP: &&
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
{ $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ;
diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor
old mode 100644
new mode 100755
index 0eca7bdc47..310e387bd5
--- a/extra/cpu/8080/emulator/emulator.factor
+++ b/extra/cpu/8080/emulator/emulator.factor
@@ -4,7 +4,7 @@
USING: kernel math sequences words arrays io
io.files namespaces math.parser kernel.private
assocs quotations parser parser-combinators tools.time
- combinators.private compiler.units ;
+ sequences.private compiler.units ;
IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor
old mode 100644
new mode 100755
index 53c7fd5a9b..2a35ed08f8
--- a/extra/icfp/2006/2006.factor
+++ b/extra/icfp/2006/2006.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Gavin Harrison
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences kernel.private namespaces arrays io io.files
- splitting io.binary math.functions vectors quotations combinators.private ;
+ splitting io.binary math.functions vectors quotations sequences.private ;
IN: icfp.2006
SYMBOL: regs
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
old mode 100644
new mode 100755
index b97748514c..99dddb25f0
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -1,7 +1,7 @@
USING: kernel words inspector slots quotations sequences assocs
math arrays inference effects shuffle continuations debugger
tuples namespaces vectors bit-arrays byte-arrays strings sbufs
-math.functions macros combinators.private combinators ;
+math.functions macros sequences.private combinators ;
IN: inverse
TUPLE: fail ;
diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor
index 900f5a3829..499222073b 100755
--- a/extra/optimizer/debugger/debugger.factor
+++ b/extra/optimizer/debugger/debugger.factor
@@ -3,7 +3,7 @@
USING: classes inference inference.dataflow io kernel
kernel.private math.parser namespaces optimizer prettyprint
prettyprint.backend sequences words arrays match macros
-assocs combinators.private ;
+assocs sequences.private ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
diff --git a/extra/sequences/lib/lib-docs.factor b/extra/sequences/lib/lib-docs.factor
new file mode 100755
index 0000000000..eb56e35cd5
--- /dev/null
+++ b/extra/sequences/lib/lib-docs.factor
@@ -0,0 +1,39 @@
+USING: help.syntax help.markup kernel prettyprint sequences
+quotations math ;
+IN: sequences.lib
+
+HELP: map-withn
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }
+{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "
+"passed to the quotation given to map-withn for each element in the sequence."
+}
+{ $examples
+ { $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }
+}
+{ $see-also each-withn } ;
+
+HELP: each-withn
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
+{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "
+"passed to the quotation given to each-withn for each element in the sequence."
+}
+{ $see-also map-withn } ;
+
+HELP: sigma
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
+{ $description "Like map sum, but without creating an intermediate sequence." }
+{ $example
+ "! Find the sum of the squares [0,99]"
+ "USING: math.ranges combinators.lib ;"
+ "100 [1,b] [ sq ] sigma ."
+ "338350"
+} ;
+
+HELP: count
+{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }
+{ $description "Efficiently returns the number of elements that the predicate quotation matches." }
+{ $example
+ "USING: math.ranges combinators.lib ;"
+ "100 [1,b] [ even? ] count ."
+ "50"
+} ;
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index f7ac9c340d..048d63dc64 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
-arrays math.parser sorting strings ascii ;
+arrays math.parser sorting strings ascii macros ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor
index 4d74968c35..f5c518865d 100755
--- a/extra/space-invaders/space-invaders.factor
+++ b/extra/space-invaders/space-invaders.factor
@@ -5,7 +5,7 @@ USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel
shuffle arrays io.files combinators kernel.private
ui.gestures ui.gadgets ui.render opengl.gl system
threads concurrency match ui byte-arrays combinators.lib
- combinators.private ;
+ sequences.private ;
IN: space-invaders
TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor
old mode 100644
new mode 100755
index ac0bdc81c7..cd3cfc6324
--- a/extra/state-machine/state-machine.factor
+++ b/extra/state-machine/state-machine.factor
@@ -1,5 +1,5 @@
USING: kernel parser strings math namespaces sequences words io
-arrays quotations debugger kernel.private combinators.private ;
+arrays quotations debugger kernel.private sequences.private ;
IN: state-machine
: STATES:
diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor
index f438bcd8df..f05b3a833f 100755
--- a/extra/tools/interpreter/interpreter.factor
+++ b/extra/tools/interpreter/interpreter.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes combinators combinators.private
+USING: arrays assocs classes combinators sequences.private
continuations continuations.private generic hashtables io kernel
kernel.private math namespaces namespaces.private prettyprint
quotations sequences splitting strings threads vectors words ;
From 0f04e9714eb2af6736b3f8a18e5f00bf5a771706 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 11 Feb 2008 01:25:03 -0600
Subject: [PATCH 45/46] Fix stale USE:
---
core/bootstrap/compiler/compiler.factor | 11 -----------
1 file changed, 11 deletions(-)
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 2b278ac458..ff9d5c5e1e 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -77,14 +77,3 @@ nl
[ compiled-usages recompile ] recompile-hook set-global
" done" print flush
-
-! Load empty test vocabs
-USE: compiler.test.curry
-USE: compiler.test.float
-USE: compiler.test.intrinsics
-USE: compiler.test.redefine
-USE: compiler.test.simple
-USE: compiler.test.stack-trace
-USE: compiler.test.templates
-USE: compiler.test.templates-early
-USE: compiler.test.tuples
From 04dc25f87a9809114ef947ae207ea269729deb05 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@terrorist.(none)>
Date: Mon, 11 Feb 2008 06:11:00 -0600
Subject: [PATCH 46/46] builder.test: Only extract the vocab names from the
result of try-everything
---
extra/builder/test/test.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor
index c887c668e6..b77199c7c5 100644
--- a/extra/builder/test/test.factor
+++ b/extra/builder/test/test.factor
@@ -7,8 +7,10 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader
IN: builder.test
+: try-everything* ( -- vocabs ) try-everything [ first vocab-link-name ] map ;
+
: do-load ( -- )
- [ try-everything ] "../load-everything-time" log-runtime
+ [ try-everything* ] "../load-everything-time" log-runtime
dup empty?
[ drop ]
[ "../load-everything-log" log-object ]