diff --git a/build-support/factor.sh b/build-support/factor.sh
index 476e885257..ea0c35aa83 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -89,11 +89,6 @@ set_md5sum() {
set_gcc() {
case $OS in
openbsd) ensure_program_installed egcc; CC=egcc;;
- netbsd) if [[ $WORD -eq 64 ]] ; then
- CC=/usr/pkg/gcc34/bin/gcc
- else
- CC=gcc
- fi ;;
*) CC=gcc;;
esac
}
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 5836b4d3c5..233de6f4ee 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -737,6 +737,7 @@ define-builtin
{ "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" }
+ { "unimplemented" "kernel.private" }
}
dup length [ >r first2 r> make-primitive ] 2each
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 99737e0ac5..8f505c21a1 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -594,3 +594,5 @@ set-primitive-effect
\ dll-valid? { object } { object } <effect> set-primitive-effect
\ modify-code-heap { array object } { } <effect> set-primitive-effect
+
+\ unimplemented { } { } <effect> set-primitive-effect
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 3c40984d7a..4b129ad59d 100755
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -108,3 +108,12 @@ IN: kernel.tests
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] must-fail
+
+! Discovered on Windows
+: total-failure-1 "" [ ] map unimplemented ;
+
+[ total-failure-1 ] must-fail
+
+: total-failure-2 [ ] (call) unimplemented ;
+
+[ total-failure-2 ] must-fail
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 5adecca206..d11f036445 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -284,10 +284,6 @@ HELP: use
HELP: in
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
-HELP: shadow-warnings
-{ $values { "vocab" "an assoc mapping strings to words" } { "vocabs" "a sequence of assocs" } }
-{ $description "Tests if any keys in " { $snippet "vocab" } " shadow keys in the elements of " { $snippet "vocabs" } ", and if so, prints a warning message. These warning messages can be disabled by setting " { $link parser-notes } " to " { $link f } "." } ;
-
HELP: (use+)
{ $values { "vocab" "an assoc mapping strings to words" } }
{ $description "Adds an assoc at the front of the search path." }
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 7db7e46b3a..6d091fd1c0 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -191,22 +191,8 @@ SYMBOL: in
: word/vocab% ( word -- )
"(" % dup word-vocabulary % " " % word-name % ")" % ;
-: shadow-warning ( new old -- )
- 2dup eq? [
- 2drop
- ] [
- [ word/vocab% " shadowed by " % word/vocab% ] "" make
- note.
- ] if ;
-
-: shadow-warnings ( vocab vocabs -- )
- [
- swapd assoc-stack dup
- [ shadow-warning ] [ 2drop ] if
- ] curry assoc-each ;
-
: (use+) ( vocab -- )
- vocab-words use get 2dup shadow-warnings push ;
+ vocab-words use get push ;
: use+ ( vocab -- )
load-vocab (use+) ;
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 55e672ec80..1a1a18c942 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -11,14 +11,19 @@ TUPLE: db
update-statements
delete-statements ;
-: <db> ( handle -- obj )
- H{ } clone H{ } clone H{ } clone
- db construct-boa ;
+: construct-db ( class -- obj )
+ construct-empty
+ H{ } clone >>insert-statements
+ H{ } clone >>update-statements
+ H{ } clone >>delete-statements ;
GENERIC: make-db* ( seq class -- db )
-GENERIC: db-open ( db -- )
+
+: make-db ( seq class -- db )
+ construct-db make-db* ;
+
+GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
-: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
@@ -30,10 +35,13 @@ HOOK: db-close db ( handle -- )
handle>> db-close
] with-variable ;
+! TUPLE: sql sql in-params out-params ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
-TUPLE: simple-statement ;
-TUPLE: prepared-statement ;
-TUPLE: nonthrowable-statement ;
+TUPLE: simple-statement < statement ;
+TUPLE: prepared-statement < statement ;
+TUPLE: nonthrowable-statement < statement ;
+TUPLE: throwable-statement < statement ;
+
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
@@ -41,14 +49,13 @@ TUPLE: nonthrowable-statement ;
nonthrowable-statement construct-delegate
] if ;
-MIXIN: throwable-statement
-INSTANCE: statement throwable-statement
-INSTANCE: simple-statement throwable-statement
-INSTANCE: prepared-statement throwable-statement
-
TUPLE: result-set sql in-params out-params handle n max ;
-: <statement> ( sql in out -- statement )
- { (>>sql) (>>in-params) (>>out-params) } statement construct ;
+
+: construct-statement ( sql in out class -- statement )
+ construct-empty
+ swap >>out-params
+ swap >>in-params
+ swap >>sql ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
@@ -88,11 +95,14 @@ M: nonthrowable-statement execute-statement ( statement -- )
dup #rows >>max
0 >>n drop ;
-: <result-set> ( query handle tuple -- result-set )
- >r >r { sql>> in-params>> out-params>> } get-slots r>
- { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
- construct r> construct-delegate ;
-
+: construct-result-set ( query handle class -- result-set )
+ construct-empty
+ swap >>handle
+ >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
+ swap >>out-params
+ swap >>in-params
+ swap >>sql ;
+
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
@@ -110,7 +120,7 @@ M: nonthrowable-statement execute-statement ( statement -- )
accumulator >r query-each r> { } like ; inline
: with-db ( db seq quot -- )
- >r make-db dup db-open db r>
+ >r make-db db-open db r>
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
: default-query ( query -- result-set )
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index 7925989bf5..7f428bb6b6 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -6,7 +6,8 @@ IN: db.postgresql.ffi
<< "postgresql" {
{ [ os winnt? ] [ "libpq.dll" ] }
- { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
+ { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] }
+ ! { [ os macosx? ] [ "libpq.dylib" ] }
{ [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index f9805560ad..322143e7a2 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -5,40 +5,39 @@ kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
-namespaces.lib ;
+namespaces.lib accessors ;
IN: db.postgresql
-TUPLE: postgresql-db host port pgopts pgtty db user pass ;
-TUPLE: postgresql-statement ;
-INSTANCE: postgresql-statement throwable-statement
-TUPLE: postgresql-result-set ;
+TUPLE: postgresql-db < db
+ host port pgopts pgtty db user pass ;
+
+TUPLE: postgresql-statement < throwable-statement ;
+
+TUPLE: postgresql-result-set < result-set ;
+
: <postgresql-statement> ( statement in out -- postgresql-statement )
- <statement>
- postgresql-statement construct-delegate ;
+ postgresql-statement construct-statement ;
M: postgresql-db make-db* ( seq tuple -- db )
- >r first4 r> [
- {
- set-postgresql-db-host
- set-postgresql-db-user
- set-postgresql-db-pass
- set-postgresql-db-db
- } set-slots
- ] keep ;
+ >r first4 r>
+ swap >>db
+ swap >>pass
+ swap >>user
+ swap >>host ;
-M: postgresql-db db-open ( db -- )
- dup {
- postgresql-db-host
- postgresql-db-port
- postgresql-db-pgopts
- postgresql-db-pgtty
- postgresql-db-db
- postgresql-db-user
- postgresql-db-pass
- } get-slots connect-postgres <db> swap set-delegate ;
+M: postgresql-db db-open ( db -- db )
+ dup {
+ [ host>> ]
+ [ port>> ]
+ [ pgopts>> ]
+ [ pgtty>> ]
+ [ db>> ]
+ [ user>> ]
+ [ pass>> ]
+ } cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- )
- db-handle PQfinish ;
+ handle>> PQfinish ;
M: postgresql-statement bind-statement* ( statement -- )
drop ;
@@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- )
] keep set-statement-bind-params ;
M: postgresql-result-set #rows ( result-set -- n )
- result-set-handle PQntuples ;
+ handle>> PQntuples ;
M: postgresql-result-set #columns ( result-set -- n )
- result-set-handle PQnfields ;
+ handle>> PQnfields ;
M: postgresql-result-set row-column ( result-set column -- obj )
>r dup result-set-handle swap result-set-n r> pq-get-string ;
@@ -69,7 +68,7 @@ M: postgresql-statement query-results ( query -- result-set )
] [
dup do-postgresql-statement
] if*
- postgresql-result-set <result-set>
+ postgresql-result-set construct-result-set
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
@@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
- >r db get db-handle "" r>
+ >r db get handle>> "" r>
dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 9b3185bcf2..11c0150cd2 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -5,61 +5,48 @@ hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
-io namespaces.lib ;
-USE: tools.walker
+io namespaces.lib accessors ;
IN: db.sqlite
-TUPLE: sqlite-db path ;
+TUPLE: sqlite-db < db path ;
M: sqlite-db make-db* ( path db -- db )
- [ set-sqlite-db-path ] keep ;
+ swap >>path ;
-M: sqlite-db db-open ( db -- )
- dup sqlite-db-path sqlite-open <db>
- swap set-delegate ;
+M: sqlite-db db-open ( db -- db )
+ [ path>> sqlite-open ] [ swap >>handle ] bi ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
-: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
-TUPLE: sqlite-statement ;
-INSTANCE: sqlite-statement throwable-statement
+TUPLE: sqlite-statement < throwable-statement ;
-TUPLE: sqlite-result-set has-more? ;
+TUPLE: sqlite-result-set < result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str in out -- obj )
- {
- set-statement-sql
- set-statement-in-params
- set-statement-out-params
- } statement construct
- sqlite-statement construct-delegate ;
+ sqlite-statement construct-statement ;
: sqlite-maybe-prepare ( statement -- statement )
- dup statement-handle [
- [
- delegate
- db get db-handle over statement-sql sqlite-prepare
- swap set-statement-handle
- ] keep
+ dup handle>> [
+ db get handle>> over sql>> sqlite-prepare
+ >>handle
] unless ;
M: sqlite-statement dispose ( statement -- )
- statement-handle
+ handle>>
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- )
- f swap set-result-set-handle ;
+ f >>handle drop ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- )
- sqlite-maybe-prepare
- statement-handle sqlite-reset ;
+ sqlite-maybe-prepare handle>> sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
@@ -69,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- )
M: sqlite-statement bind-tuple ( tuple statement -- )
[
- statement-in-params
+ in-params>>
[
- [ sql-spec-column-name ":" prepend ]
- [ sql-spec-slot-name rot get-slot-named ]
- [ sql-spec-type ] tri 3array
+ [ column-name>> ":" prepend ]
+ [ slot-name>> rot get-slot-named ]
+ [ type>> ] tri 3array
] with map
] keep
bind-statement ;
@@ -86,25 +73,24 @@ M: sqlite-db insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
- result-set-handle sqlite-#columns ;
+ handle>> sqlite-#columns ;
M: sqlite-result-set row-column ( result-set n -- obj )
- >r result-set-handle r> sqlite-column ;
+ [ handle>> ] [ sqlite-column ] bi* ;
M: sqlite-result-set row-column-typed ( result-set n -- obj )
- dup pick result-set-out-params nth sql-spec-type
- >r >r result-set-handle r> r> sqlite-column-typed ;
+ dup pick out-params>> nth type>>
+ >r >r handle>> r> r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
- [ result-set-handle sqlite-next ] keep
- set-sqlite-result-set-has-more? ;
+ dup handle>> sqlite-next >>has-more? drop ;
M: sqlite-result-set more-rows? ( result-set -- ? )
- sqlite-result-set-has-more? ;
+ has-more?>> ;
M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare
- dup statement-handle sqlite-result-set <result-set>
+ dup handle>> sqlite-result-set construct-result-set
dup advance-row ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
@@ -119,9 +105,9 @@ M: sqlite-db create-sql-statement ( class -- statement )
[
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
- dup sql-spec-column-name 0%
+ dup column-name>> 0%
" " 0%
- dup sql-spec-type t lookup-type 0%
+ dup type>> t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] sqlite-make ;
@@ -134,7 +120,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
"insert into " 0% 0%
"(" 0%
maybe-remove-id
- dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
@@ -145,11 +131,11 @@ M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
: where-primary-key% ( specs -- )
" where " 0%
- find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
+ find-primary-key dup column-name>> 0% " = " 0% bind% ;
: where-clause ( specs -- )
" where " 0%
- [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
+ [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
@@ -157,7 +143,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
0%
" set " 0%
dup remove-id
- [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+ [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
where-primary-key%
] sqlite-make ;
@@ -166,23 +152,23 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
"delete from " 0% 0%
" where " 0%
find-primary-key
- dup sql-spec-column-name 0% " = " 0% bind%
+ dup column-name>> 0% " = " 0% bind%
] sqlite-make ;
! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ;
M: sqlite-db bind% ( spec -- )
- dup 1, sql-spec-column-name ":" prepend 0% ;
+ dup 1, column-name>> ":" prepend 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
over [ ", " 0% ]
- [ dup sql-spec-column-name 0% 2, ] interleave
+ [ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
- [ sql-spec-slot-name swap get-slot-named ] with subset
+ [ slot-name>> swap get-slot-named ] with subset
dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ;
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 6b61981119..951ded32ea 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -260,10 +260,10 @@ C: <secret> secret
! [ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
-! [ assigned-person-schema test-repeated-insert ] test-sqlite
-! [ native-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-repeated-insert ] test-postgresql
+ [ assigned-person-schema test-repeated-insert ] test-sqlite
+ [ native-person-schema test-tuples ] test-postgresql
+ [ assigned-person-schema test-tuples ] test-postgresql
+ [ assigned-person-schema test-repeated-insert ] test-postgresql
! \ insert-tuple must-infer
! \ update-tuple must-infer
diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor
index 95a56da2d2..283fea6fcc 100644
--- a/extra/hardware-info/backend/backend.factor
+++ b/extra/hardware-info/backend/backend.factor
@@ -2,6 +2,7 @@ USING: system ;
IN: hardware-info.backend
HOOK: cpus os ( -- n )
+HOOK: cpu-mhz os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor
index 6d27cf5252..53aab483a1 100755
--- a/extra/hardware-info/hardware-info.factor
+++ b/extra/hardware-info/hardware-info.factor
@@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info
: write-unit ( x n str -- )
- [ 2^ /i number>string write bl ] [ write ] bi* ;
+ [ 2^ /f number>string write bl ] [ write ] bi* ;
: kb ( x -- ) 10 "kB" write-unit ;
: megs ( x -- ) 20 "MB" write-unit ;
: gigs ( x -- ) 30 "GB" write-unit ;
+: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
<< {
{ [ os windows? ] [ "hardware-info.windows" ] }
@@ -18,4 +19,5 @@ IN: hardware-info
: hardware-report. ( -- )
"CPUs: " write cpus number>string write nl
+ "CPU Speed: " write cpu-mhz ghz nl
"Physical RAM: " write physical-mem megs nl ;
diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor
index dac052a1de..91838d2a53 100644
--- a/extra/hardware-info/macosx/macosx.factor
+++ b/extra/hardware-info/macosx/macosx.factor
@@ -41,7 +41,7 @@ M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
-: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ;
+M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor
index fac6471b8c..8b13b9b3b9 100755
--- a/extra/io/windows/nt/launcher/launcher-tests.factor
+++ b/extra/io/windows/nt/launcher/launcher-tests.factor
@@ -1,7 +1,7 @@
IN: io.windows.launcher.nt.tests
USING: io.launcher tools.test calendar accessors
namespaces kernel system arrays io io.files io.encodings.ascii
-sequences parser assocs hashtables ;
+sequences parser assocs hashtables math ;
[ ] [
<process>
@@ -129,3 +129,14 @@ sequences parser assocs hashtables ;
"HOME" swap at "XXX" =
] unit-test
+
+2 [
+ [ ] [
+ <process>
+ "cmd.exe /c dir" >>command
+ "dir.txt" temp-file >>stdout
+ try-process
+ ] unit-test
+
+ [ ] [ "dir.txt" temp-file delete-file ] unit-test
+] times
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index a01ba4698e..97de248d24 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -39,7 +39,7 @@ IN: io.windows.nt.launcher
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
- CreateFile dup invalid-handle? dup close-later ;
+ CreateFile dup invalid-handle? dup close-always ;
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor
index 13ce834df3..cc218533d8 100755
--- a/extra/ui/tools/listener/listener-tests.factor
+++ b/extra/ui/tools/listener/listener-tests.factor
@@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads ;
+threads arrays generic ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
@@ -13,11 +13,11 @@ IN: ui.tools.listener.tests
"listener" get [
[ "dup" ] [
- \ dup "listener" get word-completion-string
+ \ dup word-completion-string
] unit-test
- [ "USE: slots.private slot" ]
- [ \ slot "listener" get word-completion-string ] unit-test
+ [ "equal?" ]
+ [ \ array \ equal? method word-completion-string ] unit-test
<pane> <interactor> "i" set
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index 52c3d2de42..91f7b0ec5d 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
prettyprint listener debugger threads boxes concurrency.flags
-math arrays generic accessors ;
+math arrays generic accessors combinators ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
@@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- )
: clear-stack ( listener -- )
[ clear ] swap (call-listener) ;
-GENERIC# word-completion-string 1 ( word listener -- string )
+GENERIC: word-completion-string ( word -- string )
+
+M: word word-completion-string
+ word-name ;
M: method-body word-completion-string
- >r "method-generic" word-prop r> word-completion-string ;
+ "method-generic" word-prop word-completion-string ;
USE: generic.standard.engines.tuple
M: tuple-dispatch-engine-word word-completion-string
- >r "engine-generic" word-prop r> word-completion-string ;
+ "engine-generic" word-prop word-completion-string ;
-M: word word-completion-string ( word listener -- string )
- >r [ word-name ] [ word-vocabulary ] bi dup vocab-words r>
- input>> interactor-use memq?
- [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
+: use-if-necessary ( word seq -- )
+ >r word-vocabulary vocab-words r>
+ {
+ { [ dup not ] [ 2drop ] }
+ { [ 2dup memq? ] [ 2drop ] }
+ { [ t ] [ push ] }
+ } cond ;
: insert-word ( word -- )
- get-workspace
- workspace-listener
- [ word-completion-string ] keep
- input>> user-input ;
+ get-workspace workspace-listener input>>
+ [ >r word-completion-string r> user-input ]
+ [ interactor-use use-if-necessary ]
+ 2bi ;
: quot-action ( interactor -- lines )
dup control-value
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 0adcf0ca39..d3b8b6e39e 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -315,8 +315,6 @@ INLINE void* allot_object(CELL type, CELL a)
{
CELL *object;
- /* If the object is bigger than the nursery, allocate it in
- tenured space */
if(nursery->size - ALLOT_BUFFER_ZONE > a)
{
/* If there is insufficient room, collect the nursery */
@@ -325,6 +323,8 @@ INLINE void* allot_object(CELL type, CELL a)
object = allot_zone(nursery,a);
}
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
else
{
F_ZONE *tenured = &data_heap->generations[TENURED];
diff --git a/vm/errors.c b/vm/errors.c
index 27158cbf44..6d99d34766 100755
--- a/vm/errors.c
+++ b/vm/errors.c
@@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
}
+
+/* For testing purposes */
+DEFINE_PRIMITIVE(unimplemented)
+{
+ not_implemented_error();
+}
diff --git a/vm/errors.h b/vm/errors.h
index 747a3415ba..227fed9228 100755
--- a/vm/errors.h
+++ b/vm/errors.h
@@ -55,3 +55,5 @@ void *signal_callstack_top;
void memory_signal_handler_impl(void);
void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);
+
+DECLARE_PRIMITIVE(unimplemented);
diff --git a/vm/os-windows.c b/vm/os-windows.c
index 1be41f8b57..664df9e774 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.c
@@ -215,7 +215,7 @@ void sleep_millis(DWORD msec)
Sleep(msec);
}
-DECLARE_PRIMITIVE(set_os_envs)
+DEFINE_PRIMITIVE(set_os_envs)
{
not_implemented_error();
}
diff --git a/vm/primitives.c b/vm/primitives.c
index 038a7d84a5..533fcebc9a 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -187,4 +187,5 @@ void *primitives[] = {
primitive_resize_bit_array,
primitive_resize_float_array,
primitive_dll_validp,
+ primitive_unimplemented,
};