diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 1f9940e2c6..c6a3623666 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -79,7 +79,7 @@ M: int-regs inc-reg-class M: float-regs inc-reg-class dup (inc-reg-class) - fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ; + fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ; : reg-class-full? ( class -- ? ) dup class get swap param-regs length >= ; diff --git a/core/bootstrap/ui/tools/tools.factor b/core/bootstrap/ui/tools/tools.factor index c469aedcff..52e4367b42 100644 --- a/core/bootstrap/ui/tools/tools.factor +++ b/core/bootstrap/ui/tools/tools.factor @@ -8,3 +8,5 @@ USING: kernel vocabs vocabs.loader sequences ; "ui.cocoa.tools" require ] when ] when + +macosx? [ "ui.tools.deploy" require ] when diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 07a4a073de..cadfcfda14 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -278,7 +278,7 @@ M: arm-backend %alien-indirect ( -- ) M: arm-backend %alien-callback ( quot -- ) R0 load-indirect - "run_callback" f %alien-invoke ; + "c_to_factor" f %alien-invoke ; M: arm-backend %callback-value ( ctype -- ) ! Save top of data stack diff --git a/core/cpu/arm/arm.factor b/core/cpu/arm/arm.factor index ca37912790..f6d851e36b 100755 --- a/core/cpu/arm/arm.factor +++ b/core/cpu/arm/arm.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types kernel math namespaces cpu.architecture cpu.arm.architecture cpu.arm.assembler cpu.arm.intrinsics generator generator.registers continuations -compiler io vocabs.loader sequences ; +compiler io vocabs.loader sequences system ; ! EABI passes floats in integer registers. [ alien-float ] @@ -53,4 +53,4 @@ T{ arm-backend } compiler-backend set-global t have-BLX? set-global ] when -7 cells set-profiler-prologue +7 cells set-profiler-prologues diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index b85081fb6c..672520c23d 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -160,7 +160,7 @@ HOOK: %unbox-struct-2 compiler-backend ( -- ) M: x86-backend %unbox-small-struct ( size -- ) #! Alien must be in EAX. - cell align cell / { + cell align cell /i { { 1 [ %unbox-struct-1 ] } { 2 [ %unbox-struct-2 ] } } case ; diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index 8e970d82c6..97751c1858 100644 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: arrays generic kernel math models namespaces sequences -tools.test ; +tools.test assocs ; TUPLE: model-tester hit? ; @@ -106,3 +106,34 @@ f "history" set [ { 4 5 } ] [ "c" get model-value ] unit-test [ ] [ "c" get deactivate-model ] unit-test + +! Test mapping +[ ] [ + [ + 1 "one" set + 2 "two" set + ] H{ } make-assoc + "m" set +] unit-test + +[ ] [ "m" get activate-model ] unit-test + +[ H{ { "one" 1 } { "two" 2 } } ] [ + "m" get model-value +] unit-test + +[ ] [ + H{ { "one" 3 } { "two" 4 } } + "m" get set-model +] unit-test + +[ H{ { "one" 3 } { "two" 4 } } ] [ + "m" get model-value +] unit-test + +[ H{ { "one" 5 } { "two" 4 } } ] [ + 5 "one" "m" get mapping-assoc at set-model + "m" get model-value +] unit-test + +[ ] [ "m" get deactivate-model ] unit-test diff --git a/extra/models/models.factor b/extra/models/models.factor index 04ae639eff..59f888b0e0 100644 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic kernel math sequences timers arrays ; +USING: generic kernel math sequences timers arrays assocs ; IN: models TUPLE: model value connections dependencies ref ; @@ -109,6 +109,22 @@ M: compose model-activated model-changed ; M: compose set-model [ set-model ] set-composed-value ; +TUPLE: mapping assoc ; + +: ( models -- mapping ) + f mapping construct-model + over values over set-model-dependencies + tuck set-mapping-assoc ; + +M: mapping model-changed + dup mapping-assoc [ model-value ] assoc-map + swap delegate set-model ; + +M: mapping model-activated model-changed ; + +M: mapping set-model + mapping-assoc [ swapd at set-model ] curry assoc-each ; + TUPLE: history back forward ; : reset-history ( history -- ) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 13ce47ba52..d796c2611d 100644 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -2,7 +2,7 @@ ! Portions copyright (C) 2007 Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types io kernel math namespaces -sequences math.vectors opengl.gl opengl.glu combinators ; +sequences math.vectors math.constants math.functions opengl.gl opengl.glu combinators arrays ; IN: opengl : coordinates [ first2 ] 2apply ; @@ -63,6 +63,23 @@ IN: opengl : gl-poly ( points -- ) GL_LINE_LOOP (gl-poly) ; +: circle-steps dup length v/n 2 pi * v*n ; + +: unit-circle dup [ sin ] map swap [ cos ] map ; + +: adjust-points [ [ 1 + 0.5 * ] map ] 2apply ; + +: scale-points 2array flip [ v* ] curry* map [ v+ ] curry* map ; + +: circle-points ( loc dim steps -- points ) + circle-steps unit-circle adjust-points scale-points ; + +: gl-circle ( loc dim steps -- ) + circle-points gl-poly ; + +: gl-fill-circle ( loc dim steps -- ) + circle-points gl-fill-poly ; + : prepare-gradient ( direction dim -- v1 v2 ) tuck v* [ v- ] keep ; diff --git a/extra/structs/tags.txt b/extra/structs/summary.txt similarity index 100% rename from extra/structs/tags.txt rename to extra/structs/summary.txt diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor index 6f683f9c44..1528fe0015 100644 --- a/extra/tools/deploy/config/config-docs.factor +++ b/extra/tools/deploy/config/config-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax words alien.c-types assocs -kernel ; +kernel math ; IN: tools.deploy.config ARTICLE: "deploy-config" "Deployment configuration" @@ -14,17 +14,13 @@ ARTICLE: "deploy-config" "Deployment configuration" ARTICLE: "deploy-flags" "Deployment flags" "There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:" { $subsection deploy-math? } -{ $subsection deploy-compiled? } -{ $subsection deploy-io? } +{ $subsection deploy-compiler? } { $subsection deploy-ui? } "The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:" -{ $subsection strip-globals? } -{ $subsection strip-word-props? } -{ $subsection strip-word-names? } -{ $subsection strip-dictionary? } -{ $subsection strip-debugger? } -{ $subsection strip-prettyprint? } -{ $subsection strip-c-types? } ; +{ $subsection deploy-io } +{ $subsection deploy-reflection } +{ $subsection deploy-word-props? } +{ $subsection deploy-c-types? } ; ARTICLE: "prepare-deploy" "Preparing to deploy an application" "In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created." @@ -33,47 +29,22 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application" ABOUT: "prepare-deploy" -HELP: strip-globals? -{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed variables from the global namespace." +HELP: deploy-word-props? +{ $description "Deploy flag. If set, the deploy tool retains all word properties. Otherwise, it applies various heuristics to strip out un-needed word properties from words in the dictionary." $nl -"On by default. Disable this if the heuristics strip out required variables." } ; +"Off by default. Enable this if the heuristics strip out required word properties." } ; -HELP: strip-word-props? -{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed word properties from words in the dictionary." +HELP: deploy-c-types? +{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table." $nl -"On by default. Disable this if the heuristics strip out required word properties." } ; - -HELP: strip-word-names? -{ $description "Deploy flag. If set, the deploy tool strips word names from words in the dictionary." -$nl -"On by default. Disable this if your program calls " { $link word-name } "." } ; - -HELP: strip-dictionary? -{ $description "Deploy flag. If set, the deploy tool strips unused words." -$nl -"On by default. Disable this if your program calls " { $link lookup } " to look up words by name, or needs to parse code at run-time." } ; - -HELP: strip-debugger? -{ $description "Deploy flag. If set, the deploy tool strips the verbose error reporting facility; any errors thrown by the program will start the low-level debugger in the VM." -$nl -"On by default. Disable this if you need to debug a problem which only occurs when your program is running deployed." } ; - -HELP: strip-prettyprint? -{ $description "Deploy flag. If set, the deploy tool strips variables used by the prettyprinter." -$nl -"On by default. Disable this if your program uses the prettyprinter." } ; - -HELP: strip-c-types? -{ $description "Deploy flag. If set, the deploy tool strips out the " { $link c-types } " table." -$nl -"On by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link } ", " { $link } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ; +"Off by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link } ", " { $link } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ; HELP: deploy-math? -{ $description "Deploy flag. If set, the deployed image will contain the full number tower." +{ $description "Deploy flag. If set, the deployed image will contain support for " { $link ratio } " and " { $link complex } " types." $nl -"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ; +"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ; -HELP: deploy-compiled? +HELP: deploy-compiler? { $description "Deploy flag. If set, words in the deployed image will be compiled when possible." $nl "On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ; @@ -83,10 +54,11 @@ HELP: deploy-ui? $nl "Off by default. Programs wishing to use the UI must be deployed with this flag on." } ; -HELP: deploy-io? -{ $description "Deploy flag. If set, support for non-blocking I/O and networking will be included in the deployed image." -$nl -"Off by default. Programs wishing to use non-blocking I/O or networking must be deployed with this flag on." } ; +HELP: deploy-io +{ $description "The level of I/O support required by the deployed image." } ; + +HELP: deploy-reflection +{ $description "The level of reflection support required by the deployed image." } ; HELP: default-config { $values { "assoc" assoc } } diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 2b7353ad03..cebf39cbd0 100644 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -1,40 +1,59 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: vocabs.loader io.files io kernel sequences assocs -splitting parser prettyprint ; +splitting parser prettyprint namespaces math ; IN: tools.deploy.config -SYMBOL: strip-io? -SYMBOL: strip-globals? -SYMBOL: strip-word-props? -SYMBOL: strip-word-names? -SYMBOL: strip-dictionary? -SYMBOL: strip-debugger? -SYMBOL: strip-prettyprint? -SYMBOL: strip-c-types? - -SYMBOL: deploy-math? -SYMBOL: deploy-compiled? -SYMBOL: deploy-io? SYMBOL: deploy-ui? +SYMBOL: deploy-compiler? +SYMBOL: deploy-math? + +SYMBOL: deploy-io + +: deploy-io-options + { + { 1 "Level 1 - No input/output" } + { 2 "Level 2 - Basic ANSI C streams" } + { 3 "Level 3 - Non-blocking streams and networking" } + } ; + +: strip-io? deploy-io get zero? ; + +: native-io? deploy-io get 3 = ; + +SYMBOL: deploy-reflection + +: deploy-reflection-options + { + { 1 "Level 1 - No reflection" } + { 2 "Level 2 - Retain word names" } + { 3 "Level 3 - Prettyprinter" } + { 4 "Level 4 - Debugger" } + { 5 "Level 5 - Parser" } + { 6 "Level 6 - Full environment" } + } ; + +: strip-word-names? deploy-reflection get 2 < ; +: strip-prettyprint? deploy-reflection get 3 < ; +: strip-debugger? deploy-reflection get 4 < ; +: strip-dictionary? deploy-reflection get 5 < ; +: strip-globals? deploy-reflection get 6 < ; + +SYMBOL: deploy-word-props? +SYMBOL: deploy-c-types? SYMBOL: deploy-vm SYMBOL: deploy-image : default-config ( -- assoc ) V{ - { strip-io? f } - { strip-prettyprint? t } - { strip-globals? t } - { strip-word-props? t } - { strip-word-names? t } - { strip-dictionary? t } - { strip-debugger? t } - { strip-c-types? t } - { deploy-math? t } - { deploy-compiled? t } - { deploy-io? f } - { deploy-ui? f } + { deploy-ui? f } + { deploy-io 2 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } ! default value for deploy.app { "stop-after-last-window?" t } } clone ; diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index 5701d0fa1b..2832551a34 100644 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -30,13 +30,16 @@ IN: tools.deploy dup duplex-stream-out stream-close copy-lines ; +: ?append swap [ append ] [ drop ] if ; + : profile-string ( config -- string ) - { - { deploy-math? "math" } - { deploy-compiled? "compiler" } - { deploy-ui? "ui" } - { deploy-io? "io" } - } swap [ nip at ] curry assoc-subset values " " join ; + [ + "" + deploy-math? get " math" ?append + deploy-compiler? get " compiler" ?append + native-io? " io" ?append + deploy-ui? get " ui" ?append + ] bind ; : deploy-command-line ( vm image vocab config -- vm flags ) [ diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index d19c8f4a2b..73c00cbd50 100644 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -16,10 +16,10 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show "command-line" init-hooks get delete-at - strip-io? get [ "io.backend" init-hooks get delete-at ] when ; + strip-io? [ "io.backend" init-hooks get delete-at ] when ; : strip-debugger ( -- ) - strip-debugger? get [ + strip-debugger? [ "Stripping debugger" show "resource:extra/tools/deploy/shaker/strip-debugger.factor" run-file @@ -65,23 +65,13 @@ IN: tools.deploy.shaker : strip-words ( props -- ) [ word? ] instances - strip-word-props? get [ tuck strip-word-props ] [ nip ] if - strip-word-names? get [ dup strip-word-names ] when + deploy-word-props? get [ nip ] [ tuck strip-word-props ] if + strip-word-names? [ dup strip-word-names ] when strip-word-defs ; -USING: bit-arrays byte-arrays io.streams.nested ; - -: strip-classes ( -- ) - "Stripping classes" show - io-backend get [ - c-reader forget - c-writer forget - ] when - { style-stream mirror enum } [ forget ] each ; - : strip-environment ( retain-globals -- ) "Stripping environment" show - strip-globals? get [ + strip-globals? [ global strip-assoc 21 setenv ] [ drop ] if ; @@ -103,16 +93,16 @@ SYMBOL: deploy-vocab \ boot , init-hooks get values concat % , - strip-io? get [ \ flush , ] unless + strip-io? [ \ flush , ] unless ] [ ] make "Boot quotation: " write dup . flush set-boot-quot ; : retained-globals ( -- seq ) [ builtins , - strip-io? get [ io-backend , ] unless + strip-io? [ io-backend , ] unless - strip-dictionary? get [ + strip-dictionary? [ { builtins dictionary @@ -129,14 +119,14 @@ SYMBOL: deploy-vocab } % ] unless - strip-prettyprint? get [ + strip-prettyprint? [ { tab-size margin } % ] unless - strip-c-types? get not deploy-ui? get or [ + deploy-c-types? get deploy-ui? get or [ "c-types" "alien.c-types" lookup , ] when @@ -150,18 +140,7 @@ SYMBOL: deploy-vocab ] when ] { } make dup . ; -: normalize-strip-flags - strip-prettyprint? get [ - strip-word-names? off - ] unless - strip-dictionary? get [ - strip-prettyprint? off - strip-word-names? off - strip-word-props? off - ] unless ; - : strip ( -- ) - normalize-strip-flags strip-cocoa strip-debugger strip-init-hooks diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index a0dc545807..f0099e2f91 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -4,23 +4,41 @@ USING: arrays ui.gadgets generic hashtables kernel math namespaces vectors sequences math.vectors ; IN: ui.gadgets.borders -TUPLE: border size ; +TUPLE: border size fill ; : ( child gap -- border ) - border construct-gadget - [ >r dup 2array r> set-border-size ] keep - [ add-gadget ] keep ; - -: layout-border-loc ( border -- ) - dup rect-dim swap gadget-child - [ pref-dim v- 2 v/n [ >fixnum ] map ] keep set-rect-loc ; + dup 2array { 0 0 } border construct-boa + over set-delegate + tuck add-gadget ; M: border pref-dim* [ border-size 2 v*n ] keep gadget-child pref-dim v+ ; +: border-major-rect ( border -- rect ) + dup border-size swap rect-dim over 2 v*n v- ; + +: border-minor-rect ( major border -- rect ) + gadget-child pref-dim + [ >r rect-bounds r> v- 2 v/n v+ ] keep ; + +: scale-rect ( rect vec -- loc dim ) + [ v* ] curry >r rect-bounds r> 2apply ; + +: average-rects ( rect1 rect2 weight -- rect ) + tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect + swapd v+ >r v+ r> ; + +: border-child-rect ( border -- rect ) + dup border-major-rect + dup pick border-minor-rect + rot border-fill + average-rects ; + M: border layout* - dup layout-border-loc gadget-child prefer ; + dup border-child-rect swap gadget-child + over rect-loc over set-rect-loc + swap rect-dim swap set-layout-dim ; M: border focusable-child* gadget-child ; diff --git a/extra/ui/gadgets/buttons/buttons-docs.factor b/extra/ui/gadgets/buttons/buttons-docs.factor index d791e7e192..d398255bc4 100644 --- a/extra/ui/gadgets/buttons/buttons-docs.factor +++ b/extra/ui/gadgets/buttons/buttons-docs.factor @@ -7,11 +7,7 @@ HELP: button $nl "A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "." $nl -"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link } " word to construct a row of buttons for choosing among several alternatives." } ; - -HELP: >label -{ $values { "obj" "a label specifier" } { "gadget" "a new " { $link gadget } } } -{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ; +"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link } " word to construct a row of buttons for choosing among several alternatives." } ; HELP: