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

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

db4
John Benediktsson 2008-12-05 13:25:03 -08:00
parent 832ebcf26f 2e31f7d792
commit 5e136b470c
123 changed files with 1121 additions and 776 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/bootstrap/image/image.factor
View File

@ -351,7 +351,12 @@ M: wrapper '
: pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ;
: check-string ( string -- )
[ 127 > ] contains?
[ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
: emit-string ( string -- ptr )
dup check-string
string type-number object tag-number [
dup length emit-fixnum
f ' emit

19
basis/cocoa/application/application.factor
View File

@ -27,17 +27,19 @@ IN: cocoa.application
: NSApp ( -- app ) NSApplication -> sharedApplication ;
: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ; inline
: next-event ( app -- event )
0 f CFRunLoopDefaultMode 1
NSAnyEventMask f CFRunLoopDefaultMode 1
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
: do-event ( app -- ? )
dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
: add-observer ( observer selector name object -- )
[
@ -49,14 +51,7 @@ FUNCTION: void NSBeep ( ) ;
[ NSNotificationCenter -> defaultCenter ] dip
-> removeObserver: ;
: finish-launching ( -- ) NSApp -> finishLaunching ;
: cocoa-app ( quot -- )
[
call
finish-launching
NSApp -> run
] with-cocoa ; inline
: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
@ -81,6 +76,6 @@ M: objc-error summary ( error -- )
running.app? [
drop
] [
"The " swap " requires you to run Factor from an application bundle."
3append throw
"The " " requires you to run Factor from an application bundle."
surround throw
] if ;

26
basis/cocoa/cocoa-tests.factor
View File

@ -1,7 +1,7 @@
IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
compiler.units ;
compiler.units math ;
CLASS: {
{ +superclass+ "NSObject" }
@ -45,3 +45,27 @@ Bar [
[ 2.0 ] [ "x" get NSRect-y ] unit-test
[ 101.0 ] [ "x" get NSRect-w ] unit-test
[ 102.0 ] [ "x" get NSRect-h ] unit-test
! Make sure that we can add methods
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "Bar" }
} {
"bar"
"NSRect"
{ "id" "SEL" }
[ 2drop test-foo "x" get ]
} {
"babb"
"int"
{ "id" "SEL" "int" }
[ 2nip sq ]
} ;
[ 144 ] [
Bar [
-> alloc -> init
dup 12 -> babb
swap -> release
] compile-call
] unit-test

44
basis/cocoa/messages/messages.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
combinators compiler compiler.alien kernel math namespaces make
parser prettyprint prettyprint.sections quotations sequences
strings words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects libc libc.private parser lexer init
core-foundation fry generalizations
continuations combinators compiler compiler.alien kernel math
namespaces make parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
memoize debugger io.encodings.ascii effects libc libc.private
parser lexer init core-foundation fry generalizations
specialized-arrays.direct.alien ;
IN: cocoa.messages
@ -85,9 +85,17 @@ MACRO: (send) ( selector super? -- quot )
\ super-send soft "break-after" set-word-prop
! Runtime introspection
: (objc-class) ( string word -- class )
dupd execute
[ ] [ "No such class: " prepend throw ] ?if ; inline
SYMBOL: class-init-hooks
class-init-hooks global [ H{ } clone or ] change-at
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
drop over class-init-hooks get at [ assert-depth ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
] if ; inline
: objc-class ( string -- class )
\ objc_getClass (objc-class) ;
@ -221,23 +229,19 @@ assoc-union alien>objc-types set-global
: class-exists? ( string -- class ) objc_getClass >boolean ;
: unless-defined ( class quot -- )
[ class-exists? ] dip unless ; inline
: define-objc-class-word ( name quot -- )
: define-objc-class-word ( quot name -- )
[ class-init-hooks get set-at ]
[
over , , \ unless-defined , dup , \ objc-class ,
] [ ] make [ "cocoa.classes" create ] dip
(( -- class )) define-declared ;
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
(( -- class )) define-declared
] bi ;
: import-objc-class ( name quot -- )
2dup unless-defined
dupd define-objc-class-word
over define-objc-class-word
'[
_
dup
objc-class register-objc-methods
objc-meta-class register-objc-methods
[ objc-class register-objc-methods ]
[ objc-meta-class register-objc-methods ] bi
] try ;
: root-class ( class -- root )

67
basis/cocoa/subclassing/subclassing.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime
compiler.units io.encodings.ascii generalizations
continuations make ;
parser sequences words cocoa.messages cocoa.runtime locals
compiler.units io.encodings.ascii continuations make fry ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
@ -12,22 +11,25 @@ IN: cocoa.subclassing
[ sel_registerName ] [ execute ] [ ascii string>alien ]
tri* ;
: throw-if-false ( YES/NO -- )
zero? [ "Failed to add method or protocol to class" throw ]
when ;
: throw-if-false ( obj what -- )
swap { f 0 } member?
[ "Failed to " prepend throw ] [ drop ] if ;
: add-method ( class sel imp types -- )
class_addMethod "add method to class" throw-if-false ;
: add-methods ( methods class -- )
swap
[ init-method class_addMethod throw-if-false ] with each ;
'[ [ _ ] dip init-method add-method ] each ;
: add-protocol ( class protocol -- )
class_addProtocol "add protocol to class" throw-if-false ;
: add-protocols ( protocols class -- )
swap [ objc-protocol class_addProtocol throw-if-false ]
with each ;
'[ [ _ ] dip objc-protocol add-protocol ] each ;
: (define-objc-class) ( protocols superclass name imeth -- )
-rot
: (define-objc-class) ( imeth protocols superclass name -- )
[ objc-class ] dip 0 objc_allocateClassPair
[ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
: encode-types ( return types -- encoding )
@ -45,28 +47,19 @@ IN: cocoa.subclassing
[ first4 prepare-method 3array ] map
] with-compilation-unit ;
: types= ( a b -- ? )
[ ascii alien>string ] bi@ = ;
: (verify-method-type) ( class sel types -- )
[ class_getInstanceMethod method_getTypeEncoding ]
dip types=
[ "Objective-C method types cannot be changed once defined" throw ]
unless ;
: verify-method-type ( class sel imp types -- class sel imp types )
4 ndup nip (verify-method-type) ;
: (redefine-objc-method) ( class method -- )
init-method ! verify-method-type
drop
[ class_getInstanceMethod ] dip method_setImplementation drop ;
:: (redefine-objc-method) ( class method -- )
method init-method [| sel imp types |
class sel class_getInstanceMethod [
imp method_setImplementation drop
] [
class sel imp types add-method
] if*
] call ;
: redefine-objc-methods ( imeth name -- )
dup class-exists? [
objc_getClass swap [ (redefine-objc-method) ] with each
] [
2drop
] if ;
objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
] [ 2drop ] if ;
SYMBOL: +name+
SYMBOL: +protocols+
@ -76,10 +69,10 @@ SYMBOL: +superclass+
clone [
prepare-methods
+name+ get "cocoa.classes" create drop
+name+ get 2dup redefine-objc-methods swap [
+protocols+ get , +superclass+ get , +name+ get , ,
\ (define-objc-class) ,
] [ ] make import-objc-class
+name+ get 2dup redefine-objc-methods swap
+protocols+ get +superclass+ get +name+ get
'[ _ _ _ _ (define-objc-class) ]
import-objc-class
] bind ;
: CLASS:

2
basis/compiler/cfg/def-use/def-use.factor
View File

@ -15,6 +15,7 @@ M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs dst/tmp-vregs ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs dst/tmp-vregs ;
M: ##set-string-nth-fast defs-vregs temp>> 1array ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
@ -31,6 +32,7 @@ M: ##slot-imm uses-vregs obj>> 1array ;
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##compare-imm-branch uses-vregs src1>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;

1
basis/compiler/cfg/instructions/instructions.factor
View File

@ -73,6 +73,7 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
! String element access
INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ;
! Integer arithmetic
INSN: ##add < ##commutative ;

2
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -45,6 +45,7 @@ IN: compiler.cfg.intrinsics
slots.private:slot
slots.private:set-slot
strings.private:string-nth
strings.private:set-string-nth-fast
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
@ -126,6 +127,7 @@ IN: compiler.cfg.intrinsics
{ \ slots.private:slot [ emit-slot iterate-next ] }
{ \ slots.private:set-slot [ emit-set-slot iterate-next ] }
{ \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
{ \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
{ \ arrays:<array> [ emit-<array> iterate-next ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }

4
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -54,3 +54,7 @@ IN: compiler.cfg.intrinsics.slots
: emit-string-nth ( -- )
2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
: emit-set-string-nth-fast ( -- )
3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
swap i ##set-string-nth-fast ;

8
basis/compiler/codegen/codegen.factor
View File

@ -131,6 +131,14 @@ M: ##string-nth generate-insn
[ temp>> register ]
} cleave %string-nth ;
M: ##set-string-nth-fast generate-insn
{
[ src>> register ]
[ obj>> register ]
[ index>> register ]
[ temp>> register ]
} cleave %set-string-nth-fast ;
: dst/src ( insn -- dst src )
[ dst>> register ] [ src>> register ] bi ; inline

2
basis/compiler/codegen/fixup/fixup.factor
View File

@ -9,7 +9,7 @@ IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
: code-format 22 getenv ;
: code-format ( -- n ) 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;

2
basis/compiler/tree/builder/builder.factor
View File

@ -21,7 +21,7 @@ IN: compiler.tree.builder
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
[ >vector meta-d set ]
[ >vector \ meta-d set ]
[ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;

26
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -20,6 +20,10 @@ SYMBOL: node-count
: count-nodes ( nodes -- )
0 swap [ drop 1+ ] each-node node-count set ;
! We try not to inline the same word too many times, to avoid
! combinatorial explosion
SYMBOL: inlining-count
! Splicing nodes
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
@ -120,17 +124,25 @@ DEFER: (flat-length)
bi and
] contains? ;
: node-count-bias ( -- n )
45 node-count get [-] 8 /i ;
: body-length-bias ( word -- n )
[ flat-length ] [ inlining-count get at 0 or ] bi
over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
: inlining-rank ( #call word -- n )
[ classes-known? 2 0 ? ]
[
{
[ drop node-count get 45 swap [-] 8 /i ]
[ flat-length 24 swap [-] 4 /i ]
[ body-length-bias ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
] bi* + + + + + ;
node-count-bias
loop-nesting get 0 or 2 *
] bi* + + + + + + ;
: should-inline? ( #call word -- ? )
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
@ -138,12 +150,12 @@ DEFER: (flat-length)
SYMBOL: history
: remember-inlining ( word -- )
history [ swap suffix ] change ;
[ [ 1 ] dip inlining-count get at+ ]
[ history [ swap suffix ] change ]
bi ;
: inline-word-def ( #call word quot -- ? )
over history get memq? [
3drop f
] [
over history get memq? [ 3drop f ] [
[
swap remember-inlining
dupd splicing-nodes >>body

7
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -144,10 +144,9 @@ most-negative-fixnum most-positive-fixnum [a,b]
comparison-ops
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
generic-comparison-ops [
dup specific-comparison
'[ _ _ define-comparison-constraints ] each-derived-op
] each
! generic-comparison-ops [
! dup specific-comparison define-comparison-constraints
! ] each
! Remove redundant comparisons
: fold-comparison ( info1 info2 word -- info )

2
basis/compiler/tree/propagation/nodes/nodes.factor
View File

@ -6,6 +6,8 @@ compiler.tree.propagation.copy
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.nodes
SYMBOL: loop-nesting
GENERIC: propagate-before ( node -- )
GENERIC: propagate-after ( node -- )

1
basis/compiler/tree/propagation/propagation.factor
View File

@ -19,5 +19,6 @@ IN: compiler.tree.propagation
H{ } clone copies set
H{ } clone 1array value-infos set
H{ } clone 1array constraints set
H{ } clone inlining-count set
dup count-nodes
dup (propagate) ;

4
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive
M: #recursive propagate-around ( #recursive -- )
constraints [ H{ } clone suffix ] change
[
loop-nesting inc
constraints [ but-last H{ } clone suffix ] change
child>>
@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- )
[ first propagate-recursive-phi ]
[ (propagate) ]
tri
loop-nesting dec
] until-fixed-point ;
: recursive-phi-infos ( node -- infos )

1
basis/cpu/architecture/architecture.factor
View File

@ -59,6 +59,7 @@ HOOK: %set-slot cpu ( src obj slot tag temp -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
HOOK: %string-nth cpu ( dst obj index temp -- )
HOOK: %set-string-nth-fast cpu ( ch obj index temp -- )
HOOK: %add cpu ( dst src1 src2 -- )
HOOK: %add-imm cpu ( dst src1 src2 -- )

23
basis/cpu/x86/x86.factor
View File

@ -365,23 +365,38 @@ M:: x86 %box-alien ( dst src temp -- )
M:: x86 %string-nth ( dst src index temp -- )
"end" define-label
dst { src index temp } [| new-dst |
! Load the least significant 7 bits into new-dst.
! 8th bit indicates whether we have to load from
! the aux vector or not.
temp src index [+] LEA
new-dst 1 small-reg temp string-offset [+] MOV
new-dst new-dst 1 small-reg MOVZX
! Do we have to look at the aux vector?
new-dst HEX: 80 CMP
"end" get JL
! Yes, this is a non-ASCII character. Load aux vector
temp src string-aux-offset [+] MOV
temp \ f tag-number CMP
"end" get JE
new-dst temp XCHG
! Compute index
new-dst index ADD
new-dst index ADD
! Load high 16 bits
new-dst 2 small-reg new-dst byte-array-offset [+] MOV
new-dst new-dst 2 small-reg MOVZX
new-dst 8 SHL
new-dst temp OR
new-dst 7 SHL
! Compute code point
new-dst temp XOR
"end" resolve-label
dst new-dst ?MOV
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str } [| new-ch |
new-ch ch ?MOV
temp str index [+] LEA
temp string-offset [+] new-ch 1 small-reg MOV
] with-small-register ;
:: %alien-integer-getter ( dst src size quot -- )
dst { src } [| new-dst |
new-dst dup size small-reg dup src [] MOV

6
basis/debugger/debugger.factor
View File

@ -72,12 +72,6 @@ M: string error. print ;
: try ( quot -- )
[ print-error-and-restarts ] recover ;
M: relative-underflow summary
drop "Too many items removed from data stack" ;
M: relative-overflow summary
drop "Superfluous items pushed to data stack" ;
: expired-error. ( obj -- )
"Object did not survive image save/load: " write third . ;

5
basis/editors/scite/scite.factor
View File

@ -14,7 +14,10 @@ IN: editors.scite
: scite-path ( -- path )
\ scite-path get-global [
program-files "wscite\\SciTE.exe" append-path
program-files "ScITE Source Code Editor\\SciTE.exe" append-path
dup exists? [
drop program-files "wscite\\SciTE.exe" append-path
] unless
] unless* ;
: scite-command ( file line -- cmd )

2
basis/functors/functors.factor
View File

@ -17,7 +17,7 @@ IN: functors
scan-param parsed
scan {
{ ";" [ tuple parsed f parsed ] }
{ "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] }
{ "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
[
[ tuple parsed ] dip
[ parse-slot-name [ parse-tuple-slots ] when ] { }

23
basis/help/lint/lint.factor
View File

@ -67,7 +67,7 @@ IN: help.lint
vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
] each ;
: check-rendering ( word element -- )
: check-rendering ( element -- )
[ print-topic ] with-string-writer drop ;
: all-word-help ( words -- seq )
@ -87,13 +87,14 @@ M: help-error error.
: check-word ( word -- )
dup word-help [
[
dup word-help [
2dup check-examples
2dup check-values
2dup check-see-also
2dup nip check-modules
2dup drop check-rendering
] assert-depth 2drop
dup word-help '[
_ _ {
[ check-examples ]
[ check-values ]
[ check-see-also ]
[ [ check-rendering ] [ check-modules ] bi* ]
} 2cleave
] assert-depth
] check-something
] [ drop ] if ;
@ -101,9 +102,9 @@ M: help-error error.
: check-article ( article -- )
[
dup article-content [
2dup check-modules check-rendering
] assert-depth 2drop
dup article-content
'[ _ check-rendering _ check-modules ]
assert-depth
] check-something ;
: files>vocabs ( -- assoc )

1
basis/html/templates/chloe/chloe.factor
View File

@ -4,6 +4,7 @@ USING: accessors kernel sequences combinators kernel fry
namespaces make classes.tuple assocs splitting words arrays io
io.files io.encodings.utf8 io.streams.string unicode.case
mirrors math urls present multiline quotations xml logging
continuations
xml.data
html.forms
html.elements

2
basis/html/templates/chloe/compiler/compiler.factor
View File

@ -3,7 +3,7 @@
USING: assocs namespaces make kernel sequences accessors
combinators strings splitting io io.streams.string present
xml.writer xml.data xml.entities html.forms
html.templates html.templates.chloe.syntax ;
html.templates html.templates.chloe.syntax continuations ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )

8
basis/io/windows/mmap/mmap-tests.factor
View File

@ -1,8 +0,0 @@
USING: io io.mmap io.files kernel tools.test continuations
sequences io.encodings.ascii accessors ;
IN: io.windows.mmap.tests
[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
[ ] [ "mmap-grow-test.txt" temp-file 100 [ [ ] change-each ] with-mapped-file ] unit-test
[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

2
basis/logging/server/server.factor
View File

@ -26,7 +26,7 @@ SYMBOL: log-files
: log-stream ( service -- stream )
log-files get [ open-log-stream ] cache ;
: multiline-header 20 CHAR: - <string> ; foldable
: multiline-header ( -- string ) 20 CHAR: - <string> ; foldable
: (write-message) ( msg name>> level multi? -- )
[

51
basis/random/mersenne-twister/mersenne-twister.factor
View File

@ -11,48 +11,39 @@ IN: random.mersenne-twister
TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
: mt-n 624 ; inline
: mt-m 397 ; inline
: mt-a HEX: 9908b0df ; inline
: n 624 ; inline
: m 397 ; inline
: a uint-array{ 0 HEX: 9908b0df } ; inline
: mersenne-wrap ( n -- n' )
dup mt-n > [ mt-n - ] when ; inline
: y ( n seq -- y )
[ nth-unsafe 31 mask-bit ]
[ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
: wrap-nth ( n seq -- obj )
[ mersenne-wrap ] dip nth-unsafe ; inline
: set-wrap-nth ( obj n seq -- )
[ mersenne-wrap ] dip set-nth-unsafe ; inline
: calculate-y ( n seq -- y )
[ wrap-nth 31 mask-bit ]
[ [ 1+ ] [ wrap-nth ] bi* 31 bits ] 2bi bitor ; inline
: (mt-generate) ( n seq -- next-mt )
: mt[k] ( offset n seq -- )
[
calculate-y
[ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
] [
[ mt-m + ] [ wrap-nth ] bi*
] 2bi bitxor ; inline
[ [ + ] dip nth-unsafe ]
[ y [ 2/ ] [ 1 bitand a nth ] bi bitxor ] 2bi
bitxor
] 2keep set-nth-unsafe ; inline
: mt-generate ( mt -- )
[
mt-n swap seq>> '[
_ [ (mt-generate) ] [ set-wrap-nth ] 2bi
] each
seq>>
[ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
[ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
bi
] [ 0 >>i drop ] bi ; inline
: init-mt-formula ( i seq -- f(seq[i]) )
dupd wrap-nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
: init-mt-rest ( seq -- )
mt-n 1- swap '[
_ [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi
n 1- swap '[
_ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
] each ; inline
: init-mt-seq ( seed -- seq )
32 bits mt-n <uint-array>
32 bits n <uint-array>
[ set-first ] [ init-mt-rest ] [ ] tri ; inline
: mt-temper ( y -- yt )
@ -62,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
dup -18 shift bitxor ; inline
: next-index ( mt -- i )
dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; inline
dup i>> dup n < [ nip ] [ drop mt-generate 0 ] if ; inline
PRIVATE>
@ -75,7 +66,7 @@ M: mersenne-twister seed-random ( mt seed -- )
M: mersenne-twister random-32* ( mt -- r )
[ next-index ]
[ seq>> wrap-nth mt-temper ]
[ seq>> nth-unsafe mt-temper ]
[ [ 1+ ] change-i drop ] tri ;
USE: init

2
basis/specialized-arrays/direct/functor/functor.factor
View File

@ -20,7 +20,7 @@ SET-NTH [ T dup c-setter array-accessor ]
WHERE
TUPLE: A
{ underlying alien read-only }
{ underlying c-ptr read-only }
{ length fixnum read-only } ;
: <A> ( alien len -- direct-array ) A boa ; inline

11
basis/stack-checker/backend/backend-tests.factor
View File

@ -3,20 +3,21 @@ stack-checker.state sequences ;
IN: stack-checker.backend.tests
[ ] [
V{ } clone meta-d set
V{ } clone meta-r set
V{ } clone \ meta-d set
V{ } clone \ meta-r set
V{ } clone \ literals set
0 d-in set
] unit-test
[ 0 ] [ 0 ensure-d length ] unit-test
[ 2 ] [ 2 ensure-d length ] unit-test
[ 2 ] [ meta-d get length ] unit-test
[ 2 ] [ meta-d length ] unit-test
[ 3 ] [ 3 ensure-d length ] unit-test
[ 3 ] [ meta-d get length ] unit-test
[ 3 ] [ meta-d length ] unit-test
[ 1 ] [ 1 ensure-d length ] unit-test
[ 3 ] [ meta-d get length ] unit-test
[ 3 ] [ meta-d length ] unit-test
[ ] [ 1 consume-d drop ] unit-test

72
basis/stack-checker/backend/backend.factor
View File

@ -9,10 +9,10 @@ stack-checker.visitor stack-checker.errors
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d get push ;
: push-d ( obj -- ) meta-d push ;
: pop-d ( -- obj )
meta-d get [
meta-d [
<value> dup 1array #introduce, d-in inc
] [ pop ] if-empty ;
@ -22,46 +22,52 @@ IN: stack-checker.backend
[ <value> ] replicate ;
: ensure-d ( n -- values )
meta-d get 2dup length > [
meta-d 2dup length > [
2dup
[ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
[ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri
meta-d get push-all
[ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri
meta-d push-all
] when swap tail* ;
: shorten-by ( n seq -- )
[ length swap - ] keep shorten ; inline
: consume-d ( n -- seq )
[ ensure-d ] [ meta-d get shorten-by ] bi ;
[ ensure-d ] [ meta-d shorten-by ] bi ;
: output-d ( values -- ) meta-d get push-all ;
: output-d ( values -- ) meta-d push-all ;
: produce-d ( n -- values )
make-values dup meta-d get push-all ;
make-values dup meta-d push-all ;
: push-r ( obj -- ) meta-r get push ;
: push-r ( obj -- ) meta-r push ;
: pop-r ( -- obj )
meta-r get dup empty?
: pop-r ( -- obj )
meta-r dup empty?
[ too-many-r> inference-error ] [ pop ] if ;
: consume-r ( n -- seq )
meta-r get 2dup length >
meta-r 2dup length >
[ too-many-r> inference-error ] when
[ swap tail* ] [ shorten-by ] 2bi ;
: output-r ( seq -- ) meta-r get push-all ;
: pop-literal ( -- rstate obj )
pop-d
[ 1array #drop, ]
[ literal [ recursion>> ] [ value>> ] bi ] bi ;
GENERIC: apply-object ( obj -- )
: output-r ( seq -- ) meta-r push-all ;
: push-literal ( obj -- )
dup <literal> make-known [ nip push-d ] [ #push, ] 2bi ;
literals get push ;
: pop-literal ( -- rstate obj )
literals get [
pop-d
[ 1array #drop, ]
[ literal [ recursion>> ] [ value>> ] bi ] bi
] [ pop recursive-state get swap ] if-empty ;
: literals-available? ( n -- literals ? )
literals get 2dup length <=
[ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ;
GENERIC: apply-object ( obj -- )
M: wrapper apply-object
wrapped>>
@ -72,10 +78,17 @@ M: wrapper apply-object
M: object apply-object push-literal ;
: terminate ( -- )
terminated? on meta-d get clone meta-r get clone #terminate, ;
terminated? on meta-d clone meta-r clone #terminate, ;
: check->r ( -- )
meta-r empty? [ \ too-many->r inference-error ] unless ;
: infer-quot-here ( quot -- )
[ apply-object terminated? get not ] all? drop ;
meta-r [
V{ } clone \ meta-r set
[ apply-object terminated? get not ] all?
[ commit-literals check->r ] [ literals get delete-all ] if
] dip \ meta-r set ;
: infer-quot ( quot rstate -- )
recursive-state get [
@ -103,10 +116,10 @@ M: object apply-object push-literal ;
] if ;
: infer->r ( n -- )
consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ;
consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
: infer-r> ( n -- )
consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ;
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
: undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ;
@ -127,20 +140,15 @@ M: object apply-object push-literal ;
: infer-word-def ( word -- )
[ specialized-def ] [ add-recursive-state ] bi infer-quot ;
: check->r ( -- )
meta-r get empty? terminated? get or
[ \ too-many->r inference-error ] unless ;
: end-infer ( -- )
check->r
meta-d get clone #return, ;
meta-d clone #return, ;
: effect-required? ( word -- ? )
{
{ [ dup inline? ] [ drop f ] }
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
[ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
[ def>> [ word? ] contains? ]
} cond ;
: ?missing-effect ( word -- )

41
basis/stack-checker/branches/branches.factor
View File

@ -57,9 +57,9 @@ SYMBOL: quotations
branch-variable ;
: datastack-phi ( seq -- phi-in phi-out )
[ d-in branch-variable ] [ meta-d active-variable ] bi
[ d-in branch-variable ] [ \ meta-d active-variable ] bi
unify-branches
[ d-in set ] [ ] [ dup >vector meta-d set ] tri* ;
[ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ;
: terminated-phi ( seq -- terminated )
terminated? branch-variable ;
@ -74,17 +74,25 @@ SYMBOL: quotations
tri ;
: copy-inference ( -- )
meta-d [ clone ] change
V{ } clone meta-r set
\ meta-d [ clone ] change
literals [ clone ] change
d-in [ ] change ;
: infer-branch ( literal -- namespace )
GENERIC: infer-branch ( literal -- namespace )
M: literal infer-branch
[
copy-inference
nest-visitor
[ value>> quotation set ] [ infer-literal-quot ] bi
check->r
] H{ } make-assoc ; inline
] H{ } make-assoc ;
M: callable infer-branch
[
copy-inference
nest-visitor
[ quotation set ] [ infer-quot-here ] bi
] H{ } make-assoc ;
: infer-branches ( branches -- input children data )
[ pop-d ] dip
@ -96,16 +104,19 @@ SYMBOL: quotations
[ first2 #if, ] dip compute-phi-function ;
: infer-if ( -- )
2 consume-d
dup [ known [ curried? ] [ composed? ] bi or ] contains? [
output-d
[ rot [ drop call ] [ nip call ] if ]
infer-quot-here
2 literals-available? [
(infer-if)
] [
[ #drop, ] [ [ literal ] map (infer-if) ] bi
drop 2 consume-d
dup [ known [ curried? ] [ composed? ] bi or ] contains? [
output-d
[ rot [ drop call ] [ nip call ] if ]
infer-quot-here
] [
[ #drop, ] [ [ literal ] map (infer-if) ] bi
] if
] if ;
: infer-dispatch ( -- )
pop-literal nip [ <literal> ] map
infer-branches
pop-literal nip infer-branches
[ #dispatch, ] dip compute-phi-function ;

17
basis/stack-checker/inlining/inlining.factor
View File

@ -51,14 +51,14 @@ SYMBOL: enter-out
: prepare-stack ( word -- )
required-stack-effect in>>
[ length ensure-d drop ] [
meta-d get clone enter-in set
meta-d get swap make-copies enter-out set
meta-d clone enter-in set
meta-d swap make-copies enter-out set
] bi ;
: emit-enter-recursive ( label -- )
enter-out get >>enter-out
enter-in get enter-out get #enter-recursive,
enter-out get >vector meta-d set ;
enter-out get >vector \ meta-d set ;
: entry-stack-height ( label -- stack )
enter-out>> length ;
@ -77,7 +77,7 @@ SYMBOL: enter-out
: end-recursive-word ( word label -- )
[ check-return ]
[ meta-d get dup copy-values dup meta-d set #return-recursive, ]
[ meta-d dup copy-values dup \ meta-d set #return-recursive, ]
bi ;
: recursive-word-inputs ( label -- n )
@ -95,10 +95,8 @@ SYMBOL: enter-out
[ nip ]
2tri
check->r
dup recursive-word-inputs
meta-d get
meta-d
stack-visitor get
terminated? get
] with-scope ;
@ -116,7 +114,7 @@ SYMBOL: enter-out
swap word>> required-stack-effect in>> length tail* ;
: call-site-stack ( label -- stack )
meta-d get trim-stack ;
meta-d trim-stack ;
: trimmed-enter-out ( label -- stack )
dup enter-out>> trim-stack ;
@ -131,7 +129,7 @@ SYMBOL: enter-out
: adjust-stack-effect ( effect -- effect' )
[ in>> ] [ out>> ] bi
meta-d get length pick length [-]
meta-d length pick length [-]
object <repetition> '[ _ prepend ] bi@
<effect> ;
@ -142,6 +140,7 @@ SYMBOL: enter-out
] [ drop undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
commit-literals
[ inlined-dependency depends-on ]
[
dup inline-recursive-label [

55
basis/stack-checker/known-words/known-words.factor
View File

@ -63,7 +63,9 @@ IN: stack-checker.known-words
GENERIC: infer-call* ( value known -- )
: infer-call ( value -- ) dup known infer-call* ;
: (infer-call) ( value -- ) dup known infer-call* ;
: infer-call ( -- ) pop-d (infer-call) ;
M: literal infer-call*
[ 1array #drop, ] [ infer-literal-quot ] bi* ;
@ -73,7 +75,7 @@ M: curried infer-call*
[ uncurry ] infer-quot-here
[ quot>> known pop-d [ set-known ] keep ]
[ obj>> known pop-d [ set-known ] keep ] bi
push-d infer-call ;
push-d (infer-call) ;
M: composed infer-call*
swap push-d
@ -81,20 +83,41 @@ M: composed infer-call*
[ quot2>> known pop-d [ set-known ] keep ]
[ quot1>> known pop-d [ set-known ] keep ] bi
push-d push-d
1 infer->r pop-d infer-call
terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
1 infer->r infer-call
terminated? get [ 1 infer-r> infer-call ] unless ;
M: object infer-call*
\ literal-expected inference-warning ;
: infer-slip ( -- )
1 infer->r pop-d infer-call 1 infer-r> ;
1 infer->r infer-call 1 infer-r> ;
: infer-2slip ( -- )
2 infer->r pop-d infer-call 2 infer-r> ;
2 infer->r infer-call 2 infer-r> ;
: infer-3slip ( -- )
3 infer->r pop-d infer-call 3 infer-r> ;
3 infer->r infer-call 3 infer-r> ;
: infer-dip ( -- )
commit-literals
literals get
[ \ dip def>> infer-quot-here ]
[ pop 1 infer->r infer-quot-here 1 infer-r> ]
if-empty ;
: infer-2dip ( -- )
commit-literals
literals get
[ \ 2dip def>> infer-quot-here ]
[ pop 2 infer->r infer-quot-here 2 infer-r> ]
if-empty ;
: infer-3dip ( -- )
commit-literals
literals get
[ \ 3dip def>> infer-quot-here ]
[ pop 3 infer->r infer-quot-here 3 infer-r> ]
if-empty ;
: infer-curry ( -- )
2 consume-d
@ -157,11 +180,14 @@ M: object infer-call*
{ \ >r [ 1 infer->r ] }
{ \ r> [ 1 infer-r> ] }
{ \ declare [ infer-declare ] }
{ \ call [ pop-d infer-call ] }
{ \ (call) [ pop-d infer-call ] }
{ \ call [ infer-call ] }
{ \ (call) [ infer-call ] }
{ \ slip [ infer-slip ] }
{ \ 2slip [ infer-2slip ] }
{ \ 3slip [ infer-3slip ] }
{ \ dip [ infer-dip ] }
{ \ 2dip [ infer-2dip ] }
{ \ 3dip [ infer-3dip ] }
{ \ curry [ infer-curry ] }
{ \ compose [ infer-compose ] }
{ \ execute [ infer-execute ] }
@ -190,10 +216,10 @@ M: object infer-call*
"local-word-def" word-prop infer-quot-here ;
{
>r r> declare call (call) slip 2slip 3slip curry compose
execute (execute) if dispatch <tuple-boa> (throw)
load-locals get-local drop-locals do-primitive alien-invoke
alien-indirect alien-callback
>r r> declare call (call) slip 2slip 3slip dip 2dip 3dip
curry compose execute (execute) if dispatch <tuple-boa>
(throw) load-locals get-local drop-locals do-primitive
alien-invoke alien-indirect alien-callback
} [ t "special" set-word-prop ] each
{ call execute dispatch load-locals get-local drop-locals }
@ -536,7 +562,8 @@ M: object infer-call*
\ string-nth { fixnum string } { fixnum } define-primitive
\ string-nth make-flushable
\ set-string-nth { fixnum fixnum string } { } define-primitive
\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
\ resize-array { integer array } { array } define-primitive
\ resize-array make-flushable

31
basis/stack-checker/state/state.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs arrays namespaces sequences kernel definitions
math effects accessors words fry classes.algebra
compiler.units ;
compiler.units stack-checker.values stack-checker.visitor ;
IN: stack-checker.state
! Did the current control-flow path throw an error?
@ -11,23 +11,40 @@ SYMBOL: terminated?
! Number of inputs current word expects from the stack
SYMBOL: d-in
DEFER: commit-literals
! Compile-time data stack
SYMBOL: meta-d
: meta-d ( -- stack ) commit-literals \ meta-d get ;
! Compile-time retain stack
SYMBOL: meta-r
: meta-r ( -- stack ) \ meta-r get ;
: current-stack-height ( -- n ) meta-d get length d-in get - ;
! Uncommitted literals. This is a form of local dead-code
! elimination; the goal is to reduce the number of IR nodes
! which get constructed. Technically it is redundant since
! we do global DCE later, but it speeds up compile time.
SYMBOL: literals
: (push-literal) ( obj -- )
dup <literal> make-known
[ nip \ meta-d get push ] [ #push, ] 2bi ;
: commit-literals ( -- )
literals get [
[ [ (push-literal) ] each ] [ delete-all ] bi
] unless-empty ;
: current-stack-height ( -- n ) meta-d length d-in get - ;
: current-effect ( -- effect )
d-in get
meta-d get length <effect>
meta-d length <effect>
terminated? get >>terminated? ;
: init-inference ( -- )
terminated? off
V{ } clone meta-d set
V{ } clone meta-r set
V{ } clone \ meta-d set
V{ } clone literals set
0 d-in set ;
! Words that the current quotation depends on

7
basis/stack-checker/transforms/transforms.factor
View File

@ -19,11 +19,8 @@ IN: stack-checker.transforms
rot with-datastack first2
dup [
[
[ drop ] [
[ length meta-d get '[ _ pop* ] times ]
[ #drop, ]
bi
] bi*
[ drop ]
[ [ length meta-d shorten-by ] [ #drop, ] bi ] bi*
] 2dip
swap infer-quot
] [

5
basis/threads/threads-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private io
threads.private continuations init quotations strings
assocs heaps boxes namespaces deques ;
assocs heaps boxes namespaces deques dlists ;
IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads"
@ -82,7 +82,7 @@ $nl
{ $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link <thread> } " then passed to " { $link (spawn) } "." } ;
HELP: run-queue
{ $values { "queue" deque } }
{ $values { "dlist" dlist } }
{ $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time."
$nl
"By convention, threads are queued with " { $link push-front }
@ -97,6 +97,7 @@ HELP: resume-with
{ $description "Adds a thread to the end of the run queue together with an object to pass to the thread. The thread must have previously been suspended by a call to " { $link suspend } "; the object is returned from the " { $link suspend } " call." } ;
HELP: sleep-queue
{ $values { "heap" min-heap } }
{ $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ;
HELP: sleep-time

6
basis/threads/threads.factor
View File

@ -36,7 +36,7 @@ sleep-entry ;
: tchange ( key quot -- )
tnamespace swap change-at ; inline
: threads 64 getenv ;
: threads ( -- assoc ) 64 getenv ;
: thread ( id -- thread ) threads at ;
@ -73,9 +73,9 @@ PRIVATE>
: <thread> ( quot name -- thread )
\ thread new-thread ;
: run-queue 65 getenv ;
: run-queue ( -- dlist ) 65 getenv ;
: sleep-queue 66 getenv ;
: sleep-queue ( -- heap ) 66 getenv ;
: resume ( thread -- )
f >>state

2
basis/tools/test/test-docs.factor
View File

@ -86,7 +86,7 @@ HELP: test-all
{ $description "Runs unit tests for all loaded vocabularies." } ;
HELP: run-all-tests
{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
{ $values { "failures" "an association list of unit test failures" } }
{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
HELP: test-failures.

4
basis/tools/test/test-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: tools.test.tests
USING: tools.test ;
\ test-all must-infer

2
basis/tools/test/test.factor
View File

@ -88,7 +88,7 @@ SYMBOL: this-test
: test ( prefix -- )
run-tests test-failures. ;
: run-all-tests ( prefix -- failures )
: run-all-tests ( -- failures )
"" run-tests ;
: test-all ( -- )

21
basis/ui/cocoa/cocoa.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math arrays cocoa cocoa.application
USING: accessors math arrays assocs 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
@ -96,16 +96,29 @@ M: cocoa-ui-backend flush-gl-context ( handle -- )
M: cocoa-ui-backend beep ( -- )
NSBeep ;
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "FactorApplicationDelegate" }
}
{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" }
[ 3drop event-loop ]
} ;
: install-app-delegate ( -- )
NSApp FactorApplicationDelegate install-delegate ;
SYMBOL: cocoa-init-hook
cocoa-init-hook global [ [ install-app-delegate ] or ] change-at
M: cocoa-ui-backend ui
"UI" assert.app [
[
init-clipboard
cocoa-init-hook get [ call ] when*
cocoa-init-hook get call
start-ui
finish-launching
event-loop
NSApp -> run
] ui-running
] with-cocoa ;

6
basis/ui/cocoa/tools/tools.factor
View File

@ -20,8 +20,8 @@ IN: ui.cocoa.tools
! Handle Open events from the Finder
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "FactorApplicationDelegate" }
{ +superclass+ "FactorApplicationDelegate" }
{ +name+ "FactorWorkspaceApplicationDelegate" }
}
{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
@ -49,7 +49,7 @@ CLASS: {
} ;
: install-app-delegate ( -- )
NSApp FactorApplicationDelegate install-delegate ;
NSApp FactorWorkspaceApplicationDelegate install-delegate ;
! Service support; evaluate Factor code from other apps
:: do-service ( pboard error quot -- )

2
basis/unicode/breaks/breaks.factor
View File

@ -72,7 +72,7 @@ VALUE: grapheme-table
grapheme-table nth nth not ;
: chars ( i str n -- str[i] str[i+n] )
swap >r dupd + r> [ ?nth ] curry bi@ ;
swap [ dupd + ] dip [ ?nth ] curry bi@ ;
: find-index ( seq quot -- i ) find drop ; inline
: find-last-index ( seq quot -- i ) find-last drop ; inline

2
basis/unicode/collation/collation.factor
View File

@ -124,7 +124,7 @@ PRIVATE>
[ zero? ] tri@ and and ;
: filter-ignorable ( weights -- weights' )
>r f r> [
f swap [
tuck primary>> zero? and
[ swap ignorable?>> or ]
[ swap completely-ignorable? or not ] 2bi

2
core/arrays/arrays.factor
View File

@ -16,8 +16,6 @@ M: object new-sequence drop f <array> ;
M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
M: array like drop dup array? [ >array ] unless ;
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;

3
core/bootstrap/primitives.factor
View File

@ -499,7 +499,8 @@ tuple
{ "alien-address" "alien" }
{ "set-slot" "slots.private" }
{ "string-nth" "strings.private" }
{ "set-string-nth" "strings.private" }
{ "set-string-nth-fast" "strings.private" }
{ "set-string-nth-slow" "strings.private" }
{ "resize-array" "arrays" }
{ "resize-string" "strings" }
{ "<array>" "arrays" }

1
core/byte-arrays/byte-arrays.factor
View File

@ -9,7 +9,6 @@ M: byte-array length length>> ;
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
M: byte-array new-sequence drop <byte-array> ;
M: byte-array equal?

15
core/byte-vectors/byte-vectors.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays ;
sequences.private growable byte-arrays accessors ;
IN: byte-vectors
TUPLE: byte-vector
@ -26,6 +26,19 @@ M: byte-vector new-sequence
M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ;
M: byte-array like
#! If we have an byte-array, we're done.
#! If we have a byte-vector, and it's at full capacity,
#! we're done. Otherwise, call resize-byte-array, which is a
#! relatively fast primitive.
drop dup byte-array? [
dup byte-vector? [
[ length ] [ underlying>> ] bi
2dup length eq?
[ nip ] [ resize-byte-array ] if
] [ >byte-array ] if
] unless ;
M: byte-array new-resizable drop <byte-vector> ;
INSTANCE: byte-vector growable

12
core/combinators/combinators-docs.factor
View File

@ -29,17 +29,9 @@ $nl
$nl
"A combinator which can help with implementing methods on " { $link hashcode* } ":"
{ $subsection recursive-hashcode }
{ $subsection "assertions" }
{ $subsection "combinators-quot" }
{ $see-also "quotations" "dataflow" } ;
ARTICLE: "assertions" "Assertions"
"Some words to make assertions easier to enforce:"
{ $subsection assert }
{ $subsection assert= }
"Runtime stack depth checking:"
{ $subsection assert-depth } ;
ABOUT: "combinators"
HELP: cleave
@ -167,7 +159,3 @@ HELP: dispatch ( n array -- )
{ $values { "n" "a fixnum" } { "array" "an array of quotations" } }
{ $description "Calls the " { $snippet "n" } "th quotation in the array." }
{ $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is an implementation detail used by the generic word system to accelerate method dispatch. It does not perform type or bounds checks, and user code should not need to call it directly." } ;
HELP: assert-depth
{ $values { "quot" "a quotation" } }
{ $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ;

16
core/combinators/combinators.factor
View File

@ -134,22 +134,6 @@ ERROR: no-case ;
[ drop linear-case-quot ]
} cond ;
! assert-depth
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
2dup [ length ] bi@ min tuck [ tail ] 2bi@ ;
ERROR: relative-underflow stack ;
ERROR: relative-overflow stack ;
: assert-depth ( quot -- )
[ datastack ] dip dip [ datastack ] dip
2dup [ length ] compare {
{ +lt+ [ trim-datastacks nip relative-underflow ] }
{ +eq+ [ 2drop ] }
{ +gt+ [ trim-datastacks drop relative-overflow ] }
} case ; inline
! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline

5
core/continuations/continuations-docs.factor
View File

@ -83,6 +83,7 @@ $nl
{ $subsection with-return }
"Reflecting the datastack:"
{ $subsection with-datastack }
{ $subsection assert-depth }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
@ -216,6 +217,10 @@ HELP: with-datastack
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
} ;
HELP: assert-depth
{ $values { "quot" "a quotation" } }
{ $description "Runs a quotation. Throws an error if the quotation attempts to take input values from the stack, or leave outputs on the stack." } ;
HELP: <continuation>
{ $description "Constructs a new continuation." }
{ $notes "User code should call " { $link continuation } " instead." } ;

3
core/continuations/continuations.factor
View File

@ -114,6 +114,9 @@ SYMBOL: return-continuation
] 3 (throw)
] callcc1 2nip ;
: assert-depth ( quot -- )
{ } swap with-datastack { } assert= ; inline
GENERIC: compute-restarts ( error -- seq )
<PRIVATE

6
core/io/streams/c/c-docs.factor
View File

@ -61,13 +61,13 @@ HELP: fread ( n alien -- str/f )
{ $errors "Throws an error if the input operation failed." } ;
HELP: stdin-handle
{ $values { "in" "a C FILE* handle" } }
{ $values { "alien" "a C FILE* handle" } }
{ $description "Outputs the console standard input file handle." } ;
HELP: stdout-handle
{ $values { "out" "a C FILE* handle" } }
{ $values { "alien" "a C FILE* handle" } }
{ $description "Outputs the console standard output file handle." } ;
HELP: stderr-handle
{ $values { "out" "a C FILE* handle" } }
{ $values { "alien" "a C FILE* handle" } }
{ $description "Outputs the console standard error file handle." } ;

6
core/io/streams/c/c.factor
View File

@ -56,9 +56,9 @@ M: c-reader dispose*
M: c-io-backend init-io ;
: stdin-handle 11 getenv ;
: stdout-handle 12 getenv ;
: stderr-handle 61 getenv ;
: stdin-handle ( -- alien ) 11 getenv ;
: stdout-handle ( -- alien ) 12 getenv ;
: stderr-handle ( -- alien ) 61 getenv ;
: init-c-stdio ( -- stdin stdout stderr )
stdin-handle <c-reader>

6
core/kernel/kernel-docs.factor
View File

@ -887,6 +887,11 @@ $nl
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
ARTICLE: "assertions" "Assertions"
"Some words to make assertions easier to enforce:"
{ $subsection assert }
{ $subsection assert= } ;
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
{ $subsection "words" }
@ -902,6 +907,7 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"Advanced topics:"
{ $subsection "assertions" }
{ $subsection "implementing-combinators" }
{ $subsection "errors" }
{ $subsection "continuations" } ;

10
core/kernel/kernel.factor
View File

@ -52,7 +52,9 @@ DEFER: if
: ?if ( default cond true false -- )
pick [ roll 2drop call ] [ 2nip call ] if ; inline
! Slippers
! Slippers and dippers.
! Not declared inline because the compiler special-cases them
: slip ( quot x -- x )
#! 'slip' and 'dip' can be defined in terms of each other
#! because the JIT special-cases a 'dip' preceeded by
@ -71,11 +73,11 @@ DEFER: if
#! a literal quotation.
[ call ] 3dip ;
: dip ( x quot -- x ) swap slip ; inline
: dip ( x quot -- x ) swap slip ;
: 2dip ( x y quot -- x y ) -rot 2slip ; inline
: 2dip ( x y quot -- x y ) -rot 2slip ;
: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline
: 3dip ( x y z quot -- x y z ) -roll 3slip ;
! Keepers
: keep ( x quot -- x ) over slip ; inline

6
core/math/math-docs.factor
View File

@ -166,15 +166,17 @@ HELP: log2
HELP: 1+
{ $values { "x" number } { "y" number } }
{ $description
"Increments a number by 1. The following two lines are equivalent, but the first is more efficient:"
"Increments a number by 1. The following two lines are equivalent:"
{ $code "1+" "1 +" }
"There is no difference in behavior or efficiency."
} ;
HELP: 1-
{ $values { "x" number } { "y" number } }
{ $description
"Decrements a number by 1. The following two lines are equivalent, but the first is more efficient:"
"Decrements a number by 1. The following two lines are equivalent:"
{ $code "1-" "1 -" }
"There is no difference in behavior or efficiency."
} ;
HELP: ?1+

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

@ -5,6 +5,8 @@ sorting classes.tuple compiler.units debugger vocabs
vocabs.loader accessors eval combinators lexer ;
IN: parser.tests
\ run-file must-infer
[
[ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
@ -400,7 +402,7 @@ IN: parser.tests
] times
[ "resource:core/parser/test/assert-depth.factor" run-file ]
[ stack>> { 1 2 3 } sequence= ]
[ got>> { 1 2 3 } sequence= ]
must-fail-with
2 [

2
core/parser/parser.factor
View File

@ -307,7 +307,7 @@ print-use-hook global [ [ ] or ] change-at
] recover ;
: run-file ( file -- )
[ dup parse-file call ] assert-depth drop ;
[ parse-file call ] curry assert-depth ;
: ?run-file ( path -- )
dup exists? [ run-file ] [ drop ] if ;

16
core/sbufs/sbufs.factor
View File

@ -31,16 +31,16 @@ M: sbuf equal?
M: string new-resizable drop <sbuf> ;
M: string like
#! If we have a string, we're done.
#! If we have an sbuf, and it's at full capacity, we're done.
#! Otherwise, call resize-string, which is a relatively
#! fast primitive.
drop dup string? [
dup sbuf? [
dup length over underlying>> length eq? [
underlying>> dup reset-string-hashcode
] [
>string
] if
] [
>string
] if
[ length ] [ underlying>> ] bi
2dup length eq?
[ nip dup reset-string-hashcode ] [ resize-string ] if
] [ >string ] if
] unless ;
INSTANCE: sbuf growable

11
core/strings/strings.factor
View File

@ -16,6 +16,10 @@ IN: strings
: rehash-string ( str -- )
1 over sequence-hashcode swap set-string-hashcode ; inline
: set-string-nth ( ch n str -- )
pick HEX: 7f fixnum<=
[ set-string-nth-fast ] [ set-string-nth-slow ] if ; inline
PRIVATE>
M: string equal?
@ -27,8 +31,9 @@ M: string equal?
] if ;
M: string hashcode*
nip dup string-hashcode [ ]
[ dup rehash-string string-hashcode ] ?if ;
nip
dup string-hashcode
[ ] [ dup rehash-string string-hashcode ] ?if ;
M: string length
length>> ;
@ -38,7 +43,7 @@ M: string nth-unsafe
M: string set-nth-unsafe
dup reset-string-hashcode
[ [ >fixnum ] dip >fixnum ] dip set-string-nth ;
[ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ;
M: string clone
(clone) [ clone ] change-aux ;

16
core/vectors/vectors.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math sequences sequences.private growable ;
USING: arrays kernel math sequences sequences.private growable
accessors ;
IN: vectors
TUPLE: vector
@ -22,6 +23,19 @@ M: vector new-sequence
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
M: array like
#! If we have an array, we're done.
#! If we have a vector, and it's at full capacity, we're done.
#! Otherwise, call resize-array, which is a relatively
#! fast primitive.
drop dup array? [
dup vector? [
[ length ] [ underlying>> ] bi
2dup length eq?
[ nip ] [ resize-array ] if
] [ >array ] if
] unless ;
M: sequence new-resizable drop <vector> ;
INSTANCE: vector growable

3
core/vocabs/loader/loader-tests.factor
View File

@ -154,9 +154,6 @@ forget-junk
[ ] [ [ "vocabs.loader.test.e" forget-vocab ] with-compilation-unit ] unit-test
[ "vocabs.loader.test.e" require ]
[ relative-overflow? ] must-fail-with
0 "vocabs.loader.test.g" set-global
[

0
unmaintained/bunny/authors.txt → extra/bunny/authors.txt
View File

0
unmaintained/bunny/bun_zipper.ply → extra/bunny/bun_zipper.ply
View File

0
unmaintained/bunny/bunny.factor → extra/bunny/bunny.factor
View File

0
unmaintained/bunny/cel-shaded/cel-shaded.factor → extra/bunny/cel-shaded/cel-shaded.factor
View File

0
unmaintained/bunny/deploy.factor → extra/bunny/deploy.factor
View File

3
unmaintained/bunny/fixed-pipeline/fixed-pipeline.factor → extra/bunny/fixed-pipeline/fixed-pipeline.factor Normal file → Executable file
View File

@ -1,5 +1,6 @@
USING: alien.c-types continuations destructors kernel
opengl opengl.gl bunny.model specialized-arrays.float ;
opengl opengl.gl bunny.model specialized-arrays.float
accessors ;
IN: bunny.fixed-pipeline
TUPLE: bunny-fixed-pipeline ;

4
unmaintained/bunny/model/model.factor → extra/bunny/model/model.factor
View File

@ -3,7 +3,7 @@ http.client io io.encodings.ascii io.files kernel math
math.matrices math.parser math.vectors opengl
opengl.capabilities opengl.gl opengl.demo-support sequences
sequences.lib splitting vectors words
specialized-arrays.double specialized-arrays.uint ;
specialized-arrays.float specialized-arrays.uint ;
IN: bunny.model
: numbers ( str -- seq )
@ -66,7 +66,7 @@ TUPLE: bunny-buffers array element-array nv ni ;
{
[
[ first concat ] [ second concat ] bi
append >double-array underlying>>
append >float-array underlying>>
GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
]
[

0
unmaintained/bunny/outlined/outlined.factor → extra/bunny/outlined/outlined.factor
View File

0
unmaintained/bunny/summary.txt → extra/bunny/summary.txt
View File

0
unmaintained/bunny/tags.txt → extra/bunny/tags.txt
View File

3
extra/hardware-info/windows/nt/nt.factor
View File

@ -1,6 +1,7 @@
USING: alien alien.c-types alien.strings
kernel libc math namespaces hardware-info.backend
windows windows.advapi32 windows.kernel32 system ;
hardware-info.windows windows windows.advapi32
windows.kernel32 system byte-arrays ;
IN: hardware-info.windows.nt
M: winnt cpus ( -- n )

44
extra/math/blas/cblas/cblas.factor
View File

@ -34,10 +34,10 @@ TYPEDEF: int CBLAS_SIDE
TYPEDEF: int CBLAS_INDEX
C-STRUCT: CBLAS_C
C-STRUCT: float-complex
{ "float" "real" }
{ "float" "imag" } ;
C-STRUCT: CBLAS_Z
C-STRUCT: double-complex
{ "double" "real" }
{ "double" "imag" } ;
@ -53,14 +53,14 @@ FUNCTION: double cblas_ddot
( int N, double* X, int incX, double* Y, int incY ) ;
FUNCTION: void cblas_cdotu_sub
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotu ) ;
( int N, void* X, int incX, void* Y, int incY, void* dotu ) ;
FUNCTION: void cblas_cdotc_sub
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotc ) ;
( int N, void* X, int incX, void* Y, int incY, void* dotc ) ;
FUNCTION: void cblas_zdotu_sub
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotu ) ;
( int N, void* X, int incX, void* Y, int incY, void* dotu ) ;
FUNCTION: void cblas_zdotc_sub
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotc ) ;
( int N, void* X, int incX, void* Y, int incY, void* dotc ) ;
FUNCTION: float cblas_snrm2
( int N, float* X, int incX ) ;
@ -73,23 +73,23 @@ FUNCTION: double cblas_dasum
( int N, double* X, int incX ) ;
FUNCTION: float cblas_scnrm2
( int N, CBLAS_C* X, int incX ) ;
( int N, void* X, int incX ) ;
FUNCTION: float cblas_scasum
( int N, CBLAS_C* X, int incX ) ;
( int N, void* X, int incX ) ;
FUNCTION: double cblas_dznrm2
( int N, CBLAS_Z* X, int incX ) ;
( int N, void* X, int incX ) ;
FUNCTION: double cblas_dzasum
( int N, CBLAS_Z* X, int incX ) ;
( int N, void* X, int incX ) ;
FUNCTION: CBLAS_INDEX cblas_isamax
( int N, float* X, int incX ) ;
FUNCTION: CBLAS_INDEX cblas_idamax
( int N, double* X, int incX ) ;
FUNCTION: CBLAS_INDEX cblas_icamax
( int N, CBLAS_C* X, int incX ) ;
( int N, void* X, int incX ) ;
FUNCTION: CBLAS_INDEX cblas_izamax
( int N, CBLAS_Z* X, int incX ) ;
( int N, void* X, int incX ) ;
FUNCTION: void cblas_sswap
( int N, float* X, int incX, float* Y, int incY ) ;
@ -106,31 +106,31 @@ FUNCTION: void cblas_daxpy
( int N, double alpha, double* X, int incX, double* Y, int incY ) ;
FUNCTION: void cblas_cswap
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
( int N, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_ccopy
( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
( int N, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_caxpy
( int N, CBLAS_C* alpha, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
( int N, void* alpha, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_zswap
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
( int N, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_zcopy
( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
( int N, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_zaxpy
( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
( int N, void* alpha, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_sscal
( int N, float alpha, float* X, int incX ) ;
FUNCTION: void cblas_dscal
( int N, double alpha, double* X, int incX ) ;
FUNCTION: void cblas_cscal
( int N, CBLAS_C* alpha, CBLAS_C* X, int incX ) ;
( int N, void* alpha, void* X, int incX ) ;
FUNCTION: void cblas_zscal
( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX ) ;
( int N, void* alpha, void* X, int incX ) ;
FUNCTION: void cblas_csscal
( int N, float alpha, CBLAS_C* X, int incX ) ;
( int N, float alpha, void* X, int incX ) ;
FUNCTION: void cblas_zdscal
( int N, double alpha, CBLAS_Z* X, int incX ) ;
( int N, double alpha, void* X, int incX ) ;
FUNCTION: void cblas_srotg
( float* a, float* b, float* c, float* s ) ;

2
extra/math/blas/matrices/matrices-docs.factor
View File

@ -88,7 +88,7 @@ HELP: blas-matrix-base
}
"All of these subclasses share the same tuple layout:"
{ $list
{ { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
{ { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
{ { $snippet "ld" } " indicates the distance, in elements, between matrix columns;" }
{ { $snippet "rows" } " and " { $snippet "cols" } " indicate the number of significant rows and columns in the matrix;" }
{ "and " { $snippet "transpose" } ", if set to a true value, indicates that the matrix should be treated as transposed relative to its in-memory representation." }

273
extra/math/blas/matrices/matrices.factor
View File

@ -1,31 +1,13 @@
USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.lib combinators.short-circuit fry kernel locals macros
combinators.short-circuit fry kernel locals macros
math math.blas.cblas math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order multi-methods qualified
sequences sequences.merged sequences.private generalizations
shuffle symbols speicalized-arrays.float specialized-arrays.double ;
QUALIFIED: syntax
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle symbols
specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.float specialized-arrays.double ;
IN: math.blas.matrices
TUPLE: blas-matrix-base data ld rows cols transpose ;
TUPLE: float-blas-matrix < blas-matrix-base ;
TUPLE: double-blas-matrix < blas-matrix-base ;
TUPLE: float-complex-blas-matrix < blas-matrix-base ;
TUPLE: double-complex-blas-matrix < blas-matrix-base ;
C: <float-blas-matrix> float-blas-matrix
C: <double-blas-matrix> double-blas-matrix
C: <float-complex-blas-matrix> float-complex-blas-matrix
C: <double-complex-blas-matrix> double-complex-blas-matrix
METHOD: element-type { float-blas-matrix }
drop "float" ;
METHOD: element-type { double-blas-matrix }
drop "double" ;
METHOD: element-type { float-complex-blas-matrix }
drop "CBLAS_C" ;
METHOD: element-type { double-complex-blas-matrix }
drop "CBLAS_Z" ;
TUPLE: blas-matrix-base underlying ld rows cols transpose ;
: Mtransposed? ( matrix -- ? )
transpose>> ; inline
@ -34,6 +16,11 @@ METHOD: element-type { double-complex-blas-matrix }
: Mheight ( matrix -- height )
dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline
GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
<PRIVATE
: (blas-transpose) ( matrix -- integer )
@ -41,53 +28,29 @@ METHOD: element-type { double-complex-blas-matrix }
GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
METHOD: (blas-matrix-like) { object object object object object float-blas-matrix }
drop <float-blas-matrix> ;
METHOD: (blas-matrix-like) { object object object object object double-blas-matrix }
drop <double-blas-matrix> ;
METHOD: (blas-matrix-like) { object object object object object float-complex-blas-matrix }
drop <float-complex-blas-matrix> ;
METHOD: (blas-matrix-like) { object object object object object double-complex-blas-matrix }
drop <double-complex-blas-matrix> ;
METHOD: (blas-matrix-like) { object object object object object float-blas-vector }
drop <float-blas-matrix> ;
METHOD: (blas-matrix-like) { object object object object object double-blas-vector }
drop <double-blas-matrix> ;
METHOD: (blas-matrix-like) { object object object object object float-complex-blas-vector }
drop <float-complex-blas-matrix> ;
METHOD: (blas-matrix-like) { object object object object object double-complex-blas-vector }
drop <double-complex-blas-matrix> ;
METHOD: (blas-vector-like) { object object object float-blas-matrix }
drop <float-blas-vector> ;
METHOD: (blas-vector-like) { object object object double-blas-matrix }
drop <double-blas-vector> ;
METHOD: (blas-vector-like) { object object object float-complex-blas-matrix }
drop <float-complex-blas-vector> ;
METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
drop <double-complex-blas-vector> ;
: (validate-gemv) ( A x y -- )
{
[ drop [ Mwidth ] [ length>> ] bi* = ]
[ nip [ Mheight ] [ length>> ] bi* = ]
} 3&&
[ "Mismatched matrix and vectors in matrix-vector multiplication" throw ] unless ;
[ "Mismatched matrix and vectors in matrix-vector multiplication" throw ]
unless ;
:: (prepare-gemv) ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc y )
:: (prepare-gemv)
( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
y )
A x y (validate-gemv)
CblasColMajor
A (blas-transpose)
A rows>>
A cols>>
alpha >c-arg call
A data>>
A underlying>>
A ld>>
x data>>
x underlying>>
x inc>>
beta >c-arg call
y data>>
y underlying>>
y inc>>
y ; inline
@ -96,19 +59,22 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
[ nip [ length>> ] [ Mheight ] bi* = ]
[ nipd [ length>> ] [ Mwidth ] bi* = ]
} 3&&
[ "Mismatched vertices and matrix in vector outer product" throw ] unless ;
[ "Mismatched vertices and matrix in vector outer product" throw ]
unless ;
:: (prepare-ger) ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld A )
:: (prepare-ger)
( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld
A )
x y A (validate-ger)
CblasColMajor
A rows>>
A cols>>
alpha >c-arg call
x data>>
x underlying>>
x inc>>
y data>>
y underlying>>
y inc>>
A data>>
A underlying>>
A ld>>
A f >>transpose ; inline
@ -117,9 +83,13 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
[ drop [ Mwidth ] [ Mheight ] bi* = ]
[ nip [ Mheight ] bi@ = ]
[ nipd [ Mwidth ] bi@ = ]
} 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ;
} 3&&
[ "Mismatched matrices in matrix multiplication" throw ]
unless ;
:: (prepare-gemm) ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld C )
:: (prepare-gemm)
( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld
C )
A B C (validate-gemm)
CblasColMajor
A (blas-transpose)
@ -128,12 +98,12 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
C cols>>
A Mwidth
alpha >c-arg call
A data>>
A underlying>>
A ld>>
B data>>
B underlying>>
B ld>>
beta >c-arg call
C data>>
C underlying>>
C ld>>
C f >>transpose ; inline
@ -142,65 +112,22 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
PRIVATE>
: >float-blas-matrix ( arrays -- matrix )
[ >float-array underlying>> ] (>matrix) <float-blas-matrix> ;
: >double-blas-matrix ( arrays -- matrix )
[ >double-array underlying>> ] (>matrix) <double-blas-matrix> ;
: >float-complex-blas-matrix ( arrays -- matrix )
[ (flatten-complex-sequence) >float-array underlying>> ] (>matrix)
<float-complex-blas-matrix> ;
: >double-complex-blas-matrix ( arrays -- matrix )
[ (flatten-complex-sequence) >double-array underlying>> ] (>matrix)
<double-complex-blas-matrix> ;
GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
METHOD: n*M.V+n*V! { real float-blas-matrix float-blas-vector real float-blas-vector }
[ ] (prepare-gemv) [ cblas_sgemv ] dip ;
METHOD: n*M.V+n*V! { real double-blas-matrix double-blas-vector real double-blas-vector }
[ ] (prepare-gemv) [ cblas_dgemv ] dip ;
METHOD: n*M.V+n*V! { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector }
[ (>c-complex) ] (prepare-gemv) [ cblas_cgemv ] dip ;
METHOD: n*M.V+n*V! { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector }
[ (>z-complex) ] (prepare-gemv) [ cblas_zgemv ] dip ;
METHOD: n*V(*)V+M! { real float-blas-vector float-blas-vector float-blas-matrix }
[ ] (prepare-ger) [ cblas_sger ] dip ;
METHOD: n*V(*)V+M! { real double-blas-vector double-blas-vector double-blas-matrix }
[ ] (prepare-ger) [ cblas_dger ] dip ;
METHOD: n*V(*)V+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
[ (>c-complex) ] (prepare-ger) [ cblas_cgeru ] dip ;
METHOD: n*V(*)V+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
[ (>z-complex) ] (prepare-ger) [ cblas_zgeru ] dip ;
METHOD: n*V(*)Vconj+M! { real float-blas-vector float-blas-vector float-blas-matrix }
[ ] (prepare-ger) [ cblas_sger ] dip ;
METHOD: n*V(*)Vconj+M! { real double-blas-vector double-blas-vector double-blas-matrix }
[ ] (prepare-ger) [ cblas_dger ] dip ;
METHOD: n*V(*)Vconj+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
[ (>c-complex) ] (prepare-ger) [ cblas_cgerc ] dip ;
METHOD: n*V(*)Vconj+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
[ (>z-complex) ] (prepare-ger) [ cblas_zgerc ] dip ;
METHOD: n*M.M+n*M! { real float-blas-matrix float-blas-matrix real float-blas-matrix }
[ ] (prepare-gemm) [ cblas_sgemm ] dip ;
METHOD: n*M.M+n*M! { real double-blas-matrix double-blas-matrix real double-blas-matrix }
[ ] (prepare-gemm) [ cblas_dgemm ] dip ;
METHOD: n*M.M+n*M! { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix }
[ (>c-complex) ] (prepare-gemm) [ cblas_cgemm ] dip ;
METHOD: n*M.M+n*M! { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix }
[ (>z-complex) ] (prepare-gemm) [ cblas_zgemm ] dip ;
! XXX should do a dense clone
syntax:M: blas-matrix-base clone
M: blas-matrix-base clone
[
[
{ [ data>> ] [ ld>> ] [ cols>> ] [ element-type heap-size ] } cleave
* * memory>byte-array
] [ { [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> ] } cleave ] bi
[ {
[ underlying>> ]
[ ld>> ]
[ cols>> ]
[ element-type heap-size ]
} cleave * * memory>byte-array ]
[ {
[ ld>> ]
[ rows>> ]
[ cols>> ]
[ transpose>> ]
} cleave ]
bi
] keep (blas-matrix-like) ;
! XXX try rounding stride to next 128 bit bound for better vectorizin'
@ -246,29 +173,31 @@ syntax:M: blas-matrix-base clone
:: (Msub) ( matrix row col height width -- data ld rows cols )
matrix ld>> col * row + matrix element-type heap-size *
matrix data>> <displaced-alien>
matrix underlying>> <displaced-alien>
matrix ld>>
height
width ;
: Msub ( matrix row col height width -- sub )
5 npick dup transpose>>
[ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep
swap (blas-matrix-like) ;
:: Msub ( matrix row col height width -- sub )
matrix dup transpose>>
[ col row width height ]
[ row col height width ] if (Msub)
matrix transpose>> matrix (blas-matrix-like) ;
TUPLE: blas-matrix-rowcol-sequence parent inc rowcol-length rowcol-jump length ;
TUPLE: blas-matrix-rowcol-sequence
parent inc rowcol-length rowcol-jump length ;
C: <blas-matrix-rowcol-sequence> blas-matrix-rowcol-sequence
INSTANCE: blas-matrix-rowcol-sequence sequence
syntax:M: blas-matrix-rowcol-sequence length
M: blas-matrix-rowcol-sequence length
length>> ;
syntax:M: blas-matrix-rowcol-sequence nth-unsafe
M: blas-matrix-rowcol-sequence nth-unsafe
{
[
[ rowcol-jump>> ]
[ parent>> element-type heap-size ]
[ parent>> data>> ] tri
[ parent>> underlying>> ] tri
[ * * ] dip <displaced-alien>
]
[ rowcol-length>> ]
@ -277,11 +206,11 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe
} cleave (blas-vector-like) ;
: (Mcols) ( A -- columns )
{ [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] } cleave
<blas-matrix-rowcol-sequence> ;
{ [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] }
cleave <blas-matrix-rowcol-sequence> ;
: (Mrows) ( A -- rows )
{ [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } cleave
<blas-matrix-rowcol-sequence> ;
{ [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] }
cleave <blas-matrix-rowcol-sequence> ;
: Mrows ( A -- rows )
dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
@ -300,11 +229,79 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe
recip swap n*M ; inline
: Mtranspose ( matrix -- matrix^T )
[ { [ data>> ] [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> not ] } cleave ] keep (blas-matrix-like) ;
[ {
[ underlying>> ]
[ ld>> ] [ rows>> ]
[ cols>> ]
[ transpose>> not ]
} cleave ] keep (blas-matrix-like) ;
syntax:M: blas-matrix-base equal?
M: blas-matrix-base equal?
{
[ [ Mwidth ] bi@ = ]
[ [ Mcols ] bi@ [ = ] 2all? ]
} 2&& ;
<<
FUNCTOR: (define-blas-matrix) ( TYPE T U C -- )
VECTOR IS ${TYPE}-blas-vector
<VECTOR> IS <${TYPE}-blas-vector>
>ARRAY IS >${TYPE}-array
TYPE>ARG IS ${TYPE}>arg
XGEMV IS cblas_${T}gemv
XGEMM IS cblas_${T}gemm
XGERU IS cblas_${T}ger${U}
XGERC IS cblas_${T}ger${C}
MATRIX DEFINES ${TYPE}-blas-matrix
<MATRIX> DEFINES <${TYPE}-blas-matrix>
>MATRIX DEFINES >${TYPE}-blas-matrix
WHERE
TUPLE: MATRIX < blas-matrix-base ;
: <MATRIX> ( underlying ld rows cols transpose -- matrix )
MATRIX boa ; inline
M: MATRIX element-type
drop TYPE ;
M: MATRIX (blas-matrix-like)
drop <MATRIX> execute ;
M: VECTOR (blas-matrix-like)
drop <MATRIX> execute ;
M: MATRIX (blas-vector-like)
drop <VECTOR> execute ;
: >MATRIX ( arrays -- matrix )
[ >ARRAY execute underlying>> ] (>matrix)
<MATRIX> execute ;
M: VECTOR n*M.V+n*V!
[ TYPE>ARG execute ] (prepare-gemv)
[ XGEMV execute ] dip ;
M: MATRIX n*M.M+n*M!
[ TYPE>ARG execute ] (prepare-gemm)
[ XGEMM execute ] dip ;
M: MATRIX n*V(*)V+M!
[ TYPE>ARG execute ] (prepare-ger)
[ XGERU execute ] dip ;
M: MATRIX n*V(*)Vconj+M!
[ TYPE>ARG execute ] (prepare-ger)
[ XGERC execute ] dip ;
;FUNCTOR
: define-real-blas-matrix ( TYPE T -- )
"" "" (define-blas-matrix) ;
: define-complex-blas-matrix ( TYPE T -- )
"u" "c" (define-blas-matrix) ;
"float" "s" define-real-blas-matrix
"double" "d" define-real-blas-matrix
"float-complex" "c" define-complex-blas-matrix
"double-complex" "z" define-complex-blas-matrix
>>

26
extra/math/blas/syntax/syntax.factor
View File

@ -1,4 +1,4 @@
USING: kernel math.blas.matrices math.blas.vectors parser
USING: kernel math.blas.vectors math.blas.matrices parser
arrays prettyprint.backend sequences ;
IN: math.blas.syntax
@ -20,15 +20,23 @@ IN: math.blas.syntax
: zmatrix{
\ } [ >double-complex-blas-matrix ] parse-literal ; parsing
M: float-blas-vector pprint-delims drop \ svector{ \ } ;
M: double-blas-vector pprint-delims drop \ dvector{ \ } ;
M: float-complex-blas-vector pprint-delims drop \ cvector{ \ } ;
M: double-complex-blas-vector pprint-delims drop \ zvector{ \ } ;
M: float-blas-vector pprint-delims
drop \ svector{ \ } ;
M: double-blas-vector pprint-delims
drop \ dvector{ \ } ;
M: float-complex-blas-vector pprint-delims
drop \ cvector{ \ } ;
M: double-complex-blas-vector pprint-delims
drop \ zvector{ \ } ;
M: float-blas-matrix pprint-delims drop \ smatrix{ \ } ;
M: double-blas-matrix pprint-delims drop \ dmatrix{ \ } ;
M: float-complex-blas-matrix pprint-delims drop \ cmatrix{ \ } ;
M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ;
M: float-blas-matrix pprint-delims
drop \ smatrix{ \ } ;
M: double-blas-matrix pprint-delims
drop \ dmatrix{ \ } ;
M: float-complex-blas-matrix pprint-delims
drop \ cmatrix{ \ } ;
M: double-complex-blas-matrix pprint-delims
drop \ zmatrix{ \ } ;
M: blas-vector-base >pprint-sequence ;
M: blas-vector-base pprint* pprint-object ;

2
extra/math/blas/vectors/vectors-docs.factor
View File

@ -37,7 +37,7 @@ HELP: blas-vector-base
}
"All of these subclasses share the same tuple layout:"
{ $list
{ { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
{ { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
{ { $snippet "length" } " indicates the length of the vector;" }
{ "and " { $snippet "inc" } " indicates the distance, in elements, between elements." }
} } ;

473
extra/math/blas/vectors/vectors.factor
View File

@ -1,231 +1,77 @@
USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.short-circuit fry kernel macros math math.blas.cblas
math.complex math.functions math.order multi-methods qualified
sequences sequences.private generalizations
combinators.short-circuit fry kernel math math.blas.cblas
math.complex math.functions math.order sequences.complex
sequences.complex-components sequences sequences.private
functors words locals
specialized-arrays.float specialized-arrays.double
specialized-arrays.direct.float specialized-arrays.direct.double ;
QUALIFIED: syntax
IN: math.blas.vectors
TUPLE: blas-vector-base data length inc ;
TUPLE: float-blas-vector < blas-vector-base ;
TUPLE: double-blas-vector < blas-vector-base ;
TUPLE: float-complex-blas-vector < blas-vector-base ;
TUPLE: double-complex-blas-vector < blas-vector-base ;
TUPLE: blas-vector-base underlying length inc ;
INSTANCE: float-blas-vector sequence
INSTANCE: double-blas-vector sequence
INSTANCE: float-complex-blas-vector sequence
INSTANCE: double-complex-blas-vector sequence
INSTANCE: blas-vector-base virtual-sequence
C: <float-blas-vector> float-blas-vector
C: <double-blas-vector> double-blas-vector
C: <float-complex-blas-vector> float-complex-blas-vector
C: <double-complex-blas-vector> double-complex-blas-vector
GENERIC: element-type ( v -- type )
GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
GENERIC: n*V! ( alpha x -- x=alpha*x )
GENERIC: V. ( x y -- x.y )
GENERIC: V.conj ( x y -- xconj.y )
GENERIC: Vnorm ( x -- norm )
GENERIC: Vasum ( x -- sum )
GENERIC: Vswap ( x y -- x=y y=x )
GENERIC: Viamax ( x -- max-i )
GENERIC: element-type ( v -- type )
METHOD: element-type { float-blas-vector }
drop "float" ;
METHOD: element-type { double-blas-vector }
drop "double" ;
METHOD: element-type { float-complex-blas-vector }
drop "CBLAS_C" ;
METHOD: element-type { double-complex-blas-vector }
drop "CBLAS_Z" ;
<PRIVATE
GENERIC: (blas-vector-like) ( data length inc exemplar -- vector )
METHOD: (blas-vector-like) { object object object float-blas-vector }
drop <float-blas-vector> ;
METHOD: (blas-vector-like) { object object object double-blas-vector }
drop <double-blas-vector> ;
METHOD: (blas-vector-like) { object object object float-complex-blas-vector }
drop <float-complex-blas-vector> ;
METHOD: (blas-vector-like) { object object object double-complex-blas-vector }
drop <double-complex-blas-vector> ;
GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
: (prepare-copy) ( v element-size -- length v-data v-inc v-dest-data v-dest-inc )
[ [ length>> ] [ data>> ] [ inc>> ] tri ] dip
4 npick * <byte-array>
1 ;
: shorter-length ( v1 v2 -- length )
[ length>> ] bi@ min ; inline
: data-and-inc ( v -- data inc )
[ underlying>> ] [ inc>> ] bi ; inline
: datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
[ data-and-inc ] bi@ ; inline
MACRO: (do-copy) ( copy make-vector -- )
'[ over 6 npick _ 2dip 1 @ ] ;
:: (prepare-copy)
( v element-size -- length v-data v-inc v-dest-data v-dest-inc
copy-data copy-length copy-inc )
v [ length>> ] [ data-and-inc ] bi
v length>> element-size * <byte-array>
1
over v length>> 1 ;
: (prepare-swap) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc v1 v2 )
[
[ [ length>> ] bi@ min ]
[ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
] 2keep ;
: (prepare-swap)
( v1 v2 -- length v1-data v1-inc v2-data v2-inc
v1 v2 )
[ shorter-length ] [ datas-and-incs ] [ ] 2tri ;
: (prepare-axpy) ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc v2 )
[
[ [ length>> ] bi@ min swap ]
[ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
] keep ;
:: (prepare-axpy)
( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc
v2 )
v1 v2 shorter-length
n
v1 v2 datas-and-incs
v2 ;
: (prepare-scal) ( n v -- length n v-data v-inc v )
[ [ length>> swap ] [ data>> ] [ inc>> ] tri ] keep ;
:: (prepare-scal)
( n v -- length n v-data v-inc
v )
v length>>
n
v data-and-inc
v ;
: (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc )
[ [ length>> ] bi@ min ]
[ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi ;
[ shorter-length ] [ datas-and-incs ] 2bi ;
: (prepare-nrm2) ( v -- length v1-data v1-inc )
[ length>> ] [ data>> ] [ inc>> ] tri ;
: (flatten-complex-sequence) ( seq -- seq' )
[ [ real-part ] [ imaginary-part ] bi 2array ] map concat ;
: (>c-complex) ( complex -- alien )
[ real-part ] [ imaginary-part ] bi float-array{ } 2sequence underlying>> ;
: (>z-complex) ( complex -- alien )
[ real-part ] [ imaginary-part ] bi double-array{ } 2sequence underlying>> ;
: (c-complex>) ( alien -- complex )
2 <direct-float-array> first2 rect> ;
: (z-complex>) ( alien -- complex )
2 <direct-double-array> first2 rect> ;
: (prepare-nth) ( n v -- n*inc v-data )
[ inc>> ] [ data>> ] bi [ * ] dip ;
MACRO: (complex-nth) ( nth-quot -- )
'[
[ 2 * dup 1+ ] dip
_ curry bi@ rect>
] ;
: (c-complex-nth) ( n alien -- complex )
[ float-nth ] (complex-nth) ;
: (z-complex-nth) ( n alien -- complex )
[ double-nth ] (complex-nth) ;
MACRO: (set-complex-nth) ( set-nth-quot -- )
'[
[
[ [ real-part ] [ imaginary-part ] bi ]
[ 2 * dup 1+ ] bi*
swapd
] dip
_ curry 2bi@
] ;
: (set-c-complex-nth) ( complex n alien -- )
[ set-float-nth ] (set-complex-nth) ;
: (set-z-complex-nth) ( complex n alien -- )
[ set-double-nth ] (set-complex-nth) ;
: (prepare-nrm2) ( v -- length data inc )
[ length>> ] [ data-and-inc ] bi ;
PRIVATE>
: <zero-vector> ( exemplar -- zero )
[ element-type <c-object> ]
[ length>> 0 ]
[ (blas-vector-like) ] tri ;
: <empty-vector> ( length exemplar -- vector )
[ element-type <c-array> ]
[ 1 swap ] 2bi
(blas-vector-like) ;
syntax:M: blas-vector-base length
length>> ;
syntax:M: float-blas-vector nth-unsafe
(prepare-nth) float-nth ;
syntax:M: float-blas-vector set-nth-unsafe
(prepare-nth) set-float-nth ;
syntax:M: double-blas-vector nth-unsafe
(prepare-nth) double-nth ;
syntax:M: double-blas-vector set-nth-unsafe
(prepare-nth) set-double-nth ;
syntax:M: float-complex-blas-vector nth-unsafe
(prepare-nth) (c-complex-nth) ;
syntax:M: float-complex-blas-vector set-nth-unsafe
(prepare-nth) (set-c-complex-nth) ;
syntax:M: double-complex-blas-vector nth-unsafe
(prepare-nth) (z-complex-nth) ;
syntax:M: double-complex-blas-vector set-nth-unsafe
(prepare-nth) (set-z-complex-nth) ;
syntax:M: blas-vector-base equal?
{
[ [ length ] bi@ = ]
[ [ = ] 2all? ]
} 2&& ;
: >float-blas-vector ( seq -- v )
[ >float-array underlying>> ] [ length ] bi 1 <float-blas-vector> ;
: >double-blas-vector ( seq -- v )
[ >double-array underlying>> ] [ length ] bi 1 <double-blas-vector> ;
: >float-complex-blas-vector ( seq -- v )
[ (flatten-complex-sequence) >float-array underlying>> ] [ length ] bi
1 <float-complex-blas-vector> ;
: >double-complex-blas-vector ( seq -- v )
[ (flatten-complex-sequence) >double-array underlying>> ] [ length ] bi
1 <double-complex-blas-vector> ;
syntax:M: float-blas-vector clone
"float" heap-size (prepare-copy)
[ cblas_scopy ] [ <float-blas-vector> ] (do-copy) ;
syntax:M: double-blas-vector clone
"double" heap-size (prepare-copy)
[ cblas_dcopy ] [ <double-blas-vector> ] (do-copy) ;
syntax:M: float-complex-blas-vector clone
"CBLAS_C" heap-size (prepare-copy)
[ cblas_ccopy ] [ <float-complex-blas-vector> ] (do-copy) ;
syntax:M: double-complex-blas-vector clone
"CBLAS_Z" heap-size (prepare-copy)
[ cblas_zcopy ] [ <double-complex-blas-vector> ] (do-copy) ;
METHOD: Vswap { float-blas-vector float-blas-vector }
(prepare-swap) [ cblas_sswap ] 2dip ;
METHOD: Vswap { double-blas-vector double-blas-vector }
(prepare-swap) [ cblas_dswap ] 2dip ;
METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector }
(prepare-swap) [ cblas_cswap ] 2dip ;
METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector }
(prepare-swap) [ cblas_zswap ] 2dip ;
METHOD: n*V+V! { real float-blas-vector float-blas-vector }
(prepare-axpy) [ cblas_saxpy ] dip ;
METHOD: n*V+V! { real double-blas-vector double-blas-vector }
(prepare-axpy) [ cblas_daxpy ] dip ;
METHOD: n*V+V! { number float-complex-blas-vector float-complex-blas-vector }
[ (>c-complex) ] 2dip
(prepare-axpy) [ cblas_caxpy ] dip ;
METHOD: n*V+V! { number double-complex-blas-vector double-complex-blas-vector }
[ (>z-complex) ] 2dip
(prepare-axpy) [ cblas_zaxpy ] dip ;
METHOD: n*V! { real float-blas-vector }
(prepare-scal) [ cblas_sscal ] dip ;
METHOD: n*V! { real double-blas-vector }
(prepare-scal) [ cblas_dscal ] dip ;
METHOD: n*V! { number float-complex-blas-vector }
[ (>c-complex) ] dip
(prepare-scal) [ cblas_cscal ] dip ;
METHOD: n*V! { number double-complex-blas-vector }
[ (>z-complex) ] dip
(prepare-scal) [ cblas_zscal ] dip ;
: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
@ -242,62 +88,185 @@ METHOD: n*V! { number double-complex-blas-vector }
: V/n ( x alpha -- x/alpha )
recip swap n*V ; inline
METHOD: V. { float-blas-vector float-blas-vector }
(prepare-dot) cblas_sdot ;
METHOD: V. { double-blas-vector double-blas-vector }
(prepare-dot) cblas_ddot ;
METHOD: V. { float-complex-blas-vector float-complex-blas-vector }
(prepare-dot)
"CBLAS_C" <c-object> [ cblas_cdotu_sub ] keep (c-complex>) ;
METHOD: V. { double-complex-blas-vector double-complex-blas-vector }
(prepare-dot)
"CBLAS_Z" <c-object> [ cblas_zdotu_sub ] keep (z-complex>) ;
METHOD: V.conj { float-blas-vector float-blas-vector }
(prepare-dot) cblas_sdot ;
METHOD: V.conj { double-blas-vector double-blas-vector }
(prepare-dot) cblas_ddot ;
METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector }
(prepare-dot)
"CBLAS_C" <c-object> [ cblas_cdotc_sub ] keep (c-complex>) ;
METHOD: V.conj { double-complex-blas-vector double-complex-blas-vector }
(prepare-dot)
"CBLAS_Z" <c-object> [ cblas_zdotc_sub ] keep (z-complex>) ;
METHOD: Vnorm { float-blas-vector }
(prepare-nrm2) cblas_snrm2 ;
METHOD: Vnorm { double-blas-vector }
(prepare-nrm2) cblas_dnrm2 ;
METHOD: Vnorm { float-complex-blas-vector }
(prepare-nrm2) cblas_scnrm2 ;
METHOD: Vnorm { double-complex-blas-vector }
(prepare-nrm2) cblas_dznrm2 ;
METHOD: Vasum { float-blas-vector }
(prepare-nrm2) cblas_sasum ;
METHOD: Vasum { double-blas-vector }
(prepare-nrm2) cblas_dasum ;
METHOD: Vasum { float-complex-blas-vector }
(prepare-nrm2) cblas_scasum ;
METHOD: Vasum { double-complex-blas-vector }
(prepare-nrm2) cblas_dzasum ;
METHOD: Viamax { float-blas-vector }
(prepare-nrm2) cblas_isamax ;
METHOD: Viamax { double-blas-vector }
(prepare-nrm2) cblas_idamax ;
METHOD: Viamax { float-complex-blas-vector }
(prepare-nrm2) cblas_icamax ;
METHOD: Viamax { double-complex-blas-vector }
(prepare-nrm2) cblas_izamax ;
: Vamax ( x -- max )
[ Viamax ] keep nth ; inline
: Vsub ( v start length -- sub )
rot [
[
nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri
[ * * ] dip <displaced-alien>
] [ swap 2nip ] [ 2nip inc>> ] 3tri
] keep (blas-vector-like) ;
:: Vsub ( v start length -- sub )
v inc>> start * v element-type heap-size *
v underlying>> <displaced-alien>
length v inc>> v (blas-vector-like) ;
: <zero-vector> ( exemplar -- zero )
[ element-type <c-object> ]
[ length>> 0 ]
[ (blas-vector-like) ] tri ;
: <empty-vector> ( length exemplar -- vector )
[ element-type <c-array> ]
[ 1 swap ] 2bi
(blas-vector-like) ;
M: blas-vector-base equal?
{
[ [ length ] bi@ = ]
[ [ = ] 2all? ]
} 2&& ;
M: blas-vector-base length
length>> ;
M: blas-vector-base virtual-seq
(blas-direct-array) ;
M: blas-vector-base virtual@
[ inc>> * ] [ nip (blas-direct-array) ] 2bi ;
: float>arg ( f -- f ) ; inline
: double>arg ( f -- f ) ; inline
: arg>float ( f -- f ) ; inline
: arg>double ( f -- f ) ; inline
<<
FUNCTOR: (define-blas-vector) ( TYPE T -- )
<DIRECT-ARRAY> IS <direct-${TYPE}-array>
>ARRAY IS >${TYPE}-array
XCOPY IS cblas_${T}copy
XSWAP IS cblas_${T}swap
IXAMAX IS cblas_i${T}amax
VECTOR DEFINES ${TYPE}-blas-vector
<VECTOR> DEFINES <${TYPE}-blas-vector>
>VECTOR DEFINES >${TYPE}-blas-vector
WHERE
TUPLE: VECTOR < blas-vector-base ;
: <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
: >VECTOR ( seq -- v )
[ >ARRAY execute underlying>> ] [ length ] bi 1 <VECTOR> execute ;
M: VECTOR clone
TYPE heap-size (prepare-copy)
[ XCOPY execute ] 3dip <VECTOR> execute ;
M: VECTOR element-type
drop TYPE ;
M: VECTOR Vswap
(prepare-swap) [ XSWAP execute ] 2dip ;
M: VECTOR Viamax
(prepare-nrm2) IXAMAX execute ;
M: VECTOR (blas-vector-like)
drop <VECTOR> execute ;
M: VECTOR (blas-direct-array)
[ underlying>> ]
[ [ length>> ] [ inc>> ] bi * ] bi
<DIRECT-ARRAY> execute ;
;FUNCTOR
FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
VECTOR IS ${TYPE}-blas-vector
XDOT IS cblas_${T}dot
XNRM2 IS cblas_${T}nrm2
XASUM IS cblas_${T}asum
XAXPY IS cblas_${T}axpy
XSCAL IS cblas_${T}scal
WHERE
M: VECTOR V.
(prepare-dot) XDOT execute ;
M: VECTOR V.conj
(prepare-dot) XDOT execute ;
M: VECTOR Vnorm
(prepare-nrm2) XNRM2 execute ;
M: VECTOR Vasum
(prepare-nrm2) XASUM execute ;
M: VECTOR n*V+V!
(prepare-axpy) [ XAXPY execute ] dip ;
M: VECTOR n*V!
(prepare-scal) [ XSCAL execute ] dip ;
;FUNCTOR
FUNCTOR: (define-complex-helpers) ( TYPE -- )
<DIRECT-COMPLEX-ARRAY> DEFINES <direct-${TYPE}-complex-array>
>COMPLEX-ARRAY DEFINES >${TYPE}-complex-array
ARG>COMPLEX DEFINES arg>${TYPE}-complex
COMPLEX>ARG DEFINES ${TYPE}-complex>arg
<DIRECT-ARRAY> IS <direct-${TYPE}-array>
>ARRAY IS >${TYPE}-array
WHERE
: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
1 shift <DIRECT-ARRAY> execute <complex-sequence> ;
: >COMPLEX-ARRAY ( sequence -- sequence )
<complex-components> >ARRAY execute ;
: COMPLEX>ARG ( complex -- alien )
>rect 2array >ARRAY execute underlying>> ;
: ARG>COMPLEX ( alien -- complex )
2 <DIRECT-ARRAY> execute first2 rect> ;
;FUNCTOR
FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
VECTOR IS ${TYPE}-blas-vector
XDOTU_SUB IS cblas_${C}dotu_sub
XDOTC_SUB IS cblas_${C}dotc_sub
XXNRM2 IS cblas_${S}${C}nrm2
XXASUM IS cblas_${S}${C}asum
XAXPY IS cblas_${C}axpy
XSCAL IS cblas_${C}scal
TYPE>ARG IS ${TYPE}>arg
ARG>TYPE IS arg>${TYPE}
WHERE
M: VECTOR V.
(prepare-dot) TYPE <c-object>
[ XDOTU_SUB execute ] keep
ARG>TYPE execute ;
M: VECTOR V.conj
(prepare-dot) TYPE <c-object>
[ XDOTC_SUB execute ] keep
ARG>TYPE execute ;
M: VECTOR Vnorm
(prepare-nrm2) XXNRM2 execute ;
M: VECTOR Vasum
(prepare-nrm2) XXASUM execute ;
M: VECTOR n*V+V!
[ TYPE>ARG execute ] 2dip
(prepare-axpy) [ XAXPY execute ] dip ;
M: VECTOR n*V!
[ TYPE>ARG execute ] dip
(prepare-scal) [ XSCAL execute ] dip ;
;FUNCTOR
: define-real-blas-vector ( TYPE T -- )
[ (define-blas-vector) ]
[ (define-real-blas-vector) ] 2bi ;
:: define-complex-blas-vector ( TYPE C S -- )
TYPE (define-complex-helpers)
TYPE "-complex" append
[ C (define-blas-vector) ]
[ C S (define-complex-blas-vector) ] bi ;
"float" "s" define-real-blas-vector
"double" "d" define-real-blas-vector
"float" "c" "s" define-complex-blas-vector
"double" "z" "d" define-complex-blas-vector
>>

0
unmaintained/opengl/capabilities/authors.txt → extra/opengl/capabilities/authors.txt
View File

0
unmaintained/opengl/capabilities/capabilities-docs.factor → extra/opengl/capabilities/capabilities-docs.factor
View File

0
unmaintained/opengl/capabilities/capabilities.factor → extra/opengl/capabilities/capabilities.factor
View File

0
unmaintained/opengl/capabilities/summary.txt → extra/opengl/capabilities/summary.txt
View File

0
unmaintained/opengl/capabilities/tags.txt → extra/opengl/capabilities/tags.txt
View File

0
unmaintained/opengl/demo-support/authors.txt → extra/opengl/demo-support/authors.txt
View File

0
unmaintained/opengl/demo-support/demo-support.factor → extra/opengl/demo-support/demo-support.factor
View File

0
unmaintained/opengl/demo-support/summary.txt → extra/opengl/demo-support/summary.txt
View File

0
unmaintained/opengl/demo-support/tags.txt → extra/opengl/demo-support/tags.txt
View File

0
unmaintained/opengl/framebuffers/authors.txt → extra/opengl/framebuffers/authors.txt
View File

0
unmaintained/opengl/framebuffers/framebuffers-docs.factor → extra/opengl/framebuffers/framebuffers-docs.factor
View File

0
unmaintained/opengl/framebuffers/framebuffers.factor → extra/opengl/framebuffers/framebuffers.factor
View File

0
unmaintained/opengl/framebuffers/summary.txt → extra/opengl/framebuffers/summary.txt
View File

0
unmaintained/opengl/framebuffers/tags.txt → extra/opengl/framebuffers/tags.txt
View File

0
unmaintained/opengl/gadgets/gadgets-tests.factor → extra/opengl/gadgets/gadgets-tests.factor
View File

0
unmaintained/opengl/gadgets/gadgets.factor → extra/opengl/gadgets/gadgets.factor
View File

0
unmaintained/opengl/shaders/authors.txt → extra/opengl/shaders/authors.txt
View File

0
unmaintained/opengl/shaders/shaders-docs.factor → extra/opengl/shaders/shaders-docs.factor
View File

9
unmaintained/opengl/shaders/shaders.factor → extra/opengl/shaders/shaders.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien alien.strings libc opengl math sequences combinators
combinators.lib macros arrays io.encodings.ascii fry ;
combinators.lib macros arrays io.encodings.ascii fry
specialized-arrays.uint destructors accessors ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
@ -93,9 +94,9 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
: gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length
dup <uint-array>
0 <int> swap
[ underlying>> glGetAttachedShaders ] { 3 1 } multikeep ;
0 <int>
over <uint-array>
[ underlying>> glGetAttachedShaders ] keep ;
: delete-gl-program-only ( program -- )
glDeleteProgram ; inline

Some files were not shown because too many files have changed in this diff Show More