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

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

db4
Eduardo Cavazos 2008-08-31 01:43:00 -05:00
parent 7535c1d256 b93baaa315
commit df85ac4b5d
58 changed files with 563 additions and 251 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/compiler/compiler.factor
View File

@ -42,12 +42,17 @@ SYMBOL: +failed+
[ compiled-unxref ]
[
dup crossref?
[ dependencies get compiled-xref ] [ drop ] if
[
dependencies get
generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;
: (compile) ( word -- )
'[
H{ } clone dependencies set
H{ } clone generic-dependencies set
, {
[ compile-begins ]

5
basis/compiler/tests/insane.factor
View File

@ -1,4 +1,5 @@
IN: compiler.tests
USING: words kernel stack-checker alien.strings tools.test ;
USING: words kernel stack-checker alien.strings tools.test
compiler.units ;
[ ] [ \ if redefined [ string>alien ] infer. ] unit-test
[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test

29
basis/compiler/tests/redefine10.factor Normal file
View File

@ -0,0 +1,29 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math classes ;
IN: compiler.tests.redefine10
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
"> eval
] unit-test
[ ] [
<"
USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin
"> eval
] unit-test
[ 2.0 ] [
1.0 "my-inline" "compiler.tests.redefine10" lookup execute
] unit-test

32
basis/compiler/tests/redefine11.factor Normal file
View File

@ -0,0 +1,32 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math classes arrays ;
IN: compiler.tests.redefine11
MIXIN: my-mixin
INSTANCE: array my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ;
"> eval
] unit-test
[ ] [
[
array "my-mixin" "compiler.tests.redefine11" lookup
remove-mixin-instance
] with-compilation-unit
] unit-test
[ 1 ] [
"my-inline" "compiler.tests.redefine11" lookup execute
] unit-test

33
basis/compiler/tests/redefine6.factor Normal file
View File

@ -0,0 +1,33 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel kernel.private ;
IN: compiler.tests.redefine6
GENERIC: my-generic ( a -- b )
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
"> eval
] unit-test
[ ] [
<"
USING: kernel ;
IN: compiler.tests.redefine6
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin
"> eval
] unit-test
[ 1 ] [
"my-tuple" "compiler.tests.redefine6" lookup boa
"my-inline" "compiler.tests.redefine6" lookup execute
] unit-test

29
basis/compiler/tests/redefine7.factor Normal file
View File

@ -0,0 +1,29 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math ;
IN: compiler.tests.redefine7
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
"> eval
] unit-test
[ ] [
<"
USE: math
IN: compiler.tests.redefine7
INSTANCE: float my-mixin
"> eval
] unit-test
[ 2.0 ] [
1.0 "my-inline" "compiler.tests.redefine7" lookup execute
] unit-test

32
basis/compiler/tests/redefine8.factor Normal file
View File

@ -0,0 +1,32 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math math.order sorting ;
IN: compiler.tests.redefine8
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval
] unit-test
[ ] [
<"
USE: math
IN: compiler.tests.redefine8
INSTANCE: float my-mixin
"> eval
] unit-test
[ 2.0 ] [
1.0 "my-generic" "compiler.tests.redefine8" lookup execute
] unit-test

35
basis/compiler/tests/redefine9.factor Normal file
View File

@ -0,0 +1,35 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel generic.math ;
IN: compiler.tests
! Mixin redefinition did not recompile all necessary words.
[ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test
[ ] [
<"
USING: kernel math math.order sorting ;
IN: compiler.tests.redefine9
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
GENERIC: my-generic ( a -- b )
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> eval
] unit-test
[ ] [
<"
USE: math
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin
"> eval
] unit-test
[
"my-tuple" "compiler.tests.redefine9" lookup boa
"my-generic" "compiler.tests.redefine9" lookup
execute
] [ no-math-method? ] must-fail-with

11
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -42,7 +42,7 @@ GENERIC: cleanup* ( node -- node/nodes )
: cleanup-folding ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
#! inputs followed by #push nodes for the outputs.
[ word>> +inlined+ depends-on ]
[ word>> inlined-dependency depends-on ]
[
[ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip #push ] 2map
@ -50,11 +50,16 @@ GENERIC: cleanup* ( node -- node/nodes )
[ in-d>> #drop ]
tri prefix ;
: add-method-dependency ( #call -- )
dup method>> word? [
[ word>> ] [ class>> ] bi depends-on-generic
] [ drop ] if ;
: cleanup-inlining ( #call -- nodes )
[
dup method>>
[ method>> dup word? [ +called+ depends-on ] [ drop ] if ]
[ word>> +inlined+ depends-on ] if
[ add-method-dependency ]
[ word>> inlined-dependency depends-on ] if
] [ body>> cleanup ] bi ;
! Removing overflow checks

2
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -106,7 +106,7 @@ M: #push remove-dead-code*
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
[ word>> +inlined+ depends-on ]
[ word>> flushed-dependency depends-on ]
[ in-d>> #drop remove-dead-code* ]
bi ;

19
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -24,18 +24,19 @@ M: quotation splicing-nodes
body>> (propagate) ;
! Dispatch elimination
: eliminate-dispatch ( #call word/quot/f -- ? )
[
: eliminate-dispatch ( #call class/f word/f -- ? )
dup [
[ >>class ] dip
over method>> over = [ drop ] [
2dup splicing-nodes
[ >>method ] [ >>body ] bi*
] if
propagate-body t
] [ f >>method f >>body drop f ] if* ;
] [ 2drop f >>method f >>body f >>class drop f ] if ;
: inlining-standard-method ( #call word -- method/f )
: inlining-standard-method ( #call word -- class/f method/f )
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> ] dip
[ swap nth value-info class>> dup ] dip
specific-method ;
: inline-standard-method ( #call word -- ? )
@ -51,15 +52,17 @@ M: quotation splicing-nodes
object
} [ class<= ] with find nip ;
: inlining-math-method ( #call word -- quot/f )
: inlining-math-method ( #call word -- class/f quot/f )
swap in-d>>
first2 [ value-info class>> normalize-math-class ] bi@
3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
3dup math-both-known?
[ math-method* ] [ 3drop f ] if
number swap ;
: inline-math-method ( #call word -- ? )
dupd inlining-math-method eliminate-dispatch ;
: inlining-math-partial ( #call word -- quot/f )
: inlining-math-partial ( #call word -- class/f quot/f )
[ "derived-from" word-prop first inlining-math-method ]
[ nip 1quotation ] 2bi
[ = not ] [ drop ] 2bi and ;

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

@ -5,6 +5,8 @@ math.partial-dispatch math.intervals math.parser math.order
layouts words sequences sequences.private arrays assocs classes
classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private slots.private
definitions
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@ -280,6 +282,14 @@ generic-comparison-ops [
] +constraints+ set-word-prop
\ instance? [
! We need to force the caller word to recompile when the class
! is redefined, since now we're making assumptions but the
! class definition itself.
dup literal>> class?
[ literal>> predicate-output-infos ] [ 2drop object-info ] if
[
literal>>
[ inlined-dependency depends-on ]
[ predicate-output-infos ]
bi
] [ 2drop object-info ] if
] +outputs+ set-word-prop

20
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs words
namespaces classes.algebra combinators classes classes.tuple
classes.tuple.private continuations arrays byte-arrays strings
math math.partial-dispatch math.private slots generic
classes.tuple.private continuations arrays
math math.partial-dispatch math.private slots generic definitions
generic.standard generic.math
stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@ -32,7 +33,14 @@ M: #push propagate-before
[ set-value-info ] 2each ;
M: #declare propagate-before
declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
#! We need to force the caller word to recompile when the
#! classes mentioned in the declaration are redefined, since
#! now we're making assumptions but their definitions.
declaration>> [
[ inlined-dependency depends-on ]
[ <class-info> swap refine-value-info ]
bi
] assoc-each ;
: predicate-constraints ( value class boolean-value -- constraint )
[ [ is-instance-of ] dip t--> ]
@ -74,7 +82,11 @@ M: #declare propagate-before
} cond 2nip ;
: propagate-predicate ( #call word -- infos )
[ in-d>> first value-info ] [ "predicating" word-prop ] bi*
#! We need to force the caller word to recompile when the class
#! is redefined, since now we're making assumptions but the
#! class definition itself.
[ in-d>> first value-info ]
[ "predicating" word-prop dup inlined-dependency depends-on ] bi*
predicate-output-infos 1array ;
: default-output-value-infos ( #call word -- infos )

2
basis/compiler/tree/tree.factor
View File

@ -17,7 +17,7 @@ TUPLE: #introduce < node out-d ;
: #introduce ( out-d -- node )
\ #introduce new swap >>out-d ;
TUPLE: #call < node word in-d out-d body method info ;
TUPLE: #call < node word in-d out-d body method class info ;
: #call ( inputs outputs word -- node )
\ #call new

2
basis/concurrency/locks/locks-tests.factor
View File

@ -174,7 +174,7 @@ threads sequences calendar accessors ;
] ;
[ lock-timeout-test ] [
linked-error-thread name>> "Lock timeout-er" =
thread>> name>> "Lock timeout-er" =
] must-fail-with
:: read/write-test ( -- )

45
basis/concurrency/locks/locks.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: deques dlists kernel threads continuations math
concurrency.conditions ;
concurrency.conditions combinators.short-circuit accessors ;
IN: concurrency.locks
! Simple critical sections
@ -16,13 +16,13 @@ TUPLE: lock threads owner reentrant? ;
<PRIVATE
: acquire-lock ( lock timeout -- )
over lock-owner
[ 2dup >r lock-threads r> "lock" wait ] when drop
self swap set-lock-owner ;
over owner>>
[ 2dup >r threads>> r> "lock" wait ] when drop
self >>owner drop ;
: release-lock ( lock -- )
f over set-lock-owner
lock-threads notify-1 ;
f >>owner
threads>> notify-1 ;
: do-lock ( lock timeout quot acquire release -- )
>r >r pick rot r> call ! use up timeout acquire
@ -34,8 +34,8 @@ TUPLE: lock threads owner reentrant? ;
PRIVATE>
: with-lock-timeout ( lock timeout quot -- )
pick lock-reentrant? [
pick lock-owner self eq? [
pick reentrant?>> [
pick owner>> self eq? [
2nip call
] [
(with-lock)
@ -56,44 +56,43 @@ TUPLE: rw-lock readers writers reader# writer ;
<PRIVATE
: add-reader ( lock -- )
dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;
[ 1+ ] change-reader# drop ;
: acquire-read-lock ( lock timeout -- )
over rw-lock-writer
[ 2dup >r rw-lock-readers r> "read lock" wait ] when drop
over writer>>
[ 2dup >r readers>> r> "read lock" wait ] when drop
add-reader ;
: notify-writer ( lock -- )
rw-lock-writers notify-1 ;
writers>> notify-1 ;
: remove-reader ( lock -- )
dup rw-lock-reader# 1- swap set-rw-lock-reader# ;
[ 1- ] change-reader# drop ;
: release-read-lock ( lock -- )
dup remove-reader
dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ;
dup reader#>> zero? [ notify-writer ] [ drop ] if ;
: acquire-write-lock ( lock timeout -- )
over rw-lock-writer pick rw-lock-reader# 0 > or
[ 2dup >r rw-lock-writers r> "write lock" wait ] when drop
self swap set-rw-lock-writer ;
over writer>> pick reader#>> 0 > or
[ 2dup >r writers>> r> "write lock" wait ] when drop
self >>writer drop ;
: release-write-lock ( lock -- )
f over set-rw-lock-writer
dup rw-lock-readers deque-empty?
[ notify-writer ] [ rw-lock-readers notify-all ] if ;
f >>writer
dup readers>> deque-empty?
[ notify-writer ] [ readers>> notify-all ] if ;
: reentrant-read-lock-ok? ( lock -- ? )
#! If we already have a write lock, then we can grab a read
#! lock too.
rw-lock-writer self eq? ;
writer>> self eq? ;
: reentrant-write-lock-ok? ( lock -- ? )
#! The only case where we have a writer and > 1 reader is
#! write -> read re-entrancy, and in this case we prohibit
#! a further write -> read -> write re-entrancy.
dup rw-lock-writer self eq?
swap rw-lock-reader# zero? and ;
{ [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
PRIVATE>

2
basis/concurrency/messaging/messaging-tests.factor
View File

@ -7,7 +7,7 @@ match quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data clear-deque ] unit-test
[ ] [ my-mailbox data>> clear-deque ] unit-test
[ "received" ] [
[

2
basis/help/syntax/syntax.factor
View File

@ -18,5 +18,5 @@ IN: help.syntax
: ABOUT:
scan-object
in get vocab
dup +inlined+ changed-definition
dup changed-definition
set-vocab-help ; parsing

2
basis/hints/hints.factor
View File

@ -55,7 +55,7 @@ IN: hints
: HINTS:
scan-word
[ +inlined+ changed-definition ]
[ redefined ]
[ parse-definition "specializer" set-word-prop ] bi ;
parsing

11
basis/multiline/multiline.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces parser lexer kernel sequences words quotations math ;
USING: namespaces parser lexer kernel sequences words quotations math
accessors ;
IN: multiline
: next-line-text ( -- str )
lexer get dup next-line lexer-line-text ;
lexer get dup next-line text>> ;
: (parse-here) ( -- )
next-line-text [
@ -22,7 +23,7 @@ IN: multiline
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get lexer-line-text [
lexer get text>> [
2dup start
[ rot dupd >r >r swap subseq % r> r> length + ] [
rot tail % "\n" % 0
@ -32,8 +33,8 @@ IN: multiline
: parse-multiline-string ( end-text -- str )
[
lexer get lexer-column swap (parse-multiline-string)
lexer get set-lexer-column
lexer get column>> swap (parse-multiline-string)
lexer get (>>column)
] "" make rest but-last ;
: <"

6
basis/prettyprint/prettyprint-tests.factor
View File

@ -195,11 +195,11 @@ DEFER: parse-error-file
: string-layout
{
"USING: debugger io kernel lexer ;"
"USING: accessors debugger io kernel ;"
"IN: prettyprint.tests"
": string-layout-test ( error -- )"
" \"Expected \" write dup unexpected-want expected>string write"
" \" but got \" write unexpected-got expected>string print ;"
" \"Expected \" write dup want>> expected>string write"
" \" but got \" write got>> expected>string print ;"
} ;

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

@ -115,10 +115,10 @@ M: object short-section? section-fits? ;
: pprint-section ( section -- )
dup short-section? [
dup section-style [ short-section ] with-style
dup style>> [ short-section ] with-style
] [
[ <long-section ]
[ dup section-style [ long-section ] with-style ]
[ dup style>> [ long-section ] with-style ]
[ long-section> ]
tri
] if ;

26
basis/stack-checker/backend/backend.factor
View File

@ -8,29 +8,6 @@ sets generic.standard.engines.tuple stack-checker.state
stack-checker.visitor stack-checker.errors ;
IN: stack-checker.backend
! Word properties we use
SYMBOL: visited
: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
: (redefined) ( word -- )
dup visited get key? [ drop ] [
[ reset-on-redefine reset-props ]
[ visited get conjoin ]
[
crossref get at keys
[ word? ] filter
[
[ reset-on-redefine [ word-prop ] with contains? ]
[ inline? ]
bi or
] filter
[ (redefined) ] each
] tri
] if ;
M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
: push-d ( obj -- ) meta-d get push ;
: pop-d ( -- obj )
@ -72,7 +49,7 @@ GENERIC: apply-object ( obj -- )
M: wrapper apply-object
wrapped>>
[ dup word? [ +called+ depends-on ] [ drop ] if ]
[ dup word? [ called-dependency depends-on ] [ drop ] if ]
[ push-literal ]
bi ;
@ -175,6 +152,7 @@ M: object apply-object push-literal ;
init-known-values
stack-visitor off
dependencies off
generic-dependencies off
[ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
[ finish-word current-effect ]
bi

2
basis/stack-checker/inlining/inlining.factor
View File

@ -140,7 +140,7 @@ SYMBOL: enter-out
] [ undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
[ +inlined+ depends-on ]
[ inlined-dependency depends-on ]
[
{
{ [ dup inline-recursive-label ] [ call-recursive-inline-word ] }

2
basis/stack-checker/known-words/known-words.factor
View File

@ -176,7 +176,7 @@ do-primitive alien-invoke alien-indirect alien-callback
SYMBOL: +primitive+
: non-inline-word ( word -- )
dup +called+ depends-on
dup called-dependency depends-on
{
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
{ [ dup "special" word-prop ] [ infer-special ] }

18
basis/stack-checker/state/state-tests.factor
View File

@ -9,22 +9,22 @@ definitions ;
SYMBOL: a
SYMBOL: b
[ ] [ a +called+ depends-on ] unit-test
[ ] [ a called-dependency depends-on ] unit-test
[ H{ { a +called+ } } ] [
[ a +called+ depends-on ] computing-dependencies
[ H{ { a called-dependency } } ] [
[ a called-dependency depends-on ] computing-dependencies
] unit-test
[ H{ { a +called+ } { b +inlined+ } } ] [
[ H{ { a called-dependency } { b inlined-dependency } } ] [
[
a +called+ depends-on b +inlined+ depends-on
a called-dependency depends-on b inlined-dependency depends-on
] computing-dependencies
] unit-test
[ H{ { a +inlined+ } { b +inlined+ } } ] [
[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
[
a +inlined+ depends-on
a +called+ depends-on
b +inlined+ depends-on
a inlined-dependency depends-on
a called-dependency depends-on
b inlined-dependency depends-on
] computing-dependencies
] unit-test

15
basis/stack-checker/state/state.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel definitions math
effects accessors words stack-checker.errors ;
effects accessors words fry classes.algebra stack-checker.errors
compiler.units ;
IN: stack-checker.state
: <value> ( -- value ) \ <value> counter ;
@ -88,9 +89,15 @@ SYMBOL: meta-r
SYMBOL: dependencies
: depends-on ( word how -- )
swap dependencies get dup [
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
] [ 3drop ] if ;
dependencies get dup
[ swap '[ , strongest-dependency ] change-at ] [ 3drop ] if ;
! Generic words that the current quotation depends on
SYMBOL: generic-dependencies
: depends-on-generic ( generic class -- )
generic-dependencies get dup
[ swap '[ null or , class-or ] change-at ] [ 3drop ] if ;
! Words we've inferred the stack effect of, for rollback
SYMBOL: recorded

10
basis/stack-checker/transforms/transforms.factor
View File

@ -46,7 +46,7 @@ SYMBOL: +transform-n+
] [ 2drop give-up-transform ] if ;
: apply-transform ( word -- )
[ +inlined+ depends-on ] [
[ inlined-dependency depends-on ] [
[ ]
[ +transform-quot+ word-prop ]
[ +transform-n+ word-prop ]
@ -55,7 +55,7 @@ SYMBOL: +transform-n+
] bi ;
: apply-macro ( word -- )
[ +inlined+ depends-on ] [
[ inlined-dependency depends-on ] [
[ ]
[ "macro" word-prop ]
[ "declared-effect" word-prop in>> length ]
@ -92,13 +92,13 @@ SYMBOL: +transform-n+
\ spread [ spread>quot ] 1 define-transform
\ (call-next-method) [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
[ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi
] 2 define-transform
! Constructors
\ boa [
dup tuple-class? [
dup +inlined+ depends-on
dup inlined-dependency depends-on
[ "boa-check" word-prop ]
[ tuple-layout '[ , <tuple-boa> ] ]
bi append
@ -107,7 +107,7 @@ SYMBOL: +transform-n+
\ new [
dup tuple-class? [
dup +inlined+ depends-on
dup inlined-dependency depends-on
dup all-slots rest-slice ! delegate slot
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
] [ drop f ] if

14
basis/tools/deploy/deploy-tests.factor
View File

@ -35,13 +35,13 @@ namespaces continuations layouts accessors ;
[ t ] [ 1200000 small-enough? ] unit-test
[ ] [ "tetris" shake-and-bake ] unit-test
[ t ] [ 1500000 small-enough? ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [ 2500000 small-enough? ] unit-test
! [ ] [ "tetris" shake-and-bake ] unit-test
!
! [ t ] [ 1500000 small-enough? ] unit-test
!
! [ ] [ "bunny" shake-and-bake ] unit-test
!
! [ t ] [ 2500000 small-enough? ] unit-test
{
"tools.deploy.test.1"

18
basis/tools/deploy/test/2/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-word-defs? f }
{ deploy-random? f }
{ deploy-name "tools.deploy.test.2" }
{ deploy-threads? t }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-reflection 2 }
{ deploy-ui? f }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-threads? t }
{ deploy-c-types? f }
{ deploy-random? f }
{ "stop-after-last-window?" t }
{ deploy-name "tools.deploy.test.2" }
{ deploy-io 2 }
{ deploy-word-defs? f }
}

6
basis/units/units.factor
View File

@ -39,7 +39,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
[ dimensions 2array ] bi@ =
[ dimensions-not-equal ] unless ;
: 2values ( dim dim -- val val ) [ dimensioned-value ] bi@ ;
: 2values ( dim dim -- val val ) [ value>> ] bi@ ;
: <dimension-op ( dim dim -- top bot val val )
2dup check-dimensions dup dimensions 2swap 2values ;
@ -56,8 +56,8 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
: d* ( d d -- d )
[ dup number? [ scalar ] when ] bi@
[ [ dimensioned-top ] bi@ append ] 2keep
[ [ dimensioned-bot ] bi@ append ] 2keep
[ [ top>> ] bi@ append ] 2keep
[ [ bot>> ] bi@ append ] 2keep
2values * dimension-op> ;
: d-neg ( d -- d ) -1 d* ;

5
core/assocs/assocs.factor
View File

@ -110,6 +110,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
2dup [ assoc-size ] bi@ + pick new-assoc
[ rot update ] keep [ swap update ] keep ;
: assoc-combine ( seq -- union )
H{ } clone [ dupd update ] reduce ;
: assoc-diff ( assoc1 assoc2 -- diff )
[ nip key? not ] curry assoc-filter ;
@ -186,7 +189,7 @@ M: sequence assoc-clone-like
>r >alist r> clone-like ;
M: sequence assoc-like
over sequence? [ like ] [ assoc-clone-like ] if ;
>r >alist r> like ;
M: sequence >alist ;

1
core/bootstrap/primitives.factor
View File

@ -35,6 +35,7 @@ H{ } clone sub-primitives set
H{ } clone dictionary set
H{ } clone new-classes set
H{ } clone changed-definitions set
H{ } clone changed-generics set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set

5
core/classes/algebra/algebra-tests.factor
View File

@ -310,3 +310,8 @@ SINGLETON: sb
SINGLETON: sc
[ sa ] [ sa { sa sb sc } min-class ] unit-test
[ +lt+ ] [ integer sequence class<=> ] unit-test
[ +lt+ ] [ sequence object class<=> ] unit-test
[ +gt+ ] [ object sequence class<=> ] unit-test
[ +eq+ ] [ integer integer class<=> ] unit-test

7
core/classes/algebra/algebra.factor
View File

@ -186,6 +186,13 @@ M: anonymous-complement (classes-intersect?)
[ [ rank-class ] bi@ < ]
} cond ;
: class<=> ( first second -- ? )
{
{ [ 2dup class<= not ] [ 2drop +gt+ ] }
{ [ 2dup swap class<= not ] [ 2drop +lt+ ] }
[ [ rank-class ] bi@ <=> ]
} cond ;
: class= ( first second -- ? )
[ class<= ] [ swap class<= ] 2bi and ;

1
core/classes/classes.factor
View File

@ -122,6 +122,7 @@ M: sequence implementors [ implementors ] gather ;
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup redefined
dup props>>
r> assoc-union >>props
dup predicate-word

6
core/classes/mixin/mixin.factor
View File

@ -63,8 +63,10 @@ TUPLE: check-mixin-class mixin ;
: remove-mixin-instance ( class mixin -- )
[
[ [ swap remove ] change-mixin-class ] keep
update-classes
[ class-usages update-methods ]
[ [ swap remove ] change-mixin-class ]
[ nip update-classes ]
2tri
] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;

6
core/classes/tuple/tuple.factor
View File

@ -227,9 +227,8 @@ M: tuple-class update-class
2drop
[
[ update-tuples-after ]
[ +inlined+ changed-definition ]
[ redefined ]
tri
bi
] each-subclass
]
[ define-new-tuple-class ]
@ -270,9 +269,6 @@ M: tuple-class define-tuple-class
tri* define-declared
] 3tri ;
M: tuple-class update-generic
over new-class? [ 2drop ] [ call-next-method ] if ;
M: tuple-class reset-class
[
dup "slots" word-prop [

9
core/compiler/units/units-tests.factor Normal file
View File

@ -0,0 +1,9 @@
IN: compiler.units.tests
USING: definitions compiler.units tools.test arrays sequences ;
[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test

54
core/compiler/units/units.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets ;
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math.order classes classes.algebra ;
IN: compiler.units
SYMBOL: old-definitions
@ -72,9 +73,51 @@ GENERIC: definitions-changed ( assoc obj -- )
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: strongest-dependency ( how1 how2 -- how )
[ called-dependency or ] bi@ max ;
: weakest-dependency ( how1 how2 -- how )
[ inlined-dependency or ] bi@ min ;
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
: (compiled-usages) ( word -- assoc )
#! If the word is not flushable anymore, we have to recompile
#! all words which flushable away a call (presumably when the
#! word was still flushable). If the word is flushable, we
#! don't have to recompile words that folded this away.
[ compiled-usage ]
[ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
[ after=? nip ] curry assoc-filter ;
: compiled-usages ( assoc -- assocs )
[ drop word? ] assoc-filter
[ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
: compiled-generic-usage ( word -- assoc )
compiled-generic-crossref get at ;
: (compiled-generic-usages) ( generic class -- assoc )
dup class? [
[ compiled-generic-usage ] dip
[ [ classes-intersect? ] [ null class<= ] bi or nip ]
curry assoc-filter
] [ 2drop f ] if ;
: compiled-generic-usages ( assoc -- assocs )
[ (compiled-generic-usages) ] { } assoc>map ;
: words-only ( assoc -- assoc' )
[ drop word? ] assoc-filter ;
: to-recompile ( -- seq )
changed-definitions get compiled-usages
changed-generics get compiled-generic-usages
append assoc-combine keys ;
: call-recompile-hook ( -- )
changed-definitions get [ drop word? ] assoc-filter
compiled-usages recompile-hook get call ;
to-recompile recompile-hook get call ;
: call-update-tuples-hook ( -- )
update-tuples-hook get call ;
@ -93,13 +136,16 @@ SYMBOL: update-tuples-hook
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
H{ } clone changed-generics set
H{ } clone outdated-tuples set
H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
: with-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
H{ } clone changed-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
H{ } clone new-classes set

31
core/definitions/definitions.factor
View File

@ -1,17 +1,38 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: definitions
USING: kernel sequences namespaces assocs graphs ;
USING: kernel sequences namespaces assocs graphs math math.order ;
ERROR: no-compilation-unit definition ;
SINGLETON: inlined-dependency
SINGLETON: flushed-dependency
SINGLETON: called-dependency
UNION: dependency
inlined-dependency
flushed-dependency
called-dependency ;
M: dependency <=>
[
{
called-dependency
flushed-dependency
inlined-dependency
} index
] bi@ <=> ;
SYMBOL: changed-definitions
SYMBOL: +inlined+
SYMBOL: +called+
: changed-definition ( defspec -- )
inlined-dependency swap changed-definitions get
[ set-at ] [ no-compilation-unit ] if* ;
: changed-definition ( defspec how -- )
swap changed-definitions get
SYMBOL: changed-generics
: changed-generic ( class generic -- )
changed-generics get
[ set-at ] [ no-compilation-unit ] if* ;
SYMBOL: new-classes

16
core/generic/generic.factor
View File

@ -53,22 +53,12 @@ GENERIC: next-method-quot* ( class generic combination -- quot )
TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
over class? over generic? and [
2dup [ class? ] [ generic? ] bi* and [
\ check-method boa throw
] unless ; inline
: affected-methods ( class generic -- seq )
"methods" word-prop swap
[ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
values ;
GENERIC# update-generic 1 ( class generic -- )
M: class update-generic
affected-methods [ +called+ changed-definition ] each ;
: with-methods ( class generic quot -- )
[ drop update-generic ]
[ drop changed-generic ]
[ [ "methods" word-prop ] dip call ]
[ drop make-generic drop ]
3tri ; inline
@ -168,7 +158,7 @@ M: method-body smart-usage
M: sequence update-methods ( class seq -- )
implementors [
[ update-generic ] [ make-generic drop ] 2bi
[ changed-generic ] [ make-generic drop ] 2bi
] with each ;
: define-generic ( word combination -- )

91
core/words/words.factor
View File

@ -101,60 +101,79 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
[ drop crossref? ] assoc-filter
[ "compiled-uses" set-word-prop ]
[ compiled-crossref get add-vertex* ]
2bi ;
SYMBOL: compiled-generic-crossref
compiled-generic-crossref global [ H{ } assoc-like ] change-at
: (compiled-xref) ( word dependencies word-prop variable -- )
[ [ set-word-prop ] curry ]
[ [ get add-vertex* ] curry ]
bi* 2bi ;
: compiled-xref ( word dependencies generic-dependencies -- )
[ [ drop crossref? ] assoc-filter ] bi@
[ over ] dip
[ "compiled-uses" compiled-crossref (compiled-xref) ]
[ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
2bi* ;
: (compiled-unxref) ( word word-prop variable -- )
[ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]
[ drop [ f swap set-word-prop ] curry ]
2bi bi ;
: compiled-unxref ( word -- )
[
dup "compiled-uses" word-prop
compiled-crossref get remove-vertex*
]
[ f "compiled-uses" set-word-prop ] bi ;
[ "compiled-uses" compiled-crossref (compiled-unxref) ]
[ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
bi ;
: delete-compiled-xref ( word -- )
dup compiled-unxref
compiled-crossref get delete-at ;
[ compiled-unxref ]
[ compiled-crossref get delete-at ]
[ compiled-generic-crossref get delete-at ]
tri ;
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
GENERIC: inline? ( word -- ? )
: compiled-usages ( assoc -- seq )
clone [
dup [
M: word inline? "inline" word-prop ;
SYMBOL: visited
: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
: (redefined) ( word -- )
dup visited get key? [ drop ] [
[ reset-on-redefine reset-props ]
[ visited get conjoin ]
[
crossref get at keys
[ word? ] filter
[
[ compiled-usage ] dip
+inlined+ eq? [
[ nip +inlined+ eq? ] assoc-filter
] when
] dip swap update
] curry assoc-each
] keep keys ;
[ reset-on-redefine [ word-prop ] with contains? ]
[ inline? ]
bi or
] filter
[ (redefined) ] each
] tri
] if ;
GENERIC: redefined ( word -- )
M: object redefined drop ;
: redefined ( word -- )
[ H{ } clone visited [ (redefined) ] with-variable ]
[ changed-definition ]
bi ;
: define ( word def -- )
[ ] like
over unxref
over redefined
>>def
dup +inlined+ changed-definition
dup crossref? [ dup xref ] when drop ;
: set-stack-effect ( effect word -- )
2dup "declared-effect" word-prop = [ 2drop ] [
swap
[ "declared-effect" set-word-prop ]
[
drop
dup primitive? [ drop ] [
[ redefined ] [ +inlined+ changed-definition ] bi
] if
] 2bi
[ drop dup primitive? [ dup redefined ] unless drop ] 2bi
] if ;
: define-declared ( word def effect -- )
@ -226,10 +245,6 @@ ERROR: bad-create name vocab ;
: constructor-word ( name vocab -- word )
>r "<" swap ">" 3append r> create ;
GENERIC: inline? ( word -- ? )
M: word inline? "inline" word-prop ;
PREDICATE: parsing-word < word "parsing" word-prop ;
: delimiter? ( obj -- ? )

4
extra/classes/tuple/lib/lib.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel macros sequences slots words classes.tuple
quotations combinators ;
quotations combinators accessors ;
IN: classes.tuple.lib
: reader-slots ( seq -- quot )
[ slot-spec-reader 1quotation ] map [ cleave ] curry ;
[ reader>> 1quotation ] map [ cleave ] curry ;
MACRO: >tuple< ( class -- )
all-slots rest-slice reader-slots ;

4
extra/fjsc/fjsc.factor
View File

@ -353,11 +353,11 @@ M: quotation fjsc-parse ( object -- ast )
] with-string-writer ;
: fjsc-compile* ( string -- string )
'statement' parse parse-result-ast fjsc-compile ;
'statement' parse ast>> fjsc-compile ;
: fc* ( string -- string )
[
'statement' parse parse-result-ast values>> do-expressions
'statement' parse ast>> values>> do-expressions
] { } make [ write ] each ;

2
extra/inverse/inverse.factor
View File

@ -208,7 +208,7 @@ DEFER: _
: slot-readers ( class -- quot )
all-slots rest ! tail gets rid of delegate
[ slot-spec-reader 1quotation [ keep ] curry ] map concat
[ reader>> 1quotation [ keep ] curry ] map concat
[ ] like [ drop ] compose ;
: ?wrapped ( object -- wrapped )

7
extra/json/reader/reader.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser-combinators namespaces sequences promises strings
assocs math math.parser math.vectors math.functions math.order
lists hashtables ascii ;
lists hashtables ascii accessors ;
IN: json.reader
! Grammar for JSON from RFC 4627
@ -169,11 +169,12 @@ LAZY: 'value' ( -- parser )
'array' ,
'number' ,
] [<|>] spaced ;
ERROR: could-not-parse-json ;
: json> ( string -- object )
#! Parse a json formatted string to a factor object
'value' parse dup nil? [
"Could not parse json" throw
could-not-parse-json
] [
car parse-result-parsed
car parsed>>
] if ;

2
extra/lists/lazy/lazy.factor
View File

@ -24,7 +24,7 @@ TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
[ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone
[ set-promise-value ] keep ;
swap >>value ;
M: lazy-cons car ( lazy-cons -- car )
car>> force ;

2
extra/morse/morse.factor
View File

@ -116,7 +116,7 @@ LAZY: 'morse-words' ( -- parser )
PRIVATE>
: morse> ( str -- str )
'morse-words' parse car parse-result-parsed [
'morse-words' parse car parsed>> [
[
>string morse>ch
] map >string

16
extra/nehe/4/4.factor
View File

@ -1,5 +1,5 @@
USING: arrays kernel math opengl opengl.gl opengl.glu ui
ui.gadgets ui.render threads ;
ui.gadgets ui.render threads accessors ;
IN: nehe.4
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
@ -10,8 +10,8 @@ TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
: <nehe4-gadget> ( -- gadget )
nehe4-gadget new-gadget
0.0 over set-nehe4-gadget-rtri
0.0 over set-nehe4-gadget-rquad ;
0.0 >>rtri
0.0 >>rquad ;
M: nehe4-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
@ -53,22 +53,22 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
1.0 -1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f
] do-state
dup nehe4-gadget-rtri 0.2 + over set-nehe4-gadget-rtri
dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ;
[ 0.2 + ] change-rtri
[ 0.15 - ] change-rquad drop ;
: nehe4-update-thread ( gadget -- )
dup nehe4-gadget-quit? [ drop ] [
dup quit?>> [ drop ] [
redraw-interval sleep
dup relayout-1
nehe4-update-thread
] if ;
M: nehe4-gadget graft* ( gadget -- )
[ f swap set-nehe4-gadget-quit? ] keep
f >>quit?
[ nehe4-update-thread ] in-thread drop ;
M: nehe4-gadget ungraft* ( gadget -- )
t swap set-nehe4-gadget-quit? ;
t >>quit? drop ;
: run4 ( -- )
<nehe4-gadget> "NeHe Tutorial 4" open-window ;

18
extra/nehe/5/5.factor
View File

@ -1,5 +1,5 @@
USING: arrays kernel math opengl opengl.gl opengl.glu ui
ui.gadgets ui.render threads ;
ui.gadgets ui.render threads accessors ;
IN: nehe.5
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
@ -9,8 +9,8 @@ TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
: <nehe5-gadget> ( -- gadget )
nehe5-gadget new-gadget
0.0 over set-nehe5-gadget-rtri
0.0 over set-nehe5-gadget-rquad ;
0.0 >>rtri
0.0 >>rquad ;
M: nehe5-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
@ -103,11 +103,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
1.0 -1.0 1.0 glVertex3f
1.0 -1.0 -1.0 glVertex3f
] do-state
dup nehe5-gadget-rtri 0.2 + over set-nehe5-gadget-rtri
dup nehe5-gadget-rquad 0.15 - swap set-nehe5-gadget-rquad ;
[ 0.2 + ] change-rtri
[ 0.15 - ] change-rquad drop ;
: nehe5-update-thread ( gadget -- )
dup nehe5-gadget-quit? [
dup quit?>> [
drop
] [
redraw-interval sleep
@ -116,11 +116,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
] if ;
M: nehe5-gadget graft* ( gadget -- )
[ f swap set-nehe5-gadget-quit? ] keep
[ nehe5-update-thread ] in-thread drop ;
f >>quit?
[ nehe5-update-thread ] in-thread drop ;
M: nehe5-gadget ungraft* ( gadget -- )
t swap set-nehe5-gadget-quit? ;
t >>quit? drop ;
: run5 ( -- )

6
extra/ori/ori.factor
View File

@ -1,5 +1,5 @@
USING: kernel namespaces
USING: kernel namespaces accessors
math math.constants math.functions math.matrices math.vectors
sequences splitting grouping self math.trig ;
@ -11,9 +11,9 @@ C: <ori> ori
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ori> ( -- val ) self> ori-val ;
: ori> ( -- val ) self> val>> ;
: >ori ( val -- ) self> set-ori-val ;
: >ori ( val -- ) self> (>>val) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

28
extra/parser-combinators/parser-combinators.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: lists lists.lazy promises kernel sequences strings math
arrays splitting quotations combinators namespaces
unicode.case unicode.categories sequences.deep ;
unicode.case unicode.categories sequences.deep accessors ;
IN: parser-combinators
! Parser combinator protocol
@ -13,11 +13,13 @@ M: promise parse ( input parser -- list )
TUPLE: parse-result parsed unparsed ;
ERROR: cannot-parse input ;
: parse-1 ( input parser -- result )
dupd parse dup nil? [
"Cannot parse " rot append throw
rot cannot-parse
] [
nip car parse-result-parsed
nip car parsed>>
] if ;
C: <parse-result> parse-result
@ -26,12 +28,12 @@ C: <parse-result> parse-result
<parse-result> 1list ;
: parse-result-parsed-slice ( parse-result -- slice )
dup parse-result-parsed empty? [
parse-result-unparsed 0 0 rot <slice>
dup parsed>> empty? [
unparsed>> 0 0 rot <slice>
] [
dup parse-result-unparsed
dup slice-from [ rot parse-result-parsed length - ] keep
rot slice-seq <slice>
dup unparsed>>
dup from>> [ rot parsed>> length - ] keep
rot seq>> <slice>
] if ;
: string= ( str1 str2 ignore-case -- ? )
@ -132,7 +134,7 @@ TUPLE: and-parser parsers ;
: <&> ( parser1 parser2 -- parser )
over and-parser? [
>r and-parser-parsers r> suffix
>r parsers>> r> suffix
] [
2array
] if and-parser boa ;
@ -142,11 +144,11 @@ TUPLE: and-parser parsers ;
: and-parser-parse ( list p1 -- list )
swap [
dup parse-result-unparsed rot parse
dup unparsed>> rot parse
[
>r parse-result-parsed r>
[ parse-result-parsed 2array ] keep
parse-result-unparsed <parse-result>
>r parsed>> r>
[ parsed>> 2array ] keep
unparsed>> <parse-result>
] lazy-map-with
] lazy-map-with lconcat ;

4
extra/peg/ebnf/ebnf.factor
View File

@ -508,10 +508,10 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: check-parse-result ( result -- result )
dup [
dup parse-result-remaining [ blank? ] trim empty? [
dup remaining>> [ blank? ] trim empty? [
[
"Unable to fully parse EBNF. Left to parse was: " %
parse-result-remaining %
remaining>> %
] "" make throw
] unless
] [

9
extra/pos/pos.factor
View File

@ -1,5 +1,6 @@
USING: kernel math math.functions math.vectors sequences self ;
USING: kernel math math.functions math.vectors sequences self
accessors ;
IN: pos
@ -9,13 +10,13 @@ TUPLE: pos val ;
C: <pos> pos
: pos> ( -- val ) self> pos-val ;
: pos> ( -- val ) self> val>> ;
: >pos ( val -- ) self> set-pos-val ;
: >pos ( val -- ) self> (>>val) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: distance ( pos pos -- n ) pos-val swap pos-val v- [ sq ] map sum sqrt ;
: distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ;
: move-by ( point -- ) pos> v+ >pos ;

8
extra/regexp/regexp.factor
View File

@ -270,14 +270,14 @@ TUPLE: regexp source parser ignore-case? ;
] keep regexp boa ;
: do-ignore-case ( string regexp -- string regexp )
dup regexp-ignore-case? [ >r >upper r> ] when ;
dup ignore-case?>> [ >r >upper r> ] when ;
: matches? ( string regexp -- ? )
do-ignore-case regexp-parser just parse nil? not ;
do-ignore-case parser>> just parse nil? not ;
: match-head ( string regexp -- end )
do-ignore-case regexp-parser parse dup nil?
[ drop f ] [ car parse-result-unparsed from>> ] if ;
do-ignore-case parser>> parse dup nil?
[ drop f ] [ car unparsed>> from>> ] if ;
! Literal syntax for regexps
: parse-options ( string -- ? )

9
extra/state-machine/state-machine.factor
View File

@ -1,5 +1,6 @@
USING: kernel parser lexer strings math namespaces sequences words io
arrays quotations debugger kernel.private sequences.private ;
USING: kernel parser lexer strings math namespaces
sequences words io arrays quotations debugger accessors
sequences.private ;
IN: state-machine
: STATES:
@ -20,9 +21,9 @@ M: missing-state error.
! quot is ( state string -- output-string )
[ missing-state ] <array> dup
[
[ >r dup dup state-data swap state-place r> ] %
[ >r dup [ data>> ] [ place>> ] bi r> ] %
[ swapd bounds-check dispatch ] curry ,
[ each pick set-state-place swap set-state-data ] %
[ each pick (>>place) swap (>>date) ] %
] [ ] make [ over make ] curry ;
: define-machine ( word state-class -- )

10
extra/turing/turing.factor
View File

@ -1,6 +1,6 @@
IN: turing
USING: arrays assocs io kernel math namespaces
prettyprint sequences strings vectors words ;
prettyprint sequences strings vectors words accessors ;
IN: turing
! A turing machine simulator.
@ -55,9 +55,9 @@ SYMBOL: tape
: turing-step ( -- )
#! Do one step of the turing machine.
next-state
dup state-sym set-sym
dup state-dir position [ + ] change
state-next state set ;
dup sym>> set-sym
dup dir>> position [ + ] change
next>> state set ;
: c ( -- )
#! Print current turing machine state.