diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index b5835de5fd..0875967bd2 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -1,24 +1,42 @@ USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic -definitions arrays words assocs eval ; +definitions arrays words assocs eval strings ; IN: compiler.tests -GENERIC: method-redefine-test ( a -- b ) +GENERIC: method-redefine-generic-1 ( a -- b ) -M: integer method-redefine-test 3 + ; +M: integer method-redefine-generic-1 3 + ; -: method-redefine-test-1 ( -- b ) 3 method-redefine-test ; +: method-redefine-test-1 ( -- b ) 3 method-redefine-generic-1 ; [ 6 ] [ method-redefine-test-1 ] unit-test -[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test +[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test -[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test +[ ] [ [ fixnum \ method-redefine-generic-1 method forget ] with-compilation-unit ] unit-test [ 6 ] [ method-redefine-test-1 ] unit-test +GENERIC: method-redefine-generic-2 ( a -- b ) + +M: integer method-redefine-generic-2 3 + ; + +: method-redefine-test-2 ( -- b ) 3 method-redefine-generic-2 ; + +[ 6 ] [ method-redefine-test-2 ] unit-test + +[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test + +[ 7 ] [ method-redefine-test-2 ] unit-test + +[ ] [ + [ + fixnum string [ \ method-redefine-generic-2 method forget ] bi@ + ] with-compilation-unit +] unit-test + ! Test ripple-up behavior : hey ( -- ) ; : there ( -- ) hey ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index b2388c30d2..953956c3bd 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -17,8 +17,10 @@ IN: compiler.tree.propagation.inlining ! we are more eager to inline SYMBOL: node-count -: count-nodes ( nodes -- ) - 0 swap [ drop 1+ ] each-node node-count set ; +: count-nodes ( nodes -- n ) + 0 swap [ drop 1+ ] each-node ; + +: compute-node-count ( nodes -- ) count-nodes node-count set ; ! We try not to inline the same word too many times, to avoid ! combinatorial explosion @@ -33,9 +35,6 @@ M: word splicing-nodes M: callable splicing-nodes build-sub-tree analyze-recursive normalize ; -: propagate-body ( #call -- ) - body>> (propagate) ; - ! Dispatch elimination : eliminate-dispatch ( #call class/f word/quot/f -- ? ) dup [ @@ -44,7 +43,7 @@ M: callable splicing-nodes 2dup splicing-nodes [ >>method ] [ >>body ] bi* ] if - propagate-body t + body>> (propagate) t ] [ 2drop f >>method f >>body f >>class drop f ] if ; : inlining-standard-method ( #call word -- class/f method/f ) @@ -161,10 +160,10 @@ SYMBOL: history : inline-word-def ( #call word quot -- ? ) over history get memq? [ 3drop f ] [ [ - swap remember-inlining - dupd splicing-nodes >>body - propagate-body - ] with-scope + [ remember-inlining ] dip + [ drop ] [ splicing-nodes ] 2bi + [ >>body drop ] [ count-nodes ] [ (propagate) ] tri + ] with-scope node-count +@ t ] if ; diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index 2a9825e3f1..3dd2c4998a 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -20,5 +20,5 @@ IN: compiler.tree.propagation H{ } clone 1array value-infos set H{ } clone 1array constraints set H{ } clone inlining-count set - dup count-nodes + dup compute-node-count dup (propagate) ; diff --git a/extra/rewrite-closures/tags.txt b/basis/constructors/tags.txt similarity index 100% rename from extra/rewrite-closures/tags.txt rename to basis/constructors/tags.txt diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 5a2f4802e9..9456941880 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -1,4 +1,4 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup delegate.private ; IN: delegate HELP: define-protocol @@ -8,7 +8,7 @@ HELP: define-protocol HELP: PROTOCOL: { $syntax "PROTOCOL: protocol-name words... ;" } -{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ; +{ $description "Defines an explicit protocol, which can be used as a basis for delegation." } ; { define-protocol POSTPONE: PROTOCOL: } related-words @@ -22,6 +22,12 @@ HELP: CONSULT: { $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } } { $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ; +HELP: SLOT-PROTOCOL: +{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" } +{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ; + +{ define-protocol POSTPONE: PROTOCOL: } related-words + { define-consult POSTPONE: CONSULT: } related-words HELP: group-words @@ -40,6 +46,8 @@ $nl "Defining new protocols:" { $subsection POSTPONE: PROTOCOL: } { $subsection define-protocol } +"Defining new protocols consisting of slot accessors:" +{ $subsection POSTPONE: SLOT-PROTOCOL: } "Defining consultation:" { $subsection POSTPONE: CONSULT: } { $subsection define-consult } diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index ff55fb1282..e2bea82e68 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,6 +1,7 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string -accessors eval multiline ; +accessors eval multiline generic.standard delegate.protocols +delegate.private assocs ; IN: delegate.tests TUPLE: hello this that ; @@ -35,7 +36,7 @@ M: hello bing hello-test ; [ 3 ] [ 1 0 f 2 whoa ] unit-test [ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test -[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test +[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test @@ -112,6 +113,7 @@ PROTOCOL: silly-protocol do-me ; [ ] [ T{ a-tuple } do-me ] unit-test +! Change method definition to consultation [ [ ] ] [ <" IN: delegate.tests USE: kernel @@ -119,8 +121,17 @@ PROTOCOL: silly-protocol do-me ; CONSULT: silly-protocol a-tuple drop f ; "> "delegate-test" parse-stream ] unit-test +! Method should be there [ ] [ T{ a-tuple } do-me ] unit-test +! Now try removing the consulation +[ [ ] ] [ + <" IN: delegate.tests "> "delegate-test" parse-stream +] unit-test + +! Method should be gone +[ T{ a-tuple } do-me ] [ no-method? ] must-fail-with + ! A slot protocol issue DEFER: slot-protocol-test-3 SLOT: y @@ -155,4 +166,34 @@ TUPLE: slot-protocol-test-3 x y ;"> CONSULT: sequence-protocol override-method-test seq>> ; M: override-method-test like drop ; "> "delegate-test-2" parse-stream +] unit-test + +DEFER: seq-delegate + +! See if removing a consultation updates protocol-consult word prop +[ [ ] ] [ + <" IN: delegate.tests + USING: accessors delegate delegate.protocols ; + TUPLE: seq-delegate seq ; + CONSULT: sequence-protocol seq-delegate seq>> ;"> + "remove-consult-test" parse-stream +] unit-test + +[ t ] [ + seq-delegate + sequence-protocol \ protocol-consult word-prop + key? +] unit-test + +[ [ ] ] [ + <" IN: delegate.tests + USING: delegate delegate.protocols ; + TUPLE: seq-delegate seq ;"> + "remove-consult-test" parse-stream +] unit-test + +[ f ] [ + seq-delegate + sequence-protocol \ protocol-consult word-prop + key? ] unit-test \ No newline at end of file diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index a4eef54907..0c16b7c336 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -2,10 +2,13 @@ ! Portions copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes.tuple definitions generic -generic.standard hashtables kernel lexer make math parser -generic.parser sequences sets slots words words.symbol fry ; +generic.standard hashtables kernel lexer math parser +generic.parser sequences sets slots words words.symbol fry +compiler.units ; IN: delegate + ( group class quot -- consultation ) + f consultation boa ; + +: create-consult-method ( word consultation -- method ) + [ class>> swap first create-method dup fake-definition ] keep + [ drop ] [ "consultation" set-word-prop ] 2bi ; + +PREDICATE: consult-method < method-body "consultation" word-prop ; + +M: consult-method reset-word + [ call-next-method ] [ f "consultation" set-word-prop ] bi ; + +: consult-method-quot ( quot word -- object ) + [ second [ [ dip ] curry ] times ] [ first ] bi + '[ _ call _ execute ] ; + +: consult-method ( word consultation -- ) + [ create-consult-method ] + [ quot>> swap consult-method-quot ] 2bi define ; : change-word-prop ( word prop quot -- ) [ swap props>> ] dip change-at ; inline -: register-protocol ( group class quot -- ) - [ \ protocol-consult ] 2dip - '[ [ _ _ swap ] dip ?set-at ] change-word-prop ; +: each-generic ( consultation quot -- ) + [ [ group>> group-words ] keep ] dip curry each ; inline -: define-consult ( group class quot -- ) - [ register-protocol ] - [ [ group-words ] 2dip '[ _ _ consult-method ] each ] - 3bi ; +: register-consult ( consultation -- ) + [ group>> \ protocol-consult ] [ ] [ class>> ] tri + '[ [ _ _ ] dip ?set-at ] change-word-prop ; + +: consult-methods ( consultation -- ) + [ consult-method ] each-generic ; + +: unregister-consult ( consultation -- ) + [ class>> ] [ group>> ] bi + \ protocol-consult word-prop delete-at ; + +: unconsult-method ( word consultation -- ) + [ class>> swap first method ] keep + over [ + over "consultation" word-prop eq? + [ forget ] [ drop ] if + ] [ 2drop ] if ; + +: unconsult-methods ( consultation -- ) + [ unconsult-method ] each-generic ; + +PRIVATE> + +: define-consult ( consultation -- ) + [ register-consult ] [ consult-methods ] bi ; : CONSULT: - scan-word scan-word parse-definition define-consult ; parsing + scan-word scan-word parse-definition + [ save-location ] [ define-consult ] bi ; parsing + +M: consultation where loc>> ; + +M: consultation set-where (>>loc) ; + +M: consultation forget* + [ unconsult-methods ] [ unregister-consult ] bi ; ! Protocols +alist ] [ added-words ] 2bi - [ swap first2 consult-method ] cross-2each ; + [ drop protocol-consult values ] [ added-words ] 2bi + [ swap consult-method ] cross-2each ; : initialize-protocol-props ( protocol wordlist -- ) [ @@ -81,6 +131,11 @@ M: tuple-class group-words : fill-in-depth ( wordlist -- wordlist' ) [ dup word? [ 0 2array ] when ] map ; +: show-words ( wordlist' -- wordlist ) + [ dup second zero? [ first ] when ] map ; + +PRIVATE> + : define-protocol ( protocol wordlist -- ) [ drop define-symbol ] [ fill-in-depth @@ -97,8 +152,6 @@ PREDICATE: protocol < word protocol-words ; ! Subclass of symbol? M: protocol forget* [ f forget-old-definitions ] [ call-next-method ] bi ; -: show-words ( wordlist' -- wordlist ) - [ dup second zero? [ first ] when ] map ; M: protocol definition protocol-words show-words ; diff --git a/unmaintained/bitfields/tags.txt b/basis/delegate/tags.txt similarity index 100% rename from unmaintained/bitfields/tags.txt rename to basis/delegate/tags.txt diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 4b2906db95..e08a7487ae 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -42,7 +42,7 @@ MACRO: all-enabled ( seq quot -- ) [ words>values ] dip '[ _ _ (all-enabled) ] ; MACRO: all-enabled-client-state ( seq quot -- ) - [ words>values ] dip '[ _ (all-enabled-client-state) ] ; + [ words>values ] dip '[ _ _ (all-enabled-client-state) ] ; : do-matrix ( mode quot -- ) swap [ glMatrixMode glPushMatrix call ] keep diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index 3550424b83..7896cabd2e 100644 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -288,7 +288,7 @@ M: vocab-tag article-name name>> ; M: vocab-tag article-content \ $tagged-vocabs swap name>> 2array ; -M: vocab-tag article-parent drop "vocab-index" ; +M: vocab-tag article-parent drop "vocab-tags" ; M: vocab-tag summary article-title ; @@ -302,6 +302,6 @@ M: vocab-author article-name name>> ; M: vocab-author article-content \ $authored-vocabs swap name>> 2array ; -M: vocab-author article-parent drop "vocab-index" ; +M: vocab-author article-parent drop "vocab-authors" ; M: vocab-author summary article-title ; diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor index 1c36f4f9fd..710a9fb492 100644 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ui.backend ui.gadgets -ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces -classes.tuple colors accessors ; +USING: ui.backend ui.gadgets ui.gadgets.worlds ui.pens.solid opengl +opengl.gl kernel namespaces classes.tuple colors colors.constants +accessors ; IN: ui.gadgets.canvas TUPLE: canvas < gadget dlist ; : new-canvas ( class -- canvas ) - new black >>interior ; inline + new COLOR: black >>interior ; inline : delete-canvas-dlist ( canvas -- ) [ find-gl-context ] @@ -23,8 +23,6 @@ TUPLE: canvas < gadget dlist ; [ 2nip ] [ drop make-canvas-dlist ] if ; inline : draw-canvas ( canvas quot -- ) - origin get [ - cache-canvas-dlist glCallList - ] with-translation ; inline + cache-canvas-dlist glCallList ; inline M: canvas ungraft* delete-canvas-dlist ; diff --git a/basis/ui/pens/polygon/polygon-docs.factor b/basis/ui/pens/polygon/polygon-docs.factor index 706c1449a6..dfe687f398 100644 --- a/basis/ui/pens/polygon/polygon-docs.factor +++ b/basis/ui/pens/polygon/polygon-docs.factor @@ -1,5 +1,5 @@ +USING: colors help.markup help.syntax ui.pens ; IN: ui.pens.polygon -USING: help.markup help.syntax ; HELP: polygon { $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:" diff --git a/basis/ui/pens/polygon/polygon.factor b/basis/ui/pens/polygon/polygon.factor index 4fc05c468b..4d7793dd65 100644 --- a/basis/ui/pens/polygon/polygon.factor +++ b/basis/ui/pens/polygon/polygon.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ; +USING: accessors colors help.markup help.syntax kernel opengl +opengl.gl sequences specialized-arrays.float ui.pens ; IN: ui.pens.polygon ! Polygon pen diff --git a/unmaintained/fs/tags.txt b/basis/ui/text/pango/tags.txt similarity index 100% rename from unmaintained/fs/tags.txt rename to basis/ui/text/pango/tags.txt diff --git a/basis/ui/windows/summary.txt b/basis/ui/windows/summary.txt deleted file mode 100644 index 9a0a894850..0000000000 --- a/basis/ui/windows/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Windows UI backend diff --git a/basis/ui/x11/summary.txt b/basis/ui/x11/summary.txt deleted file mode 100644 index 046c83ad89..0000000000 --- a/basis/ui/x11/summary.txt +++ /dev/null @@ -1 +0,0 @@ -X11 UI backend diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor deleted file mode 100755 index 2a622a6985..0000000000 --- a/basis/ui/x11/x11.factor +++ /dev/null @@ -1,297 +0,0 @@ -! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types arrays ui ui.gadgets -ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render -ui.event-loop assocs kernel math namespaces opengl sequences -strings x11.xlib x11.events x11.xim x11.glx x11.clipboard -x11.constants x11.windows io.encodings.string io.encodings.ascii -io.encodings.utf8 combinators combinators.short-circuit command-line -math.vectors classes.tuple opengl.gl threads math.geometry.rect -environment ascii ; -IN: ui.x11 - -SINGLETON: x11-ui-backend - -: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ; - -TUPLE: x11-handle-base glx ; -TUPLE: x11-handle < x11-handle-base xic window ; -TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ; - -C: x11-handle -C: x11-pixmap-handle - -M: world expose-event nip relayout ; - -M: world configure-event - over configured-loc >>window-loc - swap configured-dim >>dim - ! In case dimensions didn't change - relayout-1 ; - -CONSTANT: modifiers - { - { S+ HEX: 1 } - { C+ HEX: 4 } - { A+ HEX: 8 } - } - -CONSTANT: key-codes - H{ - { HEX: FF08 "BACKSPACE" } - { HEX: FF09 "TAB" } - { HEX: FF0D "RET" } - { HEX: FF8D "ENTER" } - { HEX: FF1B "ESC" } - { HEX: FFFF "DELETE" } - { HEX: FF50 "HOME" } - { HEX: FF51 "LEFT" } - { HEX: FF52 "UP" } - { HEX: FF53 "RIGHT" } - { HEX: FF54 "DOWN" } - { HEX: FF55 "PAGE_UP" } - { HEX: FF56 "PAGE_DOWN" } - { HEX: FF57 "END" } - { HEX: FF58 "BEGIN" } - { HEX: FFBE "F1" } - { HEX: FFBF "F2" } - { HEX: FFC0 "F3" } - { HEX: FFC1 "F4" } - { HEX: FFC2 "F5" } - { HEX: FFC3 "F6" } - { HEX: FFC4 "F7" } - { HEX: FFC5 "F8" } - { HEX: FFC6 "F9" } - } - -: key-code ( keysym -- keycode action? ) - dup key-codes at [ t ] [ 1string f ] ?if ; - -: event-modifiers ( event -- seq ) - XKeyEvent-state modifiers modifier ; - -: valid-input? ( string gesture -- ? ) - over empty? [ 2drop f ] [ - mods>> { f { S+ } } member? [ - [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all? - ] [ - [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all? - ] if - ] if ; - -: key-down-event>gesture ( event world -- string gesture ) - dupd - handle>> xic>> lookup-string - [ swap event-modifiers ] dip key-code ; - -M: world key-down-event - [ key-down-event>gesture ] keep - [ propagate-key-gesture drop ] - [ 2over valid-input? [ nip user-input ] [ 3drop ] if ] - 3bi ; - -: key-up-event>gesture ( event -- gesture ) - dup event-modifiers swap 0 XLookupKeysym key-code ; - -M: world key-up-event - [ key-up-event>gesture ] dip propagate-key-gesture ; - -: mouse-event>gesture ( event -- modifiers button loc ) - [ event-modifiers ] - [ XButtonEvent-button ] - [ mouse-event-loc ] - tri ; - -M: world button-down-event - [ mouse-event>gesture [ ] dip ] dip - send-button-down ; - -M: world button-up-event - [ mouse-event>gesture [ ] dip ] dip - send-button-up ; - -: mouse-event>scroll-direction ( event -- pair ) - XButtonEvent-button { - { 4 { 0 -1 } } - { 5 { 0 1 } } - { 6 { -1 0 } } - { 7 { 1 0 } } - } at ; - -M: world wheel-event - [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip - send-wheel ; - -M: world enter-event motion-event ; - -M: world leave-event 2drop forget-rollover ; - -M: world motion-event - [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip - move-hand fire-motion ; - -M: world focus-in-event - nip - dup handle>> xic>> XSetICFocus focus-world ; - -M: world focus-out-event - nip - dup handle>> xic>> XUnsetICFocus unfocus-world ; - -M: world selection-notify-event - [ handle>> window>> selection-from-event ] keep - user-input ; - -: supported-type? ( atom -- ? ) - { "UTF8_STRING" "STRING" "TEXT" } - [ x-atom = ] with any? ; - -: clipboard-for-atom ( atom -- clipboard ) - { - { XA_PRIMARY [ selection get ] } - { XA_CLIPBOARD [ clipboard get ] } - [ drop ] - } case ; - -: encode-clipboard ( string type -- bytes ) - XSelectionRequestEvent-target - XA_UTF8_STRING = utf8 ascii ? encode ; - -: set-selection-prop ( evt -- ) - dpy get swap - [ XSelectionRequestEvent-requestor ] keep - [ XSelectionRequestEvent-property ] keep - [ XSelectionRequestEvent-target ] keep - [ 8 PropModeReplace ] dip - [ - XSelectionRequestEvent-selection - clipboard-for-atom contents>> - ] keep encode-clipboard dup length XChangeProperty drop ; - -M: world selection-request-event - drop dup XSelectionRequestEvent-target { - { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] } - { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] } - { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] } - [ drop send-notify-failure ] - } cond ; - -M: x11-ui-backend (close-window) ( handle -- ) - dup xic>> XDestroyIC - dup glx>> destroy-glx - window>> dup unregister-window - destroy-window ; - -M: world client-event - swap close-box? [ ungraft ] [ drop ] if ; - -: gadget-window ( world -- ) - dup window-loc>> over rect-dim glx-window - over "Factor" create-xic rot - 2dup window>> register-window - >>handle drop ; - -: wait-event ( -- event ) - QueuedAfterFlush events-queued 0 > [ - next-event dup - None XFilterEvent zero? [ drop wait-event ] unless - ] [ - ui-wait wait-event - ] if ; - -M: x11-ui-backend do-events - wait-event dup XAnyEvent-window window dup - [ handle-event ] [ 2drop ] if ; - -: x-clipboard@ ( gadget clipboard -- prop win ) - atom>> swap - find-world handle>> window>> ; - -M: x-clipboard copy-clipboard - [ x-clipboard@ own-selection ] keep - (>>contents) ; - -M: x-clipboard paste-clipboard - [ find-world handle>> window>> ] dip atom>> convert-selection ; - -: init-clipboard ( -- ) - XA_PRIMARY selection set-global - XA_CLIPBOARD clipboard set-global ; - -: set-title-old ( dpy window string -- ) - dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ; - -: set-title-new ( dpy window string -- ) - [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip - utf8 encode dup length XChangeProperty drop ; - -M: x11-ui-backend set-title ( string world -- ) - handle>> window>> swap - [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; - -M: x11-ui-backend set-fullscreen* ( ? world -- ) - handle>> window>> "XClientMessageEvent" - tuck set-XClientMessageEvent-window - swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? - over set-XClientMessageEvent-data0 - ClientMessage over set-XClientMessageEvent-type - dpy get over set-XClientMessageEvent-display - "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type - 32 over set-XClientMessageEvent-format - "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1 - [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ; - -M: x11-ui-backend (open-window) ( world -- ) - dup gadget-window - handle>> window>> dup set-closable map-window ; - -M: x11-ui-backend raise-window* ( world -- ) - handle>> [ - dpy get swap window>> XRaiseWindow drop - ] when* ; - -M: x11-handle select-gl-context ( handle -- ) - dpy get swap - [ window>> ] [ glx>> ] bi glXMakeCurrent - [ "Failed to set current GLX context" throw ] unless ; - -M: x11-handle flush-gl-context ( handle -- ) - dpy get swap window>> glXSwapBuffers ; - -M: x11-pixmap-handle select-gl-context ( handle -- ) - dpy get swap - [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent - [ "Failed to set current GLX context" throw ] unless ; - -M: x11-pixmap-handle flush-gl-context ( handle -- ) - drop ; - -M: x11-ui-backend (open-offscreen-buffer) ( world -- ) - dup dim>> glx-pixmap >>handle drop ; -M: x11-ui-backend (close-offscreen-buffer) ( handle -- ) - dpy get swap - [ glx-pixmap>> glXDestroyGLXPixmap ] - [ pixmap>> XFreePixmap drop ] - [ glx>> glXDestroyContext ] 2tri ; - -M: x11-ui-backend offscreen-pixels ( world -- alien w h ) - [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ; - -M: x11-ui-backend ui ( -- ) - [ - f [ - [ - init-clipboard - start-ui - event-loop - ] with-xim - ] with-x - ] ui-running ; - -M: x11-ui-backend beep ( -- ) - dpy get 100 XBell drop ; - -x11-ui-backend ui-backend set-global - -[ "DISPLAY" os-env "ui" "listener" ? ] -main-vocab-hook set-global diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 0577f8b83c..178e29fd93 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -23,6 +23,9 @@ TUPLE: redefine-error def ; : remember-definition ( definition loc -- ) new-definitions get first (remember-definition) ; +: fake-definition ( definition -- ) + old-definitions get [ delete-at ] with each ; + : remember-class ( class loc -- ) [ dup new-definitions get first key? [ dup redefine-error ] when ] dip new-definitions get second (remember-definition) ; @@ -72,14 +75,12 @@ SYMBOL: outdated-tuples SYMBOL: update-tuples-hook SYMBOL: remake-generics-hook +: index>= ( obj1 obj2 seq -- ? ) + [ index ] curry bi@ >= ; + : dependency>= ( how1 how2 -- ? ) - [ - { - called-dependency - flushed-dependency - inlined-dependency - } index - ] bi@ >= ; + { called-dependency flushed-dependency inlined-dependency } + index>= ; : strongest-dependency ( how1 how2 -- how ) [ called-dependency or ] bi@ [ dependency>= ] most ; diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 726116909f..db99d7e3a3 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -9,13 +9,9 @@ SYMBOL: inlined-dependency SYMBOL: flushed-dependency SYMBOL: called-dependency - - SYMBOL: changed-definitions : changed-definition ( defspec -- ) @@ -23,14 +19,8 @@ SYMBOL: changed-definitions SYMBOL: changed-generics -: changed-generic ( class generic -- ) - changed-generics get set-in-unit ; - SYMBOL: remake-generics -: remake-generic ( generic -- ) - dup remake-generics get set-in-unit ; - SYMBOL: new-classes : new-class ( word -- ) @@ -52,11 +42,9 @@ M: object forget* drop ; SYMBOL: forgotten-definitions : forgotten-definition ( defspec -- ) - dup forgotten-definitions get - [ no-compilation-unit ] unless* - set-at ; + dup forgotten-definitions get set-in-unit ; -: forget ( defspec -- ) dup forgotten-definition forget* ; +: forget ( defspec -- ) [ forgotten-definition ] [ forget* ] bi ; : forget-all ( definitions -- ) [ forget ] each ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index c520b4aaac..351a8f98fd 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -71,6 +71,13 @@ TUPLE: check-method class generic ; \ check-method boa throw ] unless ; inline +: changed-generic ( class generic -- ) + changed-generics get + [ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ; + +: remake-generic ( generic -- ) + dup remake-generics get set-in-unit ; + : with-methods ( class generic quot -- ) [ drop changed-generic ] [ [ "methods" word-prop ] dip call ] @@ -113,7 +120,7 @@ M: method-body crossref? 2bi ; : create-method ( class generic -- method ) - 2dup method dup [ 2nip ] [ + 2dup method dup [ 2nip dup reset-generic ] [ drop [ dup ] 2keep reveal-method diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 9284f8949b..5ec9ea9b3c 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -557,6 +557,9 @@ EXCLUDE: qualified.tests.bar => x ; [ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ] [ error>> no-word-error? ] must-fail-with +! Two similar bugs + +! Replace : def with something in << >> [ [ ] ] [ "IN: parser.tests : was-once-a-word-bug ( -- ) ;" "was-once-a-word-test" parse-stream @@ -570,3 +573,20 @@ EXCLUDE: qualified.tests.bar => x ; ] unit-test [ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test + +! Replace : def with DEFER: +[ [ ] ] [ + "IN: parser.tests : is-not-deferred ( -- ) ;" + "is-not-deferred" parse-stream +] unit-test + +[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test +[ f ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test + +[ [ ] ] [ + "IN: parser.tests DEFER: is-not-deferred" + "is-not-deferred" parse-stream +] unit-test + +[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test +[ t ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 9e578120f4..ac1c2695f2 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -5,7 +5,7 @@ sequences strings vectors words words.symbol quotations io combinators sorting splitting math.parser effects continuations io.files vocabs io.encodings.utf8 source-files classes hashtables compiler.errors compiler.units accessors sets -lexer vocabs.parser ; +lexer vocabs.parser slots ; IN: parser : location ( -- loc ) @@ -223,8 +223,8 @@ print-use-hook [ [ ] ] initialize swap assoc-diff keys [ { { [ dup where dup [ first ] when file get path>> = not ] [ f ] } - { [ dup "reading" word-prop ] [ f ] } - { [ dup "writing" word-prop ] [ f ] } + { [ dup reader-method? ] [ f ] } + { [ dup writer-method? ] [ f ] } [ t ] } cond nip ] filter ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index ea020c5c55..71c2bdcc90 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -10,8 +10,12 @@ TUPLE: slot-spec name offset class initial read-only ; PREDICATE: reader < word "reader" word-prop ; +PREDICATE: reader-method < method-body "reading" word-prop ; + PREDICATE: writer < word "writer" word-prop ; +PREDICATE: writer-method < method-body "writing" word-prop ; + : ( -- slot-spec ) slot-spec new object bootstrap-word >>class ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 8ee8b27fbc..de3be98ceb 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -135,8 +135,7 @@ IN: bootstrap.syntax "DEFER:" [ scan current-vocab create - dup old-definitions get [ delete-at ] with each - set-word + [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri ] define-syntax ":" [ diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor index 91c1c94b35..d761eaf473 100755 --- a/extra/4DNav/4DNav.factor +++ b/extra/4DNav/4DNav.factor @@ -13,6 +13,7 @@ sequences combinators continuations colors +colors.constants prettyprint vars quotations @@ -28,23 +29,19 @@ ui.gadgets.panes ui.gadgets.borders ui.gadgets.handler ui.gadgets.slate - ui.gadgets.theme ui.gadgets.frames ui.gadgets.tracks ui.gadgets.labels - ui.gadgets.labelled + ui.gadgets.labeled ui.gadgets.lists ui.gadgets.buttons ui.gadgets.packs ui.gadgets.grids ui.gestures - ui.tools.workspace ui.gadgets.scrollers splitting vectors math.vectors -rewrite-closures -self values 4DNav.turtle 4DNav.window3D @@ -55,6 +52,8 @@ fry adsoda adsoda.tools ; +QUALIFIED-WITH: ui.pens.solid s + IN: 4DNav VALUE: selected-file @@ -74,10 +73,13 @@ VAR: present-space ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! replacement of namespaces.lib +! namespace utilities : make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ; +: closed-quot ( quot -- quot ) + namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! waiting for deep-cleave-quots @@ -131,11 +133,11 @@ VAR: present-space : model-projection-chooser ( -- gadget ) observer3d> projection-mode>> { { 1 "perspective" } { 0 "orthogonal" } } - ; + ; : collision-detection-chooser ( -- gadget ) observer3d> collision-mode>> - { { t "on" } { f "off" } } ; + { { t "on" } { f "off" } } ; : model-projection ( x -- space ) present-space> swap space-project ; @@ -184,8 +186,11 @@ VAR: present-space ! menu ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +USE: ui.gadgets.labeled.private + : menu-rotations-4D ( -- gadget ) - + 3 3 + { 1 1 } >>filled-cell 1 >>fill "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget @@ -225,7 +230,8 @@ VAR: present-space ; : menu-translations-4D ( -- gadget ) - + 3 3 + { 1 1 } >>filled-cell 1 >>fill 1 >>fill "X+" [ drop { 1 0 0 0 } translation-step v*n @@ -325,12 +331,13 @@ VAR: present-space [ ".xml" tail? ] filter [ append-path ] with map [ add-gadget ] each - swap ; + swap ; ! ----------------------------------------------------- : menu-rotations-3D ( -- gadget ) - + 3 3 + { 1 1 } >>filled-cell "Turn\n left" [ rotation-step turn-left ] camera-button @left grid-add "Turn\n right" [ rotation-step turn-right ] @@ -348,7 +355,8 @@ VAR: present-space ; : menu-translations-3D ( -- gadget ) - + 3 3 + { 1 1 } >>filled-cell "left\n(alt)" [ translation-step strafe-left ] camera-button @left grid-add "right\n(alt)" [ translation-step strafe-right ] @@ -477,8 +485,7 @@ M: space adsoda-display-model { 0 1 } menu-bar f track-add - - { 200 400 } >>max-dim + f track-add "Projection mode : "