diff --git a/.gitignore b/.gitignore index 290f075aae..f4334f3727 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,4 @@ temp logs work build-support/wordsize +*.bak diff --git a/Makefile b/Makefile index 973ba1f3d4..ffcbf6364c 100644 --- a/Makefile +++ b/Makefile @@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS) clean: rm -f vm/*.o - rm -f factor*.dll libfactor*.* + rm -f factor*.dll libfactor.{a,so,dylib} vm/resources.o: $(WINDRES) vm/factor.rs vm/resources.o diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index cb07e5a8d6..c61967fc8a 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -27,11 +27,17 @@ HELP: parallel-filter { $errors "Throws an error if one of the iterations throws an error." } ; ARTICLE: "concurrency.combinators" "Concurrent combinators" -"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":" +"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators." +$nl +"Concurrent sequence combinators:" { $subsection parallel-each } { $subsection 2parallel-each } { $subsection parallel-map } { $subsection 2parallel-map } -{ $subsection parallel-filter } ; +{ $subsection parallel-filter } +"Concurrent cleave combinators:" +{ $subsection parallel-cleave } +{ $subsection parallel-spread } +{ $subsection parallel-napply } ; ABOUT: "concurrency.combinators" diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index 562111242d..3a38daed86 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -1,6 +1,7 @@ IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math -concurrency.mailboxes threads sequences accessors arrays ; +concurrency.mailboxes threads sequences accessors arrays +math.parser ; [ [ drop ] parallel-each ] must-infer { 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as @@ -45,3 +46,10 @@ concurrency.mailboxes threads sequences accessors arrays ; ] unit-test [ { f } [ "OOPS" throw ] parallel-each ] must-fail + +[ "1a" "4b" "3c" ] [ + 2 + { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave + [ number>string ] 3 parallel-napply + { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread +] unit-test diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor index ab3ca7ed4a..4608faf79b 100644 --- a/basis/concurrency/combinators/combinators.factor +++ b/basis/concurrency/combinators/combinators.factor @@ -1,34 +1,58 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.futures concurrency.count-downs sequences -kernel ; +kernel macros fry combinators generalizations ; IN: concurrency.combinators r r> keep await ; inline + [ ] dip keep await ; inline + PRIVATE> : parallel-each ( seq quot -- ) over length [ - [ >r curry r> spawn-stage ] 2curry each + '[ _ curry _ spawn-stage ] each ] (parallel-each) ; inline : 2parallel-each ( seq1 seq2 quot -- ) 2over min-length [ - [ >r 2curry r> spawn-stage ] 2curry 2each + '[ _ 2curry _ spawn-stage ] 2each ] (parallel-each) ; inline : parallel-filter ( seq quot -- newseq ) - over >r pusher >r each r> r> like ; inline + over [ pusher [ each ] dip ] dip like ; inline : parallel-map ( seq quot -- newseq ) - [ curry future ] curry map future-values ; - inline + [future] map future-values ; inline : 2parallel-map ( seq1 seq2 quot -- newseq ) - [ 2curry future ] curry 2map future-values ; + '[ _ 2curry future ] 2map future-values ; + + ; inline + +: (parallel-cleave) ( quots -- quot-array spread-array ) + [ [future] ] map dup length (parallel-spread) ; inline + +PRIVATE> + +MACRO: parallel-cleave ( quots -- ) + (parallel-cleave) '[ _ cleave _ spread ] ; + +MACRO: parallel-spread ( quots -- ) + (parallel-cleave) '[ _ spread _ spread ] ; + +MACRO: parallel-napply ( quot n -- ) + [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ; diff --git a/basis/io/encodings/utf16/.utf16.factor.swo b/basis/io/encodings/utf16/.utf16.factor.swo deleted file mode 100644 index 01be8fdab2..0000000000 Binary files a/basis/io/encodings/utf16/.utf16.factor.swo and /dev/null differ diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 3f254e7713..98206bc992 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -117,8 +117,8 @@ M: unix stat>file-info ( stat -- file-info ) [ stat-st_blksize >>blocksize ] } cleave ; -M: unix stat>type ( stat -- type ) - stat-st_mode S_IFMT bitand { +: n>file-type ( n -- type ) + S_IFMT bitand { { S_IFREG [ +regular-file+ ] } { S_IFDIR [ +directory+ ] } { S_IFCHR [ +character-device+ ] } @@ -129,6 +129,9 @@ M: unix stat>type ( stat -- type ) [ drop +unknown+ ] } case ; +M: unix stat>type ( stat -- type ) + stat-st_mode n>file-type ; + ! Linux has no extra fields in its stat struct os { { macosx [ "io.unix.files.bsd" require ] } @@ -150,7 +153,7 @@ os { M: unix >directory-entry ( byte-array -- directory-entry ) [ dirent-d_name utf8 alien>string ] - [ dirent-d_type ] bi directory-entry boa ; + [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ; M: unix (directory-entries) ( path -- seq ) [ diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index d0409ce59a..5746eb252d 100755 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -114,11 +114,6 @@ M: windows delete-directory ( path -- ) normalize-path RemoveDirectory win32-error=0/f ; -M: windows >directory-entry ( byte-array -- directory-entry ) - [ WIN32_FIND_DATA-cFileName utf16n alien>string ] - [ WIN32_FIND_DATA-dwFileAttributes ] - bi directory-entry boa ; - : find-first-file ( path -- WIN32_FIND_DATA handle ) "WIN32_FIND_DATA" tuck FindFirstFile @@ -177,6 +172,14 @@ TUPLE: windows-file-info < file-info attributes ; : win32-file-type ( n -- symbol ) FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; +TUPLE: windows-directory-entry < directory-entry attributes ; + +M: windows >directory-entry ( byte-array -- directory-entry ) + [ WIN32_FIND_DATA-cFileName utf16n alien>string ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ] + tri windows-directory-entry boa ; + : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) [ \ windows-file-info new ] dip { diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index ca6697be1c..04e077fc4f 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -388,6 +388,8 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test +[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test + ! :: wlet-&&-test ( a -- ? ) ! [wlet | is-integer? [ a integer? ] ! is-even? [ a even? ] diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 3befdaff2b..1ecca0ec19 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -7,7 +7,7 @@ prettyprint.config sorting splitting grouping math.parser vocabs definitions effects classes.builtin classes.tuple io.files classes continuations hashtables classes.mixin classes.union classes.intersection classes.predicate classes.singleton -combinators quotations sets accessors colors ; +combinators quotations sets accessors colors parser ; IN: prettyprint : make-pprint ( obj quot -- block in use ) @@ -48,6 +48,22 @@ IN: prettyprint dupd remove [ { "syntax" "scratchpad" } member? not ] filter use. in. ; +: vocab-names ( words -- vocabs ) + dictionary get + [ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ; + +: prelude. ( -- ) + in get use get vocab-names vocabs. ; + +[ + nl + "Restarts were invoked adding vocabularies to the search path." print + "To avoid doing this in the future, add the following USING:" print + "and IN: forms at the top of the source file:" print nl + prelude. + nl +] print-use-hook set-global + : with-use ( obj quot -- ) make-pprint vocabs. do-pprint ; inline diff --git a/basis/regexp/backend/backend.factor b/basis/regexp/backend/backend.factor index 1a261fb0af..75a010b705 100644 --- a/basis/regexp/backend/backend.factor +++ b/basis/regexp/backend/backend.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors hashtables kernel math state-tables vars vectors ; +USING: accessors hashtables kernel math state-tables vectors ; IN: regexp.backend TUPLE: regexp diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index a2d91b97fb..240b27a9cc 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -30,6 +30,10 @@ M: ascii-class class-member? ( obj class -- ? ) M: digit-class class-member? ( obj class -- ? ) drop digit? ; +M: c-identifier-class class-member? ( obj class -- ? ) + drop + { [ digit? ] [ Letter? ] [ CHAR: _ = ] } 1|| ; + M: alpha-class class-member? ( obj class -- ? ) drop alpha? ; diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index b7716d8580..b5022c602e 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -294,6 +294,7 @@ ERROR: unrecognized-escape char ; read1 { { CHAR: \ [ CHAR: \ ] } + { CHAR: / [ CHAR: / ] } { CHAR: ^ [ CHAR: ^ ] } { CHAR: $ [ CHAR: $ ] } { CHAR: - [ CHAR: - ] } diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 2a6c0dc16f..4878b67d0f 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -46,6 +46,18 @@ IN: regexp-tests [ t ] [ "a" ".+" matches? ] unit-test [ t ] [ "ab" ".+" matches? ] unit-test +[ t ] [ " " "[\\s]" matches? ] unit-test +[ f ] [ "a" "[\\s]" matches? ] unit-test +[ f ] [ " " "[\\S]" matches? ] unit-test +[ t ] [ "a" "[\\S]" matches? ] unit-test +[ f ] [ " " "[\\w]" matches? ] unit-test +[ t ] [ "a" "[\\w]" matches? ] unit-test +[ t ] [ " " "[\\W]" matches? ] unit-test +[ f ] [ "a" "[\\W]" matches? ] unit-test + +[ t ] [ "/" "\\/" matches? ] unit-test + +[ t ] [ "a" R' a'i matches? ] unit-test [ t ] [ "" "a|b*|c+|d?" matches? ] unit-test [ t ] [ "a" "a|b*|c+|d?" matches? ] unit-test @@ -334,3 +346,7 @@ IN: regexp-tests [ { 0 3 } ] [ "abc" "(ab|a)(bc)?" first-match ] unit-test [ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" first-match ] unit-test + +[ t ] [ "a:b" ".+:?" matches? ] unit-test + +[ 1 ] [ "hello" ".+?" match length ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 083a48a470..c9a1d2f47d 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -28,7 +28,7 @@ IN: regexp : match ( string regexp -- pair ) do-match return-match ; -: match* ( string regexp -- pair ) +: match* ( string regexp -- pair captured-groups ) do-match [ return-match ] [ captured-groups>> ] bi ; : matches? ( string regexp -- ? ) @@ -129,8 +129,6 @@ IN: regexp : option? ( option regexp -- ? ) options>> key? ; -USE: multiline -/* M: regexp pprint* [ [ @@ -139,4 +137,3 @@ M: regexp pprint* case-insensitive swap option? [ "i" % ] when ] "" make ] keep present-text ; -*/ diff --git a/extra/state-tables/authors.txt b/basis/state-tables/authors.txt similarity index 100% rename from extra/state-tables/authors.txt rename to basis/state-tables/authors.txt diff --git a/extra/state-tables/state-tables-tests.factor b/basis/state-tables/state-tables-tests.factor similarity index 100% rename from extra/state-tables/state-tables-tests.factor rename to basis/state-tables/state-tables-tests.factor diff --git a/extra/state-tables/state-tables.factor b/basis/state-tables/state-tables.factor similarity index 100% rename from extra/state-tables/state-tables.factor rename to basis/state-tables/state-tables.factor diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 4bb6d6142f..2306ff53a8 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -72,7 +72,9 @@ IN: tools.completion ] if ; : string-completions ( short strs -- seq ) - [ dup ] { } map>assoc completions ; + dup zip completions ; : limited-completions ( short candidates -- seq ) - completions dup length 1000 > [ drop f ] when ; + [ completions ] [ drop ] 2bi + 2dup [ length 50 > ] [ empty? ] bi* and + [ 2drop f ] [ drop 50 short head ] if ; diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index c975e64b12..d74284cbd6 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -6,7 +6,6 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render math.geometry.rect locals alien.c-types ; - IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; @@ -111,10 +110,10 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ; : checkmark-points ( dim -- points ) { - [ { 0 0 } v* ] - [ { 1 1 } v* ] - [ { 0 1 } v* ] - [ { 1 0 } v* ] + [ { 0 0 } v* { 0.5 0.5 } v+ ] + [ { 1 1 } v* { 0.5 0.5 } v+ ] + [ { 1 0 } v* { -0.3 0.5 } v+ ] + [ { 0 1 } v* { -0.3 0.5 } v+ ] } cleave 4array ; : checkmark-vertices ( dim -- vertices ) diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor old mode 100644 new mode 100755 index adfdd16f69..feca8f7c63 --- a/basis/ui/gadgets/grid-lines/grid-lines.factor +++ b/basis/ui/gadgets/grid-lines/grid-lines.factor @@ -18,18 +18,16 @@ SYMBOL: grid-dim grid-dim get spin set-axis ; : draw-grid-lines ( gaps orientation -- ) - grid get rot grid-positions grid get rect-dim suffix [ - grid-line-from/to gl-line - ] with each ; + [ grid get swap grid-positions grid get rect-dim suffix ] dip + [ [ v- ] curry map ] keep + [ swap grid-line-from/to gl-line ] curry each ; M: grid-lines draw-boundary color>> gl-color [ dup grid set dup rect-dim half-gap v- grid-dim set compute-grid - [ { -0.5 -0.5 } gl-translate { 1 0 } draw-grid-lines ] - [ - { 0.5 -0.5 } gl-translate - { 0 1 } draw-grid-lines - ] bi* + [ { 1 0 } draw-grid-lines ] + [ { 0 1 } draw-grid-lines ] + bi* ] with-scope ; diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor old mode 100644 new mode 100755 diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index bd66c5253e..bf426ad867 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -83,16 +83,6 @@ C-STRUCT: passwd : SEEK_CUR 1 ; inline : SEEK_END 2 ; inline -: DT_UNKNOWN 0 ; inline -: DT_FIFO 1 ; inline -: DT_CHR 2 ; inline -: DT_DIR 4 ; inline -: DT_BLK 6 ; inline -: DT_REG 8 ; inline -: DT_LNK 10 ; inline -: DT_SOCK 12 ; inline -: DT_WHT 14 ; inline - os { { macosx [ "unix.bsd.macosx" require ] } { freebsd [ "unix.bsd.freebsd" require ] } diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 4950daef2c..ca8a7a2e60 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types alien.syntax kernel libc sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader qualified accessors stack-checker macros locals generalizations unix.types -debugger io prettyprint ; +debugger io prettyprint io.files ; IN: unix : PROT_NONE 0 ; inline @@ -20,6 +20,29 @@ IN: unix : NGROUPS_MAX 16 ; inline +: DT_UNKNOWN 0 ; inline +: DT_FIFO 1 ; inline +: DT_CHR 2 ; inline +: DT_DIR 4 ; inline +: DT_BLK 6 ; inline +: DT_REG 8 ; inline +: DT_LNK 10 ; inline +: DT_SOCK 12 ; inline +: DT_WHT 14 ; inline + +: dirent-type>file-type ( ch -- type ) + { + { DT_BLK [ +block-device+ ] } + { DT_CHR [ +character-device+ ] } + { DT_DIR [ +directory+ ] } + { DT_LNK [ +symbolic-link+ ] } + { DT_SOCK [ +socket+ ] } + { DT_FIFO [ +fifo+ ] } + { DT_REG [ +regular-file+ ] } + { DT_WHT [ +whiteout+ ] } + [ drop +unknown+ ] + } case ; + C-STRUCT: group { "char*" "gr_name" } { "char*" "gr_passwd" } diff --git a/basis/validators/validators-tests.factor b/basis/validators/validators-tests.factor index bd24323f20..d4f3487d0b 100644 --- a/basis/validators/validators-tests.factor +++ b/basis/validators/validators-tests.factor @@ -52,3 +52,5 @@ namespaces assocs ; [ "4561_2612_1234_5467" v-credit-card ] must-fail [ "4561-2621-1234-5467" v-credit-card ] must-fail + +[ t ] [ "http://double.co.nz/w?v=foo" dup v-url = ] unit-test diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index 0ddced63e8..7c41d3efdb 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -62,9 +62,7 @@ IN: validators v-regexp ; : v-url ( str -- str ) - "URL" - R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?' - v-regexp ; + "URL" R' (ftp|http|https)://\S+' v-regexp ; : v-captcha ( str -- str ) dup empty? [ "must remain blank" throw ] unless ; diff --git a/build-support/factor.sh b/build-support/factor.sh index 8d75b8cff2..1a4aa9f965 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -131,10 +131,10 @@ check_library_exists() { $ECHO "***Factor will compile NO_UI=1" NO_UI=1 fi - rm -f $GCC_TEST - check_ret rm - rm -f $GCC_OUT - check_ret rm + $DELETE -f $GCC_TEST + check_ret $DELETE + $DELETE -f $GCC_OUT + check_ret $DELETE $ECHO "found." } @@ -209,7 +209,7 @@ c_find_word_size() { gcc -o $C_WORD $C_WORD.c WORD=$(./$C_WORD) check_ret $C_WORD - rm -f $C_WORD* + $DELETE -f $C_WORD* } intel_macosx_word_size() { @@ -236,17 +236,30 @@ find_word_size() { set_factor_binary() { case $OS in - # winnt) FACTOR_BINARY=factor-nt;; - # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; + winnt) FACTOR_BINARY=factor.exe;; *) FACTOR_BINARY=factor;; esac } +set_factor_library() { + case $OS in + winnt) FACTOR_LIBRARY=factor.dll;; + macosx) FACTOR_LIBRARY=libfactor.dylib;; + *) FACTOR_LIBRARY=libfactor.a;; + esac +} + +set_factor_image() { + FACTOR_IMAGE=factor.image +} + echo_build_info() { $ECHO OS=$OS $ECHO ARCH=$ARCH $ECHO WORD=$WORD $ECHO FACTOR_BINARY=$FACTOR_BINARY + $ECHO FACTOR_LIBRARY=$FACTOR_LIBRARY + $ECHO FACTOR_IMAGE=$FACTOR_IMAGE $ECHO MAKE_TARGET=$MAKE_TARGET $ECHO BOOT_IMAGE=$BOOT_IMAGE $ECHO MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET @@ -255,6 +268,8 @@ echo_build_info() { $ECHO DOWNLOADER=$DOWNLOADER $ECHO CC=$CC $ECHO MAKE=$MAKE + $ECHO COPY=$COPY + $ECHO DELETE=$DELETE } check_os_arch_word() { @@ -312,6 +327,8 @@ find_build_info() { find_architecture find_word_size set_factor_binary + set_factor_library + set_factor_image set_build_info set_downloader set_gcc @@ -339,6 +356,28 @@ cd_factor() { check_ret cd } +set_copy() { + case $OS in + winnt) COPY=cp;; + *) COPY=cp;; + esac +} + +set_delete() { + case $OS in + winnt) DELETE=rm;; + *) DELETE=rm;; + esac +} + +backup_factor() { + $ECHO "Backing up factor..." + $COPY $FACTOR_BINARY $FACTOR_BINARY.bak + $COPY $FACTOR_LIBRARY $FACTOR_LIBRARY.bak + $COPY $FACTOR_IMAGE $FACTOR_IMAGE.bak + $ECHO "Done with backup." +} + check_makefile_exists() { if [[ ! -e "Makefile" ]] ; then echo "" @@ -366,9 +405,9 @@ make_factor() { update_boot_images() { echo "Deleting old images..." - rm checksums.txt* > /dev/null 2>&1 - rm $BOOT_IMAGE.* > /dev/null 2>&1 - rm temp/staging.*.image > /dev/null 2>&1 + $DELETE checksums.txt* > /dev/null 2>&1 + $DELETE $BOOT_IMAGE.* > /dev/null 2>&1 + $DELETE temp/staging.*.image > /dev/null 2>&1 if [[ -f $BOOT_IMAGE ]] ; then get_url http://factorcode.org/images/latest/checksums.txt factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`; @@ -382,7 +421,7 @@ update_boot_images() { if [[ "$factorcode_md5" == "$disk_md5" ]] ; then echo "Your disk boot image matches the one on factorcode.org." else - rm $BOOT_IMAGE > /dev/null 2>&1 + $DELETE $BOOT_IMAGE > /dev/null 2>&1 get_boot_image; fi else @@ -459,6 +498,7 @@ install() { update() { get_config_info git_pull_factorcode + backup_factor make_clean make_factor } @@ -469,12 +509,12 @@ update_bootstrap() { } refresh_image() { - ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit" + ./$FACTOR_BINARY -script -e="USE: vocabs.loader USE: system refresh-all USE: memory save 0 exit" check_ret factor } make_boot_image() { - ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: system USE: bootstrap.image make-image save 0 exit" check_ret factor } @@ -513,6 +553,9 @@ if [[ -n "$2" ]] ; then parse_build_info $2 fi +set_copy +set_delete + case "$1" in install) install ;; install-x11) install_build_system_apt; install ;; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index ca8125d936..25f6f36e7c 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -175,6 +175,7 @@ SYMBOL: +character-device+ SYMBOL: +block-device+ SYMBOL: +fifo+ SYMBOL: +socket+ +SYMBOL: +whiteout+ SYMBOL: +unknown+ ! File metadata diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 289d39868c..40094d5589 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -606,7 +606,7 @@ HELP: 3compose } ; HELP: dip -{ $values { "obj" object } { "quot" quotation } } +{ $values { "x" object } { "quot" quotation } } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." } { $notes "The following are equivalent:" { $code ">r foo bar r>" } @@ -614,7 +614,7 @@ HELP: dip } ; HELP: 2dip -{ $values { "obj1" object } { "obj2" object } { "quot" quotation } } +{ $values { "x" object } { "y" object } { "quot" quotation } } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." } { $notes "The following are equivalent:" { $code ">r >r foo bar r> r>" } @@ -622,7 +622,7 @@ HELP: 2dip } ; HELP: 3dip -{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" quotation } } +{ $values { "x" object } { "y" object } { "z" object } { "quot" quotation } } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." } { $notes "The following are equivalent:" { $code ">r >r >r foo bar r> r> r>" } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 62e37ef301..18bead109d 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -55,18 +55,18 @@ DEFER: if : 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline -: dip ( obj quot -- obj ) swap slip ; inline +: dip ( x quot -- x ) swap slip ; inline -: 2dip ( obj1 obj2 quot -- obj1 obj2 ) -rot 2slip ; inline +: 2dip ( x y quot -- x y ) swap >r dip r> ; inline -: 3dip ( obj1 obj2 obj3 quot -- obj1 obj2 obj3 ) -roll 3slip ; inline +: 3dip ( x y z quot -- x y z ) swap >r 2dip r> ; inline ! Keepers -: keep ( x quot -- x ) over slip ; inline +: keep ( x quot -- x ) dupd dip ; inline -: 2keep ( x y quot -- x y ) 2over 2slip ; inline +: 2keep ( x y quot -- x y ) >r 2dup r> 2dip ; inline -: 3keep ( x y z quot -- x y z ) >r 3dup r> -roll 3slip ; inline +: 3keep ( x y z quot -- x y z ) >r 3dup r> 3dip ; inline ! Cleavers : bi ( x p q -- ) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index ed8fc4510b..007120fd19 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -52,7 +52,12 @@ SYMBOL: in M: parsing-word stack-effect drop (( parsed -- parsed )) ; -ERROR: no-current-vocab ; +TUPLE: no-current-vocab ; + +: no-current-vocab ( -- vocab ) + \ no-current-vocab boa + { { "Define words in scratchpad vocabulary" "scratchpad" } } + throw-restarts dup set-in ; : current-vocab ( -- str ) in get [ no-current-vocab ] unless* ; @@ -64,20 +69,33 @@ ERROR: no-current-vocab ; : CREATE-WORD ( -- word ) CREATE dup reset-generic ; -: word-restarts ( possibilities -- restarts ) - natural-sort [ - [ - "Use the " swap vocabulary>> " vocabulary" 3append - ] keep - ] { } map>assoc ; +: word-restarts ( name possibilities -- restarts ) + natural-sort + [ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc + swap "Defer word in current vocabulary" swap 2array + suffix ; ERROR: no-word-error name ; +: ( name possibilities -- error restarts ) + [ drop \ no-word-error boa ] [ word-restarts ] 2bi ; + +SYMBOL: amended-use? + +SYMBOL: do-what-i-mean? + +: no-word-restarted ( restart-value -- word ) + dup word? + [ amended-use? on dup vocabulary>> (use+) ] + [ create-in ] + if ; + : no-word ( name -- newword ) - dup \ no-word-error boa - swap words-named [ forward-reference? not ] filter - word-restarts throw-restarts - dup vocabulary>> (use+) ; + dup words-named [ forward-reference? not ] filter + dup length 1 = do-what-i-mean? get and + [ nip first no-word-restarted ] + [ throw-restarts no-word-restarted ] + if ; : check-forward ( str word -- word/f ) dup forward-reference? [ @@ -127,7 +145,9 @@ ERROR: staging-violation word ; : parsed ( accum obj -- accum ) over push ; : (parse-lines) ( lexer -- quot ) - [ f parse-until >quotation ] with-lexer ; + [ + f parse-until >quotation + ] with-lexer ; : parse-lines ( lines -- quot ) lexer-factory get call (parse-lines) ; @@ -206,8 +226,18 @@ SYMBOL: interactive-vocabs call ] with-scope ; inline +SYMBOL: print-use-hook + +print-use-hook global [ [ ] or ] change-at + : parse-fresh ( lines -- quot ) - [ parse-lines ] with-file-vocabs ; + [ + amended-use? off + parse-lines + amended-use? get [ + print-use-hook get call + ] when + ] with-file-vocabs ; : parsing-file ( file -- ) "quiet" get [ diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index d160740c44..8ed7a3c31b 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -1,58 +1,34 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences math opengl.gadgets kernel -byte-arrays cairo.ffi cairo io.backend -ui.gadgets accessors opengl.gl -arrays fry classes ; +USING: sequences math kernel byte-arrays cairo.ffi cairo +io.backend ui.gadgets accessors opengl.gl arrays fry +classes ui.render namespaces ; IN: cairo.gadgets : width>stride ( width -- stride ) 4 * ; -: copy-cairo ( dim quot -- byte-array ) - >r first2 over width>stride - [ * nip dup CAIRO_FORMAT_ARGB32 ] - [ cairo_image_surface_create_for_data ] 3bi - r> with-cairo-from-surface ; inline +GENERIC: render-cairo* ( gadget -- ) -TUPLE: cairo-gadget < texture-gadget ; +: render-cairo ( gadget -- byte-array ) + dup dim>> first2 over width>stride + [ * nip dup CAIRO_FORMAT_ARGB32 ] + [ cairo_image_surface_create_for_data ] 3bi + rot '[ _ render-cairo* ] with-cairo-from-surface ; inline + +TUPLE: cairo-gadget < gadget ; : ( dim -- gadget ) cairo-gadget new-gadget swap >>dim ; -M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ; - -: render-cairo ( dim quot -- bytes format ) - >r 2^-bounds r> copy-cairo GL_BGRA ; inline - -GENERIC: render-cairo* ( gadget -- ) - -M: cairo-gadget render* - [ dim>> dup ] [ '[ _ render-cairo* ] ] bi - render-cairo render-bytes* ; - -! maybe also texture>png -! : cairo>png ( gadget path -- ) -! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ] -! [ height>> ] tri over width>stride -! cairo_image_surface_create_for_data -! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ; +M: cairo-gadget draw-gadget* + [ dim>> ] [ render-cairo ] bi + origin get first2 glRasterPos2i + 1.0 -1.0 glPixelZoom + >r first2 GL_BGRA GL_UNSIGNED_BYTE r> + glDrawPixels ; : copy-surface ( surface -- ) cr swap 0 0 cairo_set_source_surface cr cairo_paint ; - -TUPLE: png-gadget < texture-gadget path ; -: ( path -- gadget ) - png-gadget new-gadget - swap >>path ; - -M: png-gadget render* - path>> normalize-path cairo_image_surface_create_from_png - [ cairo_image_surface_get_width ] - [ cairo_image_surface_get_height 2array dup 2^-bounds ] - [ [ copy-surface ] curry copy-cairo ] tri - GL_BGRA render-bytes* ; - -M: png-gadget cache-key* path>> ; diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index ea5462acf2..3bd1a5f174 100644 --- a/extra/cap/cap.factor +++ b/extra/cap/cap.factor @@ -6,7 +6,7 @@ models opengl.framebuffers ui.gadgets.worlds ui.gadgets fry alien.syntax ; IN: cap : screenshot-array ( world -- byte-array ) - dim>> product 3 * ; + dim>> [ first 3 * 4 align ] [ second ] bi * ; : gl-screenshot ( gadget -- byte-array ) [ diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor index 758bfe280e..d028ea958c 100644 --- a/extra/opengl/gadgets/gadgets.factor +++ b/extra/opengl/gadgets/gadgets.factor @@ -47,6 +47,11 @@ C: cache-entry cache-key* textures get delete-at* [ tex>> delete-texture ] [ drop ] if ; +: clear-textures ( -- ) + textures get values [ tex>> delete-texture ] each + H{ } clone textures set-global + H{ } clone refcounts set-global ; + M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ; M: texture-gadget ungraft* ( gadget -- ) diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 06468b8751..826c66851e 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -15,16 +15,26 @@ main() ; STRING: plane-fragment-shader +uniform float checker_size_inv; +uniform vec4 checker_color_1, checker_color_2; varying vec3 object_position; + +bool +checker_color(vec3 p) +{ + vec3 pprime = checker_size_inv * object_position; + return fract((floor(pprime.x) + floor(pprime.z)) * 0.5) == 0.0; +} + void main() { float distance_factor = (gl_FragCoord.z * 0.5 + 0.5); distance_factor = pow(distance_factor, 500.0)*0.5; - gl_FragColor = fract((floor(0.125*object_position.x)+floor(0.125*object_position.z)) * 0.5) == 0.0 - ? vec4(1.0, 1.0 - distance_factor, 1.0 - distance_factor, 1.0) - : vec4(1.0, distance_factor, distance_factor, 1.0); + gl_FragColor = checker_color(object_position) + ? mix(checker_color_1, checker_color_2, distance_factor) + : mix(checker_color_2, checker_color_1, distance_factor); } ; @@ -213,7 +223,11 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) ] with-gl-program ] [ plane-program>> [ - drop + { + [ "checker_size_inv" glGetUniformLocation 0.125 glUniform1f ] + [ "checker_color_1" glGetUniformLocation 1.0 0.5 0.0 1.0 glUniform4f ] + [ "checker_color_2" glGetUniformLocation 0.0 0.0 0.0 1.0 glUniform4f ] + } cleave GL_QUADS [ -1000.0 -30.0 1000.0 glVertex3f -1000.0 -30.0 -1000.0 glVertex3f diff --git a/extra/ui/render/test/reference.bmp b/extra/ui/render/test/reference.bmp index 0740fcc817..3ba20c4043 100644 Binary files a/extra/ui/render/test/reference.bmp and b/extra/ui/render/test/reference.bmp differ diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor old mode 100644 new mode 100755 index 01b5b65bcf..2267c22a20 --- a/extra/ui/render/test/test.factor +++ b/extra/ui/render/test/test.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors colors arrays kernel sequences math byte-arrays -namespaces cap graphics.bitmap +namespaces grouping fry cap graphics.bitmap ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons ui.render ui opengl opengl.gl ; @@ -17,29 +17,45 @@ M: line-test draw-interior line-test >>interior { 1 10 } >>dim ; -TUPLE: ui-render-test < pack { first-time? initial: t } ; - : message-window ( text -- )