diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 10883830fd..5c2de0e2f8 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -108,22 +108,34 @@ H{ { "c" "char" } { "i" "int" } { "s" "short" } - { "l" "long" } - { "q" "longlong" } { "C" "uchar" } { "I" "uint" } { "S" "ushort" } - { "L" "ulong" } - { "Q" "ulonglong" } { "f" "float" } { "d" "double" } { "B" "bool" } { "v" "void" } { "*" "char*" } + { "?" "unknown_type" } { "@" "id" } - { "#" "id" } + { "#" "Class" } { ":" "SEL" } -} objc>alien-types set-global +} +"ptrdiff_t" heap-size { + { 4 [ H{ + { "l" "long" } + { "q" "longlong" } + { "L" "ulong" } + { "Q" "ulonglong" } + } ] } + { 8 [ H{ + { "l" "long32" } + { "q" "long" } + { "L" "ulong32" } + { "Q" "ulong" } + } ] } +} case +assoc-union objc>alien-types set-global ! The transpose of the above map SYMBOL: alien>objc-types @@ -132,16 +144,22 @@ objc>alien-types get [ swap ] assoc-map ! A hack... "ptrdiff_t" heap-size { { 4 [ H{ - { "NSPoint" "{_NSPoint=ff}" } - { "NSRect" "{_NSRect=ffff}" } - { "NSSize" "{_NSSize=ff}" } - { "NSRange" "{_NSRange=II}" } + { "NSPoint" "{_NSPoint=ff}" } + { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" } + { "NSSize" "{_NSSize=ff}" } + { "NSRange" "{_NSRange=II}" } + { "NSInteger" "i" } + { "NSUInteger" "I" } + { "CGFloat" "f" } } ] } { 8 [ H{ - { "NSPoint" "{_NSPoint=dd}" } - { "NSRect" "{_NSRect=dddd}" } - { "NSSize" "{_NSSize=dd}" } - { "NSRange" "{_NSRange=QQ}" } + { "NSPoint" "{CGPoint=dd}" } + { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" } + { "NSSize" "{CGSize=dd}" } + { "NSRange" "{_NSRange=QQ}" } + { "NSInteger" "q" } + { "NSUInteger" "Q" } + { "CGFloat" "d" } } ] } } case assoc-union alien>objc-types set-global @@ -184,12 +202,23 @@ assoc-union alien>objc-types set-global swap method_getName sel_getName objc-methods get set-at ; -: (register-objc-methods) ( methods count -- methods ) - over [ void*-nth register-objc-method ] curry each ; +: each-method-in-class ( class quot -- ) + [ 0 [ class_copyMethodList ] keep *uint over ] dip + '[ _ void*-nth @ ] each (free) ; inline : register-objc-methods ( class -- ) - 0 [ class_copyMethodList ] keep *uint - (register-objc-methods) (free) ; + [ register-objc-method ] each-method-in-class ; + +: method. ( method -- ) + { + [ method_getName sel_getName ] + [ method-return-type ] + [ method-arg-types ] + [ method_getImplementation ] + } cleave 4array . ; + +: methods. ( class -- ) + [ method. ] each-method-in-class ; : class-exists? ( string -- class ) objc_getClass >boolean ; diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 3451ce5e6e..1a741b789f 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -9,7 +9,7 @@ TYPEDEF: void* id FUNCTION: char* sel_getName ( SEL aSelector ) ; -FUNCTION: bool sel_isMapped ( SEL aSelector ) ; +FUNCTION: char sel_isMapped ( SEL aSelector ) ; FUNCTION: SEL sel_registerName ( char* str ) ; @@ -54,6 +54,8 @@ FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ; FUNCTION: Class class_getSuperclass ( Class cls ) ; +FUNCTION: char* class_getName ( Class cls ) ; + FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ; FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ; @@ -73,5 +75,6 @@ FUNCTION: void* method_getTypeEncoding ( Method method ) ; FUNCTION: SEL method_getName ( Method method ) ; FUNCTION: void* method_setImplementation ( Method method, void* imp ) ; +FUNCTION: void* method_getImplementation ( Method method ) ; FUNCTION: Class object_getClass ( id object ) ; diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index 3f8e709df0..fd18c7fa89 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -12,12 +12,17 @@ IN: cocoa.subclassing [ sel_registerName ] [ execute ] [ ascii string>alien ] tri* ; +: throw-if-false ( YES/NO -- ) + zero? [ "Failed to add method or protocol to class" throw ] + when ; + : add-methods ( methods class -- ) swap - [ init-method class_addMethod drop ] with each ; + [ init-method class_addMethod throw-if-false ] with each ; : add-protocols ( protocols class -- ) - swap [ objc-protocol class_addProtocol drop ] with each ; + swap [ objc-protocol class_addProtocol throw-if-false ] + with each ; : (define-objc-class) ( protocols superclass name imeth -- ) -rot diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index 0bf4257a0b..a76e74d9aa 100644 --- a/basis/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -10,25 +10,6 @@ TYPEDEF: ulong NSUInteger { 8 [ "double" ] } } case "CGFloat" typedef >> -C-STRUCT: NSRect - { "CGFloat" "x" } - { "CGFloat" "y" } - { "CGFloat" "w" } - { "CGFloat" "h" } ; - -TYPEDEF: NSRect _NSRect -TYPEDEF: NSRect CGRect - -: ( x y w h -- rect ) - "NSRect" - [ set-NSRect-h ] keep - [ set-NSRect-w ] keep - [ set-NSRect-y ] keep - [ set-NSRect-x ] keep ; - -: NSRect-x-y ( alien -- origin-x origin-y ) - [ NSRect-x ] keep NSRect-y ; - C-STRUCT: NSPoint { "CGFloat" "x" } { "CGFloat" "y" } ; @@ -47,19 +28,58 @@ C-STRUCT: NSSize TYPEDEF: NSSize _NSSize TYPEDEF: NSSize CGSize -TYPEDEF: NSPoint CGPoint : ( w h -- size ) "NSSize" [ set-NSSize-h ] keep [ set-NSSize-w ] keep ; +C-STRUCT: NSRect + { "NSPoint" "origin" } + { "NSSize" "size" } ; + +TYPEDEF: NSRect _NSRect +TYPEDEF: NSRect CGRect + +: NSRect-x ( NSRect -- x ) + NSRect-origin NSPoint-x ; inline +: NSRect-y ( NSRect -- y ) + NSRect-origin NSPoint-y ; inline +: NSRect-w ( NSRect -- w ) + NSRect-size NSSize-w ; inline +: NSRect-h ( NSRect -- h ) + NSRect-size NSSize-h ; inline + +: set-NSRect-x ( x NSRect -- ) + NSRect-origin set-NSPoint-x ; inline +: set-NSRect-y ( y NSRect -- ) + NSRect-origin set-NSPoint-y ; inline +: set-NSRect-w ( w NSRect -- ) + NSRect-size set-NSSize-w ; inline +: set-NSRect-h ( h NSRect -- ) + NSRect-size set-NSSize-h ; inline + +: ( x y w h -- rect ) + "NSRect" + [ set-NSRect-h ] keep + [ set-NSRect-w ] keep + [ set-NSRect-y ] keep + [ set-NSRect-x ] keep ; + +: NSRect-x-y ( alien -- origin-x origin-y ) + [ NSRect-x ] keep NSRect-y ; + C-STRUCT: NSRange { "NSUInteger" "location" } { "NSUInteger" "length" } ; TYPEDEF: NSRange _NSRange +! The "lL" type encodings refer to 32-bit values even in 64-bit mode +TYPEDEF: int long32 +TYPEDEF: uint ulong32 +TYPEDEF: void* unknown_type + : ( length location -- size ) "NSRange" [ set-NSRange-length ] keep diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index f9c9ea73ec..2b4cadf489 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -230,6 +230,7 @@ M: postgresql-db persistent-table ( -- hashtable ) { +foreign-id+ { f f "references" } } + { +on-update+ { f f "on update" } } { +on-delete+ { f f "on delete" } } { +restrict+ { f f "restrict" } } { +cascade+ { f f "cascade" } } diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 768ec70185..3cf4d98215 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -114,6 +114,9 @@ M: sequence where ( spec obj -- ) [ " or " 0% ] [ dupd where ] interleave drop ] in-parens ; +M: NULL where ( spec obj -- ) + drop column-name>> 0% " is NULL" 0% ; + : object-where ( spec obj -- ) over column-name>> 0% " = " 0% bind# ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 216f324bbf..93135a23e3 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -178,6 +178,7 @@ M: sqlite-db persistent-table ( -- assoc ) { +random-id+ { "integer" "integer" f } } { +foreign-id+ { "integer" "integer" "references" } } + { +on-update+ { f f "on update" } } { +on-delete+ { f f "on delete" } } { +restrict+ { f f "restrict" } } { +cascade+ { f f "cascade" } } diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index 02f5dfa38c..51830ee610 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -229,7 +229,7 @@ T{ book "Now we've created a book. Let's save it to the database." { $code <" USING: db db.sqlite fry io.files ; : with-book-tutorial ( quot -- ) - '[ "book-tutorial.db" temp-file sqlite-db _ with-db ] call ; + '[ "book-tutorial.db" temp-file _ with-db ] call ; [ book recreate-table diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index f5569a97cd..192986484e 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -472,7 +472,12 @@ TUPLE: exam id name score ; T{ exam } select-tuples ] unit-test - [ 4 ] [ T{ exam } count-tuples ] unit-test ; + [ 4 ] [ T{ exam } count-tuples ] unit-test + + [ ] [ T{ exam { score 10 } } insert-tuple ] unit-test + + [ 10 ] + [ T{ exam { name NULL } } select-tuples first score>> ] unit-test ; TUPLE: bignum-test id m n o ; : ( m n o -- obj ) diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index ac9e3397f8..6a889689ce 100644 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -26,8 +26,8 @@ SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ; UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ; SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ -+foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+ -+set-default+ ; ++foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+ ++set-null+ +set-default+ ; SYMBOL: IGNORE @@ -91,7 +91,7 @@ ERROR: not-persistent class ; : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER +SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL URL ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 90c40f9bd5..7dfceafe59 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -27,7 +27,8 @@ SYMBOL: edit-hook : edit-location ( file line -- ) >r (normalize-path) r> - edit-hook get [ call ] [ no-edit-hook edit-location ] if* ; + edit-hook get-global + [ call ] [ no-edit-hook edit-location ] if* ; : edit ( defspec -- ) where [ first2 edit-location ] when* ; diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index bc1e736b75..c449c26348 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -1,7 +1,7 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint io.streams.string parser accessors generic eval combinators combinators.short-circuit -combinators.short-circuit.smart math.order ; +combinators.short-circuit.smart math.order math.functions ; IN: locals.tests :: foo ( a b -- a a ) a a ; @@ -305,17 +305,29 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; [ f ] [ 8 &&-test ] unit-test [ t ] [ 12 &&-test ] unit-test -:: wlet-&&-test ( a -- ? ) - [wlet | is-integer? [ a integer? ] - is-even? [ a even? ] - >10? [ a 10 > ] | - { [ is-integer? ] [ is-even? ] [ >10? ] } && +:: let-and-cond-test-1 ( -- a ) + [let | a [ 10 ] | + [let | a [ 20 ] | + { + { [ t ] [ [let | c [ 30 ] | a ] ] } + } cond + ] ] ; -! [ f ] [ 1.5 wlet-&&-test ] unit-test -! [ f ] [ 3 wlet-&&-test ] unit-test -! [ f ] [ 8 wlet-&&-test ] unit-test -! [ t ] [ 12 wlet-&&-test ] unit-test +\ let-and-cond-test-1 must-infer + +[ 20 ] [ let-and-cond-test-1 ] unit-test + +:: let-and-cond-test-2 ( -- pair ) + [let | A [ 10 ] | + [let | B [ 20 ] | + { { [ t ] [ { A B } ] } } cond + ] + ] ; + +\ let-and-cond-test-2 must-infer + +[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test [ { 10 } ] [ 10 [| a | { a } ] call ] unit-test [ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test @@ -333,6 +345,16 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as + +:: literal-identity-test ( -- a b ) + { } V{ } ; + +[ t f ] [ + literal-identity-test + literal-identity-test + swapd [ eq? ] [ eq? ] 2bi* +] unit-test + :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- ) obj1 obj2 <=> { { +lt+ [ lt-quot call ] } @@ -340,4 +362,30 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { +gt+ [ gt-quot call ] } } case ; inline -[ [ ] [ ] [ ] compare-case ] must-infer \ No newline at end of file +[ [ ] [ ] [ ] compare-case ] must-infer + +:: big-case-test ( a -- b ) + a { + { 0 [ a 1 + ] } + { 1 [ a 1 - ] } + { 2 [ a 1 swap / ] } + { 3 [ a dup * ] } + { 4 [ a sqrt ] } + { 5 [ a a ^ ] } + } case ; + +\ big-case-test must-infer + +[ 9 ] [ 3 big-case-test ] unit-test + +! :: wlet-&&-test ( a -- ? ) +! [wlet | is-integer? [ a integer? ] +! is-even? [ a even? ] +! >10? [ a 10 > ] | +! { [ is-integer? ] [ is-even? ] [ >10? ] } && +! ] ; + +! [ f ] [ 1.5 wlet-&&-test ] unit-test +! [ f ] [ 3 wlet-&&-test ] unit-test +! [ f ] [ 8 wlet-&&-test ] unit-test +! [ t ] [ 12 wlet-&&-test ] unit-test \ No newline at end of file diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index bbcc8a6745..89a5c02746 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -35,11 +35,15 @@ C: wlet M: lambda expand-macros clone [ expand-macros ] change-body ; +M: lambda expand-macros* expand-macros literal ; + M: binding-form expand-macros clone [ [ expand-macros ] assoc-map ] change-bindings [ expand-macros ] change-body ; +M: binding-form expand-macros* expand-macros literal ; + PREDICATE: local < word "local?" word-prop ; : ( name -- word ) @@ -142,12 +146,12 @@ GENERIC: free-vars* ( form -- ) [ free-vars* ] { } make prune ; : add-if-free ( object -- ) - { - { [ dup local-writer? ] [ "local-reader" word-prop , ] } - { [ dup lexical? ] [ , ] } - { [ dup quote? ] [ local>> , ] } - { [ t ] [ free-vars* ] } - } cond ; + { + { [ dup local-writer? ] [ "local-reader" word-prop , ] } + { [ dup lexical? ] [ , ] } + { [ dup quote? ] [ local>> , ] } + { [ t ] [ free-vars* ] } + } cond ; M: object free-vars* drop ; @@ -195,6 +199,20 @@ M: block lambda-rewrite* swap point-free , ] keep length \ curry % ; +GENERIC: rewrite-literal? ( obj -- ? ) + +M: special rewrite-literal? drop t ; + +M: array rewrite-literal? [ rewrite-literal? ] contains? ; + +M: hashtable rewrite-literal? drop t ; + +M: vector rewrite-literal? drop t ; + +M: tuple rewrite-literal? drop t ; + +M: object rewrite-literal? drop f ; + GENERIC: rewrite-element ( obj -- ) : rewrite-elements ( seq -- ) @@ -203,7 +221,8 @@ GENERIC: rewrite-element ( obj -- ) : rewrite-sequence ( seq -- ) [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ; -M: array rewrite-element rewrite-sequence ; +M: array rewrite-element + dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; M: vector rewrite-element rewrite-sequence ; @@ -441,7 +460,7 @@ M: lambda-memoized definition "lambda" word-prop body>> ; M: lambda-memoized reset-word - [ f "lambda" set-word-prop ] [ call-next-method ] bi ; + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; : method-stack-effect ( method -- effect ) dup "lambda" word-prop vars>> diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index d62c6bf466..c2fceffae6 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -1,14 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces make quotations accessors -words continuations vectors effects math -stack-checker.transforms ; +USING: kernel sequences sequences.private namespaces make +quotations accessors words continuations vectors effects math +generalizations stack-checker.transforms fry ; IN: macros.expander GENERIC: expand-macros ( quot -- quot' ) -> literal ; +: expand-dispatch? ( word -- ? ) + \ dispatch eq? stack get length 1 >= and ; + +: expand-dispatch ( -- ) + stack get pop end + [ [ expand-macros ] [ ] map-as '[ _ dip ] % ] + [ + length [ ] keep + [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch , + ] bi ; + : expand-macro ( quot -- ) stack [ swap with-datastack >vector ] change stack get pop >quotation end (expand-macros) ; @@ -38,8 +47,14 @@ M: wrapper expand-macros* wrapped>> literal ; stack get length <= ] [ 2drop f f ] if ; +: word, ( word -- ) end , ; + M: word expand-macros* - dup expand-macro? [ nip expand-macro ] [ drop end , ] if ; + dup expand-dispatch? [ drop expand-dispatch ] [ + dup expand-macro? [ nip expand-macro ] [ + drop word, + ] if + ] if ; M: object expand-macros* literal ; @@ -48,5 +63,3 @@ M: callable expand-macros* M: callable expand-macros ( quot -- quot' ) [ begin (expand-macros) end ] [ ] make ; - -PRIVATE> diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 45ab8ac0ce..c6942a8158 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -128,12 +128,12 @@ CLASS: { } ! Rendering -{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" } - [ 3drop window relayout-1 ] +{ "drawRect:" "void" { "id" "SEL" "NSRect" } + [ 2drop window relayout-1 ] } ! Events -{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" } +{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" } [ 3drop 1 ] } @@ -251,7 +251,7 @@ CLASS: { ! "rotateWithEvent:" "void" { "id" "SEL" "id" }} -{ "acceptsFirstResponder" "bool" { "id" "SEL" } +{ "acceptsFirstResponder" "char" { "id" "SEL" } [ 2drop 1 ] } @@ -264,26 +264,26 @@ CLASS: { ] } -{ "writeSelectionToPasteboard:types:" "bool" { "id" "SEL" "id" "id" } +{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" } [ CF>string-array NSStringPboardType swap member? [ >r drop window-focus gadget-selection dup [ - r> set-pasteboard-string t + r> set-pasteboard-string 1 ] [ - r> 2drop f + r> 2drop 0 ] if ] [ - 3drop f + 3drop 0 ] if ] } -{ "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" } +{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" } [ pasteboard-string dup [ - >r drop window-focus r> swap user-input t + >r drop window-focus r> swap user-input 1 ] [ - 3drop f + 3drop 0 ] if ] } @@ -293,7 +293,7 @@ CLASS: { [ [ nip send-user-input ] ui-try ] } -{ "hasMarkedText" "bool" { "id" "SEL" } +{ "hasMarkedText" "char" { "id" "SEL" } [ 2drop 0 ] } @@ -321,7 +321,7 @@ CLASS: { [ 3drop f ] } -{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" } +{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" } [ 3drop 0 ] } @@ -329,7 +329,7 @@ CLASS: { [ 3drop 0 0 0 0 ] } -{ "conversationIdentifier" "long" { "id" "SEL" } +{ "conversationIdentifier" "NSInteger" { "id" "SEL" } [ drop alien-address ] } @@ -394,9 +394,9 @@ CLASS: { ] } -{ "windowShouldClose:" "bool" { "id" "SEL" "id" } +{ "windowShouldClose:" "char" { "id" "SEL" "id" } [ - 3drop t + 3drop 1 ] } diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 4a362a7f9d..577dd153a1 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors -hashtables sorting words sets math.order ; +hashtables sorting words sets math.order make ; IN: combinators ! cleave @@ -116,17 +116,16 @@ ERROR: no-case ; ] [ drop f ] if ] [ drop f ] if ; -: dispatch-case ( value from to default array -- ) - >r >r 3dup between? r> r> rot [ - >r 2drop - >fixnum r> dispatch - ] [ - drop 2nip call - ] if ; inline - : dispatch-case-quot ( default assoc -- quot ) - [ nip keys [ infimum ] [ supremum ] bi ] 2keep - sort-keys values [ >quotation ] map - [ dispatch-case ] 2curry 2curry ; + [ + \ dup , + dup keys [ infimum , ] [ supremum , ] bi \ between? , + [ + dup keys infimum , [ - >fixnum ] % + sort-keys values [ >quotation ] map , + \ dispatch , + ] [ ] make , , \ if , + ] [ ] make ; : case>quot ( default assoc -- quot ) dup keys { diff --git a/extra/bind-in/bind-in.factor b/extra/bind-in/bind-in.factor new file mode 100644 index 0000000000..ab6ff19094 --- /dev/null +++ b/extra/bind-in/bind-in.factor @@ -0,0 +1,12 @@ + +USING: kernel parser lexer locals.private ; + +IN: bind-in + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: -> + "[" parse-tokens make-locals dup push-locals + \ ] (parse-lambda) + parsed-lambda + \ call parsed ; parsing \ No newline at end of file diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index ed89f2a809..d0625e464f 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,6 +1,7 @@ USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline bunny.model bunny.outlined destructors kernel math opengl.demo-support -opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ; +opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures +ui.render words ; IN: bunny TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; @@ -18,6 +19,7 @@ TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; >>draw-n relayout-1 ; M: bunny-gadget graft* ( gadget -- ) + dup find-gl-context GL_DEPTH_TEST glEnable dup model-triangles>> >>geom dup @@ -29,6 +31,7 @@ M: bunny-gadget graft* ( gadget -- ) drop ; M: bunny-gadget ungraft* ( gadget -- ) + dup find-gl-context [ geom>> [ dispose ] when* ] [ draw-seq>> [ [ dispose ] when* ] each ] bi ; diff --git a/extra/dns/cache/nx/nx.factor b/extra/dns/cache/nx/nx.factor new file mode 100644 index 0000000000..9904f857ba --- /dev/null +++ b/extra/dns/cache/nx/nx.factor @@ -0,0 +1,35 @@ + +USING: kernel assocs locals combinators + math math.functions system unicode.case ; + +IN: dns.cache.nx + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: nx-cache ( -- table ) H{ } ; + +: nx-cache-at ( name -- time ) >lower nx-cache at ; +: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ; +: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: now ( -- seconds ) millis 1000.0 / round >integer ; + +:: non-existent-name? ( NAME -- ? ) + [let | TIME [ NAME nx-cache-at ] | + { + { [ TIME f = ] [ f ] } + { [ TIME now <= ] [ NAME nx-cache-delete-at f ] } + { [ t ] [ t ] } + } + cond + ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: cache-non-existent-name ( NAME TTL -- ) + [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/dns/cache/rr/rr.factor b/extra/dns/cache/rr/rr.factor new file mode 100644 index 0000000000..f3082b124c --- /dev/null +++ b/extra/dns/cache/rr/rr.factor @@ -0,0 +1,65 @@ + +USING: kernel sequences assocs sets locals combinators + accessors system math math.functions unicode.case prettyprint + combinators.cleave dns ; + +IN: dns.cache.rr + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: time data ; + +: now ( -- seconds ) millis 1000.0 / round >integer ; + +: expired? ( -- ? ) time>> now <= ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-cache-key ( obj -- key ) + { [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } 1arr " " join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cache ( -- table ) H{ } ; + +: cache-at ( obj -- ent ) make-cache-key cache at ; +: cache-delete ( obj -- ) make-cache-key cache delete-at ; +: cache-set-at ( ent obj -- ) make-cache-key cache set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: cache-get ( OBJ -- rrs/f ) + [let | ENT [ OBJ cache-at ] | + { + { [ ENT f = ] [ f ] } + { [ ENT expired? ] [ OBJ cache-delete f ] } + { + [ t ] + [ + [let | NAME [ OBJ name>> ] + TYPE [ OBJ type>> ] + CLASS [ OBJ class>> ] + TTL [ now ENT time>> - ] | + ENT data>> + [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ] + map + ] + ] + } + } + cond + ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: cache-add ( RR -- ) + [let | ENT [ RR cache-at ] + TIME [ RR ttl>> now + ] + RDATA [ RR rdata>> ] | + { + { [ ENT f = ] [ T{ f TIME V{ RDATA } } RR cache-set-at ] } + { [ ENT expired? ] [ RR cache-delete RR cache-add ] } + { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] } + } + cond + ] ; \ No newline at end of file diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ed7f40598c..6fe3de4f03 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -4,7 +4,8 @@ USING: combinators.lib kernel sequences math namespaces make assocs random sequences.private shuffle math.functions arrays math.parser math.private sorting strings ascii macros assocs.lib -quotations hashtables math.order locals generalizations ; +quotations hashtables math.order locals generalizations +math.ranges random ; IN: sequences.lib : each-withn ( seq quot n -- ) nwith each ; inline @@ -131,11 +132,6 @@ PRIVATE> : power-set ( seq -- subsets ) 2 over length exact-number-strings swap [ switches ] curry map ; -USE: continuations -: ?subseq ( from to seq -- subseq ) - >r >r 0 max r> r> - [ length tuck min >r min r> ] keep subseq ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : attempt-each ( seq quot -- result ) (each) iterate-prep (attempt-each-integer) ; inline -: ?nth* ( n seq -- elt/f ? ) - 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USE: math.ranges -USE: random : randomize ( seq -- seq' ) dup length 1 (a,b] [ dup random pick exchange ] each ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: enumerate ( seq -- seq' ) - >alist ; +: enumerate ( seq -- seq' ) >alist ; diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 84621f8e18..f119956db6 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,6 +1,6 @@ USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers -opengl multiline ui.gadgets accessors sequences ui.render ui math -arrays generalizations combinators ; +opengl multiline ui.gadgets accessors sequences ui.render ui math locals +arrays generalizations combinators opengl.capabilities ui.gadgets.worlds ; IN: spheres STRING: plane-vertex-shader @@ -162,6 +162,9 @@ M: spheres-gadget distance-step ( gadget -- dz ) 3array check-gl-program ; M: spheres-gadget graft* ( gadget -- ) + dup find-gl-context + "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions + { "GL_EXT_framebuffer_object" } require-gl-extensions (plane-program) >>plane-program (solid-sphere-program) >>solid-sphere-program (texture-sphere-program) >>texture-sphere-program @@ -171,6 +174,7 @@ M: spheres-gadget graft* ( gadget -- ) drop ; M: spheres-gadget ungraft* ( gadget -- ) + dup find-gl-context { [ reflection-framebuffer>> [ delete-framebuffer ] when* ] [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] @@ -182,14 +186,15 @@ M: spheres-gadget ungraft* ( gadget -- ) M: spheres-gadget pref-dim* ( gadget -- dim ) drop { 640 480 } ; - -: (draw-sphere) ( program center radius surfacecolor -- ) - roll - [ [ "center" glGetAttribLocation swap first3 glVertexAttrib3f ] curry ] - [ [ "radius" glGetAttribLocation swap glVertexAttrib1f ] curry ] - [ [ "surface_color" glGetAttribLocation swap first4 glVertexAttrib4f ] curry ] - tri tri* + +:: (draw-sphere) ( program center radius -- ) + program "center" glGetAttribLocation center first3 glVertexAttrib3f + program "radius" glGetAttribLocation radius glVertexAttrib1f { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ; + +:: (draw-colored-sphere) ( program center radius surfacecolor -- ) + program "surface_color" glGetAttribLocation surfacecolor first4 glVertexAttrib4f + program center radius (draw-sphere) ; : sphere-scene ( gadget -- ) GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear @@ -197,12 +202,12 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) solid-sphere-program>> [ { [ "light_position" glGetUniformLocation 0.0 0.0 100.0 glUniform3f ] - [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ] - [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ] - [ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ] - [ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ] - [ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-sphere) ] - [ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-sphere) ] + [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-colored-sphere) ] + [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-colored-sphere) ] + [ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-colored-sphere) ] + [ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-colored-sphere) ] + [ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-colored-sphere) ] + [ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-colored-sphere) ] } cleave ] with-gl-program ] [ @@ -271,7 +276,7 @@ M: spheres-gadget draw-gadget* ( gadget -- ) [ texture-sphere-program>> [ [ "surface_texture" glGetUniformLocation 0 glUniform1i ] - [ { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ] + [ { 0.0 0.0 0.0 } 4.0 (draw-sphere) ] bi ] with-gl-program ] diff --git a/extra/webapps/calculator/calculator.factor b/extra/webapps/calculator/calculator.factor index f1416fb02d..d19946d39b 100644 --- a/extra/webapps/calculator/calculator.factor +++ b/extra/webapps/calculator/calculator.factor @@ -33,7 +33,7 @@ TUPLE: calculator < dispatcher ; ! Deployment example USING: db.sqlite furnace.alloy namespaces http.server ; -: calculator-db ( -- params db ) "calculator.db" sqlite-db ; +: calculator-db ( -- db ) "calculator.db" ; : run-calculator ( -- ) diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index a5c9fbc6b9..d62096fffc 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -32,7 +32,7 @@ M: counter-app init-session* drop 0 count sset ; ! Deployment example USING: db.sqlite furnace.alloy namespaces ; -: counter-db ( -- params db ) "counter.db" sqlite-db ; +: counter-db ( -- db ) "counter.db" ; : run-counter ( -- )