Fix conflict

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}" }
+        { "NSPoint"    "{_NSPoint=ff}" }
-        { "NSRect" "{_NSRect=ffff}" }
+        { "NSRect"     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
-        { "NSSize" "{_NSSize=ff}" }
+        { "NSSize"     "{_NSSize=ff}" }
-        { "NSRange" "{_NSRange=II}" }
+        { "NSRange"    "{_NSRange=II}" }
+        { "NSInteger"  "i" }
+        { "NSUInteger" "I" }
+        { "CGFloat"    "f" }
     } ] }
     { 8 [ H{
-        { "NSPoint" "{_NSPoint=dd}" }
+        { "NSPoint"    "{CGPoint=dd}" }
-        { "NSRect" "{_NSRect=dddd}" }
+        { "NSRect"     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
-        { "NSSize" "{_NSSize=dd}" }
+        { "NSSize"     "{CGSize=dd}" }
-        { "NSRange" "{_NSRange=QQ}" }
+        { "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 )
+: each-method-in-class ( class quot -- )
-    over [ void*-nth register-objc-method ] curry each ;
+    [ 0 <uint> [ class_copyMethodList ] keep *uint over ] dip
+    '[ _ void*-nth @ ] each (free) ; inline
 
 : register-objc-methods ( class -- )
-    0 <uint> [ class_copyMethodList ] keep *uint 
+    [ register-objc-method ] each-method-in-class ;
-    (register-objc-methods) (free) ;
+
+: 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 ;
 

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

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

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
-
-: <NSRect> ( x y w h -- rect )
-    "NSRect" <c-object>
-    [ 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
 
 : <NSSize> ( w h -- size )
     "NSSize" <c-object>
     [ 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
+
+: <NSRect> ( x y w h -- rect )
+    "NSRect" <c-object>
+    [ 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
+
 : <NSRange> ( length location -- size )
     "NSRange" <c-object>
     [ set-NSRange-length ] keep

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

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

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

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 <sqlite-db> _ with-db ] call ;
 
 [
     book recreate-table

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 ;
 : <bignum-test> ( m n o -- obj )

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+
++foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
-+set-default+ ;
++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 ;
 

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

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 -- ? )
+:: let-and-cond-test-1 ( -- a )
-    [wlet | is-integer? [ a integer? ]
+    [let | a [ 10 ] |
-            is-even? [ a even? ]
+        [let | a [ 20 ] |
-            >10? [ a 10 > ] |
+            {
-        { [ is-integer? ] [ is-even? ] [ >10? ] } &&
+                { [ t ] [ [let | c [ 30 ] | a ] ] }
+            } cond
+        ]
     ] ;
 
-! [ f ] [ 1.5 wlet-&&-test ] unit-test
+\ let-and-cond-test-1 must-infer
-! [ f ] [ 3 wlet-&&-test ] unit-test
+
-! [ f ] [ 8 wlet-&&-test ] unit-test
+[ 20 ] [ let-and-cond-test-1 ] unit-test
-! [ t ] [ 12 wlet-&&-test ] 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
+[ [ ] [ ] [ ] 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

basis/locals/locals.factor

@@ -35,11 +35,15 @@ C: <wlet> 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 ;
 
 : <local> ( 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 local-writer? ] [ "local-reader" word-prop , ] }
-      { [ dup lexical? ]      [ , ] }
+        { [ dup lexical? ] [ , ] }
-      { [ dup quote? ]        [ local>> , ] }
+        { [ dup quote? ] [ local>> , ] }
-      { [ t ]                 [ free-vars* ] }
+        { [ t ] [ free-vars* ] }
-  } cond ;
+    } cond ;
 
 M: object free-vars* drop ;
 
@@ -195,6 +199,20 @@ M: block lambda-rewrite*
         swap point-free ,
     ] keep length \ curry <repetition> % ;
 
+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>>

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
+USING: kernel sequences sequences.private namespaces make
-words continuations vectors effects math
+quotations accessors words continuations vectors effects math
-stack-checker.transforms ;
+generalizations stack-checker.transforms fry ;
 IN: macros.expander
 
 GENERIC: expand-macros ( quot -- quot' )
 
-<PRIVATE
-
 SYMBOL: stack
 
 : begin ( -- ) V{ } clone stack set ;
@@ -28,6 +26,17 @@ GENERIC: expand-macros* ( obj -- )
 
 M: wrapper expand-macros* wrapped>> literal ;
 
+: expand-dispatch? ( word -- ? )
+    \ dispatch eq? stack get length 1 >= and ;
+
+: expand-dispatch ( -- )
+    stack get pop end
+    [ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
+    [
+        length [ <reversed> ] 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>

basis/ui/cocoa/views/views.factor

@@ -128,12 +128,12 @@ CLASS: {
 }
 
 ! Rendering
-{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
+{ "drawRect:" "void" { "id" "SEL" "NSRect" }
-    [ 3drop window relayout-1 ]
+    [ 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 <NSRect> ]
 }
 
-{ "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
     ]
 }
 

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
+        \ dup ,
-    [ dispatch-case ] 2curry 2curry ;
+        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 {

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) <lambda>
+  parsed-lambda
+  \ call parsed ; parsing

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>> <bunny-geom> >>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 ;
 

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 ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

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: <entry> time data ;
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+: expired? ( <entry> -- ? ) 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{ <entry> 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
+   ] ;

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 ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 <PRIVATE
@@ -149,18 +145,10 @@ PRIVATE>
 : 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' ) <enum> >alist ;
-
-: enumerate ( seq -- seq' )
-    <enum> >alist ;
 

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 
+opengl multiline ui.gadgets accessors sequences ui.render ui math locals
-arrays generalizations combinators ;
+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 <gl-program> 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 -- )
+:: (draw-sphere) ( program center radius -- )
-    roll
+    program "center" glGetAttribLocation center first3 glVertexAttrib3f
-    [ [ "center" glGetAttribLocation swap first3 glVertexAttrib3f ] curry ]
+    program "radius" glGetAttribLocation radius glVertexAttrib1f
-    [ [ "radius" glGetAttribLocation swap glVertexAttrib1f ] curry ]
-    [ [ "surface_color" glGetAttribLocation swap first4 glVertexAttrib4f ] curry ]
-    tri tri*
     { -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 { 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-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-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-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-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-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
         ]

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" <sqlite-db> ;
 
 : run-calculator ( -- )
     <calculator>

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" <sqlite-db> ;
 
 : run-counter ( -- )
     <counter-app>