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

basis/bootstrap/image/image.factor

@@ -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

basis/cocoa/application/application.factor

@@ -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 NSApp -> run ] with-cocoa ; inline
-
-: cocoa-app ( quot -- )
-    [
-        call
-        finish-launching
-        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."
+        "The " " requires you to run Factor from an application bundle."
-        3append throw
+        surround throw
     ] if ;

basis/cocoa/cocoa-tests.factor

@@ -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

basis/cocoa/messages/messages.factor

@@ -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
+continuations combinators compiler compiler.alien kernel math
-parser prettyprint prettyprint.sections quotations sequences
+namespaces make parser prettyprint prettyprint.sections
-strings words cocoa.runtime io macros memoize debugger
+quotations sequences strings words cocoa.runtime io macros
-io.encodings.ascii effects libc libc.private parser lexer init
+memoize debugger io.encodings.ascii effects libc libc.private
-core-foundation fry generalizations
+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 )
+SYMBOL: class-init-hooks
-    dupd execute
+
-    [ ] [ "No such class: " prepend throw ] ?if ; inline
+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 -- )
+: define-objc-class-word ( quot name -- )
-    [ class-exists? ] dip unless ; inline
+    [ class-init-hooks get set-at ]
-
-: define-objc-class-word ( name quot -- )
     [
-        over , , \ unless-defined , dup , \ objc-class ,
+        [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
-    ] [ ] make [ "cocoa.classes" create ] dip
+        (( -- class )) define-declared
-    (( -- class )) define-declared ;
+    ] bi ;
 
 : import-objc-class ( name quot -- )
-    2dup unless-defined
+    over define-objc-class-word
-    dupd define-objc-class-word
     '[
         _
-        dup
+        [ objc-class register-objc-methods ]
-        objc-class register-objc-methods
+        [ objc-meta-class register-objc-methods ] bi
-        objc-meta-class register-objc-methods
     ] try ;
 
 : root-class ( class -- root )

basis/cocoa/subclassing/subclassing.factor

@@ -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
+parser sequences words cocoa.messages cocoa.runtime locals
-compiler.units io.encodings.ascii generalizations
+compiler.units io.encodings.ascii continuations make fry ;
-continuations make ;
 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 -- )
+: throw-if-false ( obj what -- )
-    zero? [ "Failed to add method or protocol to class" throw ]
+    swap { f 0 } member?
-    when ;
+    [ "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
+    '[ [ _ ] dip init-method add-method ] each ;
-    [ init-method class_addMethod throw-if-false ] with 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 ]
+    '[ [ _ ] dip objc-protocol add-protocol ] each ;
-    with each ;
 
-: (define-objc-class) ( protocols superclass name imeth -- )
+: (define-objc-class) ( imeth protocols superclass name -- )
-    -rot
     [ 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 -- ? )
+:: (redefine-objc-method) ( class method -- )
-    [ ascii alien>string ] bi@ = ;
+    method init-method [| sel imp types |
-
+        class sel class_getInstanceMethod [
-: (verify-method-type) ( class sel types -- )
+            imp method_setImplementation drop
-    [ class_getInstanceMethod method_getTypeEncoding ]
+        ] [
-    dip types=
+            class sel imp types add-method
-    [ "Objective-C method types cannot be changed once defined" throw ]
+        ] if*
-    unless ;
+    ] call ;
-: 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-methods ( imeth name -- )
     dup class-exists? [
-        objc_getClass swap [ (redefine-objc-method) ] with each
+        objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
-    ] [
+    ] [ 2drop ] if ;
-        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 [
+        +name+ get 2dup redefine-objc-methods swap
-            +protocols+ get , +superclass+ get , +name+ get , ,
+        +protocols+ get +superclass+ get +name+ get
-            \ (define-objc-class) ,
+        '[ _ _ _ _ (define-objc-class) ]
-        ] [ ] make import-objc-class
+        import-objc-class
     ] bind ;
 
 : CLASS:

basis/compiler/cfg/def-use/def-use.factor

@@ -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 ;

basis/compiler/cfg/instructions/instructions.factor

@@ -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 ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -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 ] }

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -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 ;

basis/compiler/codegen/codegen.factor

@@ -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
 

basis/compiler/codegen/fixup/fixup.factor

@@ -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 * ;
 

basis/compiler/tree/builder/builder.factor

@@ -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>> ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -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 ]
+            [ body-length-bias ]
-            [ flat-length 24 swap [-] 4 /i ]
             [ "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? [
+    over history get memq? [ 3drop f ] [
-        3drop f
-    ] [
         [
             swap remember-inlining
             dupd splicing-nodes >>body

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -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 [
+! generic-comparison-ops [
-    dup specific-comparison
+!     dup specific-comparison define-comparison-constraints
-    '[ _ _ define-comparison-constraints ] each-derived-op
+! ] each
-] each
 
 ! Remove redundant comparisons
 : fold-comparison ( info1 info2 word -- info )

basis/compiler/tree/propagation/nodes/nodes.factor

@@ -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 -- )

basis/compiler/tree/propagation/propagation.factor

@@ -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) ;

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -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 )

basis/cpu/architecture/architecture.factor

@@ -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 -- )

basis/cpu/x86/x86.factor

@@ -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 7 SHL
-        new-dst temp OR
+        ! 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

basis/debugger/debugger.factor

@@ -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 . ;
 

basis/editors/scite/scite.factor

@@ -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 )

basis/functors/functors.factor

@@ -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 ] { }

basis/help/lint/lint.factor

@@ -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 [
+            dup word-help '[
-                2dup check-examples
+                _ _ {
-                2dup check-values
+                    [ check-examples ]
-                2dup check-see-also
+                    [ check-values ]
-                2dup nip check-modules
+                    [ check-see-also ]
-                2dup drop check-rendering
+                    [ [ check-rendering ] [ check-modules ] bi* ]
-            ] assert-depth 2drop
+                } 2cleave
+            ] assert-depth
         ] check-something
     ] [ drop ] if ;
 
@@ -101,9 +102,9 @@ M: help-error error.
 
 : check-article ( article -- )
     [
-        dup article-content [
+        dup article-content
-            2dup check-modules check-rendering
+        '[ _ check-rendering _ check-modules ]
-        ] assert-depth 2drop
+        assert-depth
     ] check-something ;
 
 : files>vocabs ( -- assoc )

basis/html/templates/chloe/chloe.factor

@@ -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

basis/html/templates/chloe/compiler/compiler.factor

@@ -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' )

basis/io/windows/mmap/mmap-tests.factor

@@ -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

basis/logging/server/server.factor

@@ -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? -- )
     [

basis/random/mersenne-twister/mersenne-twister.factor

@@ -11,48 +11,39 @@ IN: random.mersenne-twister
 
 TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
 
-: mt-n 624 ; inline
+: n 624 ; inline
-: mt-m 397 ; inline
+: m 397 ; inline
-: mt-a HEX: 9908b0df ; inline
+: a uint-array{ 0 HEX: 9908b0df } ; inline
 
-: mersenne-wrap ( n -- n' )
+: y ( n seq -- y )
-    dup mt-n > [ mt-n - ] when ; inline
+    [ nth-unsafe 31 mask-bit ]
+    [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
 
-: wrap-nth ( n seq -- obj )
+: mt[k] ( offset n seq -- )
-    [ 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 )
     [
-        calculate-y
+        [ [ + ] dip nth-unsafe ]
-        [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
+        [ y [ 2/ ] [ 1 bitand a nth ] bi bitxor ] 2bi
-    ] [
+        bitxor
-        [ mt-m + ] [ wrap-nth ] bi*
+    ] 2keep set-nth-unsafe ; inline
-    ] 2bi bitxor ; inline
 
 : mt-generate ( mt -- )
     [
-        mt-n swap seq>> '[
+        seq>>
-            _ [ (mt-generate) ] [ set-wrap-nth ] 2bi
+        [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
-        ] 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 '[
+    n 1- swap '[
-        _ [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi
+        _ [ 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

basis/specialized-arrays/direct/functor/functor.factor

@@ -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

basis/stack-checker/backend/backend-tests.factor

@@ -3,20 +3,21 @@ stack-checker.state sequences ;
 IN: stack-checker.backend.tests
 
 [ ] [
-    V{ } clone meta-d set
+    V{ } clone \ meta-d set
-    V{ } clone meta-r 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

basis/stack-checker/backend/backend.factor

@@ -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
+        [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri
-        meta-d get push-all
+        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 )
+: pop-r ( -- obj )
-    meta-r get dup empty?
+    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 ;
+: output-r ( seq -- ) meta-r push-all ;
-
-: pop-literal ( -- rstate obj )
-    pop-d
-    [ 1array #drop, ]
-    [ literal [ recursion>> ] [ value>> ] bi ] bi ;
-
-GENERIC: apply-object ( obj -- )
 
 : 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 clone #return, ;
-    meta-d get 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 -- )

basis/stack-checker/branches/branches.factor

@@ -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
+    \ meta-d [ clone ] change
-    V{ } clone meta-r set
+    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 ;
-    ] H{ } make-assoc ; inline
+
+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
+    2 literals-available? [
-    dup [ known [ curried? ] [ composed? ] bi or ] contains? [
+        (infer-if)
-        output-d
-        [ rot [ drop call ] [ nip call ] if ]
-        infer-quot-here
     ] [
-        [ #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
+    pop-literal nip infer-branches
-    infer-branches
     [ #dispatch, ] dip compute-phi-function ;

basis/stack-checker/inlining/inlining.factor

@@ -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 clone enter-in set
-        meta-d get swap make-copies enter-out 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 [

basis/stack-checker/known-words/known-words.factor

@@ -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
+    1 infer->r infer-call
-    terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
+    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 [ infer-call ] }
-        { \ (call) [ pop-d 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
+    >r r> declare call (call) slip 2slip 3slip dip 2dip 3dip
-    execute (execute) if dispatch <tuple-boa> (throw)
+    curry compose execute (execute) if dispatch <tuple-boa>
-    load-locals get-local drop-locals do-primitive alien-invoke
+    (throw) load-locals get-local drop-locals do-primitive
-    alien-indirect alien-callback
+    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

basis/stack-checker/state/state.factor

@@ -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-d set
-    V{ } clone meta-r set
+    V{ } clone literals set
     0 d-in set ;
 
 ! Words that the current quotation depends on

basis/stack-checker/transforms/transforms.factor

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

basis/threads/threads-docs.factor

@@ -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

basis/threads/threads.factor

@@ -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

basis/tools/test/test-docs.factor

@@ -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.

basis/tools/test/test-tests.factor

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

basis/tools/test/test.factor

@@ -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 ( -- )

basis/ui/cocoa/cocoa.factor

@@ -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
+            NSApp -> run
-            event-loop
         ] ui-running
     ] with-cocoa ;
 

basis/ui/cocoa/tools/tools.factor

@@ -20,8 +20,8 @@ IN: ui.cocoa.tools
 
 ! Handle Open events from the Finder
 CLASS: {
-    { +superclass+ "NSObject" }
+    { +superclass+ "FactorApplicationDelegate" }
-    { +name+ "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 -- )

basis/unicode/breaks/breaks.factor

@@ -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

basis/unicode/collation/collation.factor

@@ -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

core/arrays/arrays.factor

@@ -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 ;
 

core/bootstrap/primitives.factor

@@ -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" }

core/byte-arrays/byte-arrays.factor

@@ -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?

core/byte-vectors/byte-vectors.factor

@@ -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

core/combinators/combinators-docs.factor

@@ -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." } ;

core/combinators/combinators.factor

@@ -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

core/continuations/continuations-docs.factor

@@ -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." } ;

core/continuations/continuations.factor

@@ -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

core/io/streams/c/c-docs.factor

@@ -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." } ;

core/io/streams/c/c.factor

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

core/kernel/kernel-docs.factor

@@ -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" } ;

core/kernel/kernel.factor

@@ -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

core/math/math-docs.factor

@@ -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+

core/parser/parser-tests.factor

@@ -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 [

core/parser/parser.factor

@@ -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 ;

core/sbufs/sbufs.factor

@@ -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? [
+            [ length ] [ underlying>> ] bi
-                underlying>> dup reset-string-hashcode
+            2dup length eq?
-            ] [
+            [ nip dup reset-string-hashcode ] [ resize-string ] if
-                >string
+        ] [ >string ] if
-            ] if
-        ] [
-            >string
-        ] if
     ] unless ;
 
 INSTANCE: sbuf growable

core/strings/strings.factor

@@ -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 [ ]
+    nip
-    [ dup rehash-string string-hashcode ] ?if ;
+    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 ;

core/vectors/vectors.factor

@@ -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

core/vocabs/loader/loader-tests.factor

@@ -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
 
 [

extra/bunny/fixed-pipeline/fixed-pipeline.factor

@@ -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 ;

extra/bunny/model/model.factor

@@ -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>
         ]
         [

extra/hardware-info/windows/nt/nt.factor

@@ -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 )

extra/math/blas/cblas/cblas.factor

@@ -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 ) ;

extra/math/blas/matrices/matrices-docs.factor

@@ -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." }

extra/math/blas/matrices/matrices.factor

@@ -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
+math.complex math.functions math.order functors words
-sequences sequences.merged sequences.private generalizations
+sequences sequences.merged sequences.private shuffle symbols
-shuffle symbols speicalized-arrays.float specialized-arrays.double ;
+specialized-arrays.direct.float specialized-arrays.direct.double
-QUALIFIED: syntax
+specialized-arrays.float specialized-arrays.double ;
 IN: math.blas.matrices
 
-TUPLE: blas-matrix-base data ld rows cols transpose ;
+TUPLE: blas-matrix-base underlying 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" ;
 
 : 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
+            [ underlying>> ]
-            * * memory>byte-array
+            [ ld>> ]
-        ] [ { [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> ] } cleave ] bi
+            [ 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 )
+:: Msub ( matrix row col height width -- sub )
-    5 npick dup transpose>>
+    matrix dup transpose>>
-    [ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep
+    [ col row width height ]
-    swap (blas-matrix-like) ;
+    [ 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
+    { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] }
-    <blas-matrix-rowcol-sequence> ;
+    cleave <blas-matrix-rowcol-sequence> ;
 : (Mrows) ( A -- rows )
-    { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } cleave
+    { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] }
-    <blas-matrix-rowcol-sequence> ;
+    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
+
+>>

extra/math/blas/syntax/syntax.factor

@@ -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: float-blas-vector pprint-delims
-M: double-blas-vector pprint-delims drop \ dvector{ \ } ;
+    drop \ svector{ \ } ;
-M: float-complex-blas-vector pprint-delims drop \ cvector{ \ } ;
+M: double-blas-vector pprint-delims
-M: double-complex-blas-vector pprint-delims drop \ zvector{ \ } ;
+    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: float-blas-matrix pprint-delims
-M: double-blas-matrix pprint-delims drop \ dmatrix{ \ } ;
+    drop \ smatrix{ \ } ;
-M: float-complex-blas-matrix pprint-delims drop \ cmatrix{ \ } ;
+M: double-blas-matrix pprint-delims
-M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ;
+    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 ;

extra/math/blas/vectors/vectors-docs.factor

@@ -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." }
 } } ;

extra/math/blas/vectors/vectors.factor

@@ -1,231 +1,77 @@
 USING: accessors alien alien.c-types arrays byte-arrays combinators
-combinators.short-circuit fry kernel macros math math.blas.cblas
+combinators.short-circuit fry kernel math math.blas.cblas
-math.complex math.functions math.order multi-methods qualified
+math.complex math.functions math.order sequences.complex
-sequences sequences.private generalizations
+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: blas-vector-base underlying 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 ;
 
-INSTANCE: float-blas-vector sequence
+INSTANCE: blas-vector-base virtual-sequence
-INSTANCE: double-blas-vector sequence
-INSTANCE: float-complex-blas-vector sequence
-INSTANCE: double-complex-blas-vector sequence
 
-C: <float-blas-vector> float-blas-vector
+GENERIC: element-type ( v -- type )
-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: 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 }
+GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
-    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> ;
 
-: (prepare-copy) ( v element-size -- length v-data v-inc v-dest-data v-dest-inc )
+: shorter-length ( v1 v2 -- length )
-    [ [ length>> ] [ data>> ] [ inc>> ] tri ] dip
+    [ length>> ] bi@ min ; inline
-    4 npick * <byte-array>
+: data-and-inc ( v -- data inc )
-    1 ;
+    [ 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 -- )
+:: (prepare-copy)
-    '[ over 6 npick _ 2dip 1 @ ] ;
+    ( 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 )
+: (prepare-swap)
-    [
+    ( v1 v2 -- length v1-data v1-inc v2-data v2-inc
-        [ [ length>> ] bi@ min ]
+               v1 v2 )
-        [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
+    [ shorter-length ] [ datas-and-incs ] [ ] 2tri ;
-    ] 2keep ;
 
-: (prepare-axpy) ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc v2 )
+:: (prepare-axpy)
-    [
+    ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc
-        [ [ length>> ] bi@ min swap ]
+                 v2 )
-        [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
+    v1 v2 shorter-length
-    ] keep ;
+    n
+    v1 v2 datas-and-incs
+    v2 ;
 
-: (prepare-scal) ( n v -- length n v-data v-inc v )
+:: (prepare-scal)
-    [ [ length>> swap ] [ data>> ] [ inc>> ] tri ] keep ;
+    ( 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 ]
+    [ shorter-length ] [ datas-and-incs ] 2bi ;
-    [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi ;
 
-: (prepare-nrm2) ( v -- length v1-data v1-inc )
+: (prepare-nrm2) ( v -- length data inc )
-    [ length>> ] [ data>> ] [ inc>> ] tri ;
+    [ length>> ] [ data-and-inc ] bi ;
-
-: (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) ;
 
 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 )
+:: Vsub ( v start length -- sub )
-    rot [
+    v inc>> start * v element-type heap-size *
-        [
+    v underlying>> <displaced-alien>
-            nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri
+    length v inc>> v (blas-vector-like) ;
-            [ * * ] dip <displaced-alien>
+
-        ] [ swap 2nip ] [ 2nip inc>> ] 3tri
+: <zero-vector> ( exemplar -- zero )
-    ] keep (blas-vector-like) ;
+    [ 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
+
+>>
+

extra/opengl/shaders/shaders.factor

@@ -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>
-    0 <int> swap
+    over <uint-array>
-    [ underlying>> glGetAttachedShaders ] { 3 1 } multikeep ;
+    [ underlying>> glGetAttachedShaders ] keep ;
 
 : delete-gl-program-only ( program -- )
     glDeleteProgram ; inline