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

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

db4
William Schlieper 2008-08-01 20:57:22 -04:00
parent 942043aba2 5487188424
commit b493ed48aa
23 changed files with 126 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/concurrency/messaging/messaging-docs.factor
View File

@ -56,19 +56,19 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
"USING: concurrency.messaging kernel threads ;"
": pong-server ( -- )"
" receive >r \"pong\" r> reply-synchronous ;"
"[ pong-server t ] spawn-server"
"[ pong-server t ] \"pong-server\" spawn-server"
"\"ping\" swap send-synchronous ."
"\"pong\""
} ;
ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
"A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:"
{ $code "[ 1 0 / \"This will not print\" print ] spawn" }
{ $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" }
"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
{ $subsection spawn-linked }
"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
{ $code "["
" [ 1 0 / \"This will not print\" print ] spawn-linked drop"
" [ 1 0 / \"This will not print\" print ] \"linked-division\" spawn-linked drop"
" receive"
"] [ \"Exception caught.\" print ] recover" }
"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;

18
basis/help/stylesheet/stylesheet.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.styles namespaces ;
USING: io.styles namespaces colors ;
IN: help.stylesheet
SYMBOL: default-span-style
@ -17,7 +17,7 @@ H{
SYMBOL: link-style
H{
{ foreground { 0 0 0.3 1 } }
{ foreground T{ rgba f 0 0 0.3 1 } }
{ font-style bold }
} link-style set-global
@ -33,7 +33,7 @@ H{
{ font-size 18 }
{ font-style bold }
{ wrap-margin 500 }
{ page-color { 0.8 0.8 0.8 1 } }
{ page-color T{ rgba f 0.8 0.8 0.8 1 } }
{ border-width 5 }
} title-style set-global
@ -58,12 +58,12 @@ SYMBOL: snippet-style
H{
{ font "monospace" }
{ font-size 12 }
{ foreground { 0.1 0.1 0.4 1 } }
{ foreground T{ rgba f 0.1 0.1 0.4 1 } }
} snippet-style set-global
SYMBOL: code-style
H{
{ page-color { 0.8 0.8 0.8 0.5 } }
{ page-color T{ rgba f 0.8 0.8 0.8 0.5 } }
{ border-width 5 }
{ wrap-margin f }
} code-style set-global
@ -74,13 +74,13 @@ H{ { font-style bold } } input-style set-global
SYMBOL: url-style
H{
{ font "monospace" }
{ foreground { 0.0 0.0 1.0 1.0 } }
{ foreground T{ rgba f 0.0 0.0 1.0 1.0 } }
} url-style set-global
SYMBOL: warning-style
H{
{ page-color { 0.95 0.95 0.95 1 } }
{ border-color { 1 0 0 1 } }
{ page-color T{ rgba f 0.95 0.95 0.95 1 } }
{ border-color T{ rgba f 1 0 0 1 } }
{ border-width 5 }
{ wrap-margin 500 }
} warning-style set-global
@ -93,7 +93,7 @@ H{
SYMBOL: table-style
H{
{ table-gap { 5 5 } }
{ table-border { 0.8 0.8 0.8 1.0 } }
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
} table-style set-global
SYMBOL: list-style

6
basis/io/styles/styles.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io ;
USING: hashtables io colors ;
IN: io.styles
SYMBOL: plain
@ -33,7 +35,7 @@ SYMBOL: table-border
: standard-table-style ( -- style )
H{
{ table-gap { 5 5 } }
{ table-border { 0.8 0.8 0.8 1.0 } }
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
} ;
! Input history

5
basis/listener/listener.factor
View File

@ -3,7 +3,8 @@
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 ;
definitions compiler.units accessors colors ;
IN: listener
SYMBOL: quit-flag
@ -41,7 +42,7 @@ M: object stream-read-quot
: prompt. ( -- )
"( " in get " )" 3append
H{ { background { 1 0.7 0.7 1 } } } format bl flush ;
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
SYMBOL: error-hook

4
basis/prettyprint/backend/backend.factor
View File

@ -5,7 +5,7 @@ hashtables io assocs kernel math namespaces sequences strings
sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
combinators ;
combinators colors ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
@ -89,7 +89,7 @@ M: f pprint* drop \ f pprint-word ;
: string-style ( obj -- hash )
[
presented set
{ 0.3 0.3 0.3 1.0 } foreground set
T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
] H{ } make-assoc ;
: unparse-string ( str prefix suffix -- str )

8
basis/prettyprint/prettyprint.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: prettyprint
USING: arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
@ -8,7 +8,9 @@ prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
combinators quotations sets accessors ;
combinators quotations sets accessors colors ;
IN: prettyprint
: make-pprint ( obj quot -- block in use )
[
@ -95,7 +97,7 @@ combinators quotations sets accessors ;
SYMBOL: ->
\ ->
{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
{ { foreground T{ rgba f 1 1 1 1 } } { background T{ rgba f 0 0 0 1 } } }
"word-style" set-word-prop
: remove-step-into ( word -- )

2
core/kernel/kernel-docs.factor
View File

@ -437,7 +437,7 @@ HELP: or
HELP: xor
{ $values { "obj1" "a generalized boolean" } { "obj2" "a generalized boolean" } { "?" "a generalized boolean" } }
{ $description "Tests if at exactly one object is not " { $link f } "." }
{ $description "If exactly one input is false, outputs the other input. Otherwise outputs " { $link f } "." }
{ $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
HELP: both?

4
core/kernel/kernel-tests.factor
View File

@ -50,6 +50,10 @@ IN: kernel.tests
[ f ] [ 3 f and ] unit-test
[ 4 ] [ 4 6 or ] unit-test
[ 6 ] [ f 6 or ] unit-test
[ f ] [ 1 2 xor ] unit-test
[ 1 ] [ 1 f xor ] unit-test
[ 2 ] [ f 2 xor ] unit-test
[ f ] [ f f xor ] unit-test
[ slip ] must-fail
[ ] [ :c ] unit-test

2
core/kernel/kernel.factor
View File

@ -173,7 +173,7 @@ GENERIC: boa ( ... class -- tuple )
: or ( obj1 obj2 -- ? ) dupd ? ; inline
: xor ( obj1 obj2 -- ? ) dup not swap ? ; inline
: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
: both? ( x y quot -- ? ) bi@ and ; inline

0
extra/automata/tags.txt → extra/automata/ui/tags.txt
View File

1
extra/balloon-bomber/tags.txt
View File

@ -1,2 +1,3 @@
demos
games
applications

0
extra/boids/tags.txt → extra/boids/ui/tags.txt
View File

74
extra/cfdg/cfdg.factor
View File

@ -3,40 +3,16 @@ USING: kernel alien.c-types combinators namespaces arrays
sequences sequences.lib namespaces.lib splitting
math math.functions math.vectors math.trig
opengl.gl opengl.glu opengl ui ui.gadgets.slate
vars
random-weighted colors.hsv cfdg.gl ;
vars colors self self.slots
random-weighted colors.hsv cfdg.gl accessors ;
IN: cfdg
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! hsba { hue saturation brightness alpha }
SELF-SLOTS: hsva
: <hsba> 4array ;
VAR: color
! ( -- val )
: hue>> 0 color> nth ;
: saturation>> 1 color> nth ;
: brightness>> 2 color> nth ;
: alpha>> 3 color> nth ;
! ( val -- )
: >>hue 0 color> set-nth ;
: >>saturation 1 color> set-nth ;
: >>brightness 2 color> set-nth ;
: >>alpha 3 color> set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ;
: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ;
: gl-clear-hsba ( hsva -- ) hsva>rgba gl-clear ;
: clear-color ( color -- ) set-clear-color GL_COLOR_BUFFER_BIT glClear ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -50,18 +26,18 @@ VAR: color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: hue ( num -- ) hue>> + 360 mod >>hue ;
: hue ( num -- ) hue-> + 360 mod ->hue ;
: saturation ( num -- ) saturation>> swap adjust >>saturation ;
: brightness ( num -- ) brightness>> swap adjust >>brightness ;
: alpha ( num -- ) alpha>> swap adjust >>alpha ;
: saturation ( num -- ) saturation-> swap adjust ->saturation ;
: brightness ( num -- ) value-> swap adjust ->value ;
: alpha ( num -- ) alpha-> swap adjust ->alpha ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: h hue ;
: sat saturation ;
: b brightness ;
: a alpha ;
: h ( num -- ) hue ;
: sat ( num -- ) saturation ;
: b ( num -- ) brightness ;
: a ( num -- ) alpha ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -69,9 +45,9 @@ VAR: color-stack
: init-color-stack ( -- ) V{ } clone >color-stack ;
: push-color ( -- ) color> color-stack> push color> clone >color ;
: push-color ( -- ) self> color-stack> push self> clone >self ;
: pop-color ( -- ) color-stack> pop dup >color gl-set-hsba ;
: pop-color ( -- ) color-stack> pop dup >self set-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -102,11 +78,11 @@ VAR: threshold
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( -- )
color> gl-set-hsba
self> set-color
gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
: triangle ( -- )
color> gl-set-hsba
self> set-color
GL_POLYGON glBegin
0 0.577 glVertex2d
0.5 -0.289 glVertex2d
@ -114,7 +90,7 @@ VAR: threshold
glEnd ;
: square ( -- )
color> gl-set-hsba
self> set-color
GL_POLYGON glBegin
-0.5 0.5 glVertex2d
0.5 0.5 glVertex2d
@ -138,10 +114,10 @@ VAR: threshold
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: s size ;
: s* size* ;
: r rotate ;
: f flip ;
: s ( scale -- ) size ;
: s* ( scale-x scale-y -- ) size* ;
: r ( angle -- ) rotate ;
: f ( angle -- ) flip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -162,12 +138,12 @@ VAR: threshold
VAR: background
: set-initial-background ( -- ) { 0 0 1 1 } clone >color ;
: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
: set-background ( -- )
set-initial-background
background> call
color> gl-clear-hsba ;
self> clear-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -177,7 +153,7 @@ VAR: viewport ! { left width bottom height }
VAR: start-shape
: set-initial-color ( -- ) { 0 0 0 1 } clone >color ;
: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
: display ( -- )
@ -198,7 +174,7 @@ VAR: start-shape
set-initial-color
color> gl-set-hsba
self> set-color
start-shape> call ;

4
extra/color-picker/color-picker.factor
View File

@ -4,7 +4,7 @@ USING: kernel math math.functions math.parser models
models.filter models.range models.compose sequences ui
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
ui.gadgets.sliders ui.render math.geometry.rect accessors
ui.gadgets.grids ;
ui.gadgets.grids colors ;
IN: color-picker
! Simple example demonstrating the use of models.
@ -23,7 +23,7 @@ M: color-preview model-changed
swap model-value over set-gadget-interior relayout-1 ;
: <color-model> ( model -- model )
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
[ [ 256 /f ] map 1 suffix first4 rgba boa <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
3 [ 0 0 0 255 <range> ] replicate

2
extra/colors/colors.factor
View File

@ -27,8 +27,6 @@ M: hsva >rgba ( hsva -- rgba )
M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
M: array >rgba ( array -- rgba ) first4 rgba boa ;
M: color red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ;
M: color blue>> ( color -- blue ) >rgba blue>> ;

22
extra/demos/demos.factor Normal file
View File

@ -0,0 +1,22 @@
USING: kernel fry sequences
vocabs.loader tools.vocabs.browser
ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers
ui.tools.listener
accessors ;
IN: demos
: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
dup '[ drop [ , run ] call-listener ] <bevel-button> ;
: <demo-runner> ( -- gadget )
<pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: demos

17
extra/golden-section/golden-section.factor
View File

@ -39,16 +39,15 @@ IN: golden-section
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: <golden-section> ( -- gadget )
<cartesian>
{ 600 600 } >>pdim
{ -400 400 } x-range
{ -400 400 } y-range
[ golden-section ] >>action ;
: golden-section-window ( -- )
[
<cartesian>
{ 600 600 } >>pdim
{ -400 400 } x-range
{ -400 400 } y-range
[ golden-section ] >>action
"Golden Section" open-window
]
with-ui ;
[ <golden-section> "Golden Section" open-window ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

22
extra/processing/color/color.factor
View File

@ -1,22 +0,0 @@
USING: kernel sequences ;
IN: processing.color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: rgba red green blue alpha ;
C: <rgba> rgba
: <rgb> ( r g b -- rgba ) 1 <rgba> ;
: <gray> ( gray -- rgba ) dup dup 1 <rgba> ;
: {rgb} ( seq -- rgba ) first3 <rgb> ;
! : hex>rgba ( hex -- rgba )
! : set-gl-color ( color -- )
! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;

1
extra/space-invaders/tags.txt
View File

@ -1,2 +1,3 @@
demos
games
applications

1
extra/tetris/tags.txt
View File

@ -1,2 +1,3 @@
demos
applications
games

13
extra/ui/gadgets/slate/slate.factor
View File

@ -96,18 +96,21 @@ M: slate draw-gadget* ( slate -- )
establish-coordinate-system
GL_MODELVIEW glMatrixMode glLoadIdentity glPushMatrix
GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
setup-viewport
draw-slate
GL_PROJECTION glMatrixMode glPopMatrix
GL_MODELVIEW glMatrixMode glPopMatrix
GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
dup
find-world
default-coordinate-system
! The world coordinate system is a little wacky:
dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
setup-viewport
drop
drop ;
drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

7
unfinished/stack-checker/inlining/inlining.factor
View File

@ -106,17 +106,12 @@ SYMBOL: enter-out
'[ , prepend ] bi@
<effect> ;
: insert-copy ( effect -- )
in>> [ consume-d dup ] keep make-copies
[ nip output-d ] [ #copy, ] 2bi ;
: call-recursive-inline-word ( word -- )
dup "recursive" word-prop [
[ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
[ 2drop insert-copy ]
[ add-call drop ]
[ nip '[ , #call-recursive, ] consume/produce ]
3tri
3bi
] [ undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )

49
unmaintained/lint/lint.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors arrays assocs combinators.lib io kernel
macros math namespaces prettyprint quotations sequences
vectors vocabs words html.elements slots.private tar ;
USING: accessors alien alien.accessors arrays assocs
combinators.lib io kernel macros math namespaces prettyprint
quotations sequences vectors vocabs words html.elements sets
slots.private combinators.short-circuit ;
IN: lint
SYMBOL: def-hash
@ -18,7 +19,7 @@ SYMBOL: def-hash-keys
2drop
] if ;
: more-defs
: more-defs ( -- )
{
{ [ swap >r swap r> ] -rot }
{ [ swap swapd ] -rot }
@ -33,6 +34,7 @@ SYMBOL: def-hash-keys
{ [ 0 = ] zero? }
{ [ pop drop ] pop* }
{ [ [ ] if ] when }
{ [ f = not ] >boolean }
} [ first2 swap add-word-def ] each ;
: accessor-words ( -- seq )
@ -51,33 +53,32 @@ SYMBOL: def-hash-keys
{
[ get ] [ t ] [ { } ] [ . ] [ drop f ]
[ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
[ ">" write-html ] [ <unimplemented-typeflag> throw ]
[ "/>" write-html ]
[ ">" write-html ] [ "/>" write-html ]
} ;
H{ } clone def-hash set-global
all-words [ dup word-def add-word-def ] each
all-words [ dup def>> add-word-def ] each
more-defs
! Remove empty word defs
def-hash get-global [
drop empty? not
] assoc-subset
] assoc-filter
! Remove constants [ 1 ]
[
drop dup length 1 = swap first number? and not
] assoc-subset
] assoc-filter
! Remove set-alien-cell, etc.
[
drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
] assoc-subset
drop [ accessor-words diff ] keep [ length ] bi@ =
] assoc-filter
! Remove trivial defs
[
drop trivial-defs member? not
] assoc-subset
] assoc-filter
! Remove n m shift defs
[
@ -85,19 +86,19 @@ def-hash get-global [
dup first2 [ number? ] both?
swap third \ shift = and not
] [ drop t ] if
] assoc-subset
] assoc-filter
! Remove [ n slot ]
[
drop dup length 2 = [
first2 \ slot = swap number? and not
] [ drop t ] if
] assoc-subset def-hash set-global
] assoc-filter def-hash set-global
: find-duplicates
: find-duplicates ( -- seq )
def-hash get-global [
nip length 1 >
] assoc-subset ;
] assoc-filter ;
def-hash get-global keys def-hash-keys set-global
@ -107,18 +108,18 @@ M: object lint ( obj -- seq )
drop f ;
: subseq/member? ( subseq/member seq -- ? )
{ [ 2dup start ] [ 2dup member? ] } || 2nip ;
{ [ start ] [ member? ] } 2|| ;
M: callable lint ( quot -- seq )
def-hash-keys get [
swap subseq/member?
] with subset ;
] with filter ;
M: word lint ( word -- seq )
word-def dup callable? [ lint ] [ drop f ] if ;
def>> dup callable? [ lint ] [ drop f ] if ;
: word-path. ( word -- )
[ word-vocabulary ":" ] keep unparse 3append write nl ;
[ vocabulary>> ":" ] keep unparse 3append write nl ;
: (lint.) ( pair -- )
first2 >r word-path. r> [
@ -135,7 +136,7 @@ M: word lint ( word -- seq )
GENERIC: run-lint ( obj -- obj )
: (trim-self)
: (trim-self) ( val key -- obj ? )
def-hash get-global at* [
dupd remove empty? not
] [
@ -143,13 +144,13 @@ GENERIC: run-lint ( obj -- obj )
] if ;
: trim-self ( seq -- newseq )
[ [ (trim-self) ] subset ] assoc-map ;
[ [ (trim-self) ] filter ] assoc-map ;
: filter-symbols ( alist -- alist )
[
nip first dup def-hash get at
[ first ] bi@ literalize = not
] assoc-subset ;
] assoc-filter ;
M: sequence run-lint ( seq -- seq )
[
@ -157,7 +158,7 @@ M: sequence run-lint ( seq -- seq )
dup lint
] { } map>assoc
trim-self
[ second empty? not ] subset
[ second empty? not ] filter
filter-symbols ;
M: word run-lint ( word -- seq )