generic.standard vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer compiler.errors
-generic.parser strings.parser vocabs.loader vocabs.parser ;
+generic.parser strings.parser vocabs.loader vocabs.parser see ;
IN: debugger
GENERIC: error. ( error -- )
M: lexer-error error-help
error>> error-help ;
-M: object compiler-error. ( error word -- )
- nl
- "While compiling " write pprint ": " print
- nl
- print-error ;
+M: object compiler-error. ( error -- )
+ [
+ [
+ [
+ [ line#>> # ": " % ]
+ [ word>> synopsis % ] bi
+ ] "" make
+ ] [
+ [
+ presented set
+ bold font-style set
+ ] H{ } make-assoc
+ ] bi format nl
+ ] [ error>> error. ] bi ;
M: bad-effect summary
drop "Bad stack effect declaration" ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: models.arrows.smart.tests
+USING: models.arrow.smart tools.test accessors models math kernel ;
+
+[ 7 ] [ 3 <model> 4 <model> [ + ] <smart-arrow> [ activate-model ] [ value>> ] bi ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: models.arrow models.product stack-checker accessors fry
+generalizations macros kernel ;
+IN: models.arrow.smart
+
+MACRO: <smart-arrow> ( quot -- quot' )
+ [ infer in>> dup ] keep
+ '[ _ narray <product> [ _ firstn @ ] <arrow> ] ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
-sequences unicode.case ;
+USING: fry kernel models.arrow.smart sequences unicode.case ;
IN: models.search
: <search> ( values search quot -- model )
- [ 2array <product> ] dip
- '[ first2 _ curry filter ] <arrow> ;
+ '[ _ curry filter ] <smart-arrow> ; inline
: <string-search> ( values search quot -- model )
- '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ;
+ '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ; inline
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
-sequences sorting ;
+USING: sorting models.arrow.smart fry ;
IN: models.sort
: <sort> ( values sort -- model )
- 2array <product> [ first2 sort ] <arrow> ;
\ No newline at end of file
+ [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] <smart-arrow> ; inline
\ No newline at end of file
IN: tools.profiler
: profile ( quot -- )
- [ t profiling call ] [ f profiling ] [ ] cleanup ;
+ [ t profiling call ] [ f profiling ] [ ] cleanup ; inline
: filter-counts ( alist -- alist' )
[ second 0 > ] filter ;
kernel sequences io io.styles io.streams.string tools.test
prettyprint definitions help help.syntax help.markup
help.stylesheet splitting ui.gadgets.debug models math summary
-inspector accessors help.topics see ;
+inspector accessors help.topics see fry ;
IN: ui.gadgets.panes.tests
: #children ( -- n ) "pane" get children>> length ;
[ t ] [ #children "num-children" get = ] unit-test
: test-gadget-text ( quot -- ? )
- dup make-pane gadget-text dup print "======" print
- swap with-string-writer dup print = ;
+ '[ _ call( -- ) ]
+ [ make-pane gadget-text dup print "======" print ]
+ [ with-string-writer dup print ] bi = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
dup field>> { 2 2 } <filled-border> f track-add
values search 500 milliseconds <delay> quot <string-search>
renderer <table> f >>takes-focus? >>table
- dup table>> <scroller> 1 track-add ;
+ dup table>> <scroller> 1 track-add ; inline
M: search-table model-changed
nip field>> clear-search-field ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sorting assocs colors.constants combinators
+combinators.smart compiler.errors compiler.units fonts kernel
+math.parser math.order models models.arrow namespaces summary ui
+ui.commands ui.gadgets ui.gadgets.tables ui.gadgets.tracks
+ui.gestures ui.operations ui.tools.browser ui.tools.common
+ui.gadgets.scrollers ;
+IN: ui.tools.compiler-errors
+
+TUPLE: error-list-gadget < tool table ;
+
+SINGLETON: error-renderer
+
+M: error-renderer row-columns
+ drop [
+ {
+ [ file>> ]
+ [ line#>> number>string ]
+ [ word>> name>> ]
+ [ error>> summary ]
+ } cleave
+ ] output>array ;
+
+M: error-renderer row-value
+ drop ;
+
+M: error-renderer column-titles
+ drop { "File" "Line" "Word" "Error" } ;
+
+: <error-table> ( model -- table )
+ [ [ [ [ file>> ] [ line#>> ] bi 2array ] compare ] sort ] <arrow>
+ error-renderer <table>
+ [ invoke-primary-operation ] >>action
+ monospace-font >>font
+ COLOR: dark-gray >>column-line-color
+ 6 >>gap
+ 30 >>min-rows
+ 30 >>max-rows
+ 80 >>min-cols
+ 80 >>max-cols ;
+
+: <error-list-gadget> ( model -- gadget )
+ [ values ] <arrow> vertical error-list-gadget new-track
+ { 3 3 } >>gap
+ swap <error-table> >>table
+ dup table>> <scroller> 1 track-add ;
+
+M: error-list-gadget focusable-child*
+ table>> ;
+
+: error-list-help ( -- ) "ui-error-list" com-browse ;
+
+\ error-list-help H{ { +nullary+ t } } define-command
+
+error-list-gadget "toolbar" f {
+ { T{ key-down f f "F1" } error-list-help }
+} define-command-map
+
+SYMBOL: compiler-error-model
+
+compiler-error-model [ f <model> ] initialize
+
+SINGLETON: updater
+
+M: updater definitions-changed
+ 2drop
+ compiler-errors get-global
+ compiler-error-model get-global
+ set-model ;
+
+updater remove-definition-observer
+updater add-definition-observer
+
+: error-list-window ( obj -- )
+ compiler-error-model get-global <error-list-gadget>
+ "Compiler errors" open-window ;
\ No newline at end of file
parser prettyprint quotations tools.crossref tools.annotations
editors tools.profiler tools.test tools.time tools.walker vocabs
vocabs.loader words sequences tools.vocabs classes
-compiler.units accessors vocabs.parser macros.expander ui
+compiler.errors compiler.units accessors vocabs.parser macros.expander ui
ui.tools.browser ui.tools.listener ui.tools.listener.completion
ui.tools.profiler ui.tools.inspector ui.tools.traceback
ui.commands ui.gadgets.editors ui.gestures ui.operations
{ +listener+ t }
} define-operation
+! Compiler errors
+: edit-error ( error -- )
+ [ file>> ] [ line#>> ] bi edit-location ;
+
+[ compiler-error? ] \ edit-error H{
+ { +primary+ t }
+ { +secondary+ t }
+ { +listener+ t }
+} define-operation
+
+: com-reload ( error -- )
+ file>> run-file ;
+
+[ compiler-error? ] \ com-reload H{
+ { +listener+ t }
+} define-operation
+
+! Definitions
: com-forget ( defspec -- )
[ forget ] with-compilation-unit ;
--- /dev/null
+USING: ui.tools.profiler tools.test ;
+
+\ profiler-window must-infer
ui.tools.browser ui.tools.common ui.baseline-alignment
ui.operations ui.images ;
FROM: models.arrow => <arrow> ;
+FROM: models.arrow.smart => <smart-arrow> ;
FROM: models.product => <product> ;
IN: ui.tools.profiler
: <methods-model> ( profiler -- model )
[
[ method-counters <model> ] dip
- [ generic>> ] [ class>> ] bi 3array <product>
- [ first3 '[ _ _ method-matches? ] filter ] <arrow>
+ [ generic>> ] [ class>> ] bi
+ [ '[ _ _ method-matches? ] filter ] <smart-arrow>
] keep <profiler-model> ;
: sort-by-name ( obj1 obj2 -- <=> )
: profiler-window ( -- )
<profiler-gadget> "Profiling results" open-status-window ;
-: com-profile ( quot -- ) profile profiler-window ;
+: com-profile ( quot -- ) profile profiler-window ; inline
MAIN: profiler-window
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make assocs io sequences
-sorting continuations math math.parser ;
+sorting continuations math math.order math.parser accessors
+definitions ;
IN: compiler.errors
SYMBOL: +error+
SYMBOL: +warning+
SYMBOL: +linkage+
+TUPLE: compiler-error error word file line# ;
+
GENERIC: compiler-error-type ( error -- ? )
M: object compiler-error-type drop +error+ ;
-GENERIC# compiler-error. 1 ( error word -- )
+M: compiler-error compiler-error-type error>> compiler-error-type ;
+
+GENERIC: compiler-error. ( error -- )
SYMBOL: compiler-errors
+compiler-errors [ H{ } clone ] initialize
+
SYMBOL: with-compiler-errors?
: errors-of-type ( type -- assoc )
swap [ [ nip compiler-error-type ] dip eq? ] curry
assoc-filter ;
+: sort-compile-errors ( assoc -- alist )
+ [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+
+: group-by-source-file ( errors -- assoc )
+ H{ } clone [ [ push-at ] curry [ nip dup file>> ] prepose assoc-each ] keep ;
+
: compiler-errors. ( type -- )
- errors-of-type >alist sort-keys
- [ swap compiler-error. ] assoc-each ;
+ errors-of-type group-by-source-file sort-compile-errors
+ [
+ [ nl "==== " write print nl ]
+ [ [ nl ] [ compiler-error. ] interleave ]
+ bi*
+ ] assoc-each ;
: (compiler-report) ( what type word -- )
over errors-of-type assoc-empty? [ 3drop ] [
: :linkage ( -- ) +linkage+ compiler-errors. ;
+: <compiler-error> ( error word -- compiler-error )
+ dup where [ first2 ] [ "<unknown file>" 0 ] if* \ compiler-error boa ;
+
: compiler-error ( error word -- )
- with-compiler-errors? get [
- compiler-errors get pick
- [ set-at ] [ delete-at drop ] if
- ] [ 2drop ] if ;
+ compiler-errors get-global pick
+ [ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
: with-compiler-errors ( quot -- )
with-compiler-errors? get "quiet" get or [ call ] [
[
with-compiler-errors? on
- V{ } clone compiler-errors set-global
[ compiler-report ] [ ] cleanup
] with-scope
] if ; inline
-IN: compiler.units.tests
USING: definitions compiler.units tools.test arrays sequences words kernel
accessors namespaces fry ;
+IN: compiler.units.tests
[ [ [ ] define-temp ] with-compilation-unit ] must-infer
[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
"a" get [ "B" ] define
] with-compilation-unit
"b" get execute
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Notify observers even if compilation unit did nothing
+SINGLETON: observer
+
+observer add-definition-observer
+
+SYMBOL: counter
+
+0 counter set-global
+
+M: observer definitions-changed 2drop global [ counter inc ] bind ;
+
+[ ] with-compilation-unit
+
+[ 1 ] [ counter get-global ] unit-test
\ No newline at end of file
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math math.order classes classes.algebra classes.tuple
-classes.tuple.private generic ;
+classes.tuple.private generic compiler.errors ;
IN: compiler.units
SYMBOL: old-definitions
HOOK: recompile compiler-impl ( words -- alist )
! Non-optimizing compiler
-M: f recompile [ f ] { } map>assoc ;
+M: f recompile [ [ f swap compiler-error ] each ] [ [ f ] { } map>assoc ] bi ;
! Trivial compiler. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.