steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Aaron Schaefer 2008-11-21 02:56:16 -05:00
parent 4828ab1a4b 79bffecc2e
commit 2234c50a0f
28 changed files with 347 additions and 233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -138,6 +138,12 @@ most-negative-fixnum most-positive-fixnum [a,b]
\ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
\ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
{ /mod fixnum/mod } [
\ /i \ mod
[ "outputs" word-prop ] bi@
'[ _ _ 2bi ] "outputs" set-word-prop
] each
\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op

9
basis/help/help-docs.factor
View File

@ -129,12 +129,17 @@ HELP: $title
{ $values { "topic" "a help article name or a word" } }
{ $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ;
HELP: print-topic
{ $values { "topic" "an article name or a word" } }
{ $description
"Displays a help topic on " { $link output-stream } "."
} ;
HELP: help
{ $values { "topic" "an article name or a word" } }
{ $description
"Displays a help article or documentation associated to a word on " { $link output-stream } "."
"Displays a help topic."
} ;
HELP: about
{ $values { "vocab" "a vocabulary specifier" } }
{ $description

9
basis/help/help.factor
View File

@ -89,10 +89,17 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
] with-nesting
] with-style nl ;
: help ( topic -- )
: print-topic ( topic -- )
last-element off dup $title
article-content print-content nl ;
SYMBOL: help-hook
help-hook global [ [ print-topic ] or ] change-at
: help ( topic -- )
help-hook get call ;
: about ( vocab -- )
dup require
dup vocab [ ] [

25
basis/listener/listener-docs.factor
View File

@ -1,34 +1,39 @@
USING: help.markup help.syntax kernel io system prettyprint ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
{ $subsection visible-vars }
"To add or remove a single variable:"
{ $subsection show-var }
{ $subsection hide-var }
"To add and remove multiple variables:"
{ $subsection show-vars }
{ $subsection hide-vars } ;
ARTICLE: "listener" "The listener"
"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
$nl
"The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" }
"Multi-line phrases are supported:"
"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
$nl
"A very common operation is to inspect the contents of the data stack in the listener:"
{ $subsection .s }
"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "."
$nl
{ $subsection "listener-watch" }
"You can start a nested listener or exit a listener using the following words:"
{ $subsection listener }
{ $subsection bye }
"The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:"
{ $subsection listener-hook }
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
{ $subsection read-quot } ;
ABOUT: "listener"
<PRIVATE
HELP: quit-flag
{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
HELP: listener-hook
{ $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ;
PRIVATE>
HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }

59
basis/listener/listener.factor
View File

@ -3,16 +3,10 @@
USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors ;
definitions compiler.units accessors colors prettyprint fry
sets ;
IN: listener
SYMBOL: quit-flag
SYMBOL: listener-hook
[ ] listener-hook set-global
GENERIC: stream-read-quot ( stream -- quot/f )
: parse-lines-interactive ( lines -- quot/f )
@ -38,18 +32,57 @@ M: object stream-read-quot
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
<PRIVATE
SYMBOL: quit-flag
PRIVATE>
: bye ( -- ) quit-flag on ;
: prompt. ( -- )
"( " in get " )" 3append
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
SYMBOL: visible-vars
: show-var ( sym -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
: hide-var ( sym -- ) visible-vars [ remove ] change ;
: hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global
<PRIVATE
: title. ( string -- )
H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
: visible-vars. ( -- )
visible-vars get [
nl "--- Watched variables:" title.
standard-table-style [
[
[
[ [ short. ] with-cell ]
[ [ get short. ] with-cell ]
bi
] with-row
] each
] tabular-output
] unless-empty ;
: stacks. ( -- )
datastack [ nl "--- Data stack:" title. stack. ] unless-empty
retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ;
: prompt. ( -- )
"( " in get auto-use? get [ " - auto" append ] when " )" 3append
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
: listen ( -- )
listener-hook get call prompt.
visible-vars. stacks. prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
dup lexer-error? [
@ -62,6 +95,8 @@ SYMBOL: error-hook
: until-quit ( -- )
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
PRIVATE>
: listener ( -- )
[ until-quit ] with-interactive-vocabs ;

3
basis/prettyprint/prettyprint-docs.factor
View File

@ -17,7 +17,8 @@ ARTICLE: "prettyprint-stacks" "Prettyprinting stacks"
"Prettyprinting any stack:"
{ $subsection stack. }
"Prettyprinting any call stack:"
{ $subsection callstack. } ;
{ $subsection callstack. }
"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." ;
ARTICLE: "prettyprint-variables" "Prettyprint control variables"
"The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:"

3
basis/tools/deploy/shaker/shaker.factor
View File

@ -266,8 +266,7 @@ IN: tools.deploy.shaker
layouts:tag-numbers
layouts:type-numbers
lexer-factory
listener:listener-hook
parser:print-use-hook
print-use-hook
root-cache
vocab-roots
vocabs:dictionary

34
basis/ui/gadgets/buttons/buttons.factor
View File

@ -2,10 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences
strings quotations assocs combinators classes colors
classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect locals alien.c-types ;
classes.tuple locals alien.c-types fry opengl opengl.gl
math.vectors ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render
math.geometry.rect ;
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
@ -27,7 +28,7 @@ TUPLE: button < border pressed? selected? quot ;
relayout-1 ;
: if-clicked ( button quot -- )
>r dup button-update dup button-rollover? r> [ drop ] if ;
[ dup button-update dup button-rollover? ] dip [ drop ] if ;
: button-clicked ( button -- ) dup quot>> if-clicked ;
@ -219,9 +220,8 @@ M: radio-control model-changed
over value>> = >>selected?
relayout-1 ;
: <radio-controls> ( parent model assoc quot -- parent )
#! quot has stack effect ( value model label -- )
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
'[ _ swap _ call add-gadget ] assoc-each ; inline
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
@ -232,8 +232,7 @@ M: radio-control model-changed
: <radio-buttons> ( model assoc -- gadget )
<filled-pile>
-rot
[ <radio-button> ] <radio-controls>
spin [ <radio-button> ] <radio-controls>
{ 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget )
@ -241,20 +240,19 @@ M: radio-control model-changed
: <toggle-buttons> ( model assoc -- gadget )
<shelf>
-rot
[ <toggle-button> ] <radio-controls> ;
spin [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ;
'[ _ _ invoke-command drop ] ;
: <command-button> ( target gesture command -- button )
[ command-string ] keep
swapd
command-button-quot
<bevel-button> ;
[ command-string swap ] keep command-button-quot <bevel-button> ;
: <toolbar> ( target -- toolbar )
<shelf>
swap
"toolbar" over class command-map commands>> swap
[ -rot <command-button> add-gadget ] curry assoc-each ;
'[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ;
: add-toolbar ( track -- track )
dup <toolbar> f track-add ;

100
basis/ui/gadgets/editors/editors.factor
View File

@ -2,17 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents io kernel math models
namespaces make opengl opengl.gl sequences strings io.styles
math.vectors sorting colors combinators assocs math.order
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
math.geometry.rect ;
math.vectors sorting colors combinators assocs math.order fry
calendar alarms ui.clipboards ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
ui.render ui.gestures math.geometry.rect ;
IN: ui.gadgets.editors
TUPLE: editor < gadget
font color caret-color selection-color
caret mark
focused? ;
focused? blink blink-alarm ;
: <loc> ( -- loc ) { 0 0 } <model> ;
@ -45,6 +45,28 @@ focused? ;
dup deactivate-model
swap model>> remove-loc ;
: blink-caret ( editor -- )
[ not ] change-blink relayout-1 ;
SYMBOL: blink-interval
750 milliseconds blink-interval set-global
: start-blinking ( editor -- )
t >>blink
dup '[ _ blink-caret ] blink-interval get every >>blink-alarm drop ;
: stop-blinking ( editor -- )
[ [ cancel-alarm ] when* f ] change-blink-alarm drop ;
: restart-blinking ( editor -- )
dup focused?>> [
[ stop-blinking ]
[ start-blinking ]
[ relayout-1 ]
tri
] [ drop ] if ;
M: editor graft*
dup
dup caret>> activate-editor-model
@ -52,6 +74,7 @@ M: editor graft*
M: editor ungraft*
dup
dup stop-blinking
dup caret>> deactivate-editor-model
dup mark>> deactivate-editor-model ;
@ -64,14 +87,14 @@ M: editor ungraft*
caret>> set-model ;
: change-caret ( editor quot -- )
over >r >r dup editor-caret* swap model>> r> call r>
[ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi
set-caret ; inline
: mark>caret ( editor -- )
dup editor-caret* swap mark>> set-model ;
[ editor-caret* ] [ mark>> ] bi set-model ;
: change-caret&mark ( editor quot -- )
over >r change-caret r> mark>caret ; inline
[ change-caret ] [ drop mark>caret ] 2bi ; inline
: editor-line ( n editor -- str ) control-value nth ;
@ -85,8 +108,8 @@ M: editor ungraft*
: point>loc ( point editor -- loc )
[
>r first2 r> tuck y>line dup ,
>r dup editor-font* r>
[ first2 ] dip tuck y>line dup ,
[ dup editor-font* ] dip
rot editor-line x>offset ,
] { } make ;
@ -94,11 +117,17 @@ M: editor ungraft*
[ hand-rel ] keep point>loc ;
: click-loc ( editor model -- )
>r clicked-loc r> set-model ;
[ clicked-loc ] dip set-model ;
: focus-editor ( editor -- ) t >>focused? relayout-1 ;
: focus-editor ( editor -- )
dup start-blinking
t >>focused?
relayout-1 ;
: unfocus-editor ( editor -- ) f >>focused? relayout-1 ;
: unfocus-editor ( editor -- )
dup stop-blinking
f >>focused?
relayout-1 ;
: (offset>x) ( font col# str -- x )
swap head-slice string-width ;
@ -106,7 +135,7 @@ M: editor ungraft*
: offset>x ( col# line# editor -- x )
[ editor-line ] keep editor-font* -rot (offset>x) ;
: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
: loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ;
: line>y ( lines# editor -- y )
line-height * ;
@ -126,7 +155,7 @@ M: editor ungraft*
] [ drop ] if ;
: draw-caret ( -- )
editor get focused?>> [
editor get [ focused?>> ] [ blink>> ] bi and [
editor get
[ caret-color>> gl-color ]
[
@ -143,7 +172,7 @@ M: editor ungraft*
line-translation gl-translate ;
: draw-line ( editor str -- )
>r font>> r> { 0 0 } draw-string ;
[ font>> ] dip { 0 0 } draw-string ;
: first-visible-line ( editor -- n )
clip get rect-loc second origin get second -
@ -169,7 +198,7 @@ M: editor ungraft*
rot control-value <slice> ;
: with-editor-translation ( n quot -- )
>r line-translation origin get v+ r> with-translation ;
[ line-translation origin get v+ ] dip with-translation ;
inline
: draw-lines ( -- )
@ -199,7 +228,7 @@ M: editor ungraft*
editor get selection-start/end
over first [
2dup [
>r 2dup r> draw-selected-line
[ 2dup ] dip draw-selected-line
1 translate-lines
] each-line 2drop
] with-editor-translation ;
@ -217,7 +246,7 @@ M: editor pref-dim*
drop relayout ;
: caret/mark-changed ( model editor -- )
nip [ relayout-1 ] [ scroll>caret ] bi ;
nip [ restart-blinking ] [ scroll>caret ] bi ;
M: editor model-changed
{
@ -247,7 +276,9 @@ M: editor user-input*
M: editor gadget-text* editor-string % ;
: extend-selection ( editor -- )
dup request-focus dup caret>> click-loc ;
dup request-focus
dup restart-blinking
dup caret>> click-loc ;
: mouse-elt ( -- element )
hand-click# get {
@ -259,14 +290,15 @@ M: editor gadget-text* editor-string % ;
editor-mark* before? ;
: drag-selection-caret ( loc editor element -- loc )
>r [ drag-direction? ] 2keep
model>>
r> prev/next-elt ? ;
[
[ drag-direction? ] 2keep model>>
] dip prev/next-elt ? ;
: drag-selection-mark ( loc editor element -- loc )
>r [ drag-direction? not ] 2keep
nip dup editor-mark* swap model>>
r> prev/next-elt ? ;
[
[ drag-direction? not ] keep
[ editor-mark* ] [ model>> ] bi
] dip prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark )
dup clicked-loc swap mouse-elt
@ -285,15 +317,16 @@ M: editor gadget-text* editor-string % ;
over gadget-selection? [
drop nip remove-selection
] [
over >r >r dup editor-caret* swap model>>
r> call r> model>> remove-doc-range
[ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
[ drop model>> ]
2bi remove-doc-range
] if ; inline
: editor-delete ( editor elt -- )
swap [ over >r rot next-elt r> swap ] delete/backspace ;
swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
: editor-backspace ( editor elt -- )
swap [ over >r rot prev-elt r> ] delete/backspace ;
swap [ over [ rot prev-elt ] dip ] delete/backspace ;
: editor-select-prev ( editor elt -- )
swap [ rot prev-elt ] change-caret ;
@ -311,9 +344,8 @@ M: editor gadget-text* editor-string % ;
tuck caret>> set-model mark>> set-model ;
: select-elt ( editor elt -- )
over >r
>r dup editor-caret* swap model>> r> prev/next-elt
r> editor-select ;
[ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
editor-select ;
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;

2
basis/ui/gadgets/slots/slots.factor
View File

@ -71,7 +71,7 @@ M: value-ref finish-editing
: <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track
swap >>ref
dup <toolbar> f track-add
add-toolbar
<source-editor> >>text
dup text>> <scroller> 1 track-add
dup revert ;

7
basis/ui/gadgets/tracks/tracks-tests.factor
View File

@ -14,3 +14,10 @@ IN: ui.gadgets.tracks.tests
<gadget> { 100 100 } >>dim 1 track-add
pref-dim
] unit-test
[ { 10 10 } ] [
{ 0 1 } <track>
<gadget> { 10 10 } >>dim 1 track-add
<gadget> { 10 10 } >>dim 0 track-add
pref-dim
] unit-test

3
basis/ui/gadgets/tracks/tracks.factor
View File

@ -41,7 +41,8 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
: track-pref-dims-2 ( track -- dim )
[
[ children>> pref-dims ] [ normalized-sizes ] bi
[ [ v/n ] when* ] 2map max-dim [ >fixnum ] map
[ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map
max-dim [ >fixnum ] map
]
[ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
v+ ;

19
basis/ui/tools/browser/browser.factor
View File

@ -4,17 +4,17 @@ USING: debugger ui.tools.workspace help help.topics kernel
models models.history ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
ui.gadgets.buttons compiler.units assocs words vocabs
accessors ;
accessors fry combinators.short-circuit ;
IN: ui.tools.browser
TUPLE: browser-gadget < track pane history ;
: show-help ( link help -- )
dup history>> add-history
>r >link r> history>> set-model ;
history>> dup add-history
[ >link ] dip set-model ;
: <help-pane> ( browser-gadget -- gadget )
history>> [ [ help ] curry try ] <pane-control> ;
history>> [ '[ _ print-topic ] try ] <pane-control> ;
: init-history ( browser-gadget -- )
"handbook" >link <history> >>history drop ;
@ -22,7 +22,7 @@ TUPLE: browser-gadget < track pane history ;
: <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track
dup init-history
dup <toolbar> f track-add
add-toolbar
dup <help-pane> >>pane
dup pane>> <scroller> 1 track-add ;
@ -38,10 +38,11 @@ M: browser-gadget ungraft*
[ call-next-method ] [ remove-definition-observer ] bi ;
: showing-definition? ( defspec assoc -- ? )
[ key? ] 2keep
[ >r dup word-link? [ name>> ] when r> key? ] 2keep
>r dup vocab-link? [ vocab ] when r> key?
or or ;
{
[ key? ]
[ [ dup word-link? [ name>> ] when ] dip key? ]
[ [ dup vocab-link? [ vocab ] when ] dip key? ]
} 2|| ;
M: browser-gadget definitions-changed ( assoc browser -- )
history>>

2
basis/ui/tools/debugger/debugger.factor
View File

@ -25,7 +25,7 @@ TUPLE: debugger < track restarts ;
: <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track
dup <toolbar> f track-add
add-toolbar
-rot <restart-list> >>restarts
dup restarts>> rot <debugger-display> <scroller> 1 track-add ;

2
basis/ui/tools/inspector/inspector.factor
View File

@ -17,7 +17,7 @@ TUPLE: inspector-gadget < track object pane ;
: <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track
dup <toolbar> f track-add
add-toolbar
<pane> >>pane
dup pane>> <scroller> 1 track-add ;

4
basis/ui/tools/interactor/interactor.factor
View File

@ -178,10 +178,6 @@ M: interactor stream-read-quot
]
} cond ;
M: interactor pref-dim*
[ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
vmax ;
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }
{ T{ key-down f { C+ } "k" } clear-input }

86
basis/ui/tools/listener/listener.factor
View File

@ -1,20 +1,21 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inspector ui.tools.interactor ui.tools.inspector
ui.tools.workspace help.markup io io.styles
kernel models namespaces parser quotations sequences ui.commands
USING: inspector help help.markup io io.styles
kernel models namespaces parser quotations sequences vocabs words
prettyprint listener debugger threads boxes concurrency.flags
math arrays generic accessors combinators assocs fry ui.commands
ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
prettyprint listener debugger threads boxes concurrency.flags
math arrays generic accessors combinators assocs ;
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
ui.tools.browser ui.tools.interactor ui.tools.inspector
ui.tools.workspace ;
IN: ui.tools.listener
TUPLE: listener-gadget < track input output stack ;
TUPLE: listener-gadget < track input output ;
: listener-output, ( listener -- listener )
<scrolling-pane> >>output
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
<scrolling-pane>
[ >>output ] [ <scroller> 1 track-add ] bi ;
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
@ -23,17 +24,13 @@ TUPLE: listener-gadget < track input output stack ;
output>> <pane-stream> <interactor> ;
: listener-input, ( listener -- listener )
dup <listener-input> >>input
dup input>>
<limited-scroller>
{ 0 100 } >>min-dim
{ 1/0. 100 } >>max-dim
"Input" <labelled-gadget>
f track-add ;
dup <listener-input>
[ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
"handbook" ($link) "." print nl ;
"handbook" ($link) ". To see a list of keyboard shortcuts," print
"press F1." print nl ;
M: listener-gadget focusable-child*
input>> ;
@ -60,7 +57,7 @@ M: listener-gadget tool-scroller
: call-listener ( quot -- )
[ workspace-busy? not ] get-workspace* listener>>
[ dup wait-for-listener (call-listener) ] 2curry
'[ _ _ dup wait-for-listener (call-listener) ]
"Listener call" spawn drop ;
M: listener-command invoke-command ( target command -- )
@ -76,7 +73,7 @@ M: listener-operation invoke-command ( target command -- )
: listener-run-files ( seq -- )
[
[ [ run-file ] each ] curry call-listener
'[ _ [ run-file ] each ] call-listener
] unless-empty ;
: com-end ( listener -- )
@ -122,20 +119,8 @@ M: engine-word word-completion-string
[ select-all ]
2bi ;
TUPLE: stack-display < track ;
: <stack-display> ( workspace -- gadget )
listener>>
{ 0 1 } stack-display new-track
over <toolbar> f track-add
swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add ;
M: stack-display tool-scroller
find-workspace listener>> tool-scroller ;
: ui-listener-hook ( listener -- )
>r datastack r> stack>> set-model ;
: ui-help-hook ( topic -- )
browser-gadget call-tool ;
: ui-error-hook ( error listener -- )
find-workspace debugger-popup ;
@ -146,17 +131,20 @@ M: stack-display tool-scroller
: listener-thread ( listener -- )
dup listener-streams [
[ [ ui-listener-hook ] curry listener-hook set ]
[ [ ui-error-hook ] curry error-hook set ]
[ [ ui-inspector-hook ] curry inspector-hook set ] tri
[ ui-help-hook ] help-hook set
[ '[ _ ui-error-hook ] error-hook set ]
[ '[ _ ui-inspector-hook ] inspector-hook set ] bi
welcome.
listener
] with-streams* ;
: start-listener-thread ( listener -- )
[
[ input>> register-self ] [ listener-thread ] bi
] curry "Listener" spawn drop ;
'[
_
[ input>> register-self ]
[ listener-thread ]
bi
] "Listener" spawn drop ;
: restart-listener ( listener -- )
#! Returns when listener is ready to receive input.
@ -168,12 +156,9 @@ M: stack-display tool-scroller
[ wait-for-listener ]
} cleave ;
: init-listener ( listener -- )
f <model> >>stack drop ;
: <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track
dup init-listener
add-toolbar
listener-output,
listener-input, ;
@ -181,12 +166,21 @@ M: stack-display tool-scroller
\ listener-help H{ { +nullary+ t } } define-command
: com-auto-use ( -- )
auto-use? [ not ] change ;
\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
listener-gadget "misc" "Miscellaneous commands" {
{ T{ key-down f f "F1" } listener-help }
} define-command-map
listener-gadget "toolbar" f {
{ f restart-listener }
{ T{ key-down f { A+ } "c" } clear-output }
{ T{ key-down f { A+ } "C" } clear-stack }
{ T{ key-down f { A+ } "a" } com-auto-use }
{ T{ key-down f { A+ } "c" } clear-output }
{ T{ key-down f { A+ } "C" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
{ T{ key-down f f "F1" } listener-help }
} define-command-map
M: listener-gadget handle-gesture ( gesture gadget -- ? )

2
basis/ui/tools/profiler/profiler.factor
View File

@ -9,7 +9,7 @@ TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track
dup <toolbar> f track-add
add-toolbar
<pane> >>pane
dup pane>> <scroller> 1 track-add ;

72
basis/ui/tools/search/search.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs ui.tools.interactor ui.tools.listener
ui.tools.workspace help help.topics io.files io.styles kernel
models models.delay models.filter namespaces prettyprint
USING: accessors assocs help help.topics io.files io.styles
kernel models models.delay models.filter namespaces prettyprint
quotations sequences sorting source-files definitions strings
tools.completion tools.crossref classes.tuple ui.commands
ui.gadgets ui.gadgets.editors ui.gadgets.lists
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
;
tools.completion tools.crossref classes.tuple vocabs words
vocabs.loader tools.vocabs unicode.case calendar locals
ui.tools.interactor ui.tools.listener ui.tools.workspace
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
ui.gestures ui.operations ui ;
IN: ui.tools.search
TUPLE: live-search < track field list ;
@ -23,7 +23,7 @@ TUPLE: live-search < track field list ;
M: live-search handle-gesture ( gesture live-search -- ? )
tuck search-gesture dup [
over find-workspace hide-popup
>r search-value r> invoke-command f
[ search-value ] dip invoke-command f
] [
2drop t
] if ;
@ -47,27 +47,29 @@ search-field H{
{ T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
} set-gestures
: <search-model> ( live-search producer -- live-search filter )
>r dup field>> model>>
ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ;
: <search-model> ( live-search producer -- filter )
[
field>> model>>
ui-running? [ 1/5 seconds <delay> ] when
] dip [ "\n" join ] prepend <filter> ;
: <search-list> ( live-search seq limited? presenter -- live-search list )
>r
[ limited-completions ] [ completions ] ? curry
<search-model>
>r [ find-workspace hide-popup ] r> r>
swap <list> ;
: init-search-model ( live-search seq limited? -- live-search )
[ 2drop ]
[ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
>>model ; inline
: <live-search> ( string seq limited? presenter -- gadget )
: <search-list> ( presenter live-search -- list )
[ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
:: <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track
<search-field> >>field
dup field>> f track-add
-roll <search-list> >>list
seq limited? init-search-model
presenter over <search-list> >>list
dup field>> 1 <border> { 1 1 } >>fill f track-add
dup list>> <scroller> 1 track-add
swap
over field>> set-editor-string
dup field>> end-of-document ;
string over field>> set-editor-string
dup field>> end-of-document ;
M: live-search focusable-child* field>> ;
@ -80,26 +82,27 @@ M: live-search pref-dim* drop { 400 200 } ;
[ dup synopsis >lower ] { } map>assoc sort-values ;
: <definition-search> ( string words limited? -- gadget )
>r definition-candidates r> [ synopsis ] <live-search> ;
[ definition-candidates ] dip [ synopsis ] <live-search> ;
: word-candidates ( words -- candidates )
[ dup name>> >lower ] { } map>assoc ;
: <word-search> ( string words limited? -- gadget )
>r word-candidates r> [ synopsis ] <live-search> ;
[ word-candidates ] dip [ synopsis ] <live-search> ;
: com-words ( workspace -- )
dup current-word all-words t <word-search>
"Word search" show-titled-popup ;
: show-vocab-words ( workspace vocab -- )
"" over words natural-sort f <word-search>
"Words in " rot vocab-name append show-titled-popup ;
[ "" swap words natural-sort f <word-search> ]
[ "Words in " swap vocab-name append ]
bi show-titled-popup ;
: show-word-usage ( workspace word -- )
"" over smart-usage f <definition-search>
"Words and methods using " rot name>> append
show-titled-popup ;
[ "" swap smart-usage f <definition-search> ]
[ "Words and methods using " swap name>> append ]
bi show-titled-popup ;
: help-candidates ( seq -- candidates )
[ dup >link swap article-title >lower ] { } map>assoc
@ -127,8 +130,9 @@ M: live-search pref-dim* drop { 400 200 } ;
"Source file search" show-titled-popup ;
: show-vocab-files ( workspace vocab -- )
"" over vocab-files <source-file-search>
"Source files in " rot vocab-name append show-titled-popup ;
[ "" swap vocab-files <source-file-search> ]
[ "Source files in " swap vocab-name append ]
bi show-titled-popup ;
: vocab-candidates ( -- candidates )
all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;

2
basis/ui/tools/tools-docs.factor
View File

@ -32,7 +32,7 @@ ARTICLE: "ui-listener" "UI listener"
{ $heading "Editing commands" }
"The text editing commands are standard; see " { $link "gadgets-editors" } "."
{ $heading "Implementation" }
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), and an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ;
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } ")." ;
ARTICLE: "ui-inspector" "UI inspector"
"The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."

25
basis/ui/tools/tools.factor
View File

@ -19,8 +19,7 @@ IN: ui.tools
<toggle-buttons> ;
: <workspace-book> ( workspace -- gadget )
dup
<stack-display>
<gadget>
<browser-gadget>
<inspector-gadget>
<profiler-gadget>
@ -34,14 +33,14 @@ IN: ui.tools
dup <workspace-book> >>book
dup <workspace-tabs> f track-add
dup book>> 1/5 track-add
dup listener>> 4/5 track-add
dup <toolbar> f track-add ;
dup book>> 0 track-add
dup listener>> 1 track-add
add-toolbar ;
: resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [
1/5 over set-second
4/5 swap set-third
dup sizes>> over control-value 0 = [
0 over set-second
1 swap set-third
] [
2/3 over set-second
1/3 swap set-third
@ -55,13 +54,15 @@ M: workspace model-changed
[ workspace-window ] ui-hook set-global
: com-listener ( workspace -- ) stack-display select-tool ;
: select-tool ( workspace n -- ) swap book>> model>> set-model ;
: com-browser ( workspace -- ) browser-gadget select-tool ;
: com-listener ( workspace -- ) 0 select-tool ;
: com-inspector ( workspace -- ) inspector-gadget select-tool ;
: com-browser ( workspace -- ) 1 select-tool ;
: com-profiler ( workspace -- ) profiler-gadget select-tool ;
: com-inspector ( workspace -- ) 2 select-tool ;
: com-profiler ( workspace -- ) 3 select-tool ;
workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener }

2
basis/ui/tools/traceback/traceback.factor
View File

@ -36,7 +36,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
dup model>> <callstack-display> 2/3 track-add
dup <toolbar> f track-add ;
add-toolbar ;
: <namestack-display> ( model -- gadget )
[ [ name>> namestack. ] when* ]

4
basis/ui/tools/walker/walker.factor
View File

@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
swap >>status
dup continuation>> <traceback-gadget> >>traceback
dup <toolbar> f track-add
add-toolbar
dup status>> self <thread-status> f track-add
dup traceback>> 1 track-add ;
dup traceback>> 1 track-add ;
: walker-help ( -- ) "ui-walker" help-window ;

18
basis/ui/tools/workspace/workspace.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes continuations help help.topics kernel models
sequences ui ui.backend ui.tools.debugger ui.gadgets
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
ui.commands ui.gestures assocs arrays namespaces accessors ;
sequences assocs arrays namespaces accessors math.vectors ui
ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.gadgets.presentations ui.gadgets.status-bar ui.commands
ui.gestures ;
IN: ui.tools.workspace
TUPLE: workspace < track book listener popup ;
@ -32,8 +32,6 @@ M: gadget tool-scroller drop f ;
[ find-tool swap ] keep book>> model>>
set-model ;
: select-tool ( workspace class -- ) swap show-tool drop ;
: get-workspace* ( quot -- workspace )
[ >r dup workspace? r> [ drop f ] if ] curry find-window
[ dup raise-window gadget-child ]
@ -81,7 +79,7 @@ SYMBOL: workspace-dim
{ 600 700 } workspace-dim set-global
M: workspace pref-dim* drop workspace-dim get ;
M: workspace pref-dim* call-next-method workspace-dim get vmax ;
M: workspace focusable-child*
dup popup>> [ ] [ listener>> ] ?if ;

20
core/parser/parser-docs.factor
View File

@ -41,13 +41,15 @@ $nl
}
"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
{ $list
{ "If there are no words having this name at all, an error is thrown and parsing stops." }
{ "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." }
}
"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."
$nl
"If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used."
$nl
"If " { $link auto-use? } " mode is on and only one vocabulary has a word with this name, the vocabulary is added to the search path and parsing continues."
$nl
"If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file."
{ $subsection auto-use? } ;
ARTICLE: "vocabulary-search" "Vocabulary search path"
"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
@ -353,3 +355,7 @@ HELP: staging-violation
{ $description "Throws a " { $link staging-violation } " error." }
{ $error-description "Thrown by the parser if a parsing word is used in the same compilation unit as where it was defined; see " { $link "compilation-units" } "." }
{ $notes "One possible workaround is to use the " { $link POSTPONE: << } " word to execute code at parse time. However, executing words defined in the same source file at parse time is still prohibited." } ;
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 "vocabulary-search-errors" } "." } ;

2
core/parser/parser-tests.factor
View File

@ -496,3 +496,5 @@ DEFER: blah
[ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ]
[ error>> error>> def>> \ blah eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test

17
core/parser/parser.factor
View File

@ -25,7 +25,7 @@ t parser-notes set-global
: note. ( str -- )
parser-notes? [
file get [ path>> write ":" write ] when*
lexer get line>> number>string write ": " write
lexer get [ line>> number>string write ": " write ] when*
"Note: " write dup print
] when drop ;
@ -82,17 +82,20 @@ ERROR: no-word-error name ;
SYMBOL: amended-use?
SYMBOL: do-what-i-mean?
SYMBOL: auto-use?
: no-word-restarted ( restart-value -- word )
dup word?
[ amended-use? on dup vocabulary>> (use+) ]
[ create-in ]
if ;
dup word? [
amended-use? on
dup vocabulary>>
[ (use+) ] [
"Added ``" swap "'' vocabulary to search path" 3append note.
] bi
] [ create-in ] if ;
: no-word ( name -- newword )
dup words-named [ forward-reference? not ] filter
dup length 1 = do-what-i-mean? get and
dup length 1 = auto-use? get and
[ nip first no-word-restarted ]
[ <no-word-error> throw-restarts no-word-restarted ]
if ;

43
vm/math.c
View File

@ -33,18 +33,18 @@ void primitive_float_to_fixnum(void)
#define POP_FIXNUMS(x,y) \
F_FIXNUM y = untag_fixnum_fast(dpop()); \
F_FIXNUM x = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpeek());
void primitive_fixnum_add(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
drepl(allot_integer(x + y));
}
void primitive_fixnum_subtract(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
drepl(allot_integer(x - y));
}
/* Multiply two integers, and trap overflow.
@ -54,20 +54,20 @@ void primitive_fixnum_multiply(void)
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
dpush(tag_fixnum(0));
drepl(tag_fixnum(0));
else
{
F_FIXNUM prod = x * y;
/* if this is not equal, we have overflow */
if(prod / x == y)
box_signed_cell(prod);
drepl(allot_integer(prod));
else
{
F_ARRAY *bx = fixnum_to_bignum(x);
REGISTER_BIGNUM(bx);
F_ARRAY *by = fixnum_to_bignum(y);
UNREGISTER_BIGNUM(bx);
dpush(tag_bignum(bignum_multiply(bx,by)));
drepl(tag_bignum(bignum_multiply(bx,by)));
}
}
}
@ -75,14 +75,27 @@ void primitive_fixnum_multiply(void)
void primitive_fixnum_divint(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
F_FIXNUM result = x / y;
if(result == -FIXNUM_MIN)
drepl(allot_integer(-FIXNUM_MIN));
else
drepl(tag_fixnum(result));
}
void primitive_fixnum_divmod(void)
{
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
dpush(tag_fixnum(x % y));
F_FIXNUM y = get(ds);
F_FIXNUM x = get(ds - CELLS);
if(y == -1 && x == tag_fixnum(FIXNUM_MIN))
{
put(ds - CELLS,allot_integer(-FIXNUM_MIN));
put(ds,tag_fixnum(0));
}
else
{
put(ds - CELLS,tag_fixnum(x / y));
put(ds,x % y);
}
}
/*
@ -96,15 +109,15 @@ void primitive_fixnum_shift(void)
if(x == 0 || y == 0)
{
dpush(tag_fixnum(x));
drepl(tag_fixnum(x));
return;
}
else if(y < 0)
{
if(y <= -WORD_SIZE)
dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
drepl(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
else
dpush(tag_fixnum(x >> -y));
drepl(tag_fixnum(x >> -y));
return;
}
else if(y < WORD_SIZE - TAG_BITS)
@ -112,12 +125,12 @@ void primitive_fixnum_shift(void)
F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
{
dpush(tag_fixnum(x << y));
drepl(tag_fixnum(x << y));
return;
}
}
dpush(tag_bignum(bignum_arithmetic_shift(
drepl(tag_bignum(bignum_arithmetic_shift(
fixnum_to_bignum(x),y)));
}