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

Merge branch 'master' into global_optimization

db4
Slava Pestov 2009-05-23 01:03:24 -05:00
parent 6af61656f3 5fa0507b97
commit 96975474b0
34 changed files with 587 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -136,8 +136,6 @@ M: object xyz ;
\ +-integer-fixnum inlined?
] unit-test
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
[ t ] [
[
[ no-cond ] 1

2
basis/io/launcher/launcher.factor
View File

@ -264,7 +264,7 @@ M: output-process-error error.
: try-output-process ( command -- )
>process
+stdout+ >>stderr
+closed+ >>stdin
[ +closed+ or ] change-stdin
utf8 <process-reader*>
[ stream-contents ] [ dup wait-for-process ] bi*
0 = [ 2drop ] [ output-process-error ] if ;

4
basis/io/monitors/monitors-docs.factor
View File

@ -112,10 +112,10 @@ $nl
{ $code
"USE: io.monitors"
": watch-loop ( monitor -- )"
" dup next-change . nl nl flush watch-loop ;"
" dup next-change path>> print nl nl flush watch-loop ;"
""
": watch-directory ( path -- )"
" [ t [ watch-loop ] with-monitor ] with-monitors"
" [ t [ watch-loop ] with-monitor ] with-monitors ;"
} ;
ABOUT: "io.monitors"

3
basis/io/monitors/monitors.factor
View File

@ -60,9 +60,6 @@ SYMBOL: +rename-file+
: run-monitor ( path recursive? quot -- )
'[ [ @ t ] loop ] with-monitor ; inline
: spawn-monitor ( path recursive? quot -- )
[ '[ _ _ _ run-monitor ] ] [ 2drop "Monitoring " prepend ] 3bi
spawn drop ;
{
{ [ os macosx? ] [ "io.monitors.macosx" require ] }
{ [ os linux? ] [ "io.monitors.linux" require ] }

3
basis/math/vectors/vectors.factor
View File

@ -62,6 +62,9 @@ IN: math.vectors
[ first vnlerp ] [ second vnlerp ] bi-curry
[ 2bi@ ] [ call ] bi* ;
: v~ ( a b epsilon -- ? )
[ ~ ] curry 2all? ;
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
HINTS: norm { array } ;

57
basis/random/windows/windows.factor
View File

@ -1,6 +1,7 @@
USING: accessors alien.c-types byte-arrays continuations
kernel windows.advapi32 init namespaces random destructors
locals windows.errors ;
USING: accessors alien.c-types byte-arrays
combinators.short-circuit continuations destructors init kernel
locals namespaces random windows.advapi32 windows.errors
windows.kernel32 math.bitwise ;
IN: random.windows
TUPLE: windows-rng provider type ;
@ -12,25 +13,42 @@ C: <windows-crypto-context> windows-crypto-context
M: windows-crypto-context dispose ( tuple -- )
handle>> 0 CryptReleaseContext win32-error=0/f ;
: factor-crypto-container ( -- string ) "FactorCryptoContainer" ; inline
CONSTANT: factor-crypto-container "FactorCryptoContainer"
:: (acquire-crypto-context) ( provider type flags -- handle )
[let | handle [ "HCRYPTPROV" <c-object> ] |
handle
factor-crypto-container
provider
type
flags
CryptAcquireContextW win32-error=0/f
handle *void* ] ;
:: (acquire-crypto-context) ( provider type flags -- handle ret )
"HCRYPTPROV" <c-object> :> handle
handle
factor-crypto-container
provider
type
flags
CryptAcquireContextW handle swap ;
: acquire-crypto-context ( provider type -- handle )
[ 0 (acquire-crypto-context) ]
[ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ;
CRYPT_MACHINE_KEYSET
(acquire-crypto-context)
0 = [
GetLastError NTE_BAD_KEYSET =
[ drop f ] [ win32-error-string throw ] if
] [
*void*
] if ;
: create-crypto-context ( provider type -- handle )
{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags
(acquire-crypto-context) win32-error=0/f *void* ;
ERROR: acquire-crypto-context-failed provider type ;
: attempt-crypto-context ( provider type -- handle )
{
[ acquire-crypto-context ]
[ create-crypto-context ]
[ acquire-crypto-context-failed ]
} 2|| ;
: windows-crypto-context ( provider type -- context )
acquire-crypto-context <windows-crypto-context> ;
attempt-crypto-context <windows-crypto-context> ;
M: windows-rng random-bytes* ( n tuple -- bytes )
[
@ -44,9 +62,8 @@ M: windows-rng random-bytes* ( n tuple -- bytes )
MS_DEF_PROV
PROV_RSA_FULL <windows-rng> system-random-generator set-global
MS_STRONG_PROV
PROV_RSA_FULL <windows-rng> secure-random-generator set-global
[ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
[ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
secure-random-generator set-global
! MS_ENH_RSA_AES_PROV
! PROV_RSA_AES <windows-rng> secure-random-generator set-global
] "random.windows" add-init-hook

25
basis/tuple-arrays/tuple-arrays-docs.factor Normal file
View File

@ -0,0 +1,25 @@
IN: tuple-arrays
USING: help.markup help.syntax sequences ;
HELP: TUPLE-ARRAY:
{ $syntax "TUPLE-ARRAY: class" }
{ $description "Generates a new data type in the current vocabulary named " { $snippet { $emphasis "class" } "-array" } " for holding instances of " { $snippet "class" } ", which must be a tuple class word. Together with the class itself, this also generates words named " { $snippet "<" { $emphasis "class" } "-array>" } " and " { $snippet ">" { $emphasis "class" } "-array" } ", for creating new instances of this tuple array type." } ;
ARTICLE: "tuple-arrays" "Tuple arrays"
"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of pointers to heap-allocated objects, a tuple array stores its elements inline. Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
$nl
"Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "."
$nl
"Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
{ $subsection POSTPONE: TUPLE-ARRAY: }
"An example:"
{ $example
"USE: tuple-arrays"
"IN: scratchpad"
"TUPLE: point x y ;"
"TUPLE-ARRAY: point"
"{ T{ point f 1 2 } T{ point f 1 3 } T{ point f 2 3 } } >point-array first short."
"T{ point f 1 2 }"
} ;
ABOUT: "tuple-arrays"

2
basis/tuple-arrays/tuple-arrays.factor
View File

@ -21,7 +21,7 @@ MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
[ new ] [ smart-tuple>array ] bi ; inline
: tuple-slice ( n seq -- slice )
[ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline
[ n>> [ * dup ] keep + ] [ seq>> ] bi slice boa ; inline
: read-tuple ( slice class -- tuple )
'[ _ boa-unsafe ] input<sequence-unsafe ; inline

34
basis/windows/advapi32/advapi32.factor
View File

@ -292,6 +292,40 @@ CONSTANT: SE_GROUP_ENABLED 4
CONSTANT: SE_GROUP_OWNER 8
CONSTANT: SE_GROUP_LOGON_ID -1073741824
CONSTANT: NTE_BAD_UID HEX: 80090001
CONSTANT: NTE_BAD_HASH HEX: 80090002
CONSTANT: NTE_BAD_KEY HEX: 80090003
CONSTANT: NTE_BAD_LEN HEX: 80090004
CONSTANT: NTE_BAD_DATA HEX: 80090005
CONSTANT: NTE_BAD_SIGNATURE HEX: 80090006
CONSTANT: NTE_BAD_VER HEX: 80090007
CONSTANT: NTE_BAD_ALGID HEX: 80090008
CONSTANT: NTE_BAD_FLAGS HEX: 80090009
CONSTANT: NTE_BAD_TYPE HEX: 8009000A
CONSTANT: NTE_BAD_KEY_STATE HEX: 8009000B
CONSTANT: NTE_BAD_HASH_STATE HEX: 8009000C
CONSTANT: NTE_NO_KEY HEX: 8009000D
CONSTANT: NTE_NO_MEMORY HEX: 8009000E
CONSTANT: NTE_EXISTS HEX: 8009000F
CONSTANT: NTE_PERM HEX: 80090010
CONSTANT: NTE_NOT_FOUND HEX: 80090011
CONSTANT: NTE_DOUBLE_ENCRYPT HEX: 80090012
CONSTANT: NTE_BAD_PROVIDER HEX: 80090013
CONSTANT: NTE_BAD_PROV_TYPE HEX: 80090014
CONSTANT: NTE_BAD_PUBLIC_KEY HEX: 80090015
CONSTANT: NTE_BAD_KEYSET HEX: 80090016
CONSTANT: NTE_PROV_TYPE_NOT_DEF HEX: 80090017
CONSTANT: NTE_PROV_TYPE_ENTRY_BAD HEX: 80090018
CONSTANT: NTE_KEYSET_NOT_DEF HEX: 80090019
CONSTANT: NTE_KEYSET_ENTRY_BAD HEX: 8009001A
CONSTANT: NTE_PROV_TYPE_NO_MATCH HEX: 8009001B
CONSTANT: NTE_SIGNATURE_FILE_BAD HEX: 8009001C
CONSTANT: NTE_PROVIDER_DLL_FAIL HEX: 8009001D
CONSTANT: NTE_PROV_DLL_NOT_FOUND HEX: 8009001E
CONSTANT: NTE_BAD_KEYSET_PARAM HEX: 8009001F
CONSTANT: NTE_FAIL HEX: 80090020
CONSTANT: NTE_SYS_ERR HEX: 80090021
! SID is a variable length structure
TYPEDEF: void* PSID

3
core/math/math-tests.factor
View File

@ -26,6 +26,9 @@ IN: math.tests
[ f ] [ 0 <fp-nan> fp-nan? ] unit-test
[ t ] [ 0 <fp-nan> fp-infinity? ] unit-test
[ t ] [ 0.0 neg -0.0 fp-bitwise= ] unit-test
[ t ] [ -0.0 neg 0.0 fp-bitwise= ] unit-test
[ 0.0 ] [ -0.0 next-float ] unit-test
[ t ] [ 1.0 dup next-float < ] unit-test
[ t ] [ -1.0 dup next-float < ] unit-test

2
core/math/math.factor
View File

@ -60,7 +60,7 @@ PRIVATE>
: 1- ( x -- y ) 1 - ; inline
: 2/ ( x -- y ) -1 shift ; inline
: sq ( x -- y ) dup * ; inline
: neg ( x -- -x ) 0 swap - ; inline
: neg ( x -- -x ) -1 * ; inline
: recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline

11
core/parser/parser-tests.factor
View File

@ -618,4 +618,13 @@ EXCLUDE: qualified.tests.bar => x ;
[
"USE: kernel UNUSE: kernel dup" <string-reader> "unuse-test" parse-stream
] [ error>> error>> error>> no-word-error? ] must-fail-with
] [ error>> error>> error>> no-word-error? ] must-fail-with
[ ] [ [ "vocabs.loader.test.l" forget-vocab ] with-compilation-unit ] unit-test
[
[ "vocabs.loader.test.l" use-vocab ] must-fail
[ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> key? ] unit-test
[ ] [ "vocabs.loader.test.l" unuse-vocab ] unit-test
[ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> key? ] unit-test
] with-file-vocabs

4
core/vocabs/loader/test/l/l.factor Normal file
View File

@ -0,0 +1,4 @@
IN: vocabs.loader.test.l
USE: kernel
"Oops" throw

1
core/vocabs/loader/test/l/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

4
core/vocabs/parser/parser.factor
View File

@ -108,8 +108,8 @@ TUPLE: no-current-vocab ;
dup using-vocab?
[ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
manifest get
[ [ vocab-name ] dip search-vocab-names>> conjoin ]
[ [ load-vocab ] dip search-vocabs>> push ]
[ [ vocab-name ] dip search-vocab-names>> conjoin ]
2bi
] if ;
@ -121,8 +121,8 @@ TUPLE: no-current-vocab ;
: unuse-vocab ( vocab -- )
dup using-vocab? [
manifest get
[ [ vocab-name ] dip search-vocab-names>> delete-at ]
[ [ load-vocab ] dip search-vocabs>> delq ]
[ [ vocab-name ] dip search-vocab-names>> delete-at ]
2bi
] [ drop ] if ;

20
extra/mason/build/build.factor
View File

@ -1,12 +1,11 @@
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel calendar io.directories io.encodings.utf8
io.files io.launcher namespaces prettyprint mason.child mason.cleanup
mason.common mason.help mason.release mason.report mason.email
mason.notify ;
IN: mason.build
io.files io.launcher namespaces prettyprint combinators mason.child
mason.cleanup mason.common mason.help mason.release mason.report
mason.email mason.notify ;
QUALIFIED: continuations
IN: mason.build
: create-build-dir ( -- )
now datestamp stamp set
@ -18,11 +17,12 @@ QUALIFIED: continuations
"git" "clone" builds/factor 3array short-running-process ;
: begin-build ( -- )
"factor" [ git-id ] with-directory
[ "git-id" to-file ]
[ current-git-id set ]
[ notify-begin-build ]
tri ;
"factor" [ git-id ] with-directory {
[ "git-id" to-file ]
[ "factor/git-id" to-file ]
[ current-git-id set ]
[ notify-begin-build ]
} cleave ;
: build ( -- )
create-build-dir

5
extra/mason/child/child.factor
View File

@ -64,7 +64,10 @@ IN: mason.child
MACRO: recover-cond ( alist -- )
dup { [ length 1 = ] [ first callable? ] } 1&&
[ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ;
[ first ] [
[ first first2 ] [ rest ] bi
'[ _ _ [ _ recover-cond ] recover-else ]
] if ;
: build-child ( -- status )
copy-image

16
extra/mason/common/common.factor
View File

@ -1,22 +1,22 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.pathnames io.directories
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
calendar.format arrays mason.config locals debugger fry
continuations strings ;
continuations strings io.sockets ;
IN: mason.common
: short-host-name ( -- string )
host-name "." split1 drop ;
SYMBOL: current-git-id
: short-running-process ( command -- )
#! Give network operations and shell commands at most
#! 15 minutes to complete, to catch hangs.
>process
15 minutes >>timeout
+closed+ >>stdin
try-output-process ;
>process 15 minutes >>timeout try-output-process ;
HOOK: really-delete-tree os ( path -- )
@ -45,10 +45,6 @@ M: unix really-delete-tree delete-tree ;
dup utf8 file-lines parse-fresh
[ "Empty file: " swap append throw ] [ nip first ] if-empty ;
: cat ( file -- ) utf8 file-contents print ;
: cat-n ( file n -- ) [ utf8 file-lines ] dip short tail* [ print ] each ;
: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
: datestamp ( timestamp -- string )

8
extra/mason/notify/notify.factor
View File

@ -10,13 +10,13 @@ IN: mason.notify
[
"ssh" , status-host get , "-l" , status-username get ,
"./mason-notify" ,
host-name ,
short-host-name ,
target-cpu get ,
target-os get ,
] { } make prepend
[ 5 ] 2dip '[
<process>
_ [ +closed+ ] unless* >>stdin
_ >>stdin
_ >>command
short-running-process
] retry
@ -49,4 +49,6 @@ IN: mason.notify
] bi ;
: notify-release ( archive-name -- )
"Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
[ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ]
[ f swap "release" swap 2array status-notify ]
bi ;

55
extra/mason/notify/server/server.factor
View File

@ -1,26 +1,44 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.smart command-line db
db.sqlite db.tuples db.types io kernel namespaces sequences ;
db.sqlite db.tuples db.types io io.encodings.utf8 io.files
present kernel namespaces sequences calendar ;
IN: mason.notify.server
CONSTANT: +starting+ "starting"
CONSTANT: +make-vm+ "make-vm"
CONSTANT: +boot+ "boot"
CONSTANT: +test+ "test"
CONSTANT: +clean+ "clean"
CONSTANT: +dirty+ "dirty"
CONSTANT: +clean+ "status-clean"
CONSTANT: +dirty+ "status-dirty"
CONSTANT: +error+ "status-error"
TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
TUPLE: builder
host-name os cpu
clean-git-id clean-timestamp
last-release release-git-id
last-git-id last-timestamp last-report
current-git-id current-timestamp
status ;
builder "BUILDERS" {
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
{ "os" "OS" TEXT +user-assigned-id+ }
{ "cpu" "CPU" TEXT +user-assigned-id+ }
{ "clean-git-id" "CLEAN_GIT_ID" TEXT }
{ "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
{ "last-release" "LAST_RELEASE" TEXT }
{ "release-git-id" "RELEASE_GIT_ID" TEXT }
{ "last-git-id" "LAST_GIT_ID" TEXT }
{ "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
{ "last-report" "LAST_REPORT" TEXT }
{ "current-git-id" "CURRENT_GIT_ID" TEXT }
! Can't name it CURRENT_TIMESTAMP because of bug in db library
{ "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
{ "status" "STATUS" TEXT }
} define-persistent
@ -49,14 +67,23 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
: make-vm ( builder -- ) +make-vm+ >>status drop ;
: boot ( report -- ) +boot+ >>status drop ;
: boot ( builder -- ) +boot+ >>status drop ;
: test ( report -- ) +test+ >>status drop ;
: test ( builder -- ) +test+ >>status drop ;
: report ( builder status content -- )
[ >>status ] [ >>last-report ] bi*
dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when
dup status>> +clean+ = [
dup current-git-id>> >>clean-git-id
dup current-timestamp>> >>clean-timestamp
] when
dup current-git-id>> >>last-git-id
dup current-timestamp>> >>last-timestamp
drop ;
: release ( builder name -- )
>>last-release
dup clean-git-id>> >>release-git-id
drop ;
: update-builder ( builder -- )
@ -66,17 +93,25 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
{ "boot" [ boot ] }
{ "test" [ test ] }
{ "report" [ message-arg get contents report ] }
{ "release" [ message-arg get release ] }
} case ;
: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
: handle-update ( command-line -- )
: handle-update ( command-line timestamp -- )
mason-db [
parse-args find-builder
[ parse-args find-builder ] dip >>current-timestamp
[ update-builder ] [ update-tuple ] bi
] with-db ;
CONSTANT: log-file "resource:mason.log"
: log-update ( command-line timestamp -- )
log-file utf8 [
present write ": " write " " join print
] with-file-appender ;
: main ( -- )
command-line get handle-update ;
command-line get now [ log-update ] [ handle-update ] 2bi ;
MAIN: main

32
extra/mason/report/report.factor
View File

@ -4,13 +4,13 @@ USING: benchmark combinators.smart debugger fry io assocs
io.encodings.utf8 io.files io.sockets io.streams.string kernel
locals mason.common mason.config mason.platform math namespaces
prettyprint sequences xml.syntax xml.writer combinators.short-circuit
literals ;
literals splitting ;
IN: mason.report
: common-report ( -- xml )
target-os get
target-cpu get
host-name
short-host-name
build-dir
current-git-id get
[XML
@ -59,13 +59,13 @@ IN: mason.report
"test-log" "Tests failed" failed-report ;
: timings-table ( -- xml )
{
$ boot-time-file
$ load-time-file
$ test-time-file
$ help-lint-time-file
$ benchmark-time-file
$ html-help-time-file
${
boot-time-file
load-time-file
test-time-file
help-lint-time-file
benchmark-time-file
html-help-time-file
} [
dup eval-file milli-seconds>time
[XML <tr><td><-></td><td><-></td></tr> XML]
@ -121,13 +121,13 @@ IN: mason.report
] with-report ;
: build-clean? ( -- ? )
{
[ load-all-vocabs-file eval-file empty? ]
[ test-all-vocabs-file eval-file empty? ]
[ help-lint-vocabs-file eval-file empty? ]
[ compiler-errors-file eval-file empty? ]
[ benchmark-error-vocabs-file eval-file empty? ]
} 0&& ;
${
load-all-vocabs-file
test-all-vocabs-file
help-lint-vocabs-file
compiler-errors-file
benchmark-error-vocabs-file
} [ eval-file empty? ] all? ;
: success ( -- status )
successful-report build-clean? status-clean status-dirty ? ;

3
extra/math/affine-transforms/affine-transforms.factor
View File

@ -65,9 +65,6 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0
} 2cleave
[ [ 2array ] 2bi@ ] dip <affine-transform> ;
: v~ ( a b epsilon -- ? )
[ ~ ] curry 2all? ;
: a~ ( a b epsilon -- ? )
{
[ [ [ x>> ] bi@ ] dip v~ ]

1
extra/math/vectors/homogeneous/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

15
extra/math/vectors/homogeneous/homogeneous-tests.factor Normal file
View File

@ -0,0 +1,15 @@
! (c)2009 Joe Groff bsd license
USING: math.vectors.homogeneous tools.test ;
IN: math.vectors.homogeneous.tests
[ { 1.0 2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h+ ] unit-test
[ { 1.0 -2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h- ] unit-test
[ { 2.0 2.0 2.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 2.0 } h+ ] unit-test
[ { 1.0 2.0 2.0 } ] [ { 1.0 0.0 2.0 } { 0.0 2.0 2.0 } h+ ] unit-test
[ { 2.0 4.0 2.0 } ] [ 2.0 { 1.0 2.0 2.0 } n*h ] unit-test
[ { 2.0 4.0 2.0 } ] [ { 1.0 2.0 2.0 } 2.0 h*n ] unit-test
[ { 0.5 1.5 } ] [ { 1.0 3.0 2.0 } h>v ] unit-test
[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test
[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test

36
extra/math/vectors/homogeneous/homogeneous.factor Normal file
View File

@ -0,0 +1,36 @@
! (c)2009 Joe Groff bsd license
USING: kernel math math.vectors sequences ;
IN: math.vectors.homogeneous
: (homogeneous-xyz) ( h -- xyz )
1 head* ; inline
: (homogeneous-w) ( h -- w )
peek ; inline
: h+ ( a b -- c )
2dup [ (homogeneous-w) ] bi@ over =
[ [ [ (homogeneous-xyz) ] bi@ v+ ] dip suffix ] [
drop
[ [ (homogeneous-xyz) ] [ (homogeneous-w) ] bi* v*n ]
[ [ (homogeneous-w) ] [ (homogeneous-xyz) ] bi* n*v v+ ]
[ [ (homogeneous-w) ] [ (homogeneous-w) ] bi* * suffix ] 2tri
] if ;
: n*h ( n h -- nh )
[ (homogeneous-xyz) n*v ] [ (homogeneous-w) suffix ] bi ;
: h*n ( h n -- nh )
swap n*h ;
: hneg ( h -- -h )
-1.0 swap n*h ;
: h- ( a b -- c )
hneg h+ ;
: v>h ( v -- h )
1.0 suffix ;
: h>v ( h -- v )
[ (homogeneous-xyz) ] [ (homogeneous-w) ] bi v/n ;

1
extra/math/vectors/homogeneous/summary.txt Normal file
View File

@ -0,0 +1 @@
Homogeneous coordinate math

1
extra/nurbs/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

32
extra/nurbs/nurbs-tests.factor Normal file
View File

@ -0,0 +1,32 @@
! (c)2009 Joe Groff bsd license
USING: literals math math.functions math.vectors namespaces
nurbs tools.test ;
IN: nurbs.tests
SYMBOL: test-nurbs
CONSTANT: √2/2 $[ 0.5 sqrt ]
CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
! unit circle as NURBS
3 {
{ 1.0 0.0 1.0 }
{ $ √2/2 $ √2/2 $ √2/2 }
{ 0.0 1.0 1.0 }
{ $ -√2/2 $ √2/2 $ √2/2 }
{ -1.0 0.0 1.0 }
{ $ -√2/2 $ -√2/2 $ √2/2 }
{ 0.0 -1.0 1.0 }
{ $ √2/2 $ -√2/2 $ √2/2 }
{ 1.0 0.0 1.0 }
} { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set
[ t ] [ test-nurbs get 0.0 eval-nurbs { 1.0 0.0 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.25 eval-nurbs { 0.0 1.0 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test

73
extra/nurbs/nurbs.factor Normal file
View File

@ -0,0 +1,73 @@
! (c)2009 Joe Groff bsd license
USING: accessors arrays grouping kernel locals math math.order
math.ranges math.vectors math.vectors.homogeneous sequences
specialized-arrays.float ;
IN: nurbs
TUPLE: nurbs-curve
{ order integer }
control-points
knots
(knot-constants) ;
: ?recip ( n -- 1/n )
dup zero? [ recip ] unless ;
:: order-index-knot-constants ( curve order index -- knot-constants )
curve knots>> :> knots
index order 1 - + knots nth :> knot_i+k-1
index knots nth :> knot_i
index order + knots nth :> knot_i+k
index 1 + knots nth :> knot_i+1
knot_i+k-1 knot_i - ?recip :> c1
knot_i+1 knot_i+k - ?recip :> c2
knot_i c1 * neg :> c3
knot_i+k c2 * neg :> c4
c1 c2 c3 c4 float-array{ } 4sequence ;
: order-knot-constants ( curve order -- knot-constants )
2dup [ knots>> length ] dip - iota
[ order-index-knot-constants ] with with map ;
: knot-constants ( curve -- knot-constants )
2 over order>> [a,b]
[ order-knot-constants ] with map ;
: update-knots ( curve -- curve )
dup knot-constants >>(knot-constants) ;
: <nurbs-curve> ( order control-points knots -- nurbs-curve )
f nurbs-curve boa update-knots ;
: knot-interval ( nurbs-curve t -- index )
[ knots>> ] dip [ > ] curry find drop 1 - ;
: clip-range ( from to sequence -- from' to' )
length min [ 0 max ] dip ;
:: eval-base ( knot-constants bases t -- base )
knot-constants first t * knot-constants third + bases first *
knot-constants second t * knot-constants fourth + bases second *
+ ;
: (eval-curve) ( base-values control-points -- value )
[ n*v ] 2map { 0.0 0.0 0.0 } [ v+ ] binary-reduce h>v ;
:: (eval-bases) ( curve t interval values order -- values' )
order 2 - curve (knot-constants)>> nth :> all-knot-constants
interval order interval + all-knot-constants clip-range :> to :> from
from to all-knot-constants subseq :> knot-constants
values { 0.0 } { 0.0 } surround 2 <clumps> :> bases
knot-constants bases [ t eval-base ] 2map :> values'
order curve order>> =
[ values' from to curve control-points>> subseq (eval-curve) ]
[ curve t interval 1 - values' order 1 + (eval-bases) ] if ;
: eval-nurbs ( nurbs-curve t -- value )
2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ;

1
extra/nurbs/summary.txt Normal file
View File

@ -0,0 +1 @@
NURBS curve evaluation

42
extra/webapps/mason/download.xml Normal file
View File

@ -0,0 +1,42 @@
<?xml version='1.0' ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<link rel="stylesheet" href="http://factorcode.org/css/master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
<title>Factor binary package for <t:label t:name="platform" /></title>
</head>
<body>
<div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
<h1>Factor binary package for <t:label t:name="platform" /></h1>
<p>Requirements:</p>
<t:xml t:name="requirements" />
<h2>Download <t:xml t:name="package" /></h2>
<p>This package was built from GIT ID <t:xml t:name="git-id" />.</p>
<p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Getting started">get started</a> with the language.</p>
<h1>Build machine information</h1>
<table border="1">
<tr><td>Host name:</td><td><t:xml t:name="host-name" /></td></tr>
<tr><td>Current status:</td><td><t:xml t:name="status" /></td></tr>
<tr><td>Last build:</td><td><t:xml t:name="last-build" /></td></tr>
<tr><td>Last clean build:</td><td><t:xml t:name="last-clean-build" /></td></tr>
<tr><td>Binaries:</td><td><t:xml t:name="binaries" /></td></tr>
<tr><td>Clean images:</td><td><t:xml t:name="clean-images" /></td></tr>
</table>
<p><t:xml t:name="last-report" /></p>
</body>
</html>
</t:chloe>

221
extra/webapps/mason/mason.factor
View File

@ -1,15 +1,87 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators db db.tuples furnace.actions
http.server.responses kernel mason.platform mason.notify.server
mason.report math.order sequences sorting splitting xml.syntax
xml.writer io.pathnames io.encodings.utf8 io.files ;
http.server.responses http.server.dispatchers kernel mason.platform
mason.notify.server mason.report math.order sequences sorting
splitting xml.syntax xml.writer io.pathnames io.encodings.utf8
io.files present validators html.forms furnace.db urls ;
FROM: assocs => at keys values ;
IN: webapps.mason
: log-file ( -- path ) home "mason.log" append-path ;
TUPLE: mason-app < dispatcher ;
: recent-events ( -- xml )
log-file utf8 10 file-tail [XML <pre><-></pre> XML] ;
: link ( url label -- xml )
[XML <a href=<->><-></a> XML] ;
: download-link ( builder label -- xml )
[
[ URL" http://builds.factorcode.org/download" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
] dip link ;
: download-grid-cell ( cpu os -- xml )
builder new swap >>os swap >>cpu select-tuple [
dup last-release>> dup
[ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if
[XML <td class="supported"><div class="bigdiv"><-></div></td> XML]
] [
[XML <td class="doesnotexist" /> XML]
] if* ;
CONSTANT: oses
{
{ "winnt" "Windows" }
{ "macosx" "Mac OS X" }
{ "linux" "Linux" }
{ "freebsd" "FreeBSD" }
{ "netbsd" "NetBSD" }
{ "openbsd" "OpenBSD" }
}
CONSTANT: cpus
{
{ "x86.32" "x86" }
{ "x86.64" "x86-64" }
{ "ppc" "PowerPC" }
}
: download-grid ( -- xml )
oses
[ values [ [XML <th align='center' scope='col'><-></th> XML] ] map ]
[
keys
cpus [
[ nip second ] [ first ] 2bi [
swap download-grid-cell
] curry map
[XML <tr><th align='center' scope='row'><-></th><-></tr> XML]
] with map
] bi
[XML
<table id="downloads" cellspacing="0">
<tr><th class="nobg">OS/CPU</th><-></tr>
<->
</table>
XML] ;
: <download-grid-action> ( -- action )
<action>
[ download-grid xml>string "text/html" <content> ] >>display ;
: validate-os/cpu ( -- )
{
{ "os" [ v-one-line ] }
{ "cpu" [ v-one-line ] }
} validate-params ;
: current-builder ( -- builder )
builder new "os" value >>os "cpu" value >>cpu select-tuple ;
: <build-report-action> ( -- action )
<action>
[ validate-os/cpu ] >>init
[ current-builder last-report>> "text/html" <content> ] >>display ;
: git-link ( id -- link )
[ "http://github.com/slavapestov/factor/commit/" prepend ] keep
@ -19,67 +91,98 @@ IN: webapps.mason
swap current-git-id>> git-link
[XML <-> for <-> XML] ;
: current-status ( builder -- xml )
: status-string ( builder -- string )
dup status>> {
{ "status-dirty" [ drop "Dirty" ] }
{ "status-clean" [ drop "Clean" ] }
{ "status-error" [ drop "Error" ] }
{ "starting" [ "Starting" building ] }
{ "make-vm" [ "Compiling VM" building ] }
{ "boot" [ "Bootstrapping" building ] }
{ "test" [ "Testing" building ] }
{ +dirty+ [ drop "Dirty" ] }
{ +clean+ [ drop "Clean" ] }
{ +error+ [ drop "Error" ] }
{ +starting+ [ "Starting build" building ] }
{ +make-vm+ [ "Compiling VM" building ] }
{ +boot+ [ "Bootstrapping" building ] }
{ +test+ [ "Testing" building ] }
[ 2drop "Unknown" ]
} case ;
: current-status ( builder -- xml )
[ status-string ]
[ current-timestamp>> present " (as of " ")" surround ] bi
2array ;
: build-status ( git-id timestamp -- xml )
over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
: binaries-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
: latest-binary-link ( builder -- xml )
[ binaries-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
: binaries-link ( builder -- link )
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
dup [XML <a href=<->><-></a> XML] ;
binaries-url dup link ;
: clean-image-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
: clean-image-link ( builder -- link )
[ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend
dup [XML <a href=<->><-></a> XML] ;
clean-image-url dup link ;
: machine-table ( builder -- xml )
{
[ os>> ]
[ cpu>> ]
[ host-name>> "." split1 drop ]
[ current-status ]
[ last-git-id>> dup [ git-link ] when ]
[ clean-git-id>> dup [ git-link ] when ]
[ binaries-link ]
[ clean-image-link ]
} cleave
[XML
<h2><-> / <-></h2>
<table border="1">
<tr><td>Host name:</td><td><-></td></tr>
<tr><td>Current status:</td><td><-></td></tr>
<tr><td>Last build:</td><td><-></td></tr>
<tr><td>Last clean build:</td><td><-></td></tr>
<tr><td>Binaries:</td><td><-></td></tr>
<tr><td>Clean images:</td><td><-></td></tr>
</table>
XML] ;
: report-link ( builder -- xml )
[ URL" report" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
[XML <a href=<->>Latest build report</a> XML] ;
: machine-report ( -- xml )
builder new select-tuples
[ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
[ machine-table ] map ;
: requirements ( builder -- xml )
[
os>> {
{ "winnt" "Windows XP (also tested on Vista)" }
{ "macosx" "Mac OS X 10.5 Leopard" }
{ "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
{ "freebsd" "FreeBSD 7.0" }
{ "netbsd" "NetBSD 4.0" }
{ "openbsd" "OpenBSD 4.4" }
} at
] [
dup cpu>> "x86.32" = [
os>> {
{ [ dup { "winnt" "linux" "freebsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
{ [ dup { "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ t ] [ drop f ] }
} cond
] [ drop f ] if
] bi
2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ;
: build-farm-report ( -- xml )
recent-events
machine-report
[XML
<html>
<head><title>Factor build farm</title></head>
<body><h1>Recent events</h1><-> <h1>Machine status</h1><-></body>
</html>
XML] ;
: last-build-status ( builder -- xml )
[ last-git-id>> ] [ last-timestamp>> ] bi build-status ;
: clean-build-status ( builder -- xml )
[ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ;
: <download-binary-action> ( -- action )
<page-action>
[
validate-os/cpu
"os" value "cpu" value (platform) "platform" set-value
current-builder {
[ latest-binary-link "package" set-value ]
[ release-git-id>> git-link "git-id" set-value ]
[ requirements "requirements" set-value ]
[ host-name>> "host-name" set-value ]
[ current-status "status" set-value ]
[ last-build-status "last-build" set-value ]
[ clean-build-status "last-clean-build" set-value ]
[ binaries-link "binaries" set-value ]
[ clean-image-link "clean-images" set-value ]
[ report-link "last-report" set-value ]
} cleave
] >>init
{ mason-app "download" } >>template ;
: <mason-app> ( -- dispatcher )
mason-app new-dispatcher
<build-report-action> "report" add-responder
<download-binary-action> "download" add-responder
<download-grid-action> "grid" add-responder
mason-db <db-persistence> ;
: <build-farm-report-action> ( -- action )
<action>
[
mason-db [ build-farm-report xml>string ] with-db
"text/html" <content>
] >>display ;

4
extra/websites/concatenative/concatenative.factor
View File

@ -23,7 +23,8 @@ webapps.pastebin
webapps.planet
webapps.wiki
webapps.user-admin
webapps.help ;
webapps.help
webapps.mason ;
IN: websites.concatenative
: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
@ -95,6 +96,7 @@ SYMBOL: dh-file
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
home "docs" append-path <help-webapp> test-db <alloy> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
<mason-app> "builds.factorcode.org" add-responder
main-responder set-global ;
: <factor-secure-config> ( -- config )

18
vm/callstack.cpp
View File

@ -110,16 +110,18 @@ cell frame_scan(stack_frame *frame)
switch(frame_type(frame))
{
case QUOTATION_TYPE:
cell quot = frame_executing(frame);
if(quot == F)
return F;
else
{
char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
char *quot_xt = (char *)(frame_code(frame) + 1);
cell quot = frame_executing(frame);
if(quot == F)
return F;
else
{
char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
char *quot_xt = (char *)(frame_code(frame) + 1);
return tag_fixnum(quot_code_offset_to_scan(
quot,(cell)(return_addr - quot_xt)));
return tag_fixnum(quot_code_offset_to_scan(
quot,(cell)(return_addr - quot_xt)));
}
}
case WORD_TYPE:
return F;