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

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

db4
Eduardo Cavazos 2008-04-07 18:31:11 -05:00
parent 2ee0ab27d1 4dab4ed329
commit ce0f86167e
23 changed files with 166 additions and 152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
build-support/factor.sh
View File

@ -89,11 +89,6 @@ set_md5sum() {
set_gcc() { set_gcc() {
case $OS in case $OS in
openbsd) ensure_program_installed egcc; CC=egcc;; 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;; *) CC=gcc;;
esac esac
} }

1
core/bootstrap/primitives.factor
View File

@ -737,6 +737,7 @@ define-builtin
{ "resize-bit-array" "bit-arrays" } { "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" } { "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" } { "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
} }
dup length [ >r first2 r> make-primitive ] 2each dup length [ >r first2 r> make-primitive ] 2each

2
core/inference/known-words/known-words.factor
View File

@ -594,3 +594,5 @@ set-primitive-effect
\ dll-valid? { object } { object } <effect> set-primitive-effect \ dll-valid? { object } { object } <effect> set-primitive-effect
\ modify-code-heap { array object } { } <effect> set-primitive-effect \ modify-code-heap { array object } { } <effect> set-primitive-effect
\ unimplemented { } { } <effect> set-primitive-effect

9
core/kernel/kernel-tests.factor
View File

@ -108,3 +108,12 @@ IN: kernel.tests
H{ } values swap >r dup length swap r> 0 -roll (loop) ; H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] must-fail [ 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

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

@ -284,10 +284,6 @@ HELP: use
HELP: in HELP: in
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ; { $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+) HELP: (use+)
{ $values { "vocab" "an assoc mapping strings to words" } } { $values { "vocab" "an assoc mapping strings to words" } }
{ $description "Adds an assoc at the front of the search path." } { $description "Adds an assoc at the front of the search path." }

16
core/parser/parser.factor
View File

@ -191,22 +191,8 @@ SYMBOL: in
: word/vocab% ( word -- ) : word/vocab% ( word -- )
"(" % dup word-vocabulary % " " % word-name % ")" % ; "(" % 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 -- ) : (use+) ( vocab -- )
vocab-words use get 2dup shadow-warnings push ; vocab-words use get push ;
: use+ ( vocab -- ) : use+ ( vocab -- )
load-vocab (use+) ; load-vocab (use+) ;

50
extra/db/db.factor
View File

@ -11,14 +11,19 @@ TUPLE: db
update-statements update-statements
delete-statements ; delete-statements ;
: <db> ( handle -- obj ) : construct-db ( class -- obj )
H{ } clone H{ } clone H{ } clone construct-empty
db construct-boa ; H{ } clone >>insert-statements
H{ } clone >>update-statements
H{ } clone >>delete-statements ;
GENERIC: make-db* ( seq class -- db ) 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 -- ) HOOK: db-close db ( handle -- )
: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ; : dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
@ -30,10 +35,13 @@ HOOK: db-close db ( handle -- )
handle>> db-close handle>> db-close
] with-variable ; ] with-variable ;
! TUPLE: sql sql in-params out-params ;
TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ; TUPLE: simple-statement < statement ;
TUPLE: prepared-statement ; TUPLE: prepared-statement < statement ;
TUPLE: nonthrowable-statement ; TUPLE: nonthrowable-statement < statement ;
TUPLE: throwable-statement < statement ;
: make-nonthrowable ( obj -- obj' ) : make-nonthrowable ( obj -- obj' )
dup sequence? [ dup sequence? [
[ make-nonthrowable ] map [ make-nonthrowable ] map
@ -41,14 +49,13 @@ TUPLE: nonthrowable-statement ;
nonthrowable-statement construct-delegate nonthrowable-statement construct-delegate
] if ; ] 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 ; 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: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement ) HOOK: <prepared-statement> db ( str in out -- statement )
@ -88,10 +95,13 @@ M: nonthrowable-statement execute-statement ( statement -- )
dup #rows >>max dup #rows >>max
0 >>n drop ; 0 >>n drop ;
: <result-set> ( query handle tuple -- result-set ) : construct-result-set ( query handle class -- result-set )
>r >r { sql>> in-params>> out-params>> } get-slots r> construct-empty
{ (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set swap >>handle
construct r> construct-delegate ; >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
swap >>out-params
swap >>in-params
swap >>sql ;
: sql-row ( result-set -- seq ) : sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ; dup #columns [ row-column ] with map ;
@ -110,7 +120,7 @@ M: nonthrowable-statement execute-statement ( statement -- )
accumulator >r query-each r> { } like ; inline accumulator >r query-each r> { } like ; inline
: with-db ( db seq quot -- ) : 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 ; [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
: default-query ( query -- result-set ) : default-query ( query -- result-set )

3
extra/db/postgresql/ffi/ffi.factor
View File

@ -6,7 +6,8 @@ IN: db.postgresql.ffi
<< "postgresql" { << "postgresql" {
{ [ os winnt? ] [ "libpq.dll" ] } { [ 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" ] } { [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >> } cond "cdecl" add-library >>

57
extra/db/postgresql/postgresql.factor
View File

@ -5,40 +5,39 @@ kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker combinators sequences.lib classes locals words tools.walker
namespaces.lib ; namespaces.lib accessors ;
IN: db.postgresql IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ; TUPLE: postgresql-db < db
TUPLE: postgresql-statement ; host port pgopts pgtty db user pass ;
INSTANCE: postgresql-statement throwable-statement
TUPLE: postgresql-result-set ; TUPLE: postgresql-statement < throwable-statement ;
TUPLE: postgresql-result-set < result-set ;
: <postgresql-statement> ( statement in out -- postgresql-statement ) : <postgresql-statement> ( statement in out -- postgresql-statement )
<statement> postgresql-statement construct-statement ;
postgresql-statement construct-delegate ;
M: postgresql-db make-db* ( seq tuple -- db ) M: postgresql-db make-db* ( seq tuple -- db )
>r first4 r> [ >r first4 r>
{ swap >>db
set-postgresql-db-host swap >>pass
set-postgresql-db-user swap >>user
set-postgresql-db-pass swap >>host ;
set-postgresql-db-db
} set-slots
] keep ;
M: postgresql-db db-open ( db -- ) M: postgresql-db db-open ( db -- db )
dup { dup {
postgresql-db-host [ host>> ]
postgresql-db-port [ port>> ]
postgresql-db-pgopts [ pgopts>> ]
postgresql-db-pgtty [ pgtty>> ]
postgresql-db-db [ db>> ]
postgresql-db-user [ user>> ]
postgresql-db-pass [ pass>> ]
} get-slots connect-postgres <db> swap set-delegate ; } cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- ) M: postgresql-db dispose ( db -- )
db-handle PQfinish ; handle>> PQfinish ;
M: postgresql-statement bind-statement* ( statement -- ) M: postgresql-statement bind-statement* ( statement -- )
drop ; drop ;
@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- )
] keep set-statement-bind-params ; ] keep set-statement-bind-params ;
M: postgresql-result-set #rows ( result-set -- n ) M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ; handle>> PQntuples ;
M: postgresql-result-set #columns ( result-set -- n ) M: postgresql-result-set #columns ( result-set -- n )
result-set-handle PQnfields ; handle>> PQnfields ;
M: postgresql-result-set row-column ( result-set column -- obj ) M: postgresql-result-set row-column ( result-set column -- obj )
>r dup result-set-handle swap result-set-n r> pq-get-string ; >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 dup do-postgresql-statement
] if* ] if*
postgresql-result-set <result-set> postgresql-result-set construct-result-set
dup init-result-set ; dup init-result-set ;
M: postgresql-result-set advance-row ( 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 -- ) M: postgresql-statement prepare-statement ( statement -- )
[ [
>r db get db-handle "" r> >r db get handle>> "" r>
dup statement-sql swap statement-in-params dup statement-sql swap statement-in-params
length f PQprepare postgresql-error length f PQprepare postgresql-error
] keep set-statement-handle ; ] keep set-statement-handle ;

84
extra/db/sqlite/sqlite.factor
View File

@ -5,61 +5,48 @@ hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators words combinators.lib db.types combinators
io namespaces.lib ; io namespaces.lib accessors ;
USE: tools.walker
IN: db.sqlite IN: db.sqlite
TUPLE: sqlite-db path ; TUPLE: sqlite-db < db path ;
M: sqlite-db make-db* ( path db -- db ) M: sqlite-db make-db* ( path db -- db )
[ set-sqlite-db-path ] keep ; swap >>path ;
M: sqlite-db db-open ( db -- ) M: sqlite-db db-open ( db -- db )
dup sqlite-db-path sqlite-open <db> [ path>> sqlite-open ] [ swap >>handle ] bi ;
swap set-delegate ;
M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ; M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ; TUPLE: sqlite-statement < throwable-statement ;
INSTANCE: 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 ) M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ; <prepared-statement> ;
M: sqlite-db <prepared-statement> ( str in out -- obj ) M: sqlite-db <prepared-statement> ( str in out -- obj )
{ sqlite-statement construct-statement ;
set-statement-sql
set-statement-in-params
set-statement-out-params
} statement construct
sqlite-statement construct-delegate ;
: sqlite-maybe-prepare ( statement -- statement ) : sqlite-maybe-prepare ( statement -- statement )
dup statement-handle [ dup handle>> [
[ db get handle>> over sql>> sqlite-prepare
delegate >>handle
db get db-handle over statement-sql sqlite-prepare
swap set-statement-handle
] keep
] unless ; ] unless ;
M: sqlite-statement dispose ( statement -- ) M: sqlite-statement dispose ( statement -- )
statement-handle handle>>
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ; [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- ) M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ; f >>handle drop ;
: sqlite-bind ( triples handle -- ) : sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ; swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- ) : reset-statement ( statement -- )
sqlite-maybe-prepare sqlite-maybe-prepare handle>> sqlite-reset ;
statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- ) M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare sqlite-maybe-prepare
@ -69,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- )
M: sqlite-statement bind-tuple ( tuple statement -- ) M: sqlite-statement bind-tuple ( tuple statement -- )
[ [
statement-in-params in-params>>
[ [
[ sql-spec-column-name ":" prepend ] [ column-name>> ":" prepend ]
[ sql-spec-slot-name rot get-slot-named ] [ slot-name>> rot get-slot-named ]
[ sql-spec-type ] tri 3array [ type>> ] tri 3array
] with map ] with map
] keep ] keep
bind-statement ; bind-statement ;
@ -86,25 +73,24 @@ M: sqlite-db insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ; execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n ) 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 ) 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 ) M: sqlite-result-set row-column-typed ( result-set n -- obj )
dup pick result-set-out-params nth sql-spec-type dup pick out-params>> nth type>>
>r >r result-set-handle r> r> sqlite-column-typed ; >r >r handle>> r> r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- ) M: sqlite-result-set advance-row ( result-set -- )
[ result-set-handle sqlite-next ] keep dup handle>> sqlite-next >>has-more? drop ;
set-sqlite-result-set-has-more? ;
M: sqlite-result-set more-rows? ( result-set -- ? ) M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ; has-more?>> ;
M: sqlite-statement query-results ( query -- result-set ) M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare sqlite-maybe-prepare
dup statement-handle sqlite-result-set <result-set> dup handle>> sqlite-result-set construct-result-set
dup advance-row ; dup advance-row ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
@ -119,9 +105,9 @@ M: sqlite-db create-sql-statement ( class -- statement )
[ [
"create table " 0% 0% "create table " 0% 0%
"(" 0% [ ", " 0% ] [ "(" 0% [ ", " 0% ] [
dup sql-spec-column-name 0% dup column-name>> 0%
" " 0% " " 0%
dup sql-spec-type t lookup-type 0% dup type>> t lookup-type 0%
modifiers 0% modifiers 0%
] interleave ");" 0% ] interleave ");" 0%
] sqlite-make ; ] sqlite-make ;
@ -134,7 +120,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
"insert into " 0% 0% "insert into " 0% 0%
"(" 0% "(" 0%
maybe-remove-id maybe-remove-id
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0% ") values(" 0%
[ ", " 0% ] [ bind% ] interleave [ ", " 0% ] [ bind% ] interleave
");" 0% ");" 0%
@ -145,11 +131,11 @@ M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
: where-primary-key% ( specs -- ) : where-primary-key% ( specs -- )
" where " 0% " 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-clause ( specs -- )
" where " 0% " 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 ) M: sqlite-db <update-tuple-statement> ( class -- statement )
[ [
@ -157,7 +143,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
0% 0%
" set " 0% " set " 0%
dup remove-id dup remove-id
[ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
where-primary-key% where-primary-key%
] sqlite-make ; ] sqlite-make ;
@ -166,23 +152,23 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
"delete from " 0% 0% "delete from " 0% 0%
" where " 0% " where " 0%
find-primary-key find-primary-key
dup sql-spec-column-name 0% " = " 0% bind% dup column-name>> 0% " = " 0% bind%
] sqlite-make ; ] sqlite-make ;
! : select-interval ( interval name -- ) ; ! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ; ! : select-sequence ( seq name -- ) ;
M: sqlite-db bind% ( spec -- ) 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 ) M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[ [
"select " 0% "select " 0%
over [ ", " 0% ] over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave [ dup column-name>> 0% 2, ] interleave
" from " 0% 0% " 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% dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ; ] sqlite-make ;

8
extra/db/tuples/tuples-tests.factor
View File

@ -260,10 +260,10 @@ C: <secret> secret
! [ test-random-id ] test-sqlite ! [ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite [ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite
! [ assigned-person-schema test-repeated-insert ] test-sqlite [ assigned-person-schema test-repeated-insert ] test-sqlite
! [ native-person-schema test-tuples ] test-postgresql [ native-person-schema test-tuples ] test-postgresql
! [ assigned-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-postgresql
! \ insert-tuple must-infer ! \ insert-tuple must-infer
! \ update-tuple must-infer ! \ update-tuple must-infer

1
extra/hardware-info/backend/backend.factor
View File

@ -2,6 +2,7 @@ USING: system ;
IN: hardware-info.backend IN: hardware-info.backend
HOOK: cpus os ( -- n ) HOOK: cpus os ( -- n )
HOOK: cpu-mhz os ( -- n )
HOOK: memory-load os ( -- n ) HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n ) HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n ) HOOK: available-mem os ( -- n )

4
extra/hardware-info/hardware-info.factor
View File

@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info IN: hardware-info
: write-unit ( x n str -- ) : 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 ; : kb ( x -- ) 10 "kB" write-unit ;
: megs ( x -- ) 20 "MB" write-unit ; : megs ( x -- ) 20 "MB" write-unit ;
: gigs ( x -- ) 30 "GB" write-unit ; : gigs ( x -- ) 30 "GB" write-unit ;
: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
<< { << {
{ [ os windows? ] [ "hardware-info.windows" ] } { [ os windows? ] [ "hardware-info.windows" ] }
@ -18,4 +19,5 @@ IN: hardware-info
: hardware-report. ( -- ) : hardware-report. ( -- )
"CPUs: " write cpus number>string write nl "CPUs: " write cpus number>string write nl
"CPU Speed: " write cpu-mhz ghz nl
"Physical RAM: " write physical-mem megs nl ; "Physical RAM: " write physical-mem megs nl ;

2
extra/hardware-info/macosx/macosx.factor
View File

@ -41,7 +41,7 @@ M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ; : machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ; : vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } 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 ; : cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ; : l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ; : l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;

13
extra/io/windows/nt/launcher/launcher-tests.factor
View File

@ -1,7 +1,7 @@
IN: io.windows.launcher.nt.tests IN: io.windows.launcher.nt.tests
USING: io.launcher tools.test calendar accessors USING: io.launcher tools.test calendar accessors
namespaces kernel system arrays io io.files io.encodings.ascii namespaces kernel system arrays io io.files io.encodings.ascii
sequences parser assocs hashtables ; sequences parser assocs hashtables math ;
[ ] [ [ ] [
<process> <process>
@ -129,3 +129,14 @@ sequences parser assocs hashtables ;
"HOME" swap at "XXX" = "HOME" swap at "XXX" =
] unit-test ] 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

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

@ -39,7 +39,7 @@ IN: io.windows.nt.launcher
create-mode create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file f ! template file
CreateFile dup invalid-handle? dup close-later ; CreateFile dup invalid-handle? dup close-always ;
: set-inherit ( handle ? -- ) : set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;

8
extra/ui/tools/listener/listener-tests.factor
View File

@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private ui.gadgets.panes vocabs words tools.test.ui slots.private
threads ; threads arrays generic ;
IN: ui.tools.listener.tests IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test [ f ] [ "word" source-editor command-map empty? ] unit-test
@ -13,11 +13,11 @@ IN: ui.tools.listener.tests
"listener" get [ "listener" get [
[ "dup" ] [ [ "dup" ] [
\ dup "listener" get word-completion-string \ dup word-completion-string
] unit-test ] unit-test
[ "USE: slots.private slot" ] [ "equal?" ]
[ \ slot "listener" get word-completion-string ] unit-test [ \ array \ equal? method word-completion-string ] unit-test
<pane> <interactor> "i" set <pane> <interactor> "i" set

30
extra/ui/tools/listener/listener.factor
View File

@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words ui.gadgets.tracks ui.gestures ui.operations vocabs words
prettyprint listener debugger threads boxes concurrency.flags prettyprint listener debugger threads boxes concurrency.flags
math arrays generic accessors ; math arrays generic accessors combinators ;
IN: ui.tools.listener IN: ui.tools.listener
TUPLE: listener-gadget input output stack ; TUPLE: listener-gadget input output stack ;
@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- )
: clear-stack ( listener -- ) : clear-stack ( listener -- )
[ clear ] swap (call-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 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 USE: generic.standard.engines.tuple
M: tuple-dispatch-engine-word word-completion-string 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 ) : use-if-necessary ( word seq -- )
>r [ word-name ] [ word-vocabulary ] bi dup vocab-words r> >r word-vocabulary vocab-words r>
input>> interactor-use memq? {
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ; { [ dup not ] [ 2drop ] }
{ [ 2dup memq? ] [ 2drop ] }
{ [ t ] [ push ] }
} cond ;
: insert-word ( word -- ) : insert-word ( word -- )
get-workspace get-workspace workspace-listener input>>
workspace-listener [ >r word-completion-string r> user-input ]
[ word-completion-string ] keep [ interactor-use use-if-necessary ]
input>> user-input ; 2bi ;
: quot-action ( interactor -- lines ) : quot-action ( interactor -- lines )
dup control-value dup control-value

4
vm/data_gc.h
View File

@ -315,8 +315,6 @@ INLINE void* allot_object(CELL type, CELL a)
{ {
CELL *object; CELL *object;
/* If the object is bigger than the nursery, allocate it in
tenured space */
if(nursery->size - ALLOT_BUFFER_ZONE > a) if(nursery->size - ALLOT_BUFFER_ZONE > a)
{ {
/* If there is insufficient room, collect the nursery */ /* 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); object = allot_zone(nursery,a);
} }
/* If the object is bigger than the nursery, allocate it in
tenured space */
else else
{ {
F_ZONE *tenured = &data_heap->generations[TENURED]; F_ZONE *tenured = &data_heap->generations[TENURED];

6
vm/errors.c
View File

@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear)
{ {
throw_impl(dpop(),stack_chain->callstack_bottom); throw_impl(dpop(),stack_chain->callstack_bottom);
} }
/* For testing purposes */
DEFINE_PRIMITIVE(unimplemented)
{
not_implemented_error();
}

2
vm/errors.h
View File

@ -55,3 +55,5 @@ void *signal_callstack_top;
void memory_signal_handler_impl(void); void memory_signal_handler_impl(void);
void divide_by_zero_signal_handler_impl(void); void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void); void misc_signal_handler_impl(void);
DECLARE_PRIMITIVE(unimplemented);

2
vm/os-windows.c
View File

@ -215,7 +215,7 @@ void sleep_millis(DWORD msec)
Sleep(msec); Sleep(msec);
} }
DECLARE_PRIMITIVE(set_os_envs) DEFINE_PRIMITIVE(set_os_envs)
{ {
not_implemented_error(); not_implemented_error();
} }

1
vm/primitives.c
View File

@ -187,4 +187,5 @@ void *primitives[] = {
primitive_resize_bit_array, primitive_resize_bit_array,
primitive_resize_float_array, primitive_resize_float_array,
primitive_dll_validp, primitive_dll_validp,
primitive_unimplemented,
}; };