Fix conflict

db4
Slava Pestov 2008-10-17 18:46:56 -05:00
commit 7d6e919929
24 changed files with 390 additions and 135 deletions

View File

@ -108,22 +108,34 @@ H{
{ "c" "char" } { "c" "char" }
{ "i" "int" } { "i" "int" }
{ "s" "short" } { "s" "short" }
{ "l" "long" }
{ "q" "longlong" }
{ "C" "uchar" } { "C" "uchar" }
{ "I" "uint" } { "I" "uint" }
{ "S" "ushort" } { "S" "ushort" }
{ "L" "ulong" }
{ "Q" "ulonglong" }
{ "f" "float" } { "f" "float" }
{ "d" "double" } { "d" "double" }
{ "B" "bool" } { "B" "bool" }
{ "v" "void" } { "v" "void" }
{ "*" "char*" } { "*" "char*" }
{ "?" "unknown_type" }
{ "@" "id" } { "@" "id" }
{ "#" "id" } { "#" "Class" }
{ ":" "SEL" } { ":" "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 ! The transpose of the above map
SYMBOL: alien>objc-types SYMBOL: alien>objc-types
@ -132,16 +144,22 @@ objc>alien-types get [ swap ] assoc-map
! A hack... ! A hack...
"ptrdiff_t" heap-size { "ptrdiff_t" heap-size {
{ 4 [ H{ { 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{ { 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 } case
assoc-union alien>objc-types set-global assoc-union alien>objc-types set-global
@ -184,12 +202,23 @@ assoc-union alien>objc-types set-global
swap method_getName sel_getName swap method_getName sel_getName
objc-methods get set-at ; 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 -- ) : 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 ; : class-exists? ( string -- class ) objc_getClass >boolean ;

View File

@ -9,7 +9,7 @@ TYPEDEF: void* id
FUNCTION: char* sel_getName ( SEL aSelector ) ; FUNCTION: char* sel_getName ( SEL aSelector ) ;
FUNCTION: bool sel_isMapped ( SEL aSelector ) ; FUNCTION: char sel_isMapped ( SEL aSelector ) ;
FUNCTION: SEL sel_registerName ( char* str ) ; 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: 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_addMethod ( Class class, SEL name, void* imp, void* types ) ;
FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ; 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: SEL method_getName ( Method method ) ;
FUNCTION: void* method_setImplementation ( Method method, void* imp ) ; FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
FUNCTION: void* method_getImplementation ( Method method ) ;
FUNCTION: Class object_getClass ( id object ) ; FUNCTION: Class object_getClass ( id object ) ;

View File

@ -12,12 +12,17 @@ IN: cocoa.subclassing
[ sel_registerName ] [ execute ] [ ascii string>alien ] [ sel_registerName ] [ execute ] [ ascii string>alien ]
tri* ; tri* ;
: throw-if-false ( YES/NO -- )
zero? [ "Failed to add method or protocol to class" throw ]
when ;
: add-methods ( methods class -- ) : add-methods ( methods class -- )
swap swap
[ init-method class_addMethod drop ] with each ; [ init-method class_addMethod throw-if-false ] with each ;
: add-protocols ( protocols class -- ) : 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 -- ) : (define-objc-class) ( protocols superclass name imeth -- )
-rot -rot

View File

@ -10,25 +10,6 @@ TYPEDEF: ulong NSUInteger
{ 8 [ "double" ] } { 8 [ "double" ] }
} case "CGFloat" typedef >> } 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 C-STRUCT: NSPoint
{ "CGFloat" "x" } { "CGFloat" "x" }
{ "CGFloat" "y" } ; { "CGFloat" "y" } ;
@ -47,19 +28,58 @@ C-STRUCT: NSSize
TYPEDEF: NSSize _NSSize TYPEDEF: NSSize _NSSize
TYPEDEF: NSSize CGSize TYPEDEF: NSSize CGSize
TYPEDEF: NSPoint CGPoint
: <NSSize> ( w h -- size ) : <NSSize> ( w h -- size )
"NSSize" <c-object> "NSSize" <c-object>
[ set-NSSize-h ] keep [ set-NSSize-h ] keep
[ set-NSSize-w ] 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 C-STRUCT: NSRange
{ "NSUInteger" "location" } { "NSUInteger" "location" }
{ "NSUInteger" "length" } ; { "NSUInteger" "length" } ;
TYPEDEF: NSRange _NSRange 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> ( length location -- size )
"NSRange" <c-object> "NSRange" <c-object>
[ set-NSRange-length ] keep [ set-NSRange-length ] keep

View File

@ -230,6 +230,7 @@ M: postgresql-db persistent-table ( -- hashtable )
{ +foreign-id+ { f f "references" } } { +foreign-id+ { f f "references" } }
{ +on-update+ { f f "on update" } }
{ +on-delete+ { f f "on delete" } } { +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } } { +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } } { +cascade+ { f f "cascade" } }

View File

@ -114,6 +114,9 @@ M: sequence where ( spec obj -- )
[ " or " 0% ] [ dupd where ] interleave drop [ " or " 0% ] [ dupd where ] interleave drop
] in-parens ; ] in-parens ;
M: NULL where ( spec obj -- )
drop column-name>> 0% " is NULL" 0% ;
: object-where ( spec obj -- ) : object-where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ; over column-name>> 0% " = " 0% bind# ;

View File

@ -178,6 +178,7 @@ M: sqlite-db persistent-table ( -- assoc )
{ +random-id+ { "integer" "integer" f } } { +random-id+ { "integer" "integer" f } }
{ +foreign-id+ { "integer" "integer" "references" } } { +foreign-id+ { "integer" "integer" "references" } }
{ +on-update+ { f f "on update" } }
{ +on-delete+ { f f "on delete" } } { +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } } { +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } } { +cascade+ { f f "cascade" } }

View File

@ -229,7 +229,7 @@ T{ book
"Now we've created a book. Let's save it to the database." "Now we've created a book. Let's save it to the database."
{ $code <" USING: db db.sqlite fry io.files ; { $code <" USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- ) : 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 book recreate-table

View File

@ -472,7 +472,12 @@ TUPLE: exam id name score ;
T{ exam } select-tuples T{ exam } select-tuples
] unit-test ] 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 ; TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj ) : <bignum-test> ( m n o -- obj )

View File

@ -26,8 +26,8 @@ SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
UNION: +primary-key+ +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+ 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 SYMBOL: IGNORE
@ -91,7 +91,7 @@ ERROR: not-persistent class ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; : 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 DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL URL ; FACTOR-BLOB NULL URL ;

View File

@ -27,7 +27,8 @@ SYMBOL: edit-hook
: edit-location ( file line -- ) : edit-location ( file line -- )
>r (normalize-path) r> >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 -- ) : edit ( defspec -- )
where [ first2 edit-location ] when* ; where [ first2 edit-location ] when* ;

View File

@ -1,7 +1,7 @@
USING: locals math sequences tools.test hashtables words kernel USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order ; combinators.short-circuit.smart math.order math.functions ;
IN: locals.tests IN: locals.tests
:: foo ( a b -- a a ) a a ; :: 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 [ f ] [ 8 &&-test ] unit-test
[ t ] [ 12 &&-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 } ] [ 10 [| a | { a } ] call ] unit-test
[ { 10 20 } ] [ 10 20 [| a b | { a b } ] 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 { 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 -- ) :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
obj1 obj2 <=> { obj1 obj2 <=> {
{ +lt+ [ lt-quot call ] } { +lt+ [ lt-quot call ] }
@ -340,4 +362,30 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ +gt+ [ gt-quot call ] } { +gt+ [ gt-quot call ] }
} case ; inline } 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

View File

@ -35,11 +35,15 @@ C: <wlet> wlet
M: lambda expand-macros clone [ expand-macros ] change-body ; M: lambda expand-macros clone [ expand-macros ] change-body ;
M: lambda expand-macros* expand-macros literal ;
M: binding-form expand-macros M: binding-form expand-macros
clone clone
[ [ expand-macros ] assoc-map ] change-bindings [ [ expand-macros ] assoc-map ] change-bindings
[ expand-macros ] change-body ; [ expand-macros ] change-body ;
M: binding-form expand-macros* expand-macros literal ;
PREDICATE: local < word "local?" word-prop ; PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word ) : <local> ( name -- word )
@ -142,12 +146,12 @@ GENERIC: free-vars* ( form -- )
[ free-vars* ] { } make prune ; [ free-vars* ] { } make prune ;
: add-if-free ( object -- ) : 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 ; M: object free-vars* drop ;
@ -195,6 +199,20 @@ M: block lambda-rewrite*
swap point-free , swap point-free ,
] keep length \ curry <repetition> % ; ] 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 -- ) GENERIC: rewrite-element ( obj -- )
: rewrite-elements ( seq -- ) : rewrite-elements ( seq -- )
@ -203,7 +221,8 @@ GENERIC: rewrite-element ( obj -- )
: rewrite-sequence ( seq -- ) : rewrite-sequence ( seq -- )
[ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ; [ 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 ; M: vector rewrite-element rewrite-sequence ;
@ -441,7 +460,7 @@ M: lambda-memoized definition
"lambda" word-prop body>> ; "lambda" word-prop body>> ;
M: lambda-memoized reset-word 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 ) : method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>> dup "lambda" word-prop vars>>

View File

@ -1,14 +1,12 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: macros.expander
GENERIC: expand-macros ( quot -- quot' ) GENERIC: expand-macros ( quot -- quot' )
<PRIVATE
SYMBOL: stack SYMBOL: stack
: begin ( -- ) V{ } clone stack set ; : begin ( -- ) V{ } clone stack set ;
@ -28,6 +26,17 @@ GENERIC: expand-macros* ( obj -- )
M: wrapper expand-macros* wrapped>> literal ; 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 -- ) : expand-macro ( quot -- )
stack [ swap with-datastack >vector ] change stack [ swap with-datastack >vector ] change
stack get pop >quotation end (expand-macros) ; stack get pop >quotation end (expand-macros) ;
@ -38,8 +47,14 @@ M: wrapper expand-macros* wrapped>> literal ;
stack get length <= stack get length <=
] [ 2drop f f ] if ; ] [ 2drop f f ] if ;
: word, ( word -- ) end , ;
M: word expand-macros* 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 ; M: object expand-macros* literal ;
@ -48,5 +63,3 @@ M: callable expand-macros*
M: callable expand-macros ( quot -- quot' ) M: callable expand-macros ( quot -- quot' )
[ begin (expand-macros) end ] [ ] make ; [ begin (expand-macros) end ] [ ] make ;
PRIVATE>

View File

@ -128,12 +128,12 @@ CLASS: {
} }
! Rendering ! Rendering
{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" } { "drawRect:" "void" { "id" "SEL" "NSRect" }
[ 3drop window relayout-1 ] [ 2drop window relayout-1 ]
} }
! Events ! Events
{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" } { "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
[ 3drop 1 ] [ 3drop 1 ]
} }
@ -251,7 +251,7 @@ CLASS: {
! "rotateWithEvent:" "void" { "id" "SEL" "id" }} ! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
{ "acceptsFirstResponder" "bool" { "id" "SEL" } { "acceptsFirstResponder" "char" { "id" "SEL" }
[ 2drop 1 ] [ 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? [ CF>string-array NSStringPboardType swap member? [
>r drop window-focus gadget-selection dup [ >r drop window-focus gadget-selection dup [
r> set-pasteboard-string t r> set-pasteboard-string 1
] [ ] [
r> 2drop f r> 2drop 0
] if ] if
] [ ] [
3drop f 3drop 0
] if ] if
] ]
} }
{ "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" } { "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
[ [
pasteboard-string dup [ 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 ] if
] ]
} }
@ -293,7 +293,7 @@ CLASS: {
[ [ nip send-user-input ] ui-try ] [ [ nip send-user-input ] ui-try ]
} }
{ "hasMarkedText" "bool" { "id" "SEL" } { "hasMarkedText" "char" { "id" "SEL" }
[ 2drop 0 ] [ 2drop 0 ]
} }
@ -321,7 +321,7 @@ CLASS: {
[ 3drop f ] [ 3drop f ]
} }
{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" } { "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
[ 3drop 0 ] [ 3drop 0 ]
} }
@ -329,7 +329,7 @@ CLASS: {
[ 3drop 0 0 0 0 <NSRect> ] [ 3drop 0 0 0 0 <NSRect> ]
} }
{ "conversationIdentifier" "long" { "id" "SEL" } { "conversationIdentifier" "NSInteger" { "id" "SEL" }
[ drop alien-address ] [ drop alien-address ]
} }
@ -394,9 +394,9 @@ CLASS: {
] ]
} }
{ "windowShouldClose:" "bool" { "id" "SEL" "id" } { "windowShouldClose:" "char" { "id" "SEL" "id" }
[ [
3drop t 3drop 1
] ]
} }

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences sequences.private math.private USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors kernel kernel.private math assocs quotations vectors
hashtables sorting words sets math.order ; hashtables sorting words sets math.order make ;
IN: combinators IN: combinators
! cleave ! cleave
@ -116,17 +116,16 @@ ERROR: no-case ;
] [ drop f ] if ] [ drop f ] if
] [ 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 ) : 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 ) : case>quot ( default assoc -- quot )
dup keys { dup keys {

View File

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

View File

@ -1,6 +1,7 @@
USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
bunny.model bunny.outlined destructors kernel math opengl.demo-support 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 IN: bunny
TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; 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 ; >>draw-n relayout-1 ;
M: bunny-gadget graft* ( gadget -- ) M: bunny-gadget graft* ( gadget -- )
dup find-gl-context
GL_DEPTH_TEST glEnable GL_DEPTH_TEST glEnable
dup model-triangles>> <bunny-geom> >>geom dup model-triangles>> <bunny-geom> >>geom
dup dup
@ -29,6 +31,7 @@ M: bunny-gadget graft* ( gadget -- )
drop ; drop ;
M: bunny-gadget ungraft* ( gadget -- ) M: bunny-gadget ungraft* ( gadget -- )
dup find-gl-context
[ geom>> [ dispose ] when* ] [ geom>> [ dispose ] when* ]
[ draw-seq>> [ [ dispose ] when* ] each ] bi ; [ draw-seq>> [ [ dispose ] when* ] each ] bi ;

35
extra/dns/cache/nx/nx.factor vendored Normal file
View File

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

65
extra/dns/cache/rr/rr.factor vendored Normal file
View File

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

View File

@ -4,7 +4,8 @@
USING: combinators.lib kernel sequences math namespaces make USING: combinators.lib kernel sequences math namespaces make
assocs random sequences.private shuffle math.functions arrays assocs random sequences.private shuffle math.functions arrays
math.parser math.private sorting strings ascii macros assocs.lib 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 IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline : each-withn ( seq quot n -- ) nwith each ; inline
@ -131,11 +132,6 @@ PRIVATE>
: power-set ( seq -- subsets ) : power-set ( seq -- subsets )
2 over length exact-number-strings swap [ switches ] curry map ; 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 <PRIVATE
@ -149,18 +145,10 @@ PRIVATE>
: attempt-each ( seq quot -- result ) : attempt-each ( seq quot -- result )
(each) iterate-prep (attempt-each-integer) ; inline (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' ) : randomize ( seq -- seq' )
dup length 1 (a,b] [ dup random pick exchange ] each ; dup length 1 (a,b] [ dup random pick exchange ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : enumerate ( seq -- seq' ) <enum> >alist ;
: enumerate ( seq -- seq' )
<enum> >alist ;

View File

@ -1,6 +1,6 @@
USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers 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 IN: spheres
STRING: plane-vertex-shader STRING: plane-vertex-shader
@ -162,6 +162,9 @@ M: spheres-gadget distance-step ( gadget -- dz )
3array <gl-program> check-gl-program ; 3array <gl-program> check-gl-program ;
M: spheres-gadget graft* ( gadget -- ) 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 (plane-program) >>plane-program
(solid-sphere-program) >>solid-sphere-program (solid-sphere-program) >>solid-sphere-program
(texture-sphere-program) >>texture-sphere-program (texture-sphere-program) >>texture-sphere-program
@ -171,6 +174,7 @@ M: spheres-gadget graft* ( gadget -- )
drop ; drop ;
M: spheres-gadget ungraft* ( gadget -- ) M: spheres-gadget ungraft* ( gadget -- )
dup find-gl-context
{ {
[ reflection-framebuffer>> [ delete-framebuffer ] when* ] [ reflection-framebuffer>> [ delete-framebuffer ] when* ]
[ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
@ -182,14 +186,15 @@ M: spheres-gadget ungraft* ( gadget -- )
M: spheres-gadget pref-dim* ( gadget -- dim ) M: spheres-gadget pref-dim* ( gadget -- dim )
drop { 640 480 } ; 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 ; { -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 -- ) : sphere-scene ( gadget -- )
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
@ -197,12 +202,12 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
solid-sphere-program>> [ solid-sphere-program>> [
{ {
[ "light_position" glGetUniformLocation 0.0 0.0 100.0 glUniform3f ] [ "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 } cleave
] with-gl-program ] with-gl-program
] [ ] [
@ -271,7 +276,7 @@ M: spheres-gadget draw-gadget* ( gadget -- )
[ [
texture-sphere-program>> [ texture-sphere-program>> [
[ "surface_texture" glGetUniformLocation 0 glUniform1i ] [ "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 bi
] with-gl-program ] with-gl-program
] ]

View File

@ -33,7 +33,7 @@ TUPLE: calculator < dispatcher ;
! Deployment example ! Deployment example
USING: db.sqlite furnace.alloy namespaces http.server ; 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 ( -- ) : run-calculator ( -- )
<calculator> <calculator>

View File

@ -32,7 +32,7 @@ M: counter-app init-session* drop 0 count sset ;
! Deployment example ! Deployment example
USING: db.sqlite furnace.alloy namespaces ; USING: db.sqlite furnace.alloy namespaces ;
: counter-db ( -- params db ) "counter.db" sqlite-db ; : counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- ) : run-counter ( -- )
<counter-app> <counter-app>