diff --git a/basis/bootstrap/random/random.factor b/basis/bootstrap/random/random.factor index 3782d517cf..f6527cdda1 100755 --- a/basis/bootstrap/random/random.factor +++ b/basis/bootstrap/random/random.factor @@ -13,4 +13,4 @@ IN: bootstrap.random [ [ 32 random-bits ] with-system-random random-generator set-global -] "generator.random" add-init-hook +] "bootstrap.random" add-init-hook diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index bb21391f0a..6bec4b23c0 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -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 diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 5ffcafbbaf..e30cc2eb60 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -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 diff --git a/basis/core-foundation/run-loop/thread/thread.factor b/basis/core-foundation/run-loop/thread/thread.factor new file mode 100644 index 0000000000..326226ec0e --- /dev/null +++ b/basis/core-foundation/run-loop/thread/thread.factor @@ -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 diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor index c7d5413a47..14ddb0ed9b 100755 --- a/basis/globs/globs.factor +++ b/basis/globs/globs.factor @@ -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 diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 1b22ca8501..7f1a3f4507 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -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 encoding -- process stream ) +: ( desc encoding -- stream process ) [ >r (pipe) { [ |dispose drop ] @@ -178,13 +190,18 @@ M: object run-pipeline-element ] [ out>> dispose ] [ in>> ] - } cleave r> + } cleave r> swap ] with-destructors ; : ( desc encoding -- stream ) - nip ; inline + drop ; inline -: ( process encoding -- process stream ) +: with-process-reader ( desc encoding quot -- ) + [ ] dip + swap [ with-input-stream ] dip + wait-for-success ; inline + +: ( desc encoding -- stream process ) [ >r (pipe) { [ |dispose drop ] @@ -195,13 +212,18 @@ M: object run-pipeline-element ] [ in>> dispose ] [ out>> ] - } cleave r> + } cleave r> swap ] with-destructors ; : ( desc encoding -- stream ) - nip ; inline + drop ; inline -: ( process encoding -- process stream ) +: with-process-writer ( desc encoding quot -- ) + [ ] dip + swap [ with-output-stream ] dip + wait-for-success ; inline + +: ( 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>> ] [ out>> ] bi* ] - } 2cleave r> + } 2cleave r> swap ] with-destructors ; : ( desc encoding -- stream ) - nip ; inline + drop ; inline + +: with-process-stream ( desc encoding quot -- ) + [ ] dip + swap [ with-stream ] dip + wait-for-success ; inline : notify-exit ( process status -- ) >>status diff --git a/basis/io/windows/nt/files/files-tests.factor b/basis/io/windows/nt/files/files-tests.factor index 830861eba0..6620dd691e 100755 --- a/basis/io/windows/nt/files/files-tests.factor +++ b/basis/io/windows/nt/files/files-tests.factor @@ -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 diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor index b572d9ec65..157662ade8 100755 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -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 ; diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 2d1b644050..bae05f4244 100755 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -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 ; diff --git a/basis/random/unix/unix.factor b/basis/random/unix/unix.factor index 90f3d1efbb..599cd5e0ad 100644 --- a/basis/random/unix/unix.factor +++ b/basis/random/unix/unix.factor @@ -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 diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 41c7e2c972..abc3ae1950 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -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 '[ _ ] ] bi append ] [ drop f ] if diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 324adcaad2..cb899f4b87 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -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 -- ) @@ -31,9 +27,7 @@ IN: tools.deploy.backend +stdout+ >>stderr +closed+ >>stdin +low-priority+ >>priority - utf8 - 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. diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index f2726c00fa..7a2aa1c299 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -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 - "" "inference.dataflow" lookup [ , ] when* + "" "stack-checker.state" lookup [ , ] when* "windows-messages" "windows.messages" lookup [ , ] when* diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index de5aee68e2..2cf803e270 100755 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -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 diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index f24171b2b4..dab109e368 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -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 ) diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor index 28c0de406a..8639c93e71 100755 --- a/basis/xmode/loader/loader.factor +++ b/basis/xmode/loader/loader.factor @@ -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 diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index 69c4e4fac3..cbebe090c3 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -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? diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index d0d68febec..f777eaa18c 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -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 diff --git a/basis/xmode/rules/rules.factor b/basis/xmode/rules/rules.factor index e3c0c65db0..e4f12bcc49 100755 --- a/basis/xmode/rules/rules.factor +++ b/basis/xmode/rules/rules.factor @@ -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? ; diff --git a/build-support/factor.sh b/build-support/factor.sh index 8be61f322a..2d4547a121 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -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 } diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index f92c9c0fd5..577ad133e1 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 ] ?if ; M: tuple-class boa - [ "boa-check" word-prop call ] + [ "boa-check" word-prop [ call ] when* ] [ tuple-layout ] bi ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 58a08ed30c..1634b7a3f1 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -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 ) diff --git a/core/system/system.factor b/core/system/system.factor index 98dc605acc..3c207c4ab5 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -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 ) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 403cb4737e..c683ef6e06 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -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 } } diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index d5996f300c..dfda85e4d7 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -51,7 +51,7 @@ SYMBOL: stamp with-directory ; : git-id ( -- id ) - { "git" "show" } utf8 [ readln ] with-input-stream + { "git" "show" } utf8 [ readln ] with-process-reader " " split second ; : ?prepare-build-machine ( -- ) diff --git a/extra/regexp/authors.txt b/extra/parser-combinators/regexp/authors.txt similarity index 100% rename from extra/regexp/authors.txt rename to extra/parser-combinators/regexp/authors.txt diff --git a/extra/regexp/regexp-tests.factor b/extra/parser-combinators/regexp/regexp-tests.factor similarity index 99% rename from extra/regexp/regexp-tests.factor rename to extra/parser-combinators/regexp/regexp-tests.factor index e9433c6c64..78abd8b38a 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/parser-combinators/regexp/regexp-tests.factor @@ -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 matches? ] unit-test [ t ] [ "" "a*" f matches? ] unit-test diff --git a/extra/regexp/regexp.factor b/extra/parser-combinators/regexp/regexp.factor similarity index 99% rename from extra/regexp/regexp.factor rename to extra/parser-combinators/regexp/regexp.factor index 5ef3eacc6c..40d4603fb6 100755 --- a/extra/regexp/regexp.factor +++ b/extra/parser-combinators/regexp/regexp.factor @@ -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 > 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? [ diff --git a/unfinished/regexp2/nfa/nfa.factor b/unfinished/regexp/nfa/nfa.factor similarity index 92% rename from unfinished/regexp2/nfa/nfa.factor rename to unfinished/regexp/nfa/nfa.factor index 792d9fe30f..f070c3528b 100644 --- a/unfinished/regexp2/nfa/nfa.factor +++ b/unfinished/regexp/nfa/nfa.factor @@ -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>> nfa-node ; + +! + M: negation nfa-node ( node -- ) negation-mode inc term>> nfa-node diff --git a/unfinished/regexp2/parser/parser-tests.factor b/unfinished/regexp/parser/parser-tests.factor similarity index 82% rename from unfinished/regexp2/parser/parser-tests.factor rename to unfinished/regexp/parser/parser-tests.factor index 6911e8e76d..0f25b2e3bf 100644 --- a/unfinished/regexp2/parser/parser-tests.factor +++ b/unfinished/regexp/parser/parser-tests.factor @@ -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 diff --git a/unfinished/regexp2/parser/parser.factor b/unfinished/regexp/parser/parser.factor similarity index 92% rename from unfinished/regexp2/parser/parser.factor rename to unfinished/regexp/parser/parser.factor index fb1bd08bfe..eaee70210e 100644 --- a/unfinished/regexp2/parser/parser.factor +++ b/unfinished/regexp/parser/parser.factor @@ -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: \ ] } + { CHAR: - [ CHAR: - ] } + { CHAR: { [ CHAR: { ] } + { CHAR: } [ CHAR: } ] } + { CHAR: [ [ CHAR: [ ] } + { CHAR: ] [ CHAR: ] ] } + { CHAR: ( [ CHAR: ( ] } + { CHAR: ) [ CHAR: ) ] } + { CHAR: @ [ CHAR: @ ] } + { CHAR: * [ CHAR: * ] } + { CHAR: + [ CHAR: + ] } + { CHAR: ? [ CHAR: ? ] } { CHAR: . [ CHAR: . ] } +! xyzzy + { CHAR: : [ CHAR: : ] } { CHAR: t [ CHAR: \t ] } { CHAR: n [ CHAR: \n ] } { CHAR: r [ CHAR: \r ] } @@ -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 ] } + { CHAR: 2 [ CHAR: 2 ] } + { CHAR: 3 [ CHAR: 3 ] } + { CHAR: 4 [ CHAR: 4 ] } + { CHAR: 5 [ CHAR: 5 ] } + { CHAR: 6 [ CHAR: 6 ] } + { CHAR: 7 [ CHAR: 7 ] } + { CHAR: 8 [ CHAR: 8 ] } + { CHAR: 9 [ CHAR: 9 ] } { CHAR: Q [ parse-escaped-literals ] } + [ unrecognized-escape ] } case ; : handle-escape ( -- ) parse-escaped push-stack ; diff --git a/unfinished/regexp2/regexp2-docs.factor b/unfinished/regexp/regexp-docs.factor similarity index 89% rename from unfinished/regexp2/regexp2-docs.factor rename to unfinished/regexp/regexp-docs.factor index f903c14bc4..f6a1fe1876 100644 --- a/unfinished/regexp2/regexp2-docs.factor +++ b/unfinished/regexp/regexp-docs.factor @@ -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: { $values { "string" string } { "regexp" regexp } } diff --git a/unfinished/regexp2/regexp2-tests.factor b/unfinished/regexp/regexp-tests.factor similarity index 90% rename from unfinished/regexp2/regexp2-tests.factor rename to unfinished/regexp/regexp-tests.factor index e77a7a4419..78098952d3 100644 --- a/unfinished/regexp2/regexp2-tests.factor +++ b/unfinished/regexp/regexp-tests.factor @@ -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*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test @@ -224,6 +224,9 @@ IN: regexp2-tests [ f ] [ "a" "[a-z.-]@[a-z]" matches? ] unit-test [ t ] [ ".o" "\\.[a-z]" matches? ] unit-test +[ t ] [ "abc*" "[^\\*]*\\*" matches? ] unit-test +[ t ] [ "bca" "[^a]*a" 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]))" drop @@ -236,20 +239,20 @@ IN: regexp2-tests -[ "{Lower}" ] [ invalid-range? ] must-fail-with +! [ "{Lower}" ] [ invalid-range? ] must-fail-with -[ 1 ] [ "aaacb" "a+?" match-head ] unit-test -[ 1 ] [ "aaacb" "aa??" match-head ] unit-test -[ f ] [ "aaaab" "a++ab" matches? ] unit-test -[ t ] [ "aaacb" "a++cb" matches? ] unit-test -[ 3 ] [ "aacb" "aa?c" match-head ] unit-test -[ 3 ] [ "aacb" "aa??c" match-head ] unit-test +! [ 1 ] [ "aaacb" "a+?" match-head ] unit-test +! [ 1 ] [ "aaacb" "aa??" match-head ] unit-test +! [ f ] [ "aaaab" "a++ab" matches? ] unit-test +! [ t ] [ "aaacb" "a++cb" matches? ] unit-test +! [ 3 ] [ "aacb" "aa?c" match-head ] unit-test +! [ 3 ] [ "aacb" "aa??c" match-head ] unit-test -[ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test -[ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test +! [ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test +! [ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test -[ 3 ] [ "foobar" "foo(?=bar)" match-head ] unit-test -[ f ] [ "foobxr" "foo(?=bar)" match-head ] unit-test +! [ 3 ] [ "foobar" "foo(?=bar)" match-head ] unit-test +! [ f ] [ "foobxr" "foo(?=bar)" match-head ] unit-test ! [ f ] [ "foobxr" "foo\\z" match-head ] unit-test ! [ 3 ] [ "foo" "foo\\z" match-head ] unit-test @@ -268,6 +271,12 @@ IN: regexp2-tests ! [ t ] [ "fooxbar" "foo\\Bxbar" matches? ] unit-test ! [ f ] [ "foo" "foo\\Bbar" 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 diff --git a/unfinished/regexp2/regexp2.factor b/unfinished/regexp/regexp.factor similarity index 67% rename from unfinished/regexp2/regexp2.factor rename to unfinished/regexp/regexp.factor index feec8ea97e..47c6e52c39 100644 --- a/unfinished/regexp2/regexp2.factor +++ b/unfinished/regexp/regexp.factor @@ -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: ! ; parsing -: R" CHAR: " ; parsing -: R# CHAR: # ; parsing -: R' CHAR: ' ; parsing -: R( CHAR: ) ; parsing -: R/ CHAR: / ; parsing -: R@ CHAR: @ ; parsing -: R[ CHAR: ] ; parsing -: R` CHAR: ` ; parsing -: R{ CHAR: } ; parsing -: R| CHAR: | ; 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" = [ ] [ ] 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 ; +*/ diff --git a/unfinished/regexp2/summary.txt b/unfinished/regexp/summary.txt similarity index 100% rename from unfinished/regexp2/summary.txt rename to unfinished/regexp/summary.txt diff --git a/unfinished/regexp2/tags.txt b/unfinished/regexp/tags.txt similarity index 100% rename from unfinished/regexp2/tags.txt rename to unfinished/regexp/tags.txt diff --git a/unfinished/regexp2/transition-tables/transition-tables.factor b/unfinished/regexp/transition-tables/transition-tables.factor similarity index 95% rename from unfinished/regexp2/transition-tables/transition-tables.factor rename to unfinished/regexp/transition-tables/transition-tables.factor index c67985af4a..82e2db8496 100644 --- a/unfinished/regexp2/transition-tables/transition-tables.factor +++ b/unfinished/regexp/transition-tables/transition-tables.factor @@ -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 ; diff --git a/unfinished/regexp2/traversal/traversal.factor b/unfinished/regexp/traversal/traversal.factor similarity index 86% rename from unfinished/regexp2/traversal/traversal.factor rename to unfinished/regexp/traversal/traversal.factor index ba9284c110..752323de91 100644 --- a/unfinished/regexp2/traversal/traversal.factor +++ b/unfinished/regexp/traversal/traversal.factor @@ -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|| ; diff --git a/unfinished/regexp2/utils/utils.factor b/unfinished/regexp/utils/utils.factor similarity index 91% rename from unfinished/regexp2/utils/utils.factor rename to unfinished/regexp/utils/utils.factor index ab51436f8b..fb058ecf92 100644 --- a/unfinished/regexp2/utils/utils.factor +++ b/unfinished/regexp/utils/utils.factor @@ -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' ) diff --git a/vm/image.c b/vm/image.c index a0fa48d504..a668cb7913 100755 --- a/vm/image.c +++ b/vm/image.c @@ -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);