(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
- scan {
+ scan-token {
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
[ parse-c-type ]
(FUNCTION:) make-function define-declared ;
SYNTAX: FUNCTION-ALIAS:
- scan create-function
+ scan-token create-function
(FUNCTION:) (make-function) define-declared ;
SYNTAX: CALLBACK:
scan scan-c-type \ } parse-until <struct-slot-spec> ;
: parse-struct-slots ( slots -- slots' more? )
- scan {
+ scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot suffix! t ] }
- { f [ unexpected-eof ] }
[ invalid-struct-slot ]
} case ;
{ $values { "receiver" "an " { $snippet "NSObject" } } { "delegate" "an Objective C class" } }
{ $description "Sets the receiver's delegate to a new instance of the delegate class." } ;
-HELP: objc-error
-{ $error-description "Thrown by the Objective C runtime when an error occurs, for example, sending a message to an object with an unrecognized selector." } ;
-
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
"Utilities:"
{ $subsections
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.strings cocoa.messages cocoa cocoa.classes
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
-TUPLE: objc-error alien reason ;
-
-: objc-error ( alien -- * )
- dup -> reason CF>string \ objc-error boa throw ;
-
-M: objc-error summary ( error -- )
- drop "Objective C exception" ;
-
-[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook
-
: running.app? ( -- ? )
#! Test if we're running a .app.
".app"
+++ /dev/null
-Kevin P. Reid
+++ /dev/null
-! Copyright (C) 2005, 2006 Kevin Reid.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types assocs kernel namespaces cocoa
-cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
-IN: cocoa.callbacks
-
-SYMBOL: callbacks
-
-: reset-callbacks ( -- )
- H{ } clone callbacks set-global ;
-
-reset-callbacks
-
-CLASS: {
- { +name+ "FactorCallback" }
- { +superclass+ "NSObject" }
-}
-
-{ "perform:" void { id SEL id }
- [ 2drop callbacks get at try ]
-}
-
-{ "dealloc" void { id SEL }
- [
- drop
- dup callbacks get delete-at
- SUPER-> dealloc
- ]
-} ;
-
-: <FactorCallback> ( quot -- id )
- FactorCallback -> alloc -> init
- [ callbacks get set-at ] keep ;
+++ /dev/null
-Allows you to use Factor quotations as Cocoa actions
FROM: alien.c-types => int void ;
IN: cocoa.tests
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Foo" }
-} {
- "foo:"
- void
- { id SEL NSRect }
- [ gc "x" set 2drop ]
-} ;
+CLASS: Foo < NSObject
+[
+ METHOD: void foo: NSRect rect [
+ gc rect "x" set
+ ]
+]
: test-foo ( -- )
Foo -> alloc -> init
[ 101.0 ] [ "x" get CGRect-w ] unit-test
[ 102.0 ] [ "x" get CGRect-h ] unit-test
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Bar" }
-} {
- "bar"
- NSRect
- { id SEL }
- [ 2drop test-foo "x" get ]
-} ;
+CLASS: Bar < NSObject
+[
+ METHOD: NSRect bar [ test-foo "x" get ]
+]
Bar [
-> alloc -> init
[ 102.0 ] [ "x" get CGRect-h ] unit-test
! Make sure that we can add methods
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Bar" }
-} {
- "bar"
- NSRect
- { id SEL }
- [ 2drop test-foo "x" get ]
-} {
- "babb"
- int
- { id SEL int }
- [ 2nip sq ]
-} ;
+CLASS: Bar < NSObject
+[
+ METHOD: NSRect bar [ test-foo "x" get ]
+
+ METHOD: int babb: int x [ x sq ]
+]
[ 144 ] [
Bar [
-> alloc -> init
- dup 12 -> babb
+ dup 12 -> babb:
swap -> release
] compile-call
] unit-test
USING: help.markup help.syntax strings alien hashtables ;
IN: cocoa.subclassing
-HELP: define-objc-class
-{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
-{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
- { $list
- { { $link +name+ } " - a string naming the new class. Required." }
- { { $link +superclass+ } " - a string naming the superclass. Required." }
- { { $link +protocols+ } " - an array of strings naming protocols implemented by the superclass. Optional." }
- }
-"Every element of " { $snippet "imeth" } " defines an instance method, and is an array having the shape "
-{ $snippet "{ name return args quot }" }
-".:"
-{ $table
- { "name" { "a selector name" } }
- { "name" { "a C type name; see " { $link "c-data" } } }
- { "args" { "a sequence of C type names; see " { $link "c-data" } } }
- { "quot" { "a quotation to be run as a callback when the method is invoked; see " { $link alien-callback } } }
-}
-"The quotation is run with the following values on the stack:"
-{ $list
- { "the receiver of the message; an " { $link alien } " pointing to an instance of this class" }
- { "the selector naming the message; in most cases this value can be ignored" }
- "arguments passed to the message, if any"
-}
-"There is no way to define instance variables or class methods using this mechanism. However, instance variables can be simulated by using the receiver to key into a hashtable." } ;
-
HELP: CLASS:
-{ $syntax "CLASS: spec imeth... ;" }
-{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions" } }
-{ $description "A sugared form of the following:"
- { $code "{ imeth... } \"spec\" define-objc-class" }
+{ $syntax "CLASS: name < superclass protocols... [ imeth... ]" }
+{ $values { "name" "a new class name" } { "superclass" "a superclass name" } { "protocols" "zero or more protocol names" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
+{ $description "Defines a new Objective C class. Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word."
+$nl
"This word is preferred to calling " { $link define-objc-class } ", because it creates a class word in the " { $vocab-link "cocoa.classes" } " vocabulary at parse time, allowing code to refer to the class word in the same source file where the class is defined." } ;
-{ define-objc-class POSTPONE: CLASS: } related-words
+{ define-objc-class POSTPONE: CLASS: POSTPONE: METHOD: } related-words
+
+HELP: METHOD:
+{ $syntax "METHOD: return foo: type1 arg1 bar: type2 arg2 baz: ... [ body ]" }
+{ $values { "return" "a C type name" } { "type1" "a C type name" } { "arg1" "a local variable name" } { "body" "arbitrary code" } }
+{ $description "Defines a method inside of a " { $link POSTPONE: CLASS: } " form." } ;
ARTICLE: "objc-subclassing" "Subclassing Objective C classes"
-"Objective C classes can be subclassed, with new methods defined in Factor, using a parsing word:"
-{ $subsections POSTPONE: CLASS: }
-"This word is actually syntax sugar for an ordinary word:"
-{ $subsections define-objc-class }
+"Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:"
+{ $subsections POSTPONE: CLASS: POSTPONE: METHOD: }
"Objective C class definitions are saved in the image. If the image is saved and Factor is restarted with the saved image, custom class definitions are made available to the Objective C runtime when they are first accessed from within Factor." ;
IN: cocoa.subclassing
-! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
+! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs
-combinators compiler hashtables kernel libc math namespaces
-parser sequences words cocoa.messages cocoa.runtime locals
-compiler.units io.encodings.utf8 continuations make fry ;
+USING: alien alien.c-types alien.parser alien.strings arrays
+assocs combinators compiler hashtables kernel lexer libc
+locals.parser locals.types math namespaces parser sequences
+words cocoa.messages cocoa.runtime locals compiler.units
+io.encodings.utf8 continuations make fry effects stack-checker
+stack-checker.errors ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
: add-protocols ( protocols class -- )
'[ [ _ ] dip objc-protocol add-protocol ] each ;
-: (define-objc-class) ( imeth protocols superclass name -- )
+: (define-objc-class) ( methods protocols superclass name -- )
[ objc-class ] dip 0 objc_allocateClassPair
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
] with-compilation-unit ;
:: (redefine-objc-method) ( class method -- )
- method init-method [| sel imp types |
- class sel class_getInstanceMethod [
- imp method_setImplementation drop
- ] [
- class sel imp types add-method
- ] if*
- ] call ;
+ method init-method :> ( sel imp types )
+
+ class sel class_getInstanceMethod [
+ imp method_setImplementation drop
+ ] [
+ class sel imp types add-method
+ ] if* ;
-: redefine-objc-methods ( imeth name -- )
+: redefine-objc-methods ( methods name -- )
dup class-exists? [
objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
] [ 2drop ] if ;
-SYMBOL: +name+
-SYMBOL: +protocols+
-SYMBOL: +superclass+
-
-: define-objc-class ( imeth hash -- )
- clone [
- prepare-methods
- +name+ get "cocoa.classes" create drop
- +name+ get 2dup redefine-objc-methods swap
- +protocols+ get +superclass+ get +name+ get
- '[ _ _ _ _ (define-objc-class) ]
- import-objc-class
- ] bind ;
+:: define-objc-class ( name superclass protocols methods -- )
+ methods prepare-methods :> methods
+ name "cocoa.classes" create drop
+ methods name redefine-objc-methods
+ name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
SYNTAX: CLASS:
- parse-definition unclip
- >hashtable define-objc-class ;
+ scan-token
+ "<" expect
+ scan-token
+ "[" parse-tokens
+ \ ] parse-until define-objc-class ;
+
+: (parse-selector) ( -- )
+ scan-token {
+ { [ dup "[" = ] [ drop ] }
+ { [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
+ [ f f 3array , "[" expect ]
+ } cond ;
+
+: parse-selector ( -- selector types names )
+ [ (parse-selector) ] { } make
+ flip first3
+ [ concat ]
+ [ sift { id SEL } prepend ]
+ [ sift { "self" "selector" } prepend ] tri* ;
+
+: parse-method-body ( names -- quot )
+ [ [ make-local ] map ] H{ } make-assoc
+ (parse-lambda) <lambda> ?rewrite-closures first ;
+
+: method-effect ( quadruple -- effect )
+ [ third ] [ second void? { } { "x" } ? ] bi <effect> ;
+
+: check-method ( quadruple -- )
+ [ fourth infer ] [ method-effect ] bi
+ 2dup effect<= [ 2drop ] [ effect-error ] if ;
+
+SYNTAX: METHOD:
+ scan-c-type
+ parse-selector
+ parse-method-body [ swap ] 2dip 4array
+ dup check-method
+ suffix! ;
T{ ##compare f 6 5 1 cc= }
} test-alias-analysis
] unit-test
+
+! We can't make any assumptions about heap-ac between alien
+! calls, since they might callback into Factor code
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ } test-alias-analysis
+] unit-test
slot# vreg kill-constant-set-slot
] [ vreg kill-computed-set-slot ] if ;
+: init-alias-analysis ( -- )
+ H{ } clone vregs>acs set
+ H{ } clone acs>vregs set
+ H{ } clone live-slots set
+ H{ } clone copies set
+ H{ } clone recent-stores set
+ HS{ } clone dead-stores set
+ 0 ac-counter set ;
+
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
analyze-aliases
] when ;
-GENERIC: eliminate-dead-stores ( insn -- ? )
-
-M: ##set-slot-imm eliminate-dead-stores
- insn#>> dead-stores get in? not ;
-
-M: insn eliminate-dead-stores drop t ;
-
-: init-alias-analysis ( -- )
- H{ } clone vregs>acs set
- H{ } clone acs>vregs set
- H{ } clone live-slots set
- H{ } clone copies set
- H{ } clone recent-stores set
- HS{ } clone dead-stores set
- 0 ac-counter set ;
-
: reset-alias-analysis ( -- )
recent-stores get clear-assoc
vregs>acs get clear-assoc
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac ;
+M: factor-call-insn analyze-aliases
+ heap-ac get ac>vregs [
+ [ live-slots get at clear-assoc ]
+ [ recent-stores get at clear-assoc ] bi
+ ] each ;
+
+GENERIC: eliminate-dead-stores ( insn -- ? )
+
+M: ##set-slot-imm eliminate-dead-stores
+ insn#>> dead-stores get in? not ;
+
+M: insn eliminate-dead-stores drop t ;
+
: alias-analysis-step ( insns -- insns' )
reset-alias-analysis
[ local-live-in [ set-heap-ac ] each ]
! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit kernel
-math math.order sequences assocs namespaces vectors fry arrays
-splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
-compiler.cfg.predecessors compiler.cfg.renaming
+locals math math.order sequences assocs namespaces vectors fry
+arrays splitting compiler.cfg.def-use compiler.cfg
+compiler.cfg.rpo compiler.cfg.predecessors compiler.cfg.renaming
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
1vector >>predecessors
] with map ;
-: update-predecessor-successor ( pred copy old-bb -- )
- '[
- [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
- ] change-successors drop ;
-
: update-predecessor-successors ( copies old-bb -- )
[ predecessors>> swap ] keep
- '[ _ update-predecessor-successor ] 2each ;
+ '[ [ _ ] 2dip update-predecessors ] 2each ;
-: update-successor-predecessor ( copies old-bb succ -- )
- [
- swap 1array split swap join V{ } like
- ] change-predecessors drop ;
+:: update-successor-predecessor ( copies old-bb succ -- )
+ succ
+ [ { old-bb } split copies join V{ } like ] change-predecessors
+ drop ;
: update-successor-predecessors ( copies old-bb -- )
- dup successors>> [
- update-successor-predecessor
- ] with with each ;
+ dup successors>>
+ [ update-successor-predecessor ] with with each ;
: split-branch ( bb -- )
[ new-blocks ] keep
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays layouts math math.order math.parser
-combinators combinators.short-circuit fry make sequences
-sequences.generalizations alien alien.private alien.strings
-alien.c-types alien.libraries classes.struct namespaces kernel
-strings libc locals quotations words cpu.architecture
-compiler.utilities compiler.tree compiler.cfg
+USING: accessors assocs arrays layouts math math.order
+math.parser combinators combinators.short-circuit fry make
+sequences sequences.generalizations alien alien.private
+alien.strings alien.c-types alien.libraries classes.struct
+namespaces kernel strings libc locals quotations words
+cpu.architecture compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.alien.params
compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stack-frame
-compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
+compiler.cfg.stacks compiler.cfg.stacks.local
+compiler.cfg.registers compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
: unbox-parameters ( parameters -- vregs reps )
[
[ length iota <reversed> ] keep
- [ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
+ [ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
2 2 mnmap [ concat ] bi@
]
- [ length neg ##inc-d ] bi ;
+ [ length neg inc-d ] bi ;
: prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
dup large-struct? [
struct-return-area set ;
: box-return* ( node -- )
- return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
+ return>> [ ] [ base-type box-return ds-push ] if-void ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
[ library>> load-library ]
bi 2dup check-dlsym ;
-: alien-node-height ( params -- )
- [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
-
-: emit-alien-block ( node quot: ( params -- ) -- )
- '[
- make-kill-block
- params>>
- _ [ alien-node-height ] bi
- ] emit-trivial-block ; inline
-
: emit-stack-frame ( stack-size params -- )
[ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
[ drop ##stack-frame ]
2bi ;
M: #alien-invoke emit-node
- [
- {
- [ caller-parameters ]
- [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
- [ emit-stack-frame ]
- [ box-return* ]
- } cleave
- ] emit-alien-block ;
-
-M:: #alien-indirect emit-node ( node -- )
- node [
- D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
- [ caller-parameters src <gc-map> ##alien-indirect ]
+ params>>
+ {
+ [ caller-parameters ]
+ [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
- tri
- ] emit-alien-block ;
+ } cleave ;
-M: #alien-assembly emit-node
+M: #alien-indirect emit-node ( node -- )
+ params>>
[
- {
- [ caller-parameters ]
- [ quot>> ##alien-assembly ]
- [ emit-stack-frame ]
- [ box-return* ]
- } cleave
- ] emit-alien-block ;
+ ds-pop ^^unbox-any-c-ptr
+ [ caller-parameters ] dip
+ <gc-map> ##alien-indirect
+ ]
+ [ emit-stack-frame ]
+ [ box-return* ]
+ tri ;
+
+M: #alien-assembly emit-node
+ params>> {
+ [ caller-parameters ]
+ [ quot>> <gc-map> ##alien-assembly ]
+ [ emit-stack-frame ]
+ [ box-return* ]
+ } cleave ;
: callee-parameter ( rep on-stack? -- dst insn )
[ next-vreg dup ] 2dip
bi ;
: box-parameters ( vregs reps params -- )
- ##begin-callback
- next-vreg next-vreg ##restore-context
- [
- next-vreg next-vreg ##save-context
- box-parameter
- 1 ##inc-d D 0 ##replace
- ] 3each ;
+ ##begin-callback [ box-parameter ds-push ] 3each ;
: callee-parameters ( params -- stack-size )
[ abi>> ] [ return>> ] [ parameters>> ] tri
cfg get t >>frame-pointer? drop ;
M: #alien-callback emit-node
- dup params>> xt>> dup
+ params>> dup xt>> dup
[
needs-frame-pointer
- ##prologue
- [
- {
- [ callee-parameters ]
- [ quot>> ##alien-callback ]
+ begin-word
+
+ {
+ [ callee-parameters ]
+ [
[
- return>> [ ##end-callback ] [
- [ D 0 ^^peek ] dip
- ##end-callback
- base-type unbox-return
- ] if-void
- ]
- [ callback-stack-cleanup ]
- } cleave
- ] emit-alien-block
- ##epilogue
- ##return
+ make-kill-block
+ quot>> ##alien-callback
+ ] emit-trivial-block
+ ]
+ [
+ return>> [ ##end-callback ] [
+ [ ds-pop ] dip
+ ##end-callback
+ base-type unbox-return
+ ] if-void
+ ]
+ [ callback-stack-cleanup ]
+ } cleave
+
+ end-word
] with-cfg-builder ;
dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
! #return
-: emit-return ( -- )
+: end-word ( -- )
##branch
begin-basic-block
make-kill-block
##epilogue
##return ;
-M: #return emit-node drop emit-return ;
+M: #return emit-node drop end-word ;
M: #return-recursive emit-node
- label>> id>> loops get key? [ emit-return ] unless ;
+ label>> id>> loops get key? [ end-word ] unless ;
! #terminate
M: #terminate emit-node drop ##no-tco end-basic-block ;
: finalize-cfg ( cfg -- cfg' )
select-representations
- schedule-instructions
+ ! schedule-instructions
insert-gc-checks
dup compute-uninitialized-sets
insert-save-contexts
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
tools.test kernel vectors namespaces accessors sequences alien
-memory classes make combinators.short-circuit byte-arrays ;
+memory classes make combinators.short-circuit byte-arrays
+compiler.cfg.comparisons ;
IN: compiler.cfg.gc-checks.tests
+[ { } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##alien-invoke }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 0 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##allot }
+ T{ ##alien-invoke }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 0 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##allot }
+ T{ ##allot }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 0 4 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##allot }
+ T{ ##alien-invoke }
+ T{ ##allot }
+ T{ ##add }
+ T{ ##sub }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 3 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##alien-invoke }
+ T{ ##allot }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { { "a" } } ] [ { "a" } { } split-instructions ] unit-test
+
+[ { { } { "a" } } ] [ { "a" } { 0 } split-instructions ] unit-test
+
+[ { { "a" } { } } ] [ { "a" } { 1 } split-instructions ] unit-test
+
+[ { { "a" } { "b" } } ] [ { "a" "b" } { 1 } split-instructions ] unit-test
+
+[ { { } { "a" } { "b" "c" } } ] [ { "a" "b" "c" } { 0 1 } split-instructions ] unit-test
+
: test-gc-checks ( -- )
H{ } clone representations set
cfg new 0 get >>entry cfg set ;
[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
-[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+[ ] [ 1 get
instructions>> allocation-size 123 <alien> size assert= ] unit-test
2 \ vreg-counter set-global
[ first ##check-nursery-branch? ]
} 1&& ;
-[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
-
-4 \ vreg-counter set-global
-
-[
+: gc-call? ( bb -- ? )
+ instructions>>
V{
T{ ##call-gc f T{ gc-map } }
T{ ##branch }
- }
-]
-[
- <gc-call> instructions>>
-] unit-test
-
-30 \ vreg-counter set-global
-
-V{
- T{ ##branch }
-} 0 test-bb
+ } = ;
-V{
- T{ ##branch }
-} 1 test-bb
-
-V{
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##branch }
-} 4 test-bb
-
-0 { 1 2 } edges
-1 3 edge
-2 3 edge
-3 4 edge
-
-[ ] [ test-gc-checks ] unit-test
-
-[ ] [ cfg get needs-predecessors drop ] unit-test
-
-[ ] [ V{ } 31337 3 get (insert-gc-check) ] unit-test
-
-[ t ] [ 1 get successors>> first gc-check? ] unit-test
-
-[ t ] [ 2 get successors>> first gc-check? ] unit-test
+4 \ vreg-counter set-global
-[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+[ t ] [ <gc-call> gc-call? ] unit-test
30 \ vreg-counter set-global
[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ 1 get successors>> first successors>> first 2 set ] unit-test
+
[ 2 ] [ 2 get predecessors>> length ] unit-test
[ t ] [ 1 get successors>> first gc-check? ] unit-test
} representations set
[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ 1 get successors>> first successors>> first 3 set ] unit-test
[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
[ 2 ] [ 3 get instructions>> length ] unit-test
+
+! GC check in a block that is its own successor
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 { 1 2 } edges
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ ] [
+ 0 get successors>> first predecessors>>
+ [ first 0 get assert= ]
+ [ second 1 get [ instructions>> ] bi@ assert= ] bi
+] unit-test
+
+[ ] [
+ 0 get successors>> first successors>>
+ [ first 1 get [ instructions>> ] bi@ assert= ]
+ [ second gc-call? t assert= ] bi
+] unit-test
+
+[ ] [
+ 2 get predecessors>> first predecessors>>
+ [ first gc-check? t assert= ]
+ [ second gc-call? t assert= ] bi
+] unit-test
+
+! Brave new world of calls in the middle of BBs
+
+! call then allot
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+2 \ vreg-counter set-global
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+! The GC check should come after the alien-invoke
+[
+ V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##check-nursery-branch f 64 cc<= 3 4 }
+ }
+] [ 0 get successors>> first instructions>> ] unit-test
+
+! call then allot then call then allot
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##allot f 1 64 byte-array }
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##allot f 2 64 byte-array }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+2 \ vreg-counter set-global
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[
+ V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##check-nursery-branch f 64 cc<= 3 4 }
+ }
+] [
+ 0 get
+ successors>> first
+ instructions>>
+] unit-test
+
+[
+ V{
+ T{ ##allot f 1 64 byte-array }
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##check-nursery-branch f 64 cc<= 5 6 }
+ }
+] [
+ 0 get
+ successors>> first
+ successors>> first
+ instructions>>
+] unit-test
+
+[
+ V{
+ T{ ##allot f 2 64 byte-array }
+ T{ ##branch }
+ }
+] [
+ 0 get
+ successors>> first
+ successors>> first
+ successors>> first
+ instructions>>
+] unit-test
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators fry kernel layouts locals
-math make namespaces sequences cpu.architecture
+USING: accessors assocs combinators fry grouping kernel layouts
+locals math make namespaces sequences cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.predecessors ;
IN: compiler.cfg.gc-checks
-<PRIVATE
-
! Garbage collection check insertion. This pass runs after
! representation selection, since it needs to know which vregs
! can contain tagged pointers.
+<PRIVATE
+
: insert-gc-check? ( bb -- ? )
dup kill-block?>>
[ drop f ] [ instructions>> [ ##allocation? ] any? ] if ;
: blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ;
-! A GC check for bb consists of two new basic blocks, gc-check
-! and gc-call:
-!
-! gc-check
-! / \
-! | gc-call
-! \ /
-! bb
-
-! Any ##phi instructions at the start of bb are transplanted
-! into the gc-check block.
-
-: <gc-check> ( phis size -- bb )
- [ <basic-block> ] 2dip
- [
- [ % ]
- [
- cc<= int-rep next-vreg-rep int-rep next-vreg-rep
- ##check-nursery-branch
- ] bi*
- ] V{ } make >>instructions ;
-
-: <gc-call> ( -- bb )
- <basic-block>
- [ <gc-map> ##call-gc ##branch ] V{ } make
- >>instructions t >>unlikely? ;
-
-:: insert-guard ( body check bb -- )
- bb predecessors>> check predecessors<<
- V{ bb body } check successors<<
-
- V{ check } body predecessors<<
- V{ bb } body successors<<
+GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
- V{ check body } bb predecessors<<
+:: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
+ seen-allocation? [ call-index , ] when
+ insn-index 1 + f ;
- check predecessors>> [ bb check update-successors ] each ;
+M: ##phi gc-check-offsets* gc-check-here ;
+M: gc-map-insn gc-check-offsets* gc-check-here ;
+M: ##allocation gc-check-offsets* 3drop t ;
+M: insn gc-check-offsets* 2drop ;
-: (insert-gc-check) ( phis size bb -- )
- [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
+: gc-check-offsets ( insns -- seq )
+ ! A basic block is divided into sections by call and phi
+ ! instructions. For every section with at least one
+ ! allocation, record the offset of its first instruction
+ ! in a sequence.
+ [
+ [ 0 f ] dip
+ [ gc-check-offsets* ] each-index
+ [ , ] [ drop ] if
+ ] { } make ;
+
+:: split-instructions ( insns seq -- insns-seq )
+ ! Divide a basic block into sections, where every section
+ ! other than the first requires a GC check.
+ [
+ insns 0 seq [| insns from to |
+ from to insns subseq ,
+ insns to
+ ] each
+ tail ,
+ ] { } make ;
GENERIC: allocation-size* ( insn -- n )
M: ##box-displaced-alien allocation-size* drop 5 cells ;
-: allocation-size ( bb -- n )
- instructions>>
+: allocation-size ( insns -- n )
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
-: remove-phis ( bb -- phis )
- [ [ ##phi? ] partition ] change-instructions drop ;
+: add-gc-checks ( insns-seq -- )
+ ! Insert a GC check at the end of every chunk but the last
+ ! one. This ensures that every section other than the first
+ ! has a GC check in the section immediately preceeding it.
+ 2 <clumps> [
+ first2 allocation-size
+ cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+ \ ##check-nursery-branch new-insn
+ swap push
+ ] each ;
+
+: make-blocks ( insns-seq -- bbs )
+ [ <basic-block> swap >>instructions ] map ;
-: insert-gc-check ( bb -- )
- [ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
+: <gc-call> ( -- bb )
+ <basic-block>
+ [ <gc-map> ##call-gc ##branch ] V{ } make
+ >>instructions t >>unlikely? ;
+
+:: connect-gc-checks ( bbs -- )
+ ! Every basic block but the last has two successors:
+ ! the next block, and a GC call.
+ ! Every basic block but the first has two predecessors:
+ ! the previous block, and the previous block's GC call.
+ bbs length 1 - :> len
+ len [ <gc-call> ] replicate :> gc-calls
+ len [| n |
+ n bbs nth :> bb
+ n 1 + bbs nth :> next-bb
+ n gc-calls nth :> gc-call
+ V{ next-bb gc-call } bb successors<<
+ V{ next-bb } gc-call successors<<
+ V{ bb } gc-call predecessors<<
+ V{ bb gc-call } next-bb predecessors<<
+ ] each-integer ;
+
+:: update-predecessor-phis ( from to bb -- )
+ to [
+ [
+ [
+ [ dup from eq? [ drop bb ] when ] dip
+ ] assoc-map
+ ] change-inputs drop
+ ] each-phi ;
+
+:: (insert-gc-checks) ( bb bbs -- )
+ bb predecessors>> bbs first predecessors<<
+ bb successors>> bbs last successors<<
+ bb predecessors>> [ bb bbs first update-successors ] each
+ bb successors>> [
+ [ bb ] dip bbs last
+ [ update-predecessors ]
+ [ update-predecessor-phis ] 3bi
+ ] each ;
+
+: process-block ( bb -- )
+ dup instructions>> dup gc-check-offsets split-instructions
+ [ add-gc-checks ] [ make-blocks dup connect-gc-checks ] bi
+ (insert-gc-checks) ;
PRIVATE>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
[ needs-predecessors ] dip
- [ insert-gc-check ] each
+ [ process-block ] each
cfg-changed
] unless-empty ;
literal: gc-map ;
INSN: ##alien-assembly
-literal: quot ;
+literal: quot gc-map ;
INSN: ##begin-callback ;
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##restore-context
-temp: temp1/int-rep temp2/int-rep ;
-
! GC checks
INSN: ##check-nursery-branch
literal: size cc
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
+! Instructions that contain subroutine calls to functions which
+! can callback arbitrary Factor code
+UNION: factor-call-insn
+##alien-invoke
+##alien-indirect
+##alien-assembly ;
+
! Instructions that contain subroutine calls to functions which
! allocate memory
UNION: gc-map-insn
##call-gc
-##alien-invoke
-##alien-indirect
##box
##box-long-long
-##allot-byte-array ;
+##allot-byte-array
+factor-call-insn ;
M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs sequences sets
+USING: kernel accessors assocs namespaces sequences sets
compiler.cfg.def-use compiler.cfg.dataflow-analysis
compiler.cfg.instructions compiler.cfg.registers
cpu.architecture ;
M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
: fill-gc-map ( live-set insn -- live-set )
- gc-map>> over keys [ rep-of tagged-rep? ] filter >>gc-roots drop ;
+ representations get [
+ gc-map>> over keys
+ [ rep-of tagged-rep? ] filter
+ >>gc-roots
+ ] when
+ drop ;
M: gc-map-insn visit-insn
[ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;
USING: accessors compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.save-contexts kernel namespaces tools.test ;
+compiler.cfg.save-contexts kernel namespaces tools.test
+cpu.x86.assembler.operands cpu.architecture ;
IN: compiler.cfg.save-contexts.tests
0 vreg-counter set-global
] [
0 get instructions>>
] unit-test
+
+4 vreg-counter set-global
+
+V{
+ T{ ##inc-d f 3 }
+ T{ ##load-reg-param f 0 RCX int-rep }
+ T{ ##load-reg-param f 1 RDX int-rep }
+ T{ ##load-reg-param f 2 R8 int-rep }
+ T{ ##begin-callback }
+ T{ ##box f 4 3 "from_signed_4" int-rep
+ T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
+ }
+} 0 test-bb
+
+0 get insert-save-context
+
+[
+ V{
+ T{ ##inc-d f 3 }
+ T{ ##load-reg-param f 0 RCX int-rep }
+ T{ ##load-reg-param f 1 RDX int-rep }
+ T{ ##load-reg-param f 2 R8 int-rep }
+ T{ ##save-context f 5 6 }
+ T{ ##begin-callback }
+ T{ ##box f 4 3 "from_signed_4" int-rep
+ T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
+ }
+ }
+] [
+ 0 get instructions>>
+] unit-test
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit
-compiler.cfg.instructions compiler.cfg.registers
+USING: accessors compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
IN: compiler.cfg.save-contexts
! Insert context saves.
-: needs-save-context? ( insns -- ? )
- [
- {
- [ ##unary-float-function? ]
- [ ##binary-float-function? ]
- [ ##alien-invoke? ]
- [ ##alien-indirect? ]
- [ ##alien-assembly? ]
- } 1||
- ] any? ;
+GENERIC: needs-save-context? ( insn -- ? )
+
+M: ##unary-float-function needs-save-context? drop t ;
+M: ##binary-float-function needs-save-context? drop t ;
+M: gc-map-insn needs-save-context? drop t ;
+M: insn needs-save-context? drop f ;
+
+: bb-needs-save-context? ( insn -- ? )
+ instructions>> [ needs-save-context? ] any? ;
+
+GENERIC: modifies-context? ( insn -- ? )
+
+M: ##inc-d modifies-context? drop t ;
+M: ##inc-r modifies-context? drop t ;
+M: ##load-reg-param modifies-context? drop t ;
+M: insn modifies-context? drop f ;
+
+: save-context-offset ( bb -- n )
+ ! ##save-context must be placed after instructions that
+ ! modify the context, or instructions that read parameter
+ ! registers.
+ instructions>> [ modifies-context? not ] find drop ;
: insert-save-context ( bb -- )
- dup instructions>> dup needs-save-context? [
- tagged-rep next-vreg-rep
- tagged-rep next-vreg-rep
- \ ##save-context new-insn prefix
- >>instructions drop
- ] [ 2drop ] if ;
+ dup bb-needs-save-context? [
+ [
+ int-rep next-vreg-rep
+ int-rep next-vreg-rep
+ \ ##save-context new-insn
+ ] dip
+ [ save-context-offset ] keep
+ [ insert-nth ] change-instructions drop
+ ] [ drop ] if ;
: insert-save-contexts ( cfg -- cfg' )
dup [ insert-save-context ] each-basic-block ;
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
:: update-predecessors ( from to bb -- )
- ! Update 'to' predecessors for insertion of 'bb' between
- ! 'from' and 'to'.
+ ! Whenever 'from' appears in the list of predecessors of 'to'
+ ! replace it with 'bb'.
to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
:: update-successors ( from to bb -- )
- ! Update 'from' successors for insertion of 'bb' between
- ! 'from' and 'to'.
+ ! Whenever 'to' appears in the list of successors of 'from'
+ ! replace it with 'bb'.
from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
:: insert-basic-block ( from to insns -- )
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
-CODEGEN: ##restore-context %restore-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global
CODEGEN: ##alien-callback %alien-callback
CODEGEN: ##end-callback %end-callback
-M: ##alien-assembly generate-insn quot>> call( -- ) ;
+M: ##alien-assembly generate-insn
+ [ gc-map>> gc-map set ] [ quot>> call( -- ) ] bi ;
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler.test definitions generic.single shuffle math.order
-compiler.cfg.debugger ;
+compiler.cfg.debugger classes.struct alien.syntax alien.data ;
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
GENERIC: bad-push-test-case ( a -- b )
M: object bad-push-test-case "foo" throw ; inline
[ { 1 } "bar" ] [ { 1 } [ [ [ [ bad-push-test-case ] [ "bar" throw ] recover ] attempt-all f ] [ ] recover ] compile-call ] unit-test
+
+STRUCT: BitmapData { Scan0 void* } ;
+
+[ ALIEN: 123 ] [
+ [
+ { BitmapData }
+ [ BitmapData memory>struct ALIEN: 123 >>Scan0 drop ]
+ [ clone ]
+ with-out-parameters Scan0>>
+ ] compile-call
+] unit-test
literal>> dup tuple-class? [ drop tuple ] unless <class-info>
] "outputs" set-word-prop
-! the output of clone has the same type as the input
+! the output of (clone) has the same type as the input
: cloned-value-info ( value-info -- value-info' )
clone f >>literal f >>literal?
[ [ dup [ cloned-value-info ] when ] map ] change-slots ;
-{ clone (clone) } [
- [ cloned-value-info ] "outputs" set-word-prop
-] each
+\ (clone) [ cloned-value-info ] "outputs" set-word-prop
\ slot [
dup literal?>>
HOOK: %allot-byte-array cpu ( dst size gc-map -- )
-HOOK: %restore-context cpu ( temp1 temp2 -- )
-
HOOK: %save-context cpu ( temp1 temp2 -- )
HOOK: %prepare-var-args cpu ( -- )
: nv-reg ( -- reg ) ESI ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
+: link-reg ( -- reg ) EBX ;
: fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ;
ESP 4 [+] EAX MOV
"begin_callback" jit-call
- jit-load-vm
- jit-load-context
- jit-restore-context
-
jit-call-quot
jit-load-vm
- jit-save-context
-
ESP [] vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
: nv-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: frame-reg ( -- reg ) RBP ;
+: link-reg ( -- reg ) R11 ;
: ctx-reg ( -- reg ) R12 ;
: vm-reg ( -- reg ) R13 ;
: ds-reg ( -- reg ) R14 ;
arg1 vm-reg MOV
"begin_callback" jit-call
- jit-load-context
- jit-restore-context
-
! call the quotation
arg1 return-reg MOV
jit-call-quot
- jit-save-context
-
arg1 vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
[ [ EAX [] XMM1 UCOMISD ] { } make ] must-fail
[ { HEX: 66 HEX: 0f HEX: 38 HEX: 2a HEX: 01 } ] [ [ XMM0 ECX [] MOVNTDQA ] { } make ] unit-test
+[ { HEX: 66 HEX: 48 HEX: 0f HEX: 6e HEX: c8 } ] [ [ XMM1 RAX MOVD ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 6e HEX: c8 } ] [ [ XMM1 EAX MOVD ] { } make ] unit-test
+[ { HEX: 66 HEX: 48 HEX: 0f HEX: 7e HEX: c8 } ] [ [ RAX XMM1 MOVD ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 7e HEX: c8 } ] [ [ EAX XMM1 MOVD ] { } make ] unit-test
+
+[ { HEX: f3 HEX: 0f HEX: 7e HEX: 08 } ] [ [ XMM1 EAX [] MOVQ ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: 7e HEX: 08 } ] [ [ XMM1 EAX [] MOVQ ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: 7e HEX: ca } ] [ [ XMM1 XMM2 MOVQ ] { } make ] unit-test
+
! rm-r only sse instructions
[ { HEX: 0f HEX: 2b HEX: 08 } ] [ [ EAX [] XMM1 MOVNTPS ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: e7 HEX: 08 } ] [ [ EAX [] XMM1 MOVNTDQ ] { } make ] unit-test
: 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- )
[ , ] when* direction-op-sse extended-opcode (2-operand) ;
+: 2-operand-rm-mr-sse* ( dst src op12{rm,mr} -- )
+ direction-op-sse first2 [ , ] when* extended-opcode (2-operand) ;
+
: 2-operand-rm-sse ( dst src op1 op2 -- )
[ , ] when* extended-opcode (2-operand) ;
: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ;
: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ;
+: MOVQ ( dest src -- )
+ { { HEX: 7e HEX: f3 } { HEX: d6 HEX: 66 } } 2-operand-rm-mr-sse* ;
+
<PRIVATE
: 2shuffler ( indexes/mask -- mask )
! Save C callstack pointer
nv-reg context-callstack-save-offset [+] stack-reg MOV
- ! Load Factor callstack pointer
+ ! Load Factor stack pointers
stack-reg nv-reg context-callstack-bottom-offset [+] MOV
-
nv-reg jit-update-tib
jit-install-seh
+ rs-reg nv-reg context-retainstack-offset [+] MOV
+ ds-reg nv-reg context-datastack-offset [+] MOV
+
! Call into Factor code
- nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
- nv-reg CALL
+ link-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
+ link-reg CALL
! Load VM into vm-reg; only needed on x86-32, but doesn't
! hurt on x86-64
M: x86 %loop-entry 16 alignment [ NOP ] times ;
-M:: x86 %restore-context ( temp1 temp2 -- )
- #! Load Factor stack pointers on entry from C to Factor.
- temp1 %context
- temp2 stack-reg cell neg [+] LEA
- temp1 "callstack-top" context-field-offset [+] temp2 MOV
- ds-reg temp1 "datastack" context-field-offset [+] MOV
- rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
-
M:: x86 %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
dup search dup lexical? [ nip ] [ drop ] if ;
: scan-string-param ( -- name/param )
- scan >string-param ;
+ scan-token >string-param ;
: scan-c-type-param ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
[ "HTTP/" write version>> write crlf ]
tri ;
-: url-host ( url -- string )
- [ host>> ] [ port>> ] bi dup "http" protocol-port =
- [ drop ] [ ":" swap number>string 3append ] if ;
-
: set-host-header ( request header -- request header )
- over url>> url-host "host" pick set-at ;
+ over url>> host>> "host" pick set-at ;
: set-cookie-header ( header cookies -- header )
unparse-cookie "cookie" pick set-at ;
{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ;
ARTICLE: "http.server.requests" "HTTP request variables"
-"The following variables are set by the HTTP server at the beginning of a request."
+"The following variables are set by the HTTP server at the beginning of a request. Responder implementations may access these variables."
{ $subsections
request
url
- post-request?
responder-nesting
params
}
"Utility words:"
{ $subsections
+ post-request?
param
set-param
request-params
}
-"Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
+"Additional variables may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
ARTICLE: "http.server.responders" "HTTP server responders"
+"Responders process requests and output " { $link "http.responses" } ". To implement a responder, define a new class and implement a method on the following generic word:"
+{ $subsections call-responder* }
"The HTTP server dispatches requests to a main responder:"
{ $subsections main-responder }
-"The main responder may in turn dispatch it a subordinate dispatcher, and so on."
-$nl
-"Responders process requests and output " { $link "http.responses" } "; concretely are instances of classes which implement a generic word:"
-{ $subsections call-responder* }
-"To actually call a subordinate responder, use the following word instead:"
+"The main responder may in turn dispatch it a subordinate dispatcher, and so on. To call a subordinate responder, use the following word:"
{ $subsections call-responder }
"A simple implementation of a responder which always outputs the same response:"
{ $subsections
trivial-responder
<trivial-responder>
}
-{ $vocab-subsection "Furnace actions" "furnace.actions" }
-"In particular, writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead." ;
+"Writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead."
+{ $vocab-subsection "Furnace actions" "furnace.actions" } ;
ARTICLE: "http.server.variables" "HTTP server variables"
"The following global variables control the behavior of the HTTP server. Both are off by default."
io.encodings.binary
io.streams.limited
io.streams.string
+io.streams.throwing
io.servers.connection
io.timeouts
io.crlf
SYMBOL: upload-limit
: read-multipart-data ( request -- mime-parts )
- [ "content-type" header ]
- [ "content-length" header string>number ] bi
unlimited-input
- upload-limit get stream-throws limit-input
- stream-eofs limit-input
- binary decode-input
- parse-multipart-form-data parse-multipart ;
+ upload-limit get limited-input
+ [ "content-type" header ]
+ [ "content-length" header string>number limited-input ] bi
+ [
+ binary decode-input
+ parse-multipart-form-data parse-multipart
+ ] input-throws-on-eof ;
: read-content ( request -- bytes )
"content-length" header string>number read ;
] when ;
: extract-host ( request -- request )
- [ ] [ url>> ] [ "host" header parse-host ] tri
- [ >>host ] [ >>port ] bi*
- drop ;
+ [ ] [ url>> ] [ "host" header dup [ url-decode ] when ] tri
+ >>host drop ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookie >>cookies ] when* ;
SYMBOL: request-limit
-64 1024 * request-limit set-global
+request-limit [ 64 1024 * ] initialize
M: http-server handle-client*
drop [
- request-limit get stream-throws limit-input
- ?refresh-all
- [ read-request ] ?benchmark
- [ do-request ] ?benchmark
- [ do-response ] ?benchmark
+ request-limit get limited-input
+ [
+ ?refresh-all
+ [ read-request ] ?benchmark
+ [ do-request ] ?benchmark
+ [ do-response ] ?benchmark
+ ] input-throws-on-eof
] with-destructors ;
: <http-server> ( -- server )
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators compression.run-length endian fry grouping images
-images.loader images.normalization io io.binary
-io.encodings.8-bit.latin1 io.encodings.binary
-io.encodings.string io.files io.streams.limited kernel locals
-macros math math.bitwise math.functions namespaces sequences
+USING: accessors alien.c-types arrays byte-arrays combinators
+compression.run-length fry grouping images images.loader
+images.normalization io io.binary io.encodings.8-bit.latin1
+io.encodings.string kernel math math.bitwise sequences
specialized-arrays summary ;
QUALIFIED-WITH: bitstreams b
SPECIALIZED-ARRAYS: uint ushort ;
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays byte-arrays combinators
-compression.run-length fry grouping images images.loader io
-io.binary io.encodings.binary
-io.encodings.string io.streams.limited kernel math math.bitwise
-io.encodings.8-bit.latin1 sequences specialized-arrays summary images.bitmap ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators
-grouping compression.huffman images fry
-images.processing io io.binary io.encodings.binary io.files
-io.streams.byte-array kernel locals math math.bitwise
-math.constants math.functions math.matrices math.order
-math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep images.loader io.streams.limited ;
-IN: images.jpeg
-
+compression.huffman fry grouping images images.loader
+images.processing io io.binary io.encodings.binary
+io.streams.byte-array io.streams.limited io.streams.throwing
+kernel locals math math.bitwise math.blas.matrices
+math.blas.vectors math.constants math.functions math.matrices
+math.order math.vectors memoize namespaces sequences
+sequences.deep ;
QUALIFIED-WITH: bitstreams bs
+IN: images.jpeg
SINGLETON: jpeg-image
: decode-huff-table ( chunk -- )
data>> [ binary <byte-reader> ] [ length ] bi
- stream-throws limit
+ limit-stream <throws-on-eof>
[
[ input-stream get [ count>> ] [ limit>> ] bi < ]
[
: idct-factor ( b -- b' ) dct-matrix v.m ;
-USE: math.blas.vectors
-USE: math.blas.matrices
-
MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs byte-arrays combinators images
-io.encodings.binary io.files io.pathnames io.streams.byte-array
-io.streams.limited kernel namespaces sequences splitting
-strings unicode.case ;
+USING: assocs byte-arrays io.encodings.binary io.files
+io.pathnames io.streams.byte-array io.streams.limited
+io.streams.throwing kernel namespaces sequences strings
+unicode.case fry ;
IN: images.loader
ERROR: unknown-image-extension extension ;
[ unknown-image-extension ] unless ;
: open-image-file ( path -- stream )
- binary stream-throws <limited-file-reader> ;
+ binary <limited-file-reader> ;
PRIVATE>
M: byte-array load-image*
[
- [ binary <byte-reader> ]
- [ length stream-throws <limited-stream> ] bi
- ] dip stream>image ;
+ [ binary <byte-reader> ] [ length ] bi
+ <limited-stream> dup
+ ] dip '[ _ stream>image ] throws-on-eof ;
M: limited-stream load-image* stream>image ;
byte-vectors system io.encodings math.order io.backend
continuations classes byte-arrays namespaces splitting grouping
dlists alien alien.c-types assocs io.encodings.binary summary
-accessors destructors combinators fry specialized-arrays ;
+accessors destructors combinators fry specialized-arrays
+locals ;
SPECIALIZED-ARRAY: uchar
IN: io.ports
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
-M: output-port stream-element-type stream>> stream-element-type ; inline
+M: output-port stream-element-type
+ stream>> stream-element-type ; inline
M: output-port stream-write1
dup check-disposed
HOOK: (wait-to-write) io-backend ( port -- )
+: port-flush ( port -- )
+ dup buffer>> buffer-empty?
+ [ drop ] [ dup (wait-to-write) port-flush ] if ;
+
+M: output-port stream-flush ( port -- )
+ [ check-disposed ] [ port-flush ] bi ;
+
HOOK: tell-handle os ( handle -- n )
+
HOOK: seek-handle os ( n seek-type handle -- )
-M: buffered-port stream-tell ( stream -- n )
+M: input-port stream-tell ( stream -- n )
+ [ check-disposed ]
+ [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi - ] bi ;
+
+M: output-port stream-tell ( stream -- n )
[ check-disposed ]
- [ handle>> tell-handle ]
- [ [ buffer>> size>> - 0 max ] [ buffer>> pos>> ] bi + ] tri ;
+ [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi + ] bi ;
+
+:: do-seek-relative ( n seek-type stream -- n seek-type stream )
+ ! seek-relative needs special handling here, because of the
+ ! buffer.
+ seek-type seek-relative eq?
+ [ n stream stream-tell + seek-absolute ] [ n seek-type ] if
+ stream ;
M: input-port stream-seek ( n seek-type stream -- )
+ do-seek-relative
[ check-disposed ]
[ buffer>> 0 swap buffer-reset ]
[ handle>> seek-handle ] tri ;
M: output-port stream-seek ( n seek-type stream -- )
+ do-seek-relative
[ check-disposed ]
[ stream-flush ]
[ handle>> seek-handle ] tri ;
M: object shutdown drop ;
-: port-flush ( port -- )
- dup buffer>> buffer-empty?
- [ drop ] [ dup (wait-to-write) port-flush ] if ;
-
-M: output-port stream-flush ( port -- )
- [ check-disposed ] [ port-flush ] bi ;
-
M: output-port dispose*
[
{
HELP: <limited-stream>
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
+ { "stream" "an input stream" } { "limit" integer }
{ "stream'" "an input stream" }
}
-{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ;
+{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit-stream } " or " { $link limited-input } "." } ;
-HELP: limit
+HELP: limit-stream
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
+ { "stream" "an input stream" } { "limit" integer }
{ "stream'" "a stream" }
}
{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
-{ $examples "Throwing an exception:"
- { $example
- "USING: continuations io io.streams.limited io.streams.string"
- "kernel prettyprint ;"
- "["
- " \"123456\" <string-reader> 3 stream-throws limit"
- " 100 swap stream-read ."
- "] [ ] recover ."
-"""T{ limit-exceeded
- { n 1 }
- { stream
- T{ limited-stream
- { stream
- T{ string-reader
- { underlying "123456" }
- { i 3 }
- }
- }
- { mode stream-throws }
- { count 4 }
- { limit 3 }
- }
- }
-}"""
- }
- "Returning " { $link f } " on exhaustion:"
+{ $examples
+ "Limiting a longer stream to length three:"
{ $example
"USING: accessors continuations io io.streams.limited"
"io.streams.string kernel prettyprint ;"
- "\"123456\" <string-reader> 3 stream-eofs limit"
+ "\"123456\" <string-reader> 3 limit-stream"
"100 swap stream-read ."
"\"123\""
}
} ;
-HELP: unlimited
+HELP: unlimit-stream
{ $values
{ "stream" "an input stream" }
{ "stream'" "a stream" }
}
{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion." } ;
-HELP: limit-input
-{ $values
- { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
-}
+HELP: limited-input
+{ $values { "limit" integer } }
{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
HELP: unlimited-input
{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ;
-HELP: stream-eofs
-{ $values
- { "value" { $link stream-throws } " or " { $link stream-eofs } }
-}
-{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will return " { $link f } " upon exhaustion." } ;
-
-HELP: stream-throws
-{ $values
- { "value" { $link stream-throws } " or " { $link stream-eofs } }
-}
-{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will throw " { $link limit-exceeded } " upon exhaustion." } ;
-
-{ stream-eofs stream-throws } related-words
-
ARTICLE: "io.streams.limited" "Limited input streams"
"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end. Limiting a non-seekable stream keeps a byte count and triggers the end-of-stream behavior when this byte count has been reached. However, limiting a seekable stream creates a window of bytes that supports seeking and re-reading of bytes in that window." $nl
"Wrap a stream in a limited stream:"
-{ $subsections limit }
+{ $subsections limited-stream }
"Wrap the current " { $link input-stream } " in a limited stream:"
-{ $subsections limit-input }
+{ $subsections limited-input }
"Unlimits a limited stream:"
-{ $subsections unlimited }
+{ $subsections unlimit-stream }
"Unlimits the current " { $link input-stream } ":"
-{ $subsections unlimited-input }
-"Make a limited stream throw an exception on exhaustion:"
-{ $subsections stream-throws }
-"Make a limited stream return " { $link f } " on exhaustion:"
-{ $subsections stream-eofs } ;
+{ $subsections unlimited-input } ;
ABOUT: "io.streams.limited"
ascii encode binary <byte-reader> "data" set
] unit-test
-[ ] [ "data" get 24 stream-throws <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
[ CHAR: h ] [ "limited" get stream-read1 ] unit-test
[ "how " ] [ 4 "decoded" get stream-read ] unit-test
-[ "decoded" get stream-readln ] [ limit-exceeded? ] must-fail-with
+[ "are you " ] [ "decoded" get stream-readln ] unit-test
+
+[ f ] [ "decoded" get stream-readln ] unit-test
+
[ ] [
"abc\ndef\nghi"
ascii encode binary <byte-reader> "data" set
] unit-test
-[ ] [ "data" get 7 stream-throws <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 4 <limited-stream> "limited" set ] unit-test
-[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
+[ "abc" CHAR: \n ]
+[ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
-[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
+[ "" f ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
-[ "he" CHAR: l ] [
- B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
- ascii <byte-reader> [
- 5 stream-throws limit-input
- "l" read-until
- ] with-input-stream
-] unit-test
[ CHAR: a ]
-[ "a" <string-reader> 1 stream-eofs <limited-stream> stream-read1 ] unit-test
+[ "a" <string-reader> 1 <limited-stream> stream-read1 ] unit-test
[ "abc" ]
[
- "abc" <string-reader> 3 stream-eofs <limited-stream>
+ "abc" <string-reader> 3 <limited-stream>
4 swap stream-read
] unit-test
[ f ]
[
- "abc" <string-reader> 3 stream-eofs <limited-stream>
+ "abc" <string-reader> 3 <limited-stream>
4 over stream-read drop 10 swap stream-read
] unit-test
[ t ]
[
- "abc" <string-reader> 3 stream-eofs limit unlimited
+ "abc" <string-reader> 3 limit-stream unlimit-stream
"abc" <string-reader> =
] unit-test
[ t ]
[
- "abc" <string-reader> 3 stream-eofs limit unlimited
+ "abc" <string-reader> 3 limit-stream unlimit-stream
"abc" <string-reader> =
] unit-test
[
[
"resource:license.txt" utf8 <file-reader> &dispose
- 3 stream-eofs limit unlimited
+ 3 limit-stream unlimit-stream
"resource:license.txt" utf8 <file-reader> &dispose
[ decoder? ] both?
] with-destructors
] unit-test
-[ "HELL" ] [
- "HELLO"
- [ f stream-throws limit-input 4 read ]
- with-string-reader
-] unit-test
-
[ "asdf" ] [
- "asdf" <string-reader> 2 stream-eofs <limited-stream> [
+ "asdf" <string-reader> 2 <limited-stream> [
unlimited-input contents
] with-input-stream
] unit-test
-[ 4 ] [
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input tell-input
- ] with-input-stream
-] unit-test
-
-[
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input
- 4 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input
- -2 seek-relative
- 2 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[
- "abcdefgh" <string-reader> [
- 4 seek-relative seek-input
- 2 stream-throws limit-input
- -2 seek-relative seek-input
- 2 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[ "ef" ] [
- "abcdefgh" <string-reader> [
- 4 seek-relative seek-input
- 2 stream-throws limit-input
- 4 seek-absolute seek-input
- 2 read
- ] with-input-stream
-] unit-test
-
-[ "ef" ] [
- "abcdefgh" <string-reader> [
- 4 seek-absolute seek-input
- 2 stream-throws limit-input
- 2 seek-absolute seek-input
- 4 seek-absolute seek-input
- 2 read
- ] with-input-stream
-] unit-test
-
-! stream-throws, pipes are duplex and not seekable
+! pipes are duplex and not seekable
[ "as" ] [
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
-[
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- 3 swap stream-read
-] [
- limit-exceeded?
-] must-fail-with
-
-! stream-eofs, pipes are duplex and not seekable
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- 2 swap stream-read
-] unit-test
-
-[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
! test seeking on limited unseekable streams
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
-
-[
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- 2 seek-absolute rot in>> stream-seek
-] must-fail
-
-[
- "as"
-] [
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- [ 2 seek-absolute rot in>> stream-seek ] [ drop ] recover
- 2 swap stream-read
-] unit-test
-
-[ 7 ] [
- image binary stream-throws <limited-file-reader> [
- 7 read drop
- tell-input
- ] with-input-stream
-] unit-test
-
-[ 70000 ] [
- image binary stream-throws <limited-file-reader> [
- 70000 read drop
- tell-input
- ] with-input-stream
-] unit-test
namespaces sequences ;
IN: io.streams.limited
-TUPLE: limited-stream
- stream mode
- count limit
- current start stop ;
+TUPLE: limited-stream stream count limit current start stop ;
-SINGLETONS: stream-throws stream-eofs ;
-
-: <limited-stream> ( stream limit mode -- stream' )
+: <limited-stream> ( stream limit -- stream' )
limited-stream new
- swap >>mode
swap >>limit
swap >>stream
0 >>count ;
-: <limited-file-reader> ( path encoding mode -- stream' )
- [
- [ <file-reader> ]
- [ drop file-info size>> ] 2bi
- ] dip <limited-stream> ;
+: <limited-file-reader> ( path encoding -- stream' )
+ [ <file-reader> ]
+ [ drop file-info size>> ] 2bi
+ <limited-stream> ;
-GENERIC# limit 2 ( stream limit mode -- stream' )
+GENERIC# limit-stream 1 ( stream limit -- stream' )
-M: decoder limit ( stream limit mode -- stream' )
- [ clone ] 2dip '[ _ _ limit ] change-stream ;
+M: decoder limit-stream ( stream limit -- stream' )
+ [ clone ] dip '[ _ limit-stream ] change-stream ;
-M: object limit ( stream limit mode -- stream' )
- over [ <limited-stream> ] [ 2drop ] if ;
+M: object limit-stream ( stream limit -- stream' )
+ <limited-stream> ;
-GENERIC: unlimited ( stream -- stream' )
+GENERIC: unlimit-stream ( stream -- stream' )
-M: decoder unlimited ( stream -- stream' )
+M: decoder unlimit-stream ( stream -- stream' )
[ stream>> ] change-stream ;
-M: object unlimited ( stream -- stream' )
- stream>> ;
+M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ;
+
+M: object unlimit-stream ( stream -- stream' ) ;
-: limit-input ( limit mode -- )
- [ input-stream ] 2dip '[ _ _ limit ] change ;
+: limited-input ( limit -- )
+ [ input-stream ] dip '[ _ limit-stream ] change ;
: unlimited-input ( -- )
- input-stream [ unlimited ] change ;
+ input-stream [ unlimit-stream ] change ;
: with-unlimited-stream ( stream quot -- )
- [ clone unlimited ] dip call ; inline
+ [ clone unlimit-stream ] dip call ; inline
-: with-limited-stream ( stream limit mode quot -- )
- [ limit ] dip call ; inline
+: with-limited-stream ( stream limit quot -- )
+ [ limit-stream ] dip call ; inline
ERROR: limit-exceeded n stream ;
-ERROR: bad-stream-mode mode ;
-
<PRIVATE
: adjust-current-limit ( n stream -- n' stream )
2dup [ + ] change-current
[ current>> ] [ stop>> ] bi >
[
- dup mode>> {
- { stream-throws [ limit-exceeded ] }
- { stream-eofs [
- dup [ current>> ] [ stop>> ] bi -
- '[ _ - ] dip
- ] }
- [ bad-stream-mode ]
- } case
+ dup [ current>> ] [ stop>> ] bi -
+ '[ _ - ] dip
] when ; inline
: adjust-count-limit ( n stream -- n' stream )
2dup [ + ] change-count
[ count>> ] [ limit>> ] bi >
[
- dup mode>> {
- { stream-throws [ limit-exceeded ] }
- { stream-eofs [
- dup [ count>> ] [ limit>> ] bi -
- '[ _ - ] dip
- dup limit>> >>count
- ] }
- [ bad-stream-mode ]
- } case
+ dup [ count>> ] [ limit>> ] bi -
+ '[ _ - ] dip
+ dup limit>> >>count
] when ; inline
: check-count-bounds ( n stream -- n stream )
: (read-until) ( stream seps buf -- stream seps buf sep/f )
3dup [ [ stream-read1 dup ] dip member-eq? ] dip
- swap [ drop ] [ push (read-until) ] if ;
+ swap [
+ drop
+ ] [
+ over [ push (read-until) ] [ drop ] if
+ ] if ;
:: limited-stream-seek ( n seek-type stream -- )
seek-type {
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.streams.limited io.streams.string
+io.streams.throwing tools.test ;
+IN: io.streams.throwing.tests
+
+[ "as" ]
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ 6 read-partial ] throws-on-eof
+] unit-test
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ contents ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ 2 read read1 ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ 3 read ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ 2 read 2 read ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ contents contents ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors destructors io kernel locals namespaces
+sequences ;
+IN: io.streams.throwing
+
+ERROR: stream-exhausted n stream word ;
+
+<PRIVATE
+
+TUPLE: throws-on-eof stream ;
+
+C: <throws-on-eof> throws-on-eof
+
+M: throws-on-eof stream-element-type stream>> stream-element-type ;
+
+M: throws-on-eof dispose stream>> dispose ;
+
+M:: throws-on-eof stream-read1 ( stream -- obj )
+ stream stream>> stream-read1
+ [ 1 stream \ read1 stream-exhausted ] unless* ;
+
+M:: throws-on-eof stream-read ( n stream -- seq )
+ n stream stream>> stream-read
+ dup length n = [ n stream \ read stream-exhausted ] unless ;
+
+M:: throws-on-eof stream-read-partial ( n stream -- seq )
+ n stream stream>> stream-read-partial
+ [ n stream \ read-partial stream-exhausted ] unless* ;
+
+PRIVATE>
+
+: throws-on-eof ( stream quot -- )
+ [ <throws-on-eof> ] dip with-input-stream ; inline
+
+: input-throws-on-eof ( quot -- )
+ [ input-stream get <throws-on-eof> ] dip with-input-stream ; inline
H{ } clone (parse-lambda) ;
: parse-binding ( end -- pair/f )
- scan {
- { [ dup not ] [ unexpected-eof ] }
+ scan-token {
{ [ 2dup = ] [ 2drop f ] }
[ nip scan-object 2array ]
} cond ;
[ t ] [ { 1 1 1 } { 1 1 1 } p= ] unit-test
[ { 0 0 } { 1 1 } ] [ { 1 1 1 1 } { 1 1 } pgcd ] unit-test
+[ { 10 200 3000 } ] [ { 1 10 100 1000 } pdiff ] unit-test
+
[ V{ 0 } clone V{ 1 } clone ] 2dip swap (pgcd) [ >array ] bi@ ;
: pdiff ( p -- p' )
- dup length v* { 0 } ?head drop ;
+ dup length iota v* rest ;
: polyval ( x p -- p[x] )
[ length swap powers ] [ nip ] 2bi v. ;
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
+
+: with-extra-nesting-level ( quot -- )
+ nesting-limit [ dup [ 1 + ] [ f ] if* ] change
+ [ nesting-limit set ] curry [ ] cleanup ; inline
+
M: hashtable pprint*
- nesting-limit inc
- [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
+ [ pprint-object ] with-extra-nesting-level ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
M: hash-set pprint* pprint-object ;
] [
[ \ final-tuple see ] with-string-writer "\n" split
] unit-test
+
+[ "H{ { 1 2 } }\n" ] [ [ H{ { 1 2 } } short. ] with-string-writer ] unit-test
+
+[ "H{ { 1 ~array~ } }\n" ] [ [ H{ { 1 { 2 } } } short. ] with-string-writer ] unit-test
+
+[ "{ ~array~ }\n" ] [ [ { { 1 2 } } short. ] with-string-writer ] unit-test
+
+[ "H{ { 1 { 2 3 } } }\n" ] [
+ f nesting-limit [
+ [ H{ { 1 { 2 3 } } } . ] with-string-writer
+ ] with-variable
+] unit-test
+
: start-timer ( timer -- )
[
- '[ _ timer-loop ] "Alarm execution" spawn
+ '[ _ timer-loop ] "Timer execution" spawn
] keep thread<< ;
: stop-timer ( timer -- )
io.files io.files.info io.files.temp kernel tools.deploy.config
tools.deploy.config.editor tools.deploy.backend math sequences
io.launcher arrays namespaces continuations layouts accessors
-urls math.parser io.directories tools.deploy.test ;
+urls math.parser io.directories tools.deploy tools.deploy.test
+vocabs ;
IN: tools.deploy.tests
+[ "no such vocab, fool!" deploy ] [ no-vocab? ] must-fail-with
+
[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
deploy-test-command ascii [ readln ] with-process-reader
"test.image" temp-file =
] unit-test
+
+[ ] [ "resource:license.txt" "license.txt" temp-file copy-file ] unit-test
+
+[ ] [ "tools.deploy.test.19" shake-and-bake run-temp-image ] unit-test
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.deploy.backend system vocabs.loader kernel
+USING: tools.deploy.backend system vocabs vocabs.loader kernel
combinators tools.deploy.config.editor ;
IN: tools.deploy
-: deploy ( vocab -- ) deploy* ;
+: deploy ( vocab -- )
+ dup find-vocab-root [ deploy* ] [ no-vocab ] if ;
: deploy-image-only ( vocab image -- )
[ vm ] 2dip swap dup deploy-config make-deploy-image drop ;
QUALIFIED: source-files
QUALIFIED: source-files.errors
QUALIFIED: vocabs
+QUALIFIED: vocabs.loader
FROM: alien.libraries.private => >deployed-library-path ;
FROM: namespaces => set ;
FROM: sets => members ;
vocabs:dictionary
vocabs:load-vocab-hook
vocabs:vocab-observers
+ vocabs.loader:add-vocab-root-hook
word
parser-notes
} %
: startup-stripper ( -- )
t "quiet" set-global
f output-stream set-global
- V{ "resource:" } clone vocab-roots set-global ;
+ [ V{ "resource:" } clone vocab-roots set-global ]
+ "vocabs.loader" startup-hooks get-global set-at ;
: next-method* ( method -- quot )
[ "method-class" word-prop ]
: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
-IN: cocoa.application
-
-: objc-error ( error -- ) die ;
-
-[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook
-
H{ } clone \ pool [
global [
! Only keeps those methods that we actually call
FROM: alien.c-types => float ;
IN: tools.deploy.test.14
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Bar" }
-} {
- "bar:"
- float
- { id SEL NSRect }
- [
- [ origin>> [ x>> ] [ y>> ] bi + ]
- [ size>> [ w>> ] [ h>> ] bi + ]
- bi +
+CLASS: Bar < NSObject
+[
+ METHOD: float bar: NSRect rect [
+ rect origin>> [ x>> ] [ y>> ] bi +
+ rect size>> [ w>> ] [ h>> ] bi +
+ +
]
-} ;
+]
: main ( -- )
Bar -> alloc -> init
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files io.encodings.ascii ;
+IN: tools.deploy.test.19
+
+: main ( -- )
+ "vocab:license.txt" ascii file-contents write ;
+
+MAIN: main
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "tools.deploy.test.19" }
+ { deploy-ui? f }
+ { deploy-c-types? f }
+ { deploy-console? t }
+ { deploy-unicode? f }
+ { "stop-after-last-window?" t }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
+ { deploy-word-props? f }
+ { deploy-math? f }
+ { deploy-threads? f }
+ { deploy-word-defs? f }
+}
--- /dev/null
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- /dev/null
+license.txt
] [ 2drop ] if*
init-thread-timer ;
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorApplicationDelegate" }
-}
-
-{ "applicationDidUpdate:" void { id SEL id }
- [ 3drop reset-run-loop ]
-} ;
+CLASS: FactorApplicationDelegate < NSObject
+[
+ METHOD: void applicationDidUpdate: id obj
+ [ reset-run-loop ]
+]
: install-app-delegate ( -- )
NSApp FactorApplicationDelegate install-delegate ;
image save-panel [ save-image ] when* ;
! Handle Open events from the Finder
-CLASS: {
- { +superclass+ "FactorApplicationDelegate" }
- { +name+ "FactorWorkspaceApplicationDelegate" }
-}
-
-{ "application:openFiles:" void { id SEL id id }
- [ [ 3drop ] dip finder-run-files ]
-}
+CLASS: FactorWorkspaceApplicationDelegate < FactorApplicationDelegate
+[
+ METHOD: void application: id app openFiles: id files [ files finder-run-files ]
-{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
- [ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
-}
+ METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ]
-{ "factorListener:" id { id SEL id }
- [ 3drop show-listener f ]
-}
+ METHOD: id factorListener: id app [ show-listener f ]
-{ "factorBrowser:" id { id SEL id }
- [ 3drop show-browser f ]
-}
+ METHOD: id factorBrowser: id app [ show-browser f ]
-{ "newFactorListener:" id { id SEL id }
- [ 3drop listener-window f ]
-}
+ METHOD: id newFactorListener: id app [ listener-window f ]
-{ "newFactorBrowser:" id { id SEL id }
- [ 3drop browser-window f ]
-}
+ METHOD: id newFactorBrowser: id app [ browser-window f ]
-{ "runFactorFile:" id { id SEL id }
- [ 3drop menu-run-files f ]
-}
+ METHOD: id runFactorFile: id app [ menu-run-files f ]
-{ "saveFactorImage:" id { id SEL id }
- [ 3drop save f ]
-}
+ METHOD: id saveFactorImage: id app [ save f ]
-{ "saveFactorImageAs:" id { id SEL id }
- [ 3drop menu-save-image f ]
-}
+ METHOD: id saveFactorImageAs: id app [ menu-save-image f ]
-{ "refreshAll:" id { id SEL id }
- [ 3drop [ refresh-all ] \ refresh-all call-listener f ]
-} ;
+ METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ]
+]
: install-app-delegate ( -- )
NSApp FactorWorkspaceApplicationDelegate install-delegate ;
dup [ quot call( string -- result/f ) ] when
[ pboard set-pasteboard-string ] when* ;
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorServiceProvider" }
-} {
- "evalInListener:userData:error:"
- void
- { id SEL id id id }
- [
- nip
- [ eval-listener f ] do-service
- 2drop
- ]
-} {
- "evalToString:userData:error:"
- void
- { id SEL id id id }
+CLASS: FactorServiceProvider < NSObject
+[
+ METHOD: void evalInListener: id pboard userData: id userData error: id error
+ [ pboard error [ eval-listener f ] do-service ]
+
+ METHOD: void evalToString: id pboard userData: id userData error: id error
[
- nip
+ pboard error
[ [ (eval>string) ] with-interactive-vocabs ] do-service
- 2drop
]
-} ;
+]
: register-services ( -- )
NSApp
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
cocoa.classes cocoa.views cocoa.application cocoa.pasteboard
-cocoa.runtime cocoa.types cocoa.windows sequences io.encodings.utf8
-ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
-core-foundation.strings core-graphics core-graphics.types threads
-combinators math.rectangles ;
+cocoa.runtime cocoa.types cocoa.windows sequences
+io.encodings.utf8 locals ui ui.private ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures
+core-foundation.strings core-graphics core-graphics.types
+threads combinators math.rectangles ;
IN: ui.backend.cocoa.views
: send-mouse-moved ( view event -- )
- [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
+ [ mouse-location ] [ drop window ] 2bi
+ dup [ move-hand fire-motion yield ] [ 2drop ] if ;
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
[ event-modifiers ] [ key-code ] bi ;
: send-key-event ( view gesture -- )
- swap window propagate-key-gesture ;
+ swap window dup [ propagate-key-gesture ] [ 2drop ] if ;
: interpret-key-event ( view event -- )
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
[ nip mouse-event>gesture <button-down> ]
[ mouse-location ]
[ drop window ]
- 2tri send-button-down ;
+ 2tri
+ dup [ send-button-down ] [ 3drop ] if ;
: send-button-up$ ( view event -- )
[ nip mouse-event>gesture <button-up> ]
[ mouse-location ]
[ drop window ]
- 2tri send-button-up ;
+ 2tri
+ dup [ send-button-up ] [ 3drop ] if ;
: send-scroll$ ( view event -- )
[ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
[ mouse-location ]
[ drop window ]
- 2tri send-scroll ;
+ 2tri
+ dup [ send-scroll ] [ 3drop ] if ;
-: send-action$ ( view event gesture -- junk )
- [ drop window ] dip send-action f ;
+: send-action$ ( view event gesture -- )
+ [ drop window ] dip over [ send-action ] [ 2drop ] if ;
: add-resize-observer ( observer object -- )
[
selector>action at
[ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
-CLASS: {
- { +superclass+ "NSOpenGLView" }
- { +name+ "FactorView" }
- { +protocols+ { "NSTextInput" } }
-}
+CLASS: FactorView < NSOpenGLView NSTextInput
+[
+ ! Rendering
+ METHOD: void drawRect: NSRect rect [ self window [ draw-world ] when* ]
-! Rendering
-{ "drawRect:" void { id SEL NSRect }
- [ 2drop window draw-world ]
-}
+ ! Events
+ METHOD: char acceptsFirstMouse: id event [ 1 ]
-! Events
-{ "acceptsFirstMouse:" char { id SEL id }
- [ 3drop 1 ]
-}
+ METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
-{ "mouseEntered:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void mouseExited: id event [ forget-rollover ]
-{ "mouseExited:" void { id SEL id }
- [ 3drop forget-rollover ]
-}
+ METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
-{ "mouseMoved:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
-{ "mouseDragged:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
-{ "rightMouseDragged:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
-{ "otherMouseDragged:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void mouseDown: id event [ self event send-button-down$ ]
-{ "mouseDown:" void { id SEL id }
- [ nip send-button-down$ ]
-}
-
-{ "mouseUp:" void { id SEL id }
- [ nip send-button-up$ ]
-}
+ METHOD: void mouseUp: id event [ self event send-button-up$ ]
-{ "rightMouseDown:" void { id SEL id }
- [ nip send-button-down$ ]
-}
+ METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
-{ "rightMouseUp:" void { id SEL id }
- [ nip send-button-up$ ]
-}
+ METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
-{ "otherMouseDown:" void { id SEL id }
- [ nip send-button-down$ ]
-}
+ METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
-{ "otherMouseUp:" void { id SEL id }
- [ nip send-button-up$ ]
-}
+ METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
-{ "scrollWheel:" void { id SEL id }
- [ nip send-scroll$ ]
-}
+ METHOD: void scrollWheel: id event [ self event send-scroll$ ]
-{ "keyDown:" void { id SEL id }
- [ nip send-key-down-event ]
-}
+ METHOD: void keyDown: id event [ self event send-key-down-event ]
-{ "keyUp:" void { id SEL id }
- [ nip send-key-up-event ]
-}
+ METHOD: void keyUp: id event [ self event send-key-up-event ]
-{ "validateUserInterfaceItem:" char { id SEL id }
+ METHOD: char validateUserInterfaceItem: id event
[
- nip -> action
- 2dup [ window ] [ utf8 alien>string ] bi* validate-action
- [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
+ self window [
+ event -> action utf8 alien>string validate-action
+ [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
+ ] [ 0 ] if*
]
-}
-{ "undo:" id { id SEL id }
- [ nip undo-action send-action$ ]
-}
+ METHOD: id undo: id event [ self event undo-action send-action$ f ]
-{ "redo:" id { id SEL id }
- [ nip redo-action send-action$ ]
-}
+ METHOD: id redo: id event [ self event redo-action send-action$ f ]
-{ "cut:" id { id SEL id }
- [ nip cut-action send-action$ ]
-}
+ METHOD: id cut: id event [ self event cut-action send-action$ f ]
-{ "copy:" id { id SEL id }
- [ nip copy-action send-action$ ]
-}
+ METHOD: id copy: id event [ self event copy-action send-action$ f ]
-{ "paste:" id { id SEL id }
- [ nip paste-action send-action$ ]
-}
+ METHOD: id paste: id event [ self event paste-action send-action$ f ]
-{ "delete:" id { id SEL id }
- [ nip delete-action send-action$ ]
-}
+ METHOD: id delete: id event [ self event delete-action send-action$ f ]
-{ "selectAll:" id { id SEL id }
- [ nip select-all-action send-action$ ]
-}
+ METHOD: id selectAll: id event [ self event select-all-action send-action$ f ]
-{ "newDocument:" id { id SEL id }
- [ nip new-action send-action$ ]
-}
+ METHOD: id newDocument: id event [ self event new-action send-action$ f ]
-{ "openDocument:" id { id SEL id }
- [ nip open-action send-action$ ]
-}
+ METHOD: id openDocument: id event [ self event open-action send-action$ f ]
-{ "saveDocument:" id { id SEL id }
- [ nip save-action send-action$ ]
-}
+ METHOD: id saveDocument: id event [ self event save-action send-action$ f ]
-{ "saveDocumentAs:" id { id SEL id }
- [ nip save-as-action send-action$ ]
-}
+ METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ]
-{ "revertDocumentToSaved:" id { id SEL id }
- [ nip revert-action send-action$ ]
-}
+ METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ f ]
-! Multi-touch gestures: this is undocumented.
-! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
-{ "magnifyWithEvent:" void { id SEL id }
+ ! Multi-touch gestures
+ METHOD: void magnifyWithEvent: id event
[
- nip
+ self event
dup -> deltaZ sgn {
{ 1 [ zoom-in-action send-action$ ] }
{ -1 [ zoom-out-action send-action$ ] }
{ 0 [ 2drop ] }
} case
]
-}
-{ "swipeWithEvent:" void { id SEL id }
+ METHOD: void swipeWithEvent: id event
[
- nip
+ self event
dup -> deltaX sgn {
{ 1 [ left-action send-action$ ] }
{ -1 [ right-action send-action$ ] }
}
} case
]
-}
-{ "acceptsFirstResponder" char { id SEL }
- [ 2drop 1 ]
-}
+ METHOD: char acceptsFirstResponder [ 1 ]
-! Services
-{ "validRequestorForSendType:returnType:" id { id SEL id id }
+ ! Services
+ METHOD: id validRequestorForSendType: id sendType returnType: id returnType
[
! We return either self or nil
- [ over window-focus ] 2dip
- valid-service? [ drop ] [ 2drop f ] if
+ self window [
+ world-focus sendType returnType
+ valid-service? [ self ] [ f ] if
+ ] [ f ] if*
]
-}
-{ "writeSelectionToPasteboard:types:" char { id SEL id id }
+ METHOD: char writeSelectionToPasteboard: id pboard types: id types
[
- CF>string-array NSStringPboardType swap member? [
- [ drop window-focus gadget-selection ] dip over
- [ set-pasteboard-string 1 ] [ 2drop 0 ] if
- ] [ 3drop 0 ] if
+ NSStringPboardType types CF>string-array member? [
+ self window [
+ world-focus gadget-selection
+ [ pboard set-pasteboard-string 1 ] [ 0 ] if*
+ ] [ 0 ] if*
+ ] [ 0 ] if
]
-}
-{ "readSelectionFromPasteboard:" char { id SEL id }
+ METHOD: char readSelectionFromPasteboard: id pboard
[
- pasteboard-string dup [
- [ drop window ] dip swap user-input 1
- ] [ 3drop 0 ] if
+ self window :> window
+ window [
+ pboard pasteboard-string
+ [ window user-input 1 ] [ 0 ] if*
+ ] [ 0 ] if
]
-}
-! Text input
-{ "insertText:" void { id SEL id }
- [ nip CF>string swap window user-input ]
-}
+ ! Text input
+ METHOD: void insertText: id text
+ [
+ self window :> window
+ window [
+ text CF>string window user-input
+ ] when
+ ]
-{ "hasMarkedText" char { id SEL }
- [ 2drop 0 ]
-}
+ METHOD: char hasMarkedText [ 0 ]
-{ "markedRange" NSRange { id SEL }
- [ 2drop 0 0 <NSRange> ]
-}
+ METHOD: NSRange markedRange [ 0 0 <NSRange> ]
-{ "selectedRange" NSRange { id SEL }
- [ 2drop 0 0 <NSRange> ]
-}
+ METHOD: NSRange selectedRange [ 0 0 <NSRange> ]
-{ "setMarkedText:selectedRange:" void { id SEL id NSRange }
- [ 2drop 2drop ]
-}
+ METHOD: void setMarkedText: id text selectedRange: NSRange range [ ]
-{ "unmarkText" void { id SEL }
- [ 2drop ]
-}
+ METHOD: void unmarkText [ ]
-{ "validAttributesForMarkedText" id { id SEL }
- [ 2drop NSArray -> array ]
-}
+ METHOD: id validAttributesForMarkedText [ NSArray -> array ]
-{ "attributedSubstringFromRange:" id { id SEL NSRange }
- [ 3drop f ]
-}
+ METHOD: id attributedSubstringFromRange: NSRange range [ f ]
-{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint }
- [ 3drop 0 ]
-}
+ METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ]
-{ "firstRectForCharacterRange:" NSRect { id SEL NSRange }
- [ 3drop 0 0 0 0 <CGRect> ]
-}
+ METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 <CGRect> ]
-{ "conversationIdentifier" NSInteger { id SEL }
- [ drop alien-address ]
-}
+ METHOD: NSInteger conversationIdentifier [ self alien-address ]
-! Initialization
-{ "updateFactorGadgetSize:" void { id SEL id }
- [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
-}
+ ! Initialization
+ METHOD: void updateFactorGadgetSize: id notification
+ [
+ self window :> window
+ window [
+ self view-dim window dim<< yield
+ ] when
+ ]
-{ "doCommandBySelector:" void { id SEL SEL }
- [ 3drop ]
-}
+ METHOD: void doCommandBySelector: SEL selector [ ]
-{ "initWithFrame:pixelFormat:" id { id SEL NSRect id }
+ METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
[
- [ drop ] 2dip
- SUPER-> initWithFrame:pixelFormat:
+ self frame pixelFormat SUPER-> initWithFrame:pixelFormat:
dup dup add-resize-observer
]
-}
-{ "isOpaque" char { id SEL }
- [
- 2drop 0
- ]
-}
+ METHOD: char isOpaque [ 0 ]
-{ "dealloc" void { id SEL }
+ METHOD: void dealloc
[
- drop
- [ remove-observer ]
- [ SUPER-> dealloc ]
- bi
+ self remove-observer
+ self SUPER-> dealloc
]
-} ;
+]
: sync-refresh-to-screen ( GLView -- )
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
: save-position ( world window -- )
-> frame CGRect-top-left 2array >>window-loc drop ;
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorWindowDelegate" }
-}
-
-{ "windowDidMove:" void { id SEL id }
+CLASS: FactorWindowDelegate < NSObject
+[
+ METHOD: void windowDidMove: id notification
[
- 2nip -> object [ -> contentView window ] keep save-position
+ notification -> object -> contentView window
+ [ notification -> object save-position ] when*
]
-}
-{ "windowDidBecomeKey:" void { id SEL id }
+ METHOD: void windowDidBecomeKey: id notification
[
- 2nip -> object -> contentView window focus-world
+ notification -> object -> contentView window
+ [ focus-world ] when*
]
-}
-{ "windowDidResignKey:" void { id SEL id }
+ METHOD: void windowDidResignKey: id notification
[
forget-rollover
- 2nip -> object -> contentView
- dup -> isInFullScreenMode 0 =
- [ window [ unfocus-world ] when* ]
- [ drop ] if
+ notification -> object -> contentView :> view
+ view window :> window
+ window [
+ view -> isInFullScreenMode 0 =
+ [ window unfocus-world ] when
+ ] when
]
-}
-{ "windowShouldClose:" char { id SEL id }
- [
- 3drop 1
- ]
-}
+ METHOD: char windowShouldClose: id notification [ 1 ]
-{ "windowWillClose:" void { id SEL id }
+ METHOD: void windowWillClose: id notification
[
- 2nip -> object -> contentView
+ notification -> object -> contentView
[ window ungraft ] [ unregister-window ] bi
]
-} ;
+]
: install-window-delegate ( window -- )
FactorWindowDelegate install-delegate ;
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel models namespaces arrays
-fry prettyprint ui ui.commands ui.gadgets ui.gadgets.labeled assocs
+fry prettyprint sequences inspector models.arrow fonts ui
+ui.commands ui.gadgets ui.gadgets.labeled assocs
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers ui.gadgets.borders
-ui.gadgets.tables ui.gestures sequences inspector
-models.arrow fonts ;
+ui.gadgets.tables ui.gestures ui.tools.common ;
QUALIFIED-WITH: ui.tools.inspector i
IN: ui.tools.traceback
: <retainstack-display> ( model -- gadget )
[ retain>> ] "Retain stack" <stack-display> ;
-TUPLE: traceback-gadget < track ;
+TUPLE: traceback-gadget < tool ;
: <traceback-gadget> ( model -- gadget )
[
: window ( handle -- world ) windows get-global at ;
-: window-focus ( handle -- gadget ) window world-focus ;
-
: register-window ( world handle -- )
#! Add the new window just below the topmost window. Why?
#! So that if the new window doesn't actually receive focus
FUNCTION: ushort htons ( ushort n ) ;
! FUNCTION: int issetugid ;
FUNCTION: int isatty ( int fildes ) ;
-FUNCTION: int ioctl ( int fd, ulong request, c-string argp ) ;
+FUNCTION: int ioctl ( int fd, ulong request, void* argp ) ;
FUNCTION: int lchown ( c-string path, uid_t owner, gid_t group ) ;
FUNCTION: int listen ( int s, int backlog ) ;
FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "~foo" ] [ "~foo" url-encode ] unit-test
+[ "~foo" ] [ "~foo" url-encode-full ] unit-test
+
+[ ":foo" ] [ ":foo" url-encode ] unit-test
+[ "%3Afoo" ] [ ":foo" url-encode-full ] unit-test
+
[ "hello world" ] [ "hello+world" query-decode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
+[ "foo=%3A" ] [ { { "foo" ":" } } assoc>query ] unit-test
+
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
[ "a" ] [ { { "a" f } } assoc>query ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit
sequences splitting fry namespaces make assocs arrays strings
[ letter? ]
[ LETTER? ]
[ digit? ]
- [ "/_-.:" member? ]
+ [ "-._~/:" member? ]
} 1|| ; foldable
! see http://tools.ietf.org/html/rfc3986#section-2.2
: assoc>query ( assoc -- str )
[
assoc-strings [
- [ url-encode ] dip
- [ [ url-encode "=" glue , ] with each ] [ , ] if*
+ [ url-encode-full ] dip
+ [ [ url-encode-full "=" glue , ] with each ] [ , ] if*
] assoc-each
] { } make "&" join ;
[ scan , \ } parse-until % ] { } make ;
: parse-slot-name-delim ( end-delim string/f -- ? )
- #! This isn't meant to enforce any kind of policy, just
- #! to check for mistakes of this form:
- #!
- #! TUPLE: blahblah foo bing
- #!
- #! : ...
+ ! Check for mistakes of this form:
+ !
+ ! TUPLE: blahblah foo bing
+ !
+ ! : ...
{
- { [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond nip ;
: parse-tuple-slots-delim ( end-delim -- )
- dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+ dup scan-token parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
: parse-slot-name ( string/f -- ? )
";" swap parse-slot-name-delim ;
2dup swap slot-named* nip [ 2nip ] [ nip bad-slot-name ] if ;
: parse-slot-value ( class slots -- )
- scan check-slot-name scan-object 2array , scan {
- { f [ \ } unexpected-eof ] }
+ scan check-slot-name scan-object 2array , scan-token {
{ "}" [ ] }
[ bad-literal-tuple ]
} case ;
: (parse-slot-values) ( class slots -- )
2dup parse-slot-value
- scan {
- { f [ 2drop \ } unexpected-eof ] }
+ scan-token {
{ "{" [ (parse-slot-values) ] }
{ "}" [ 2drop ] }
[ 2nip bad-literal-tuple ]
assoc-union! seq>> boa>object ;
: parse-tuple-literal-slots ( class slots -- tuple )
- scan {
- { f [ unexpected-eof ] }
+ scan-token {
{ "f" [ drop \ } parse-until boa>object ] }
{ "{" [ 2dup parse-slot-values assoc>object ] }
{ "}" [ drop new ] }
: parse-effect-value ( token -- value )
":" ?tail [
- scan {
+ scan-token {
{ [ dup "(" = ] [ drop ")" parse-effect ] }
- { [ dup f = ] [ ")" unexpected-eof ] }
[ parse-word dup class? [ bad-effect ] unless ]
} cond 2array
] when ;
-USING: io.files io.streams.string io io.streams.byte-array
-tools.test kernel io.encodings.ascii io.encodings.utf8
-namespaces accessors io.encodings io.streams.limited ;
-IN: io.streams.encodings.tests
+USING: accessors io io.encodings io.encodings.ascii
+io.encodings.utf8 io.files io.streams.byte-array
+io.streams.string kernel namespaces tools.test ;
+IN: io.encodings.tests
[ { } ]
[ "vocab:io/test/empty-file.txt" ascii file-lines ]
"seek-test1" unique-file binary
[
[
- B{ 1 2 3 4 5 } write 0 seek-absolute seek-output
+ B{ 1 2 3 4 5 } write
+ tell-output 5 assert=
+ 0 seek-absolute seek-output
+ tell-output 0 assert=
B{ 3 } write
+ tell-output 1 assert=
] with-file-writer
] [
file-contents
"seek-test2" unique-file binary
[
[
- B{ 1 2 3 4 5 } write -1 seek-relative seek-output
+ B{ 1 2 3 4 5 } write
+ tell-output 5 assert=
+ -1 seek-relative seek-output
+ tell-output 4 assert=
B{ 3 } write
+ tell-output 5 assert=
] with-file-writer
] [
file-contents
"seek-test3" unique-file binary
[
[
- B{ 1 2 3 4 5 } write 1 seek-relative seek-output
+ B{ 1 2 3 4 5 } write
+ tell-output 5 assert=
+ 1 seek-relative seek-output
+ tell-output 6 assert=
B{ 3 } write
+ tell-output 7 assert=
] with-file-writer
] [
file-contents
set-file-contents
] [
[
- -3 seek-end seek-input 1 read
+ tell-input 0 assert=
+ -3 seek-end seek-input
+ tell-input 2 assert=
+ 1 read
+ tell-input 3 assert=
] with-file-reader
] 2bi
] unit-test
set-file-contents
] [
[
+ tell-input 0 assert=
3 seek-absolute seek-input
+ tell-input 3 assert=
-2 seek-relative seek-input
+ tell-input 1 assert=
1 read
+ tell-input 2 assert=
] with-file-reader
] 2bi
] unit-test
] with-file-reader
] must-fail
+[ ] [
+ "resource:misc/icons/Factor_48x48.png" binary [
+ 44 read drop
+ tell-input 44 assert=
+ -44 seek-relative seek-input
+ tell-input 0 assert=
+ ] with-file-reader
+] unit-test
+
[
"non-string-error" unique-file ascii [
{ } write
: stream-element-exemplar ( stream -- exemplar )
stream-element-type (stream-element-exemplar) ; inline
-: element-exemplar ( -- exemplar )
- input-stream get stream-element-exemplar ; inline
-
PRIVATE>
: each-stream-line ( stream quot -- )
HELP: scan
{ $values { "str/f" { $maybe string } } }
-{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word outputs " { $link f } " on end of input. To throw an error on end of input, use " { $link scan-token } " instead." }
+$parsing-note ;
+
+HELP: scan-token
+{ $values { "str" string } }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word throws " { $link unexpected-eof } " on end of input. To output " { $link f } " on end of input, use " { $link scan } " instead." }
$parsing-note ;
HELP: still-parsing?
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces math words strings
io vectors arrays math.parser combinators continuations
: push-parsing-word ( word -- )
lexer-parsing-word new
- swap >>word
- lexer get [
- [ line>> >>line ]
- [ line-text>> >>line-text ]
- [ column>> >>column ] tri
- ] [ parsing-words>> push ] bi ;
+ swap >>word
+ lexer get [
+ [ line>> >>line ]
+ [ line-text>> >>line-text ]
+ [ column>> >>column ] tri
+ ] [ parsing-words>> push ] bi ;
: pop-parsing-word ( -- )
lexer get parsing-words>> pop drop ;
[ line-text>> ]
} cleave subseq ;
-: parse-token ( lexer -- str/f )
+: parse-token ( lexer -- str/f )
dup still-parsing? [
dup skip-blank
dup still-parsing-line?
: unexpected-eof ( word -- * ) f unexpected ;
+: scan-token ( -- str ) scan [ "token" unexpected-eof ] unless* ;
+
: expect ( token -- )
- scan
- [ 2dup = [ 2drop ] [ unexpected ] if ]
- [ unexpected-eof ]
- if* ;
+ scan-token 2dup = [ 2drop ] [ unexpected ] if ;
: each-token ( ... end quot: ( ... token -- ... ) -- ... )
- [ scan ] 2dip {
- { [ 2over = ] [ 3drop ] }
- { [ pick not ] [ drop unexpected-eof ] }
- [ [ nip call ] [ each-token ] 2bi ]
- } cond ; inline recursive
+ [ scan-token ] 2dip 2over =
+ [ 3drop ] [ [ nip call ] [ each-token ] 2bi ] if ; inline recursive
: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
collector [ each-token ] dip { } like ; inline
: <lexer-error> ( msg -- error )
\ lexer-error new
- lexer get [
- [ line>> >>line ]
- [ column>> >>column ] bi
- ] [
- [ line-text>> >>line-text ]
- [ parsing-words>> clone >>parsing-words ] bi
- ] bi
- swap >>error ;
+ lexer get [
+ [ line>> >>line ]
+ [ column>> >>column ] bi
+ ] [
+ [ line-text>> >>line-text ]
+ [ parsing-words>> clone >>parsing-words ] bi
+ ] bi
+ swap >>error ;
: simple-lexer-dump ( error -- )
[ line>> number>string ": " append ]
[ (parsing-word-lexer-dump) ] if ;
: lexer-dump ( error -- )
- dup parsing-words>> [ simple-lexer-dump ] [ last parsing-word-lexer-dump ] if-empty ;
+ dup parsing-words>>
+ [ simple-lexer-dump ]
+ [ last parsing-word-lexer-dump ] if-empty ;
: with-lexer ( lexer quot -- newquot )
[ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
ARTICLE: "reading-ahead" "Reading ahead"
"Parsing words can consume input:"
+{ $subsections
+ scan-token
+ scan-object
+}
+"Lower-level words:"
{ $subsections
scan
scan-word
HELP: auto-use?
{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." }
{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "word-search-errors" } "." } ;
+
+HELP: scan-object
+{ $values { "object" object } }
+{ $description "Parses a literal representation of an object." }
+$parsing-note ;
! parse-tokens should do the right thing on EOF
[ "USING: kernel" eval( -- ) ]
-[ error>> T{ unexpected { want ";" } } = ] must-fail-with
+[ error>> T{ unexpected { want "token" } } = ] must-fail-with
! Test smudging
"#!" [ POSTPONE: ! ] define-core-syntax
- "IN:" [ scan set-current-vocab ] define-core-syntax
+ "IN:" [ scan-token set-current-vocab ] define-core-syntax
"<PRIVATE" [ begin-private ] define-core-syntax
"PRIVATE>" [ end-private ] define-core-syntax
- "USE:" [ scan use-vocab ] define-core-syntax
+ "USE:" [ scan-token use-vocab ] define-core-syntax
- "UNUSE:" [ scan unuse-vocab ] define-core-syntax
+ "UNUSE:" [ scan-token unuse-vocab ] define-core-syntax
"USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
- "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
+ "QUALIFIED:" [ scan-token dup add-qualified ] define-core-syntax
- "QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax
+ "QUALIFIED-WITH:" [ scan-token scan-token add-qualified ] define-core-syntax
"FROM:" [
- scan "=>" expect ";" parse-tokens add-words-from
+ scan-token "=>" expect ";" parse-tokens add-words-from
] define-core-syntax
"EXCLUDE:" [
- scan "=>" expect ";" parse-tokens add-words-excluding
+ scan-token "=>" expect ";" parse-tokens add-words-excluding
] define-core-syntax
"RENAME:" [
- scan scan "=>" expect scan add-renamed-word
+ scan-token scan-token "=>" expect scan-token add-renamed-word
] define-core-syntax
"HEX:" [ 16 parse-base ] define-core-syntax
"t" "syntax" lookup define-singleton-class
"CHAR:" [
- scan {
+ scan-token {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape >string "" assert= ] }
[ name>char-hook get call( name -- char ) ]
] define-core-syntax
"DEFER:" [
- scan current-vocab create
+ scan-token current-vocab create
[ fake-definition ] [ set-word ] [ undefined-def define ] tri
] define-core-syntax
"PREDICATE:" [
CREATE-CLASS
- scan "<" assert=
+ "<" expect
scan-word
parse-definition define-predicate-class
] define-core-syntax
] define-core-syntax
"SLOT:" [
- scan define-protocol-slot
+ scan-token define-protocol-slot
] define-core-syntax
"C:" [
[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
-[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } ]
-[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } turnaround ] unit-test
+[ H{ { "a" "a string" } { "b" H{ { "a" "アップルからの最新のニュースや情報を読む" } } } } ]
+[ H{ { "a" "a string" } { "b" H{ { "a" "アップルからの最新のニュースや情報を読む" } } } } turnaround ] unit-test
[ H{ { "a list" { 1 2.234 "hello world" } } } ]
[ H{ { "a list" { 1 2.234 "hello world" } } } turnaround ] unit-test
CONSTANT: T_MinKey HEX: FF
CONSTANT: T_MaxKey HEX: 7F
-CONSTANT: T_Binary_Function HEX: 1
-CONSTANT: T_Binary_Bytes HEX: 2
-CONSTANT: T_Binary_UUID HEX: 3
-CONSTANT: T_Binary_MD5 HEX: 5
-CONSTANT: T_Binary_Custom HEX: 80
+CONSTANT: T_Binary_Default HEX: 0
+CONSTANT: T_Binary_Function HEX: 1
+CONSTANT: T_Binary_Bytes_Deprecated HEX: 2
+CONSTANT: T_Binary_UUID HEX: 3
+CONSTANT: T_Binary_MD5 HEX: 5
+CONSTANT: T_Binary_Custom HEX: 80
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs bson.constants calendar combinators
combinators.short-circuit io io.binary kernel math locals
+io.encodings.utf8 io.encodings
namespaces sequences serialize strings vectors byte-arrays ;
FROM: io.encodings.binary => binary ;
read-byte-raw first ; inline
: read-cstring ( -- string )
- "\0" read-until drop >string ; inline
+ input-stream get utf8 <decoder>
+ "\0" swap stream-read-until drop ; inline
: read-sized-string ( length -- string )
- read 1 head-slice* >string ; inline
+ read binary [ read-cstring ] with-byte-reader ; inline
: read-timestamp ( -- timestamp )
8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi <mongo-timestamp> ;
: bson-binary-read ( -- binary )
read-int32 read-byte
{
- { T_Binary_Bytes [ read ] }
+ { T_Binary_Default [ read ] }
+ { T_Binary_Bytes_Deprecated [ drop read-int32 read ] }
{ T_Binary_Custom [ read bytes>object ] }
{ T_Binary_Function [ read ] }
[ drop read >string ]
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs bson.constants byte-arrays
calendar combinators.short-circuit fry hashtables io io.binary
+io.encodings.utf8 io.encodings io.streams.byte-array
kernel linked-assocs literals math math.parser namespaces byte-vectors
quotations sequences serialize strings vectors dlists alien.accessors ;
FROM: words => word? word ;
TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline
+TYPED: write-utf8-string ( string: string -- )
+ output-stream get utf8 <encoder> stream-write ; inline
+
TYPED: write-cstring ( string: string -- )
- get-output [ length ] [ ] bi copy 0 write1 ; inline
+ write-utf8-string 0 write1 ; inline
: write-longlong ( object -- ) INT64-SIZE (>le) ; inline
TYPED: write-byte-array ( binary: byte-array -- )
[ length write-int32 ]
- [ T_Binary_Bytes write1 write ] bi ; inline
+ [ T_Binary_Default write1 write ] bi ; inline
TYPED: write-mdbregexp ( regexp: mdbregexp -- )
[ regexp>> write-cstring ]
[ length write-int32 ]
[ T_Binary_Custom write1 write ] bi ; inline
+: write-string-length ( string -- )
+ [ length>> 1 + ]
+ [ aux>> [ length ] [ 0 ] if* ] bi + write-int32 ; inline
+
TYPED: write-string ( string: string -- )
- '[ _ write-cstring ] with-length-prefix-excl ; inline
+ dup write-string-length write-cstring ; inline
TYPED: write-boolean ( bool: boolean -- )
[ 1 write1 ] [ 0 write1 ] if ; inline
--- /dev/null
+Dmitry Shubin
--- /dev/null
+Dmitry Shubin
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax classes.struct
+combinators system ;
+IN: gdbm.ffi
+
+<< "libgdbm" os {
+ { [ unix? ] [ "libgdbm.so" ] }
+ { [ winnt? ] [ "gdbm.dll" ] }
+ { [ macosx? ] [ "libgdbm.dylib" ] }
+} cond cdecl add-library >>
+
+LIBRARY: libgdbm
+
+C-GLOBAL: c-string gdbm_version
+
+CONSTANT: GDBM_SYNC HEX: 20
+CONSTANT: GDBM_NOLOCK HEX: 40
+
+CONSTANT: GDBM_INSERT 0
+CONSTANT: GDBM_REPLACE 1
+
+CONSTANT: GDBM_CACHESIZE 1
+CONSTANT: GDBM_SYNCMODE 3
+CONSTANT: GDBM_CENTFREE 4
+CONSTANT: GDBM_COALESCEBLKS 5
+
+STRUCT: datum { dptr char* } { dsize int } ;
+
+C-TYPE: _GDBM_FILE
+TYPEDEF: _GDBM_FILE* GDBM_FILE
+
+CALLBACK: void fatal_func_cb ;
+FUNCTION: GDBM_FILE gdbm_open ( c-string name, int block_size, int read_write, int mode, fatal_func_cb fatal_func ) ;
+FUNCTION-ALIAS: gdbm-close void gdbm_close ( GDBM_FILE dbf ) ;
+FUNCTION: int gdbm_store ( GDBM_FILE dbf, datum key, datum content, int flag ) ;
+FUNCTION: datum gdbm_fetch ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: int gdbm_delete ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: datum gdbm_firstkey ( GDBM_FILE dbf ) ;
+FUNCTION: datum gdbm_nextkey ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: int gdbm_reorganize ( GDBM_FILE dbf ) ;
+FUNCTION: void gdbm_sync ( GDBM_FILE dbf ) ;
+FUNCTION: int gdbm_exists ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: int gdbm_setopt ( GDBM_FILE dbf, int option, int* value, int size ) ;
+FUNCTION: int gdbm_fdesc ( GDBM_FILE dbf ) ;
+
+C-GLOBAL: int gdbm_errno
+
+FUNCTION: c-string gdbm_strerror ( int errno ) ;
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: gdbm.ffi gdbm.private help.markup help.syntax kernel math
+quotations strings ;
+IN: gdbm
+
+HELP: gdbm
+{ $class-description "Instance of this class is used as database configuration object. It has following slots:"
+
+ { $table
+ { { $slot "name" } "The file name of the database." }
+ { { $slot "block-size" } "The size of a single transfer from disk to memory. If the value is less than 512, the file system blocksize is used (this is default)." }
+ { { $slot "role" } "Determines what kind of access the user wants to obtain (see below)." }
+ { { $slot "sync" } { "Being set to " { $link t } " causes all database operations to be synchronized to the disk." } }
+ { { $slot "nolock" } { "Being set to " { $link t } " prevents gdbm from performing any locking on the database file." } }
+ { { $slot "mode" } "An integer representing standard UNIX access permissions." }
+ }
+ "The " { $slot "role" } " can be set to one of the folowing values:"
+ { $table
+ { { $snippet "reader" } "The user can only read from existing database." }
+ { { $snippet "writer" } "The user can access existing database as reader and writer." }
+ { { $snippet "wrcreat" } "Open the database for reading and writing if it exists and create new one otherwise." }
+ { { $snippet "newdb" } "Create empty database even if there is already one with the same name." }
+ }
+} ;
+
+HELP: <gdbm>
+{ $values { "gdbm" gdbm } }
+{ $description "Creates database configuration object with all slots set to their default values. See " { $link gdbm } " for complete slots description." } ;
+
+HELP: gdbm-info
+{ $values { "str" string } }
+{ $description "Returns version number and build date." } ;
+
+HELP: delete
+{ $values { "key" object } }
+{ $description "Removes the keyed item from the database." } ;
+
+HELP: gdbm-error-message
+{ $values { "error" gdbm-error } { "msg" string } }
+{ $description "Returns error message in human readable format." } ;
+
+HELP: exists?
+{ $values { "key" object } { "?" boolean } }
+{ $description "Searches for a particular key without retreiving it." } ;
+
+HELP: each-key
+{ $values { "quot" quotation } }
+{ $description "Applies the quotation to the each key in the database." } ;
+
+HELP: each-value
+{ $values { "quot" quotation } }
+{ $description "Applies the quotation to the each value in the database." } ;
+
+HELP: each-record
+{ $values { "quot" quotation } }
+{ $description "Applies the quotation to the each key-value pair in the database." } ;
+
+HELP: gdbm-file-descriptor
+{ $values { "desc" integer } }
+{ $description "Returns the file descriptor of the database. This is used for manual database locking if it was opened with " { $snippet "nolock" } " flag set to " { $link t } "." } ;
+
+HELP: fetch
+{ $values
+ { "key" object }
+ { "content/f" { "the value associated with " { $snippet "key" } " or " { $link f } " if there is no such key" } }
+}
+{ $description "Looks up a given key and returns value associated with it. This word makes no distinction between a missing value and a value set to " { $link f } "." } ;
+
+HELP: fetch*
+{ $values { "key" object } { "content" object } { "?" boolean } }
+{ $description "Looks up a given key and returns value associated with it. The boolean flag can decide between the case of a missing value, and a value of " { $link f } "." } ;
+
+HELP: first-key
+{ $values { "key/f" object } }
+{ $description "Returns first key in the database. This word makes no distinction between an empty database case and a case of a first value set to " { $link f } "." } ;
+
+HELP: first-key*
+{ $values { "key" object } { "?" boolean } }
+{ $description "Returns first key in the database. The boolean flag can decide between the case of an empty database and a case of a first value set to " { $link f } "." } ;
+
+HELP: insert
+{ $values { "key" object } { "content" object } }
+{ $description "Inserts record into the database. Throws an error if the key already exists." } ;
+
+HELP: next-key
+{ $values { "key" object } { "key/f" object } }
+{ $description "Given a key returns next key in the database. This word makes no distinction between reaching the end of the database case and a case of a next value set to " { $link f } "." } ;
+
+HELP: next-key*
+{ $values { "key" object } { "next-key" object } { "?" boolean } }
+{ $description "Given a key returns next key in the database. The boolean flag can decide between the case of reaching the end of the database and a case of a next value set to " { $link f } "." } ;
+
+HELP: reorganize
+{ $description "Reorganisation is a process of shinking the space used by gdbm. This requires creating a new file and moving all elements from old gdbm file to new one." } ;
+
+HELP: replace
+{ $values { "key" object } { "content" object } }
+{ $description "Inserts record into the database replacing old value with the new one if the key already exists." } ;
+
+HELP: set-block-merging
+{ $values { "?" boolean } }
+{ $description "If set, this option causes adjacent free blocks to be merged. The default is " { $link f } "." } ;
+
+HELP: set-block-pool
+{ $values { "?" boolean } }
+{ $description "If set, this option causes all subsequent free blocks to be placed in the global pool. The default is " { $link f } "." } ;
+
+HELP: set-cache-size
+{ $values { "size" integer } }
+{ $description "Sets the size of the internal bucket cache. The default value is 100. This option may only be set once." } ;
+
+HELP: set-sync-mode
+{ $values { "?" boolean } }
+{ $description "Turns on or off file system synchronization. The default is " { $link f } "." } ;
+
+HELP: synchronize
+{ $description "Performs database synchronization: make sure the disk version of the database has been completely updated." } ;
+
+HELP: with-gdbm
+{ $values
+ { "gdbm" "a database configuration object" } { "quot" quotation }
+}
+{ $description "Calls the quotation with a database bound to " { $link current-dbf } " symbol." } ;
+
+
+ARTICLE: "gdbm" "GNU Database Manager"
+"The " { $vocab-link "gdbm" } " vocabulary provides an interface to GNU DataBase Manager. This is a GNU implementation of the standard Unix dbm library, originally developed at Berkeley."
+
+$nl
+"This is a very brief manual. For a more detailed description consult the official gdbm documentation."
+
+{ $heading "Basics" }
+"All interaction with gdbm database should be realized using special combinator which automates all work for database initialisation and cleanup. All initialisation options are passed to combinator with a database configuration object."
+{ $subsections gdbm <gdbm> with-gdbm }
+"For actual record manipulation the following words are used:"
+{ $subsections insert exists? fetch delete }
+
+{ $heading "Sequential access" }
+"It is possible to iterate through all records in the database with"
+{ $subsections first-key next-key }
+"The following combinators, however, provide more convenient way to do that:"
+{ $subsections each-key each-value each-record }
+"The order in which records are accessed has nothing to do with the order in which records have been stored. Note that these words can only be used in read-only algorithms since delete operation re-arranges the hash table."
+;
+
+ABOUT: "gdbm"
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays continuations gdbm io.directories
+io.files.temp kernel sequences sets tools.test ;
+IN: gdbm.tests
+
+: db-path ( -- filename ) "test.db" temp-file ;
+
+: CLEANUP ( -- ) [ db-path delete-file ] ignore-errors ;
+
+: test.db ( -- gdbm ) <gdbm> db-path >>name ;
+
+: with-test.db ( quot -- ) test.db swap with-gdbm ; inline
+
+
+CLEANUP
+
+
+[
+ test.db reader >>role [ ] with-gdbm
+] [ gdbm-file-open-error = ] must-fail-with
+
+[ f ] [ [ "foo" exists? ] with-test.db ] unit-test
+
+[ ] [ [ "foo" 41 insert ] with-test.db ] unit-test
+
+[
+ db-path [ "foo" 42 insert ] with-gdbm-writer
+] [ gdbm-cannot-replace = ] must-fail-with
+
+[ ]
+[
+ [
+ "foo" 42 replace
+ "bar" 43 replace
+ "baz" 44 replace
+ ] with-test.db
+] unit-test
+
+[ 42 t ] [ db-path [ "foo" fetch* ] with-gdbm-reader ] unit-test
+
+[ f f ] [ [ "unknown" fetch* ] with-test.db ] unit-test
+
+[
+ [
+ 300 set-cache-size 300 set-cache-size
+ ] with-test.db
+] [ gdbm-option-already-set = ] must-fail-with
+
+[ t ]
+[
+ V{ } [ [ 2array append ] each-record ] with-test.db
+ V{ "foo" "bar" "baz" 42 43 44 } set=
+
+] unit-test
+
+[ f ]
+[
+ test.db newdb >>role [ "foo" exists? ] with-gdbm
+] unit-test
+
+
+CLEANUP
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data alien.destructors
+alien.enums alien.syntax classes.struct combinators destructors
+gdbm.ffi io.backend kernel libc locals math namespaces sequences
+serialize strings ;
+IN: gdbm
+
+ENUM: gdbm-role reader writer wrcreat newdb ;
+
+TUPLE: gdbm
+ { name string }
+ { block-size integer }
+ { role initial: wrcreat }
+ { sync boolean }
+ { nolock boolean }
+ { mode integer initial: OCT: 644 } ;
+
+: <gdbm> ( -- gdbm ) gdbm new ;
+
+ENUM: gdbm-error
+ gdbm-no-error
+ gdbm-malloc-error
+ gdbm-block-size-error
+ gdbm-file-open-error
+ gdbm-file-write-error
+ gdbm-file-seek-error
+ gdbm-file-read-error
+ gdbm-bad-magic-number
+ gdbm-empty-database
+ gdbm-cant-be-reader
+ gdbm-cant-be-writer
+ gdbm-reader-cant-delete
+ gdbm-reader-cant-store
+ gdbm-reader-cant-reorganize
+ gdbm-unknown-update
+ gdbm-item-not-found
+ gdbm-reorganize-failed
+ gdbm-cannot-replace
+ gdbm-illegal-data
+ gdbm-option-already-set
+ gdbm-illegal-option ;
+
+
+<PRIVATE
+
+: gdbm-throw ( -- * ) gdbm_errno gdbm-error number>enum throw ;
+
+: check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
+
+SYMBOL: current-dbf
+
+: dbf ( -- dbf ) current-dbf get ;
+
+: get-flag ( gdbm -- n )
+ [ role>> enum>number ]
+ [ sync>> GDBM_SYNC 0 ? ]
+ [ nolock>> GDBM_NOLOCK 0 ? ]
+ tri bitor bitor ;
+
+: gdbm-open ( gdbm -- dbf )
+ {
+ [ name>> normalize-path ]
+ [ block-size>> ] [ get-flag ] [ mode>> ]
+ } cleave f gdbm_open [ gdbm-throw ] unless* ;
+
+DESTRUCTOR: gdbm-close
+
+: object>datum ( obj -- datum )
+ object>bytes [ malloc-byte-array &free ] [ length ] bi
+ datum <struct-boa> ;
+
+: datum>object* ( datum -- obj ? )
+ [ dptr>> ] [ dsize>> ] bi over
+ [ memory>byte-array bytes>object t ] [ drop f ] if ;
+
+: gdbm-store ( key content flag -- )
+ [
+ { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
+ gdbm_store check-error
+ ] with-destructors ;
+
+:: (setopt) ( value option -- )
+ [
+ int heap-size dup malloc &free :> ( size ptr )
+ value ptr 0 int set-alien-value
+ dbf option ptr size gdbm_setopt check-error
+ ] with-destructors ;
+
+: setopt ( value option -- )
+ [ GDBM_CACHESIZE = [ >c-bool ] unless ] keep (setopt) ;
+
+PRIVATE>
+
+
+: gdbm-info ( -- str ) gdbm_version ;
+
+: gdbm-error-message ( error -- msg )
+ enum>number gdbm_strerror ;
+
+: replace ( key content -- ) GDBM_REPLACE gdbm-store ;
+: insert ( key content -- ) GDBM_INSERT gdbm-store ;
+
+: delete ( key -- )
+ [ dbf swap object>datum gdbm_delete check-error ]
+ with-destructors ;
+
+: fetch* ( key -- content ? )
+ [ dbf swap object>datum gdbm_fetch datum>object* ]
+ with-destructors ;
+
+: first-key* ( -- key ? )
+ [ dbf gdbm_firstkey datum>object* ] with-destructors ;
+
+: next-key* ( key -- next-key ? )
+ [ dbf swap object>datum gdbm_nextkey datum>object* ]
+ with-destructors ;
+
+: fetch ( key -- content/f ) fetch* drop ;
+: first-key ( -- key/f ) first-key* drop ;
+: next-key ( key -- key/f ) next-key* drop ;
+
+:: each-key ( ... quot: ( ... key -- ... ) -- ... )
+ first-key*
+ [ [ next-key* ] [ quot keep ] do while ] when drop ; inline
+
+: each-value ( ... quot: ( ... value -- ... ) -- ... )
+ [ fetch ] prepose each-key ; inline
+
+: each-record ( ... quot: ( ... key value -- ... ) -- ... )
+ [ dup fetch ] prepose each-key ; inline
+
+: reorganize ( -- ) dbf gdbm_reorganize check-error ;
+
+: synchronize ( -- ) dbf gdbm_sync ;
+
+: exists? ( key -- ? )
+ [ dbf swap object>datum gdbm_exists c-bool> ]
+ with-destructors ;
+
+: set-cache-size ( size -- ) GDBM_CACHESIZE setopt ;
+: set-sync-mode ( ? -- ) GDBM_SYNCMODE setopt ;
+: set-block-pool ( ? -- ) GDBM_CENTFREE setopt ;
+: set-block-merging ( ? -- ) GDBM_COALESCEBLKS setopt ;
+
+: gdbm-file-descriptor ( -- desc ) dbf gdbm_fdesc ;
+
+: with-gdbm ( gdbm quot -- )
+ [ gdbm-open &gdbm-close current-dbf set ] prepose curry
+ [ with-scope ] curry with-destructors ; inline
+
+:: with-gdbm-role ( name role quot -- )
+ <gdbm> name >>name role >>role quot with-gdbm ; inline
+
+: with-gdbm-reader ( name quot -- )
+ reader swap with-gdbm-role ; inline
+
+: with-gdbm-writer ( name quot -- )
+ writer swap with-gdbm-role ; inline
+
--- /dev/null
+GNU DataBase Manager
--- /dev/null
+bindings
+database
! Copyrigt (C) 2009 Doug Coleman, Keith Lazuka
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators compression.lzw
+USING: accessors arrays combinators compression.lzw
constructors destructors grouping images images.loader io
-io.binary io.buffers io.encodings.binary io.encodings.string
-io.encodings.utf8 io.files io.files.info io.ports
-io.streams.limited kernel make math math.bitwise math.functions
-multiline namespaces prettyprint sequences ;
+io.binary io.buffers io.encodings.string io.encodings.utf8
+io.ports kernel make math math.bitwise namespaces sequences ;
IN: images.gif
SINGLETON: gif-image
--- /dev/null
+Niklas Waern
--- /dev/null
+! Copyright (C) 2010 Niklas Waern.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+fry kernel sequences unix.types ;
+IN: libudev
+
+<< "libudev" "libudev.so" cdecl add-library >>
+
+LIBRARY: libudev
+
+C-TYPE: udev
+
+FUNCTION: udev* udev_ref (
+ udev* udev ) ;
+
+
+
+FUNCTION: void udev_unref (
+ udev* udev ) ;
+
+
+
+FUNCTION: udev* udev_new ( ) ;
+
+
+
+CALLBACK: void udev_set_log_fn_callback (
+ udev* udev
+ int priority,
+ c-string file,
+ int line,
+ c-string fn,
+ c-string format ) ;
+ ! va_list args ) ;
+FUNCTION: void udev_set_log_fn (
+ udev* udev,
+ udev_set_log_fn_callback log_fn ) ;
+
+
+
+FUNCTION: int udev_get_log_priority (
+ udev* udev ) ;
+
+
+
+FUNCTION: void udev_set_log_priority (
+ udev* udev,
+ int priority ) ;
+
+
+
+FUNCTION: c-string udev_get_sys_path (
+ udev* udev ) ;
+
+
+
+FUNCTION: c-string udev_get_dev_path (
+ udev* udev ) ;
+
+
+
+FUNCTION: void* udev_get_userdata (
+ udev* udev ) ;
+
+
+
+FUNCTION: void udev_set_userdata (
+ udev* udev,
+ void* userdata ) ;
+
+
+
+C-TYPE: udev_list_entry
+
+FUNCTION: udev_list_entry* udev_list_entry_get_next (
+ udev_list_entry* list_entry ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_list_entry_get_by_name (
+ udev_list_entry* list_entry,
+ c-string name ) ;
+
+
+
+FUNCTION: c-string udev_list_entry_get_name (
+ udev_list_entry* list_entry ) ;
+
+
+
+FUNCTION: c-string udev_list_entry_get_value (
+ udev_list_entry* list_entry ) ;
+
+
+
+! Helper to iterate over all entries of a list.
+: udev_list_entry_foreach ( ... first_entry quot: ( ... x -- ... ) -- ... )
+ [ [ dup ] ] dip '[ [ @ ] keep udev_list_entry_get_next ]
+ while drop ; inline
+
+! Get all list entries _as_ a list
+: udev-list-entries ( first_entry -- seq )
+ [ ] collector [ udev_list_entry_foreach ] dip ;
+
+
+
+C-TYPE: udev_device
+
+FUNCTION: udev_device* udev_device_ref (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: void udev_device_unref (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev* udev_device_get_udev (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_device* udev_device_new_from_syspath (
+ udev* udev,
+ c-string syspath ) ;
+
+
+
+FUNCTION: udev_device* udev_device_new_from_devnum (
+ udev* udev,
+ char type,
+ dev_t devnum ) ;
+
+
+
+FUNCTION: udev_device* udev_device_new_from_subsystem_sysname (
+ udev* udev,
+ c-string subsystem,
+ c-string sysname ) ;
+
+
+
+FUNCTION: udev_device* udev_device_get_parent (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_device* udev_device_get_parent_with_subsystem_devtype (
+ udev_device* udev_device,
+ c-string subsystem,
+ c-string devtype ) ;
+
+
+
+FUNCTION: c-string udev_device_get_devpath (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_subsystem (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_devtype (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_syspath (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_sysname (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_sysnum (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_devnode (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_device_get_devlinks_list_entry (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_device_get_properties_list_entry (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_property_value (
+ udev_device* udev_device,
+ c-string key ) ;
+
+
+
+FUNCTION: c-string udev_device_get_driver (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: dev_t udev_device_get_devnum (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_action (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: ulonglong udev_device_get_seqnum (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_sysattr_value (
+ udev_device* udev_device,
+ c-string sysattr ) ;
+
+
+
+C-TYPE: udev_monitor
+
+FUNCTION: udev_monitor* udev_monitor_ref (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: void udev_monitor_unref (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: udev* udev_monitor_get_udev (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: udev_monitor* udev_monitor_new_from_netlink (
+ udev* udev,
+ c-string name ) ;
+
+
+
+FUNCTION: udev_monitor* udev_monitor_new_from_socket (
+ udev* udev,
+ c-string socket_path ) ;
+
+
+
+FUNCTION: int udev_monitor_enable_receiving (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: int udev_monitor_set_receive_buffer_size (
+ udev_monitor* udev_monitor,
+ int size ) ;
+
+
+
+FUNCTION: int udev_monitor_get_fd (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: udev_device* udev_monitor_receive_device (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: int udev_monitor_filter_add_match_subsystem_devtype (
+ udev_monitor* udev_monitor,
+ c-string subsystem,
+ c-string devtype ) ;
+
+
+
+FUNCTION: int udev_monitor_filter_update (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: int udev_monitor_filter_remove (
+ udev_monitor* udev_monitor ) ;
+
+
+
+C-TYPE: udev_enumerate
+
+FUNCTION: udev_enumerate* udev_enumerate_ref (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: void udev_enumerate_unref (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: udev* udev_enumerate_get_udev (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: udev_enumerate* udev_enumerate_new (
+ udev* udev ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_subsystem (
+ udev_enumerate* udev_enumerate,
+ c-string subsystem ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_nomatch_subsystem (
+ udev_enumerate* udev_enumerate,
+ c-string subsystem ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_sysattr (
+ udev_enumerate* udev_enumerate,
+ c-string sysattr,
+ c-string value ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_nomatch_sysattr (
+ udev_enumerate* udev_enumerate,
+ c-string sysattr,
+ c-string value ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_property (
+ udev_enumerate* udev_enumerate,
+ c-string property,
+ c-string value ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_sysname (
+ udev_enumerate* udev_enumerate,
+ c-string sysname ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_syspath (
+ udev_enumerate* udev_enumerate,
+ c-string syspath ) ;
+
+
+
+FUNCTION: int udev_enumerate_scan_devices (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: int udev_enumerate_scan_subsystems (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_enumerate_get_list_entry (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+C-TYPE: udev_queue
+
+FUNCTION: udev_queue* udev_queue_ref (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: void udev_queue_unref (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: udev* udev_queue_get_udev (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: udev_queue* udev_queue_new (
+ udev* udev ) ;
+
+
+
+FUNCTION: ulonglong udev_queue_get_kernel_seqnum (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: ulonglong udev_queue_get_udev_seqnum (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: int udev_queue_get_udev_is_active (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: int udev_queue_get_queue_is_empty (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: int udev_queue_get_seqnum_is_finished (
+ udev_queue* udev_queue,
+ ulonglong seqnum ) ;
+
+
+
+FUNCTION: int udev_queue_get_seqnum_sequence_is_finished (
+ udev_queue* udev_queue,
+ ulonglong start,
+ ulonglong end ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_queue_get_queued_list_entry (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_queue_get_failed_list_entry (
+ udev_queue* udev_queue ) ;
+
+
+
--- /dev/null
+Bindings to libudev
! Who receives build report e-mails.
SYMBOL: builder-recipients
-! (Optional) twitter credentials for status updates.
-SYMBOL: builder-twitter-username
-
-SYMBOL: builder-twitter-password
-
! (Optional) CPU architecture to build for.
SYMBOL: target-cpu
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger fry kernel mason.config namespaces twitter ;
IN: mason.twitter
: mason-tweet ( message -- )
- builder-twitter-username get builder-twitter-password get and
- [
- [
- builder-twitter-username get twitter-username set
- builder-twitter-password get twitter-password set
- '[ _ tweet ] try
- ] with-scope
- ] [ drop ] if ;
\ No newline at end of file
+ twitter-access-token get [ '[ _ tweet ] try ] [ drop ] if ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: oauth oauth.private tools.test accessors kernel assocs
+strings namespaces ;
+IN: oauth.tests
+
+[ "%26&b" ] [ "&" "b" hmac-key ] unit-test
+[ "%26&" ] [ "&" f hmac-key ] unit-test
+
+[ "B&http%3A%2F%2Ftwitter.com&a%3Db" ] [
+ "http://twitter.com"
+ "B"
+ { { "a" "b" } }
+ signature-base-string
+] unit-test
+
+[ "Z5tUa83q43qiy6dGGCb92bN/4ik=" ] [
+ "ABC" "DEF" <token> consumer-token set
+
+ "http://twitter.com"
+ <request-token-params>
+ 12345 >>timestamp
+ 54321 >>nonce
+ <request-token-request>
+ post-data>>
+ "oauth_signature" swap at
+ >string
+] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs base64 calendar checksums.hmac
+checksums.sha combinators fry http http.client kernel locals
+make math namespaces present random sequences sorting strings
+urls urls.encoding ;
+IN: oauth
+
+SYMBOL: consumer-token
+
+TUPLE: token key secret user-data ;
+
+: <token> ( key secret -- token )
+ token new
+ swap >>secret
+ swap >>key ;
+
+<PRIVATE
+
+TUPLE: token-params
+consumer-token
+timestamp
+nonce ;
+
+: new-token-params ( class -- params )
+ new
+ consumer-token get >>consumer-token
+ now timestamp>unix-time >integer >>timestamp
+ random-32 >>nonce ; inline
+
+:: signature-base-string ( url request-method params -- string )
+ [
+ request-method % "&" %
+ url present url-encode-full % "&" %
+ params assoc>query url-encode-full %
+ ] "" make ;
+
+: hmac-key ( consumer-secret token-secret -- key )
+ [ url-encode-full ] [ "" or url-encode-full ] bi* "&" glue ;
+
+: make-token-params ( params quot -- assoc )
+ '[
+ "1.0" "oauth_version" set
+ "HMAC-SHA1" "oauth_signature_method" set
+
+ _
+ [
+ [ consumer-token>> key>> "oauth_consumer_key" set ]
+ [ timestamp>> "oauth_timestamp" set ]
+ [ nonce>> "oauth_nonce" set ]
+ tri
+ ] bi
+ ] H{ } make-assoc ; inline
+
+:: sign-params ( url request-method consumer-token request-token params -- signed-params )
+ params >alist sort-keys :> params
+ url request-method params signature-base-string :> sbs
+ consumer-token secret>> request-token dup [ secret>> ] when hmac-key :> key
+ sbs key sha1 hmac-bytes >base64 >string :> signature
+ params { "oauth_signature" signature } prefix ;
+
+: extract-user-data ( assoc -- assoc' )
+ [
+ drop
+ { "oauth_token" "oauth_token_secret" } member? not
+ ] assoc-filter ;
+
+: parse-token ( response data -- token )
+ nip
+ query>assoc
+ [ [ "oauth_token" ] dip at ]
+ [ [ "oauth_token_secret" ] dip at ]
+ [ extract-user-data ]
+ tri
+ [ <token> ] dip >>user-data ;
+
+PRIVATE>
+
+TUPLE: request-token-params < token-params
+{ callback-url initial: "oob" } ;
+
+: <request-token-params> ( -- params )
+ request-token-params new-token-params ;
+
+<PRIVATE
+
+:: <token-request> ( url consumer-token request-token params -- request )
+ url "POST" consumer-token request-token params sign-params
+ url
+ <post-request> ;
+
+: make-request-token-params ( params -- assoc )
+ [ callback-url>> "oauth_callback" set ] make-token-params ;
+
+: <request-token-request> ( url params -- request )
+ [ consumer-token>> f ] [ make-request-token-params ] bi
+ <token-request> ;
+
+PRIVATE>
+
+: obtain-request-token ( url params -- token )
+ <request-token-request> http-request parse-token ;
+
+TUPLE: access-token-params < token-params request-token verifier ;
+
+: <access-token-params> ( -- params )
+ access-token-params new-token-params ;
+
+<PRIVATE
+
+: make-access-token-params ( params -- assoc )
+ [
+ [ request-token>> key>> "oauth_token" set ]
+ [ verifier>> "oauth_verifier" set ]
+ bi
+ ] make-token-params ;
+
+: <access-token-request> ( url params -- request )
+ [ consumer-token>> ]
+ [ request-token>> ]
+ [ make-access-token-params ] tri
+ <token-request> ;
+
+PRIVATE>
+
+: obtain-access-token ( url params -- token )
+ <access-token-request> http-request parse-token ;
+
+SYMBOL: access-token
+
+TUPLE: oauth-request-params < token-params access-token ;
+
+: <oauth-request-params> ( -- params )
+ oauth-request-params new-token-params
+ access-token get >>access-token ;
+
+<PRIVATE
+
+:: signed-oauth-request-params ( request params -- params )
+ request url>>
+ request method>>
+ params consumer-token>>
+ params access-token>>
+ params
+ [
+ access-token>> key>> "oauth_token" set
+ namespace request post-data>> assoc-union! drop
+ ] make-token-params
+ sign-params ;
+
+: build-auth-string ( params -- string )
+ [ [ present url-encode-full ] bi@ "\"" "\"" surround "=" glue ] { } assoc>map
+ ", " join "OAuth realm=\"\", " prepend ;
+
+PRIVATE>
+
+: set-oauth ( request params -- request )
+ dupd signed-oauth-request-params build-auth-string
+ "Authorization" set-header ;
HELP: role-slot-overlap
{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ;
+ARTICLE: "roles" "Roles"
+"The " { $vocab-link "roles" } " vocabulary implements a way to extend tuple classes that allows them to be composed of multiple roles objects that contain slots." $nl
+"The role superclass:"
+{ $subsections role }
+"Syntax for making a new role:"
+{ $subsection POSTPONE: ROLE: }
+"Syntax for making tuples that use roles:"
+{ $subsection POSTPONE: TUPLE: }
+"Errors with roles:"
+{ $subsections multiple-inheritance-attempted role-slot-overlap } ;
--- /dev/null
+Joe Groff
+Slava Pestov
--- /dev/null
+USING: accessors continuations fry http.client images.loader
+images.loader.private images.viewer io io.styles kernel memoize
+prettyprint sequences twitter ;
+IN: twitter.prettyprint
+
+MEMO: load-http-image ( url -- image/f )
+ '[ _
+ [ http-get [ check-response drop ] dip ]
+ [ image-class ] bi load-image*
+ ] [ drop f ] recover ;
+
+: user-image ( user -- image/f )
+ profile-image-url>> load-http-image ;
+
+CONSTANT: tweet-table-style
+ H{ { table-gap { 5 5 } } }
+
+CONSTANT: tweet-username-style
+ H{
+ { font-style bold }
+ }
+
+CONSTANT: tweet-text-style
+ H{
+ { font-name "sans-serif" }
+ { font-size 16 }
+ { wrap-margin 500 }
+ }
+
+CONSTANT: tweet-metadata-style
+ H{
+ { font-size 10 }
+ }
+
+: tweet. ( status -- )
+ tweet-table-style [
+ [
+ [ dup user>> user-image [ image. ] when* ] with-cell
+ [
+ H{ { wrap-margin 600 } } [
+ tweet-text-style [
+ tweet-username-style [
+ dup user>> screen-name>> write
+ ] with-style
+ " " write dup text>> print
+
+ tweet-metadata-style [
+ dup created-at>> write
+ " via " write
+ dup source>> write
+ ] with-style
+ ] with-style
+ ] with-nesting
+ ] with-cell
+ ] with-row
+ ] tabular-output nl
+ drop ;
+
+: friends-timeline. ( -- ) friends-timeline [ tweet. ] each ;
+: public-timeline. ( -- ) public-timeline [ tweet. ] each ;
+: user-timeline. ( user -- ) user-timeline [ tweet. ] each ;
-! Copyright (C) 2009 Joe Groff.
+! Copyright (C) 2009, 2010 Joe Groff, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators hashtables http
http.client json.reader kernel macros namespaces sequences
-urls.secure fry ;
+urls.secure fry oauth urls ;
IN: twitter
! Configuration
-SYMBOLS: twitter-username twitter-password twitter-source ;
+SYMBOLS: twitter-source twitter-consumer-token twitter-access-token ;
twitter-source [ "factor" ] initialize
-: set-twitter-credentials ( username password -- )
- [ twitter-username set ] [ twitter-password set ] bi* ;
+<PRIVATE
+
+: with-twitter-oauth ( quot -- )
+ [
+ twitter-consumer-token get consumer-token set
+ twitter-access-token get access-token set
+ call
+ ] with-scope ; inline
+
+PRIVATE>
+
+! obtain-twitter-request-token and obtain-twitter-access-token
+! should use https: URLs but Twitter sends a 301 Redirect back
+! to the same URL. Twitter bug?
+
+: obtain-twitter-request-token ( -- request-token )
+ [
+ "https://twitter.com/oauth/request_token"
+ <request-token-params>
+ obtain-request-token
+ ] with-twitter-oauth ;
+
+: twitter-authorize-url ( token -- url )
+ "https://twitter.com/oauth/authorize" >url
+ swap key>> "oauth_token" set-query-param ;
+
+: obtain-twitter-access-token ( request-token verifier -- access-token )
+ [
+ [ "https://twitter.com/oauth/access_token" ] 2dip
+ <access-token-params>
+ swap >>verifier
+ swap >>request-token
+ obtain-access-token
+ ] with-twitter-oauth ;
<PRIVATE
[ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
! Twitter requests
-
: twitter-url ( string -- url )
"https://twitter.com/statuses/" ".json" surround ;
: set-request-twitter-auth ( request -- request )
- twitter-username get twitter-password get set-basic-auth ;
+ [ <oauth-request-params> set-oauth ] with-twitter-oauth ;
: twitter-request ( request -- data )
set-request-twitter-auth
in-reply-to-user-id
favorited?
user ;
+
TUPLE: twitter-user
id
name
.
.
; """ }
-{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined as a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
{ $examples { $code """
USING: kernel variants ;
IN: scratchpad
;
""" } } ;
+HELP: VARIANT-MEMBER:
+{ $description "Defines a new member of a variant class without restricting such definitions to a single statement or source file. The variant class should be listed first, and the class member should follow." }
+{ $examples { $code """
+USING: kernel variants ;
+IN: scratchpad
+
+VARIANT: list ;
+
+VARIANT-MEMBER: list nil
+VARIANT-MEMBER: list cons: { { first object } { rest list } }
+""" } } ;
+
HELP: match
{ $values { "branches" array } }
{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
{ $subsections
POSTPONE: VARIANT:
+ POSTPONE: VARIANT-MEMBER:
variant-class
match
} ;
[ 4 ]
[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test
+
+
+VARIANT: list2 ;
+VARIANT-MEMBER: list2 nil2
+VARIANT-MEMBER: list2 cons2: { { first object } { rest list2 } }
+
+[ t ] [ nil2 list2? ] unit-test
+[ t ] [ 1 nil2 <cons2> list2? ] unit-test
+[ f ] [ 1 list2? ] unit-test
+
+: list2-length ( list2 -- length )
+ {
+ { nil2 [ 0 ] }
+ { cons2 [ nip list2-length 1 + ] }
+ } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil2 <cons2> <cons2> <cons2> <cons2> list2-length ] unit-test
: define-variant-member ( member -- class )
dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
-: define-variant-class ( class members -- )
- [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
- [ define-variant-member swap add-mixin-instance ] with each ;
+: define-variant-class ( class -- )
+ [ define-mixin-class ] [ t "variant" set-word-prop ] bi ;
+
+: define-variant-class-member ( class member -- )
+ define-variant-member swap add-mixin-instance ;
+
+: define-variant-class-members ( class members -- )
+ [ dup define-variant-class ] dip
+ [ define-variant-class-member ] with each ;
: parse-variant-tuple-member ( name -- member )
create-class-in tuple
SYNTAX: VARIANT:
CREATE-CLASS
parse-variant-members
- define-variant-class ;
+ define-variant-class-members ;
+
+SYNTAX: VARIANT-MEMBER:
+ scan-word
+ scan parse-variant-member
+ define-variant-class-member ;
MACRO: unboa ( class -- )
<wrapper> \ boa [ ] 2sequence [undo] ;
OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */
OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */
- OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */
-
OBJ_STARTUP_QUOT = 20, /* startup quotation */
OBJ_GLOBAL, /* global namespace */
OBJ_SHUTDOWN_QUOT, /* shutdown quotation */
void factor_vm::c_to_factor_toplevel(cell quot)
{
- for(;;)
- {
-NS_DURING
- c_to_factor(quot);
- NS_VOIDRETURN;
-NS_HANDLER
- ctx->push(allot_alien(false_object,(cell)localException));
- quot = special_objects[OBJ_COCOA_EXCEPTION];
- if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
- {
- /* No Cocoa exception handler was registered, so
- basis/cocoa/ is not loaded. So we pass the exception
- along. */
- [localException raise];
- }
-NS_ENDHANDLER
- }
+ c_to_factor(quot);
}
void early_init(void)
projects / factor.git / commitdiff
