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

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

db4
John Benediktsson 2008-09-19 10:23:39 -07:00
parent edc1a27fcd 005cdd4d3a
commit 36797a09d2
46 changed files with 348 additions and 184 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bootstrap/random/random.factor
View File

@ -13,4 +13,4 @@ IN: bootstrap.random
[
[ 32 random-bits ] with-system-random
<mersenne-twister> random-generator set-global
] "generator.random" add-init-hook
] "bootstrap.random" add-init-hook

7
basis/core-foundation/fsevents/fsevents.factor
View File

@ -3,13 +3,10 @@
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
continuations combinators core-foundation
core-foundation.run-loop io.encodings.utf8 destructors ;
core-foundation.run-loop core-foundation.run-loop.thread
io.encodings.utf8 destructors ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! FSEventStream API, Leopard only !
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
: kFSEventStreamCreateFlagWatchRoot 4 ; inline

2
basis/core-foundation/run-loop/run-loop.factor
View File

@ -35,5 +35,3 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
: start-run-loop-thread ( -- )
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook

8
basis/core-foundation/run-loop/thread/thread.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: init core-foundation.run-loop ;
IN: core-foundation.run-loop.thread
! Load this vocabulary if you need a run loop running.
[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook

2
basis/globs/globs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser-combinators regexp lists sequences kernel
USING: parser-combinators parser-combinators.regexp lists sequences kernel
promises strings unicode.case ;
IN: globs

57
basis/io/launcher/launcher.factor
View File

@ -99,10 +99,12 @@ M: process hashcode* handle>> hashcode* ;
GENERIC: >process ( obj -- process )
ERROR: process-already-started ;
ERROR: process-already-started process ;
M: process-already-started summary
drop "Process has already been started once" ;
M: process-already-started error.
"Process has already been started" print nl
"Launch descriptor:" print nl
process>> . ;
M: process >process
dup process-started? [
@ -116,7 +118,14 @@ HOOK: current-process-handle io-backend ( -- handle )
HOOK: run-process* io-backend ( process -- handle )
ERROR: process-was-killed ;
ERROR: process-was-killed process ;
M: process-was-killed error.
"Process was killed as a result of a call to" print
"kill-process, or a timeout" print
nl
"Launch descriptor:" print nl
process>> . ;
: wait-for-process ( process -- status )
[
@ -145,10 +154,13 @@ M: process-failed error.
"Launch descriptor:" print nl
process>> . ;
: try-process ( desc -- )
run-process dup wait-for-process dup zero?
: wait-for-success ( process -- )
dup wait-for-process dup zero?
[ 2drop ] [ process-failed ] if ;
: try-process ( desc -- )
run-process wait-for-success ;
HOOK: kill-process* io-backend ( handle -- )
: kill-process ( process -- )
@ -167,7 +179,7 @@ M: object run-pipeline-element
3bi
wait-for-process ;
: <process-reader*> ( process encoding -- process stream )
: <process-reader*> ( desc encoding -- stream process )
[
>r (pipe) {
[ |dispose drop ]
@ -178,13 +190,18 @@ M: object run-pipeline-element
]
[ out>> dispose ]
[ in>> <input-port> ]
} cleave r> <decoder>
} cleave r> <decoder> swap
] with-destructors ;
: <process-reader> ( desc encoding -- stream )
<process-reader*> nip ; inline
<process-reader*> drop ; inline
: <process-writer*> ( process encoding -- process stream )
: with-process-reader ( desc encoding quot -- )
[ <process-reader*> ] dip
swap [ with-input-stream ] dip
wait-for-success ; inline
: <process-writer*> ( desc encoding -- stream process )
[
>r (pipe) {
[ |dispose drop ]
@ -195,13 +212,18 @@ M: object run-pipeline-element
]
[ in>> dispose ]
[ out>> <output-port> ]
} cleave r> <encoder>
} cleave r> <encoder> swap
] with-destructors ;
: <process-writer> ( desc encoding -- stream )
<process-writer*> nip ; inline
<process-writer*> drop ; inline
: <process-stream*> ( process encoding -- process stream )
: with-process-writer ( desc encoding quot -- )
[ <process-writer*> ] dip
swap [ with-output-stream ] dip
wait-for-success ; inline
: <process-stream*> ( desc encoding -- stream process )
[
>r (pipe) (pipe) {
[ [ |dispose drop ] bi@ ]
@ -213,11 +235,16 @@ M: object run-pipeline-element
]
[ [ out>> dispose ] [ in>> dispose ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex>
} 2cleave r> <encoder-duplex> swap
] with-destructors ;
: <process-stream> ( desc encoding -- stream )
<process-stream*> nip ; inline
<process-stream*> drop ; inline
: with-process-stream ( desc encoding quot -- )
[ <process-stream*> ] dip
swap [ with-stream ] dip
wait-for-success ; inline
: notify-exit ( process status -- )
>>status

7
basis/io/windows/nt/files/files-tests.factor
View File

@ -4,8 +4,12 @@ IN: io.windows.nt.files.tests
[ f ] [ "\\foo" absolute-path? ] unit-test
[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test
[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test
[ t ] [ "c:\\foo" absolute-path? ] unit-test
[ t ] [ "c:" absolute-path? ] unit-test
[ t ] [ "c:\\" absolute-path? ] unit-test
[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
@ -26,6 +30,9 @@ IN: io.windows.nt.files.tests
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test
[ t ] [ "\\\\?\\c:" root-directory? ] unit-test
[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test
[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test

13
basis/io/windows/nt/files/files.factor
View File

@ -20,11 +20,14 @@ M: winnt cd
M: winnt root-directory? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] }
{ [ dup trim-right-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
[ f ]
} cond nip ;
{ [ dup empty? ] [ drop f ] }
{ [ dup [ path-separator? ] all? ] [ drop t ] }
{ [ dup trim-right-separators { [ length 2 = ]
[ second CHAR: : = ] } 1&& ] [ drop t ] }
{ [ dup unicode-prefix head? ]
[ trim-right-separators length unicode-prefix length 2 + = ] }
[ drop f ]
} cond ;
ERROR: not-absolute-path ;

12
basis/opengl/opengl.factor
View File

@ -16,8 +16,6 @@ IN: opengl
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
[ first2 [ >fixnum ] bi@ ] bi@ ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gl-color ( color -- ) first4 glColor4d ; inline
: gl-clear-color ( color -- )
@ -27,13 +25,11 @@ IN: opengl
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
: color>raw ( object -- r g b a )
>rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
>rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
: set-color ( object -- ) color>raw glColor4d ;
: set-color ( object -- ) color>raw glColor4d ;
: set-clear-color ( object -- ) color>raw glClearColor ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gl-error ( -- )
glGetError dup zero? [
"GL error: " over gluErrorString append throw
@ -53,7 +49,9 @@ IN: opengl
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
: (all-enabled-client-state) ( seq quot -- )
over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline
[ dup [ glEnableClientState ] each ] dip
dip
[ glDisableClientState ] each ; inline
MACRO: all-enabled ( seq quot -- )
>r words>values r> [ (all-enabled) ] 2curry ;

2
basis/random/unix/unix.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io io.files kernel namespaces random
io.encodings.binary init accessors system ;
IN: random.unix

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

@ -96,7 +96,7 @@ IN: stack-checker.transforms
\ boa [
dup tuple-class? [
dup inlined-dependency depends-on
[ "boa-check" word-prop ]
[ "boa-check" word-prop [ ] or ]
[ tuple-layout '[ _ <tuple-boa> ] ]
bi append
] [ drop f ] if

12
basis/tools/deploy/backend/backend.factor
View File

@ -18,12 +18,8 @@ IN: tools.deploy.backend
: image-name ( vocab bundle-name -- str )
prepend-path ".image" append ;
: (copy-lines) ( stream -- )
dup stream-readln dup
[ print flush (copy-lines) ] [ 2drop ] if ;
: copy-lines ( stream -- )
[ (copy-lines) ] with-disposal ;
: copy-lines ( -- )
readln [ print flush copy-lines ] when* ;
: run-with-output ( arguments -- )
<process>
@ -31,9 +27,7 @@ IN: tools.deploy.backend
+stdout+ >>stderr
+closed+ >>stdin
+low-priority+ >>priority
utf8 <process-reader*>
copy-lines
wait-for-process zero? [ "Deployment failed" throw ] unless ;
utf8 [ copy-lines ] with-process-reader ;
: make-boot-image ( -- )
#! If stage1 image doesn't exist, create one.

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

@ -4,7 +4,7 @@ USING: accessors qualified io.streams.c init fry namespaces make
assocs kernel parser lexer strings.parser tools.deploy.config
vocabs sequences words words.private memory kernel.private
continuations io prettyprint vocabs.loader debugger system
strings sets vectors quotations byte-arrays ;
strings sets vectors quotations byte-arrays sorting ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
@ -29,6 +29,7 @@ IN: tools.deploy.shaker
"cpu.x86" init-hooks get delete-at
"command-line" init-hooks get delete-at
"libc" init-hooks get delete-at
"system" init-hooks get delete-at
deploy-threads? get [
"threads" init-hooks get delete-at
] unless
@ -36,7 +37,12 @@ IN: tools.deploy.shaker
"io.thread" init-hooks get delete-at
] unless
strip-io? [
"io.files" init-hooks get delete-at
"io.backend" init-hooks get delete-at
] when
strip-dictionary? [
"compiler.units" init-hooks get delete-at
"tools.vocabs" init-hooks get delete-at
] when ;
: strip-debugger ( -- )
@ -74,30 +80,50 @@ IN: tools.deploy.shaker
: strip-word-props ( stripped-props words -- )
"Stripping word properties" show
[
[
props>> swap
'[ drop _ member? not ] assoc-filter sift-assoc
dup assoc-empty? [ drop f ] [ >alist >vector ] if
] keep (>>props)
] with each ;
swap '[
[
[ drop _ member? not ] assoc-filter sift-assoc
>alist f like
] change-props drop
] each
] [
"Remaining word properties:" print
[ props>> keys ] gather .
] [
H{ } clone '[
[ [ _ [ ] cache ] map ] change-props drop
] each
] tri ;
: stripped-word-props ( -- seq )
[
strip-dictionary? deploy-compiler? get and [
{
"combination"
"members"
"methods"
} %
] when
strip-dictionary? [
{
"alias"
"boa-check"
"cannot-infer"
"coercer"
"combination"
"compiled-effect"
"compiled-generic-uses"
"compiled-uses"
"constraints"
"custom-inlining"
"declared-effect"
"default"
"default-method"
"default-output-classes"
"derived-from"
"engines"
"forgotten"
"identities"
"if-intrinsics"
"infer"
"inferred-effect"
@ -114,11 +140,11 @@ IN: tools.deploy.shaker
"local-writer?"
"local?"
"macro"
"members"
"memo-quot"
"mixin"
"method-class"
"method-generic"
"methods"
"modular-arithmetic"
"no-compile"
"optimizer-hooks"
"outputs"
@ -126,9 +152,12 @@ IN: tools.deploy.shaker
"predicate"
"predicate-definition"
"predicating"
"primitive"
"reader"
"reading"
"recursive"
"register"
"register-size"
"shuffle"
"slot-names"
"slots"
@ -210,9 +239,12 @@ IN: tools.deploy.shaker
"alarms"
"tools"
"io.launcher"
"random"
} strip-vocab-globals %
strip-dictionary? [
"libraries" "alien" lookup ,
{ } { "cpu" } strip-vocab-globals %
{
@ -230,6 +262,7 @@ IN: tools.deploy.shaker
compiled-generic-crossref
compiler.units:recompile-hook
compiler.units:update-tuples-hook
compiler.units:definition-observers
definitions:crossref
interactive-vocabs
layouts:num-tags
@ -244,6 +277,7 @@ IN: tools.deploy.shaker
vocabs:dictionary
vocabs:load-vocab-hook
word
parser-notes
} %
{ } { "math.partial-dispatch" } strip-vocab-globals %
@ -273,7 +307,7 @@ IN: tools.deploy.shaker
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
"<computer>" "inference.dataflow" lookup [ , ] when*
"<value>" "stack-checker.state" lookup [ , ] when*
"windows-messages" "windows.messages" lookup [ , ] when*

64
basis/tools/deploy/shaker/strip-cocoa.factor
View File

@ -1,30 +1,50 @@
USING: cocoa cocoa.messages cocoa.application cocoa.nibs
assocs namespaces kernel words compiler.units sequences
ui ui.cocoa ;
! Copyright (C) 2007, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
namespaces kernel kernel.private words compiler.units sequences
ui ui.cocoa init ;
IN: tools.deploy.shaker.cocoa
: pool ( obj -- obj' ) \ pool get [ ] cache ;
: pool-array ( obj -- obj' ) [ pool ] map pool ;
: pool-keys ( assoc -- assoc' ) [ [ pool-array ] dip ] assoc-map ;
: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
IN: cocoa.application
: objc-error ( error -- ) die ;
[ [ die ] 19 setenv ] "cocoa.application" add-init-hook
"stop-after-last-window?" get
global [
stop-after-last-window? set
[ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
H{ } clone \ pool [
global [
stop-after-last-window? set
! Only keeps those methods that we actually call
sent-messages get super-sent-messages get assoc-union
objc-methods [ assoc-intersect ] change
[ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
sent-messages get
super-sent-messages get
[ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
super-message-senders [ assoc-intersect ] change
message-senders [ assoc-intersect ] change
! Only keeps those methods that we actually call
sent-messages get super-sent-messages get assoc-union
objc-methods [ assoc-intersect pool-values ] change
sent-messages off
super-sent-messages off
sent-messages get
super-sent-messages get
[ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
super-message-senders [ assoc-intersect pool-keys ] change
message-senders [ assoc-intersect pool-keys ] change
alien>objc-types off
objc>alien-types off
sent-messages off
super-sent-messages off
! We need this for strip-stack-traces to work fully
{ message-senders super-message-senders }
[ get values compile ] each
] bind
alien>objc-types off
objc>alien-types off
! We need this for strip-stack-traces to work fully
{ message-senders super-message-senders }
[ get values compile ] each
] bind
] with-variable

5
basis/validators/validators.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets
math.parser math.ranges assocs regexp unicode.categories arrays
hashtables words classes quotations xmode.catalog ;
math.parser math.ranges assocs parser-combinators.regexp
unicode.categories arrays hashtables words classes quotations
xmode.catalog ;
IN: validators
: v-default ( str def -- str )

2
basis/xmode/loader/loader.factor
View File

@ -1,7 +1,7 @@
USING: xmode.loader.syntax xmode.tokens xmode.rules
xmode.keyword-map xml.data xml.utilities xml assocs kernel
combinators sequences math.parser namespaces parser
xmode.utilities regexp io.files accessors ;
xmode.utilities parser-combinators.regexp io.files accessors ;
IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler

4
basis/xmode/loader/syntax/syntax.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors xmode.tokens xmode.rules xmode.keyword-map
xml.data xml.utilities xml assocs kernel combinators sequences
math.parser namespaces make parser lexer xmode.utilities regexp
io.files ;
math.parser namespaces make parser lexer xmode.utilities
parser-combinators.regexp io.files ;
IN: xmode.loader.syntax
SYMBOL: ignore-case?

6
basis/xmode/marker/marker.factor
View File

@ -3,9 +3,9 @@
IN: xmode.marker
USING: kernel namespaces make xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators
strings regexp splitting parser-combinators ascii unicode.case
combinators.short-circuit accessors ;
xmode.catalog sequences math assocs combinators strings
parser-combinators.regexp splitting parser-combinators ascii
unicode.case combinators.short-circuit accessors ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker

3
basis/xmode/rules/rules.factor
View File

@ -1,5 +1,6 @@
USING: accessors xmode.tokens xmode.keyword-map kernel
sequences vectors assocs strings memoize regexp unicode.case ;
sequences vectors assocs strings memoize unicode.case
parser-combinators.regexp ;
IN: xmode.rules
TUPLE: string-matcher string ignore-case? ;

2
build-support/factor.sh
View File

@ -464,7 +464,7 @@ make_boot_image() {
}
install_build_system_apt() {
sudo apt-get --yes install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
sudo apt-get --yes install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
check_ret sudo
}

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

@ -125,7 +125,8 @@ ERROR: bad-superclass class ;
} cond ;
: boa-check-quot ( class -- quot )
all-slots [ class>> instance-check-quot ] map spread>quot ;
all-slots [ class>> instance-check-quot ] map spread>quot
f like ;
: define-boa-check ( class -- )
dup boa-check-quot "boa-check" set-word-prop ;
@ -311,7 +312,7 @@ M: tuple-class new
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop call ]
[ "boa-check" word-prop [ call ] when* ]
[ tuple-layout ]
bi <tuple-boa> ;

13
core/io/files/files.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations destructors
io.encodings io.encodings.binary init accessors math.order ;
USING: io.backend io.files.private io hashtables kernel
kernel.private math memory namespaces sequences strings assocs
arrays definitions system combinators splitting sbufs
continuations destructors io.encodings io.encodings.binary init
accessors math.order ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@ -194,7 +195,9 @@ SYMBOL: current-directory
[
cwd current-directory set-global
image parent-directory cwd prepend-path "resource-path" set
13 getenv cwd prepend-path \ image set-global
14 getenv cwd prepend-path \ vm set-global
image parent-directory "resource-path" set-global
] "io.files" add-init-hook
: resource-path ( path -- newpath )

8
core/system/system.factor
View File

@ -55,15 +55,15 @@ UNION: unix bsd solaris linux ;
PRIVATE>
: image ( -- path ) \ image get-global ;
: vm ( -- path ) \ vm get-global ;
[
8 getenv string>cpu \ cpu set-global
9 getenv string>os \ os set-global
] "system" add-init-hook
: image ( -- path ) 13 getenv ;
: vm ( -- path ) 14 getenv ;
: embedded? ( -- ? ) 15 getenv ;
: os-envs ( -- assoc )

18
extra/hello-world/deploy.factor
View File

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

2
extra/mason/common/common.factor
View File

@ -51,7 +51,7 @@ SYMBOL: stamp
with-directory ;
: git-id ( -- id )
{ "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
{ "git" "show" } utf8 [ readln ] with-process-reader
" " split second ;
: ?prepare-build-machine ( -- )

0
extra/regexp/authors.txt → extra/parser-combinators/regexp/authors.txt
View File

4
extra/regexp/regexp-tests.factor → extra/parser-combinators/regexp/regexp-tests.factor
View File

@ -1,5 +1,5 @@
USING: regexp tools.test kernel ;
IN: regexp-tests
USING: parser-combinators.regexp tools.test kernel ;
IN: parser-combinators.regexp.tests
[ f ] [ "b" "a*" f <regexp> matches? ] unit-test
[ t ] [ "" "a*" f <regexp> matches? ] unit-test

2
extra/regexp/regexp.factor → extra/parser-combinators/regexp/regexp.factor
View File

@ -3,7 +3,7 @@ namespaces parser lexer parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order
assocs prettyprint.backend memoize unicode.case unicode.categories
combinators.short-circuit accessors make io ;
IN: regexp
IN: parser-combinators.regexp
<PRIVATE

0
extra/regexp/summary.txt → extra/parser-combinators/regexp/summary.txt
View File

0
extra/regexp/tags.txt → extra/parser-combinators/regexp/tags.txt
View File

0
unfinished/regexp2/authors.txt → unfinished/regexp/authors.txt
View File

2
unfinished/regexp2/backend/backend.factor → unfinished/regexp/backend/backend.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors hashtables kernel math state-tables vars vectors ;
IN: regexp2.backend
IN: regexp.backend
TUPLE: regexp
raw

6
unfinished/regexp2/classes/classes.factor → unfinished/regexp/classes/classes.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.order symbols regexp2.parser
words regexp2.utils unicode.categories combinators.short-circuit ;
IN: regexp2.classes
USING: accessors kernel math math.order symbols regexp.parser
words regexp.utils unicode.categories combinators.short-circuit ;
IN: regexp.classes
GENERIC: class-member? ( obj class -- ? )

13
unfinished/regexp2/dfa/dfa.factor → unfinished/regexp/dfa/dfa.factor
View File

@ -1,15 +1,14 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry kernel locals
math math.order regexp2.nfa regexp2.transition-tables sequences
sets sorting vectors regexp2.utils sequences.lib combinators.lib
sequences.deep ;
math math.order regexp.nfa regexp.transition-tables sequences
sets sorting vectors regexp.utils sequences.deep ;
USING: io prettyprint threads ;
IN: regexp2.dfa
IN: regexp.dfa
: find-delta ( states transition regexp -- new-states )
nfa-table>> transitions>>
rot [ swap at at ] with with map sift concat prune ;
rot [ swap at at ] with with gather sift ;
: (find-epsilon-closure) ( states regexp -- new-states )
eps swap find-delta ;
@ -26,7 +25,9 @@ IN: regexp2.dfa
: find-transitions ( seq1 regexp -- seq2 )
nfa-table>> transitions>>
[ at keys ] curry map concat eps swap remove ;
[ at keys ] curry map concat
eps swap remove ;
! dup t member? [ t swap remove t suffix ] when ;
: add-todo-state ( state regexp -- )
2dup visited-states>> key? [

17
unfinished/regexp2/nfa/nfa.factor → unfinished/regexp/nfa/nfa.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs grouping kernel regexp2.backend
locals math namespaces regexp2.parser sequences state-tables fry
USING: accessors arrays assocs grouping kernel regexp.backend
locals math namespaces regexp.parser sequences state-tables fry
quotations math.order math.ranges vectors unicode.categories
regexp2.utils regexp2.transition-tables words sequences.lib sets ;
IN: regexp2.nfa
regexp.utils regexp.transition-tables words sets ;
IN: regexp.nfa
SYMBOL: negation-mode
: negated? ( -- ? ) negation-mode get 0 or odd? ;
@ -121,6 +121,15 @@ M: character-class-range nfa-node ( node -- )
M: capture-group nfa-node ( node -- )
term>> nfa-node ;
! xyzzy
M: non-capture-group nfa-node ( node -- )
term>> nfa-node ;
M: reluctant-kleene-star nfa-node ( node -- )
term>> <kleene-star> nfa-node ;
!
M: negation nfa-node ( node -- )
negation-mode inc
term>> nfa-node

9
unfinished/regexp2/parser/parser-tests.factor → unfinished/regexp/parser/parser-tests.factor
View File

@ -1,13 +1,10 @@
USING: kernel tools.test regexp2.backend regexp2 ;
IN: regexp2.parser
USING: kernel tools.test regexp.backend regexp ;
IN: regexp.parser
: test-regexp ( string -- )
default-regexp parse-regexp ;
: test-regexp2 ( string -- regexp )
default-regexp dup parse-regexp ;
[ "(" ] [ unmatched-parentheses? ] must-fail-with
! [ "(" ] [ unmatched-parentheses? ] must-fail-with
[ ] [ "a|b" test-regexp ] unit-test
[ ] [ "a.b" test-regexp ] unit-test

34
unfinished/regexp2/parser/parser.factor → unfinished/regexp/parser/parser.factor
View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators io io.streams.string
kernel math math.parser multi-methods namespaces qualified sets
quotations sequences sequences.lib splitting symbols vectors
dlists math.order combinators.lib unicode.categories strings
sequences.lib regexp2.backend regexp2.utils unicode.case ;
IN: regexp2.parser
quotations sequences splitting symbols vectors math.order
unicode.categories strings regexp.backend regexp.utils
unicode.case ;
IN: regexp.parser
FROM: math.ranges => [a,b] ;
@ -280,11 +280,26 @@ ERROR: bad-escaped-literals seq ;
first|concatenation
] if-empty ;
ERROR: unrecognized-escape char ;
: parse-escaped ( -- obj )
read1
{
{ CHAR: \ [ CHAR: \ <constant> ] }
{ CHAR: - [ CHAR: - <constant> ] }
{ CHAR: { [ CHAR: { <constant> ] }
{ CHAR: } [ CHAR: } <constant> ] }
{ CHAR: [ [ CHAR: [ <constant> ] }
{ CHAR: ] [ CHAR: ] <constant> ] }
{ CHAR: ( [ CHAR: ( <constant> ] }
{ CHAR: ) [ CHAR: ) <constant> ] }
{ CHAR: @ [ CHAR: @ <constant> ] }
{ CHAR: * [ CHAR: * <constant> ] }
{ CHAR: + [ CHAR: + <constant> ] }
{ CHAR: ? [ CHAR: ? <constant> ] }
{ CHAR: . [ CHAR: . <constant> ] }
! xyzzy
{ CHAR: : [ CHAR: : <constant> ] }
{ CHAR: t [ CHAR: \t <constant> ] }
{ CHAR: n [ CHAR: \n <constant> ] }
{ CHAR: r [ CHAR: \r <constant> ] }
@ -314,8 +329,19 @@ ERROR: bad-escaped-literals seq ;
! { CHAR: G [ end of previous match ] }
! { CHAR: Z [ handle-end-of-input ] }
! { CHAR: z [ handle-end-of-input ] } ! except for terminator
! xyzzy
{ CHAR: 1 [ CHAR: 1 <constant> ] }
{ CHAR: 2 [ CHAR: 2 <constant> ] }
{ CHAR: 3 [ CHAR: 3 <constant> ] }
{ CHAR: 4 [ CHAR: 4 <constant> ] }
{ CHAR: 5 [ CHAR: 5 <constant> ] }
{ CHAR: 6 [ CHAR: 6 <constant> ] }
{ CHAR: 7 [ CHAR: 7 <constant> ] }
{ CHAR: 8 [ CHAR: 8 <constant> ] }
{ CHAR: 9 [ CHAR: 9 <constant> ] }
{ CHAR: Q [ parse-escaped-literals ] }
[ unrecognized-escape ]
} case ;
: handle-escape ( -- ) parse-escaped push-stack ;

4
unfinished/regexp2/regexp2-docs.factor → unfinished/regexp/regexp-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings help.markup help.syntax regexp2.backend ;
IN: regexp2
USING: kernel strings help.markup help.syntax regexp.backend ;
IN: regexp
HELP: <regexp>
{ $values { "string" string } { "regexp" regexp } }

37
unfinished/regexp2/regexp2-tests.factor → unfinished/regexp/regexp-tests.factor
View File

@ -1,6 +1,6 @@
USING: regexp2 tools.test kernel sequences regexp2.parser
regexp2.traversal ;
IN: regexp2-tests
USING: regexp tools.test kernel sequences regexp.parser
regexp.traversal eval ;
IN: regexp-tests
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
@ -224,6 +224,9 @@ IN: regexp2-tests
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ t ] [ ".o" "\\.[a-z]" <regexp> matches? ] unit-test
[ t ] [ "abc*" "[^\\*]*\\*" <regexp> matches? ] unit-test
[ t ] [ "bca" "[^a]*a" <regexp> matches? ] unit-test
[ ] [
"(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
<regexp> drop
@ -236,20 +239,20 @@ IN: regexp2-tests
[ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
[ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
[ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
[ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
[ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
[ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
[ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
! [ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
! [ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
! [ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
! [ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
! [ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
! [ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
! [ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
@ -268,6 +271,12 @@ IN: regexp2-tests
! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test
[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
! Bug in parsing word
! [ t ] [ "a" R' a' matches? ] unit-test

44
unfinished/regexp2/regexp2.factor → unfinished/regexp/regexp.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel math math.ranges
sequences regexp2.backend regexp2.utils memoize sets
regexp2.parser regexp2.nfa regexp2.dfa regexp2.traversal
regexp2.transition-tables assocs prettyprint.backend
make ;
IN: regexp2
sequences regexp.backend regexp.utils memoize sets
regexp.parser regexp.nfa regexp.dfa regexp.traversal
regexp.transition-tables assocs prettyprint.backend
make lexer namespaces parser ;
IN: regexp
: default-regexp ( string -- regexp )
regexp new
@ -51,17 +51,26 @@ IN: regexp2
reversed-regexp initial-option
construct-regexp ;
: R! CHAR: ! <regexp> ; parsing
: R" CHAR: " <regexp> ; parsing
: R# CHAR: # <regexp> ; parsing
: R' CHAR: ' <regexp> ; parsing
: R( CHAR: ) <regexp> ; parsing
: R/ CHAR: / <regexp> ; parsing
: R@ CHAR: @ <regexp> ; parsing
: R[ CHAR: ] <regexp> ; parsing
: R` CHAR: ` <regexp> ; parsing
: R{ CHAR: } <regexp> ; parsing
: R| CHAR: | <regexp> ; parsing
: parsing-regexp ( accum end -- accum )
lexer get dup skip-blank
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
lexer get dup still-parsing-line?
[ (parse-token) ] [ drop f ] if
"i" = [ <iregexp> ] [ <regexp> ] if parsed ;
: R! CHAR: ! parsing-regexp ; parsing
: R" CHAR: " parsing-regexp ; parsing
: R# CHAR: # parsing-regexp ; parsing
: R' CHAR: ' parsing-regexp ; parsing
: R( CHAR: ) parsing-regexp ; parsing
: R/ CHAR: / parsing-regexp ; parsing
: R@ CHAR: @ parsing-regexp ; parsing
: R[ CHAR: ] parsing-regexp ; parsing
: R` CHAR: ` parsing-regexp ; parsing
: R{ CHAR: } parsing-regexp ; parsing
: R| CHAR: | parsing-regexp ; parsing
: find-regexp-syntax ( string -- prefix suffix )
{
@ -81,6 +90,8 @@ IN: regexp2
: option? ( option regexp -- ? )
options>> key? ;
USE: multiline
/*
M: regexp pprint*
[
[
@ -89,3 +100,4 @@ M: regexp pprint*
case-insensitive swap option? [ "i" % ] when
] "" make
] keep present-text ;
*/

0
unfinished/regexp2/summary.txt → unfinished/regexp/summary.txt
View File

0
unfinished/regexp2/tags.txt → unfinished/regexp/tags.txt
View File

4
unfinished/regexp2/transition-tables/transition-tables.factor → unfinished/regexp/transition-tables/transition-tables.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry hashtables kernel sequences
vectors regexp2.utils ;
IN: regexp2.transition-tables
vectors regexp.utils ;
IN: regexp.transition-tables
TUPLE: transition from to obj ;
TUPLE: literal-transition < transition ;

15
unfinished/regexp2/traversal/traversal.factor → unfinished/regexp/traversal/traversal.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.lib kernel
math math.ranges quotations sequences regexp2.parser
regexp2.classes combinators.short-circuit assocs.lib
sequences.lib regexp2.utils ;
IN: regexp2.traversal
USING: accessors assocs combinators kernel math math.ranges
quotations sequences regexp.parser regexp.classes
combinators.short-circuit regexp.utils ;
IN: regexp.traversal
TUPLE: dfa-traverser
dfa-table
@ -54,7 +53,7 @@ TUPLE: dfa-traverser
V{ } clone >>matches ;
: match-literal ( transition from-state table -- to-state/f )
transitions>> [ at ] [ 2drop f ] if-at ;
transitions>> at* [ at ] [ 2drop f ] if ;
: match-class ( transition from-state table -- to-state/f )
transitions>> at* [
@ -62,8 +61,8 @@ TUPLE: dfa-traverser
] [ drop ] if ;
: match-default ( transition from-state table -- to-state/f )
[ nip ] dip transitions>>
[ t swap [ drop f ] unless-at ] [ drop f ] if-at ;
[ nip ] dip transitions>> at*
[ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
: match-transition ( obj from-state dfa -- to-state/f )
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;

9
unfinished/regexp2/utils/utils.factor → unfinished/regexp/utils/utils.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators.lib io kernel
math math.order namespaces regexp2.backend sequences
sequences.lib unicode.categories math.ranges fry
combinators.short-circuit vectors ;
IN: regexp2.utils
USING: accessors arrays assocs io kernel math math.order
namespaces regexp.backend sequences unicode.categories
math.ranges fry combinators.short-circuit vectors ;
IN: regexp.utils
: (while-changes) ( obj quot pred pred-ret -- obj )
! quot: ( obj -- obj' )

18
vm/image.c
View File

@ -169,8 +169,26 @@ DEFINE_PRIMITIVE(save_image)
save_image(unbox_native_string());
}
void strip_compiled_quotations(void)
{
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == QUOTATION_TYPE)
{
F_QUOTATION *quot = untag_object(obj);
quot->compiledp = F;
}
}
gc_off = false;
}
DEFINE_PRIMITIVE(save_image_and_exit)
{
/* This reduces deployed image size */
strip_compiled_quotations();
F_CHAR *path = unbox_native_string();
REGISTER_C_STRING(path);