diff --git a/.travis.yml b/.travis.yml index 393fe6bea6..0e8649d65b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -11,6 +11,14 @@ group: deprecated-2017Q4 services: - postgresql - redis-server +branches: + except: + - clean-windows-x86-64 + - clean-windows-x86-32 + - clean-linux-x86-64 + - clean-linux-x86-32 + - clean-macosx-x86-64 + - clean-macosx-x86-32 addons: apt: packages: @@ -36,9 +44,29 @@ before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start redis; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start postgresql; fi - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start memcached; fi + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rm -rf ~/.gnupg/; fi # https://github.com/rvm/rvm/issues/3110 + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -#LO https://rvm.io/mpapis.asc; fi + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then gpg --import mpapis.asc; fi + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then curl -sSL https://get.rvm.io | bash -s stable; fi # https://github.com/travis-ci/travis-ci/issues/6307 - > wget https://github.com/vmt/udis86/archive/v1.7.2.tar.gz && tar xzvf v1.7.2.tar.gz && ( cd udis86-1.7.2/ && ./autogen.sh && ./configure --enable-shared=yes && make && sudo make install ) && ( [[ "$TRAVIS_OS_NAME" != "osx" ]] && sudo ldconfig || true ) + - git remote set-branches --add origin master + - git remote set-branches --add origin clean-windows-x86-64 + - git remote set-branches --add origin clean-windows-x86-32 + - git remote set-branches --add origin clean-linux-x86-64 + - git remote set-branches --add origin clean-linux-x86-32 + - git remote set-branches --add origin clean-macosx-x86-64 + - git remote set-branches --add origin clean-macosx-x86-32 + - git fetch # so we can see which vocabs changed versus origin/master... script: + - echo "TRAVIS_BRANCH=$TRAVIS_BRANCH, TRAVIS_PULL_REQUEST_BRANCH=$TRAVIS_PULL_REQUEST_BRANCH" + - export CI_BRANCH="${TRAVIS_PULL_REQUEST_BRANCH:-$TRAVIS_BRANCH}" + - echo "CI_BRANCH=${CI_BRANCH}" - DEBUG=1 ./build.sh net-bootstrap < /dev/null + - "./factor -e='USING: memory vocabs.hierarchy ; \"zealot\" load save'" + - './factor -run=zealot.cli-changed-vocabs' + - './factor -run=tools.test `./factor -run=zealot.cli-changed-vocabs | paste -s -d " " -`' + - './factor -run=help.lint `./factor -run=zealot.cli-changed-vocabs | paste -s -d " " -`' + - "./factor -e='USING: modern.paths tools.test sequences system kernel math random ; core-vocabs os macosx? [ dup length 3 /i sample ] when [ test ] each'" diff --git a/Factor.app/Contents/Info.plist b/Factor.app/Contents/Info.plist index b4b1325ce7..48581e7554 100644 --- a/Factor.app/Contents/Info.plist +++ b/Factor.app/Contents/Info.plist @@ -32,9 +32,9 @@ CFBundlePackageType APPL CFBundleVersion - 0.98 + 0.99 NSHumanReadableCopyright - Copyright © 2003-2017 Factor developers + Copyright © 2003-2018 Factor developers NSServices diff --git a/GNUmakefile b/GNUmakefile index 1d4ebaabcf..0cf1d9fd4c 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,5 +1,5 @@ ifdef CONFIG - VERSION = 0.98 + VERSION = 0.99 GIT_LABEL = $(shell echo `git describe --all`-`git rev-parse HEAD`) BUNDLE = Factor.app diff --git a/Nmakefile b/Nmakefile index 310358a60b..0b0ce66777 100644 --- a/Nmakefile +++ b/Nmakefile @@ -1,4 +1,4 @@ -VERSION = 0.98 +VERSION = 0.99 # Crazy hack to do shell commands # We do it in Nmakefile because that way we don't have to invoke build through build.cmd diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor old mode 100755 new mode 100644 diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor old mode 100755 new mode 100644 diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor old mode 100755 new mode 100644 diff --git a/basis/bootstrap/image/primitives/primitives-docs.factor b/basis/bootstrap/image/primitives/primitives-docs.factor index 78b9f08056..ce435ac5a7 100644 --- a/basis/bootstrap/image/primitives/primitives-docs.factor +++ b/basis/bootstrap/image/primitives/primitives-docs.factor @@ -19,7 +19,7 @@ HELP: primitive-quot { $description "Creates the defining quotation for the primitive. If 'vm-func' is a string, then it is prefixed with 'primitive_' and a quotation calling that C++ function is generated." } ; ARTICLE: "bootstrap.image.primitives" "Bootstrap primitives" -"This vocab contains utilities for declaring primitives to be added to the bootstrap image. It is used by " { $vocab-link "bootstrap.primitives" } +"This vocab contains utilities for declaring primitives to be added to the bootstrap image. It is used by the file " { $snippet "resource:core/bootstrap/primitives.factor" } $nl { $link all-primitives } " is an assoc where all primitives are declared. See that constant for a description of the format." ; diff --git a/basis/cache/cache-tests.factor b/basis/cache/cache-tests.factor old mode 100755 new mode 100644 diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor old mode 100755 new mode 100644 diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 3807f3cb51..65c75613c8 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar calendar.english combinators io -io.streams.string kernel macros math math.order math.parser -math.parser.private present quotations sequences typed words ; +USING: accessors arrays calendar calendar.english combinators +fry io io.streams.string kernel macros math math.order +math.parser math.parser.private present quotations sequences +typed words ; IN: calendar.format MACRO: formatted ( spec -- quot ) @@ -16,6 +17,9 @@ MACRO: formatted ( spec -- quot ) : pad-00 ( n -- str ) number>string 2 char: 0 pad-head ; +: formatted>string ( spec -- string ) + '[ _ formatted ] with-string-writer ; inline + : pad-0000 ( n -- str ) number>string 4 char: 0 pad-head ; : pad-00000 ( n -- str ) number>string 5 char: 0 pad-head ; diff --git a/basis/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor index 3f31092610..4a8f201da9 100644 --- a/basis/cocoa/messages/messages-docs.factor +++ b/basis/cocoa/messages/messages-docs.factor @@ -2,13 +2,13 @@ USING: help.markup help.syntax strings alien ; IN: cocoa.messages HELP: send -{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } } +{ $values { "receiver" alien } { "args..." "method arguments" } { "signature" "signature" } { "selector" string } { "return..." "value returned by method, if any" } } { $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." } { $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." } { $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ; HELP: super-send -{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } } +{ $values { "receiver" alien } { "args..." "method arguments" } { "signature" "signature" } { "selector" string } { "return..." "value returned by method, if any" } } { $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ; HELP: objc-class diff --git a/basis/compiler/cfg/builder/builder-docs.factor b/basis/compiler/cfg/builder/builder-docs.factor index d62c66c131..986ea8043f 100644 --- a/basis/compiler/cfg/builder/builder-docs.factor +++ b/basis/compiler/cfg/builder/builder-docs.factor @@ -1,7 +1,7 @@ -USING: assocs compiler.cfg compiler.cfg.builder.blocks -compiler.cfg.instructions compiler.cfg.stacks.local compiler.tree -help.markup help.syntax kernel literals math multiline quotations -sequences vectors words ; +USING: arrays assocs compiler.cfg compiler.cfg.builder.blocks +compiler.cfg.instructions compiler.cfg.stacks.local +compiler.tree help.markup help.syntax kernel literals math +multiline quotations sequences vectors words ; IN: compiler.cfg.builder << @@ -104,7 +104,7 @@ HELP: end-word { $description "Ends the word by adding a basic block containing a " { $link ##return } " instructions to the " { $link cfg } "." } ; HELP: height-changes -{ $values { "#shuffle" #shuffle } { "height-changes" sequence } } +{ $values { "#shuffle" #shuffle } { "height-changes" pair } } { $description "Returns a two-tuple which represents how much the " { $link #shuffle } " node increases or decreases the data and retainstacks." } { $examples { $example @@ -115,7 +115,7 @@ HELP: height-changes } ; HELP: out-vregs/stack -{ $values { "#shuffle" #shuffle } { "seq" sequence } } +{ $values { "#shuffle" #shuffle } { "pair" sequence } } { $description "Returns a sequence of what vregs are on which stack locations after the shuffle instruction." } ; HELP: trivial-branch? diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-docs.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-docs.factor index 6d9ad819bd..646c0d8674 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment-docs.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment-docs.factor @@ -72,7 +72,7 @@ HELP: vreg>reg { $see-also lookup-spill-slot pending-interval-assoc } ; HELP: vregs>regs -{ $values { "assoc" "an " { $link assoc } " (set) of virtual registers" } { "assoc" assoc } } +{ $values { "assoc" "an " { $link assoc } " (set) of virtual registers" } { "assoc'" assoc } } { $description "Creates a mapping of virtual registers to registers." } ; HELP: vreg>spill-slot diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 65038a1b9a..ef1d0a2b5e 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -33,7 +33,7 @@ SYMBOL: pending-interval-assoc : remove-pending ( live-interval -- ) vreg>> pending-interval-assoc get delete-at ; -: vreg>spill-slot ( vreg -- slot ) +: vreg>spill-slot ( vreg -- spill-slot ) dup rep-of lookup-spill-slot ; : vreg>reg ( vreg -- reg/spill-slot ) diff --git a/basis/compiler/cfg/stacks/local/local-docs.factor b/basis/compiler/cfg/stacks/local/local-docs.factor index dc9015acf7..39a9dde1f6 100644 --- a/basis/compiler/cfg/stacks/local/local-docs.factor +++ b/basis/compiler/cfg/stacks/local/local-docs.factor @@ -51,7 +51,7 @@ HELP: height-state { $see-also inc-stack reset-incs } ; HELP: height-state>insns -{ $values { "state" sequence } { "insns" sequence } } +{ $values { "height-state" height-state } { "insns" sequence } } { $description "Converts a " { $link height-state } " tuple to 0-2 stack height change instructions." } { $examples "In this example the datastacks height is increased by 4 and the retainstacks decreased by 2." @@ -67,7 +67,7 @@ HELP: inc-stack { $description "Increases or decreases the data or retain stack depending on if loc is a " { $link ds-loc } " or " { $link rs-loc } " instance. An " { $link ##inc } " instruction will later be inserted." } ; HELP: local-loc>global -{ $values { "loc" loc } { "bb" basic-block } { "loc'" loc } } +{ $values { "loc" loc } { "height-state" height-state } { "loc'" loc } } { $description "Translates a stack location relative to a block to an absolute one. The word does the opposite to " { $link global-loc>local } "." } ; HELP: loc>vreg @@ -76,10 +76,11 @@ HELP: loc>vreg HELP: local-kill-set { $values - { "ds-height" integer } + { "ds-begin" integer } { "ds-inc" integer } - { "rs-height" integer } + { "rs-begin" integer } { "rs-inc" integer } + { "set" hash-set } } { $description "The set of stack locations that was killed. Locations on a stack are deemed killed if that stacks height is decremented." } { $see-also compute-local-kill-set } ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor old mode 100755 new mode 100644 diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor old mode 100755 new mode 100644 diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 87c09b93bc..8e48eff685 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -225,7 +225,7 @@ M: float detect-float ; { shift fixnum-shift } inlined? ] unit-test -cell-bits 32 = [ +32bit? [ [ t ] [ [ { fixnum fixnum } declare 1 swap 31 bitand shift ] \ shift inlined? diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index f361ed8456..d113e6b360 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -492,7 +492,7 @@ IN: compiler.tree.propagation.tests [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes ] unit-test -cell-bits 32 = [ +32bit? [ [ V{ integer } ] [ [ { fixnum } declare 1 swap 31 bitand shift ] final-classes diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor old mode 100755 new mode 100644 diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor old mode 100755 new mode 100644 diff --git a/basis/concurrency/mailboxes/debugger/debugger.factor b/basis/concurrency/mailboxes/debugger/debugger.factor old mode 100755 new mode 100644 diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor old mode 100755 new mode 100644 diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor old mode 100755 new mode 100644 diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor old mode 100755 new mode 100644 diff --git a/basis/editors/ui/ui.factor b/basis/editors/ui/ui.factor new file mode 100644 index 0000000000..b69a17991b --- /dev/null +++ b/basis/editors/ui/ui.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2018 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors editors fry kernel sequences ui ui.gadgets +ui.gadgets.borders ui.gadgets.buttons ui.gadgets.packs +ui.gadgets.scrollers ui.tools.listener vocabs.loader ; +IN: editors.ui + +: ( editor -- button ) + dup '[ drop [ _ reload ] \ run call-listener ] ; + +: ( -- gadget ) + { 2 2 } >>gap available-editors + [ add-gadget ] each ; + +MAIN-WINDOW: editor-window { { title "Editors" } } + { 2 2 } >>gadgets ; diff --git a/basis/english/english-docs.factor b/basis/english/english-docs.factor index 4cbe1a5e96..e025a04aa9 100644 --- a/basis/english/english-docs.factor +++ b/basis/english/english-docs.factor @@ -110,7 +110,7 @@ HELP: count-of-things } ; HELP: ?pluralize -{ $values { "count" number } { "singular" string } { "singluar/plural" string } } +{ $values { "count" number } { "singular" string } { "singular/plural" string } } { $description "A simpler variant of " { $link count-of-things } " which omits its input value from the output. As with " { $link count-of-things } ", " { $snippet "word" } " is expected to be in singular form." } { $notes { $list $keep-case $0-plurality } } { $examples @@ -189,7 +189,7 @@ HELP: comma-list } ; HELP: or-markup-example -{ $values { "markup" "a sequence of markup elements" } { "classes" "a sequence of words" } } +{ $values { "classes" "a sequence of words" } { "markup" "a sequence of markup elements" } } { $description "Used to implement " { $link $or-markup-example } " and demonstrate " { $link comma-list } "." } { $examples { "See the examples in " { $link $or-markup-example } "." } } ; diff --git a/basis/escape-strings/escape-strings.factor b/basis/escape-strings/escape-strings.factor index 4d2578549a..5f837c6d1e 100644 --- a/basis/escape-strings/escape-strings.factor +++ b/basis/escape-strings/escape-strings.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2017 John Benediktsson, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math math.order math.statistics -sequences sequences.extras sets ; +USING: assocs assocs.extras combinators kernel math math.order +math.statistics sequences sequences.extras sets ; IN: escape-strings : find-escapes ( str -- set ) @@ -26,16 +26,14 @@ IN: escape-strings dup find-escapes lowest-missing escape-string* ; : escape-strings ( strs -- str ) - dup [ find-escapes ] map - [ - [ lowest-missing ] map - [ escape-string* ] 2map concat - ] [ - [ ] [ union ] map-reduce - ] bi - dup cardinality 0 = [ - drop 1 - ] [ - members minmax nip 2 + - ] if - escape-string* ; + [ escape-string ] map concat escape-string ; + +: tag-payload ( str tag -- str' ) + [ escape-string ] dip prepend ; + +: escape-simplest ( str -- str' ) + dup { char: \' char: \" char: \r char: \n char: \s } counts { + { [ dup { char: \' char: \r char: \n char: \s } values-of sum 0 = ] [ drop "'" prepend ] } + { [ dup char: \" of not ] [ drop "\"" "\"" surround ] } + [ drop escape-string ] + } cond ; diff --git a/basis/formatting/formatting-docs.factor b/basis/formatting/formatting-docs.factor old mode 100755 new mode 100644 diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor old mode 100755 new mode 100644 diff --git a/basis/game/input/dinput/dinput.factor b/basis/game/input/dinput/dinput.factor old mode 100755 new mode 100644 diff --git a/basis/globs/globs-tests.factor b/basis/globs/globs-tests.factor old mode 100755 new mode 100644 diff --git a/basis/gobject-introspection/gobject-introspection.factor b/basis/gobject-introspection/gobject-introspection.factor old mode 100755 new mode 100644 diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor index 8e3d73487d..af7880d9b3 100644 --- a/basis/help/lint/checks/checks.factor +++ b/basis/help/lint/checks/checks.factor @@ -4,10 +4,10 @@ USING: accessors arrays assocs classes classes.struct classes.tuple combinators combinators.short-circuit combinators.smart continuations debugger definitions effects eval formatting fry grouping help help.markup help.topics io -io.streams.string kernel macros math namespaces parser.notes -prettyprint sequences sequences.deep sets splitting strings -summary tools.destructors unicode vocabs vocabs.loader words -words.constant words.symbol ; +io.streams.string kernel macros math math.statistics namespaces +parser.notes prettyprint sequences sequences.deep sets splitting +strings summary tools.destructors unicode vocabs vocabs.loader +words words.constant words.symbol ; IN: help.lint.checks ERROR: simple-lint-error message ; @@ -26,6 +26,7 @@ SYMBOL: vocab-articles "line" ! core-text "layout" ! ui.text.pango "script-string" ! windows.uniscribe + "linux-monitor" ! github issue #2014, race condition in disposing of child monitors } member? ] reject ; @@ -50,9 +51,13 @@ SYMBOL: vocab-articles ] keep last assert= ] vocabs-quot get call( quot -- ) - ] leaks members no-ui-disposables length [ - "%d disposable(s) leaked in example" sprintf simple-lint-error - ] unless-zero ; + ] leaks members no-ui-disposables + dup length 0 > [ + dup [ class-of ] histogram-by + [ "Leaked resources: " write ... ] with-string-writer simple-lint-error + ] [ + drop + ] if ; : check-examples ( element -- ) \ $example swap elements [ check-example ] each ; @@ -99,7 +104,7 @@ SYMBOL: vocab-articles [ parsing-word? ] [ "declared-effect" word-prop not ] [ constant? ] - [ "word-help" word-prop not ] + [ "help" word-prop not ] } 1|| ; : skip-check-values? ( word element -- ? ) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 95a2f7e0d0..c126b956be 100644 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs combinators continuations fry help -help.lint.checks help.topics io kernel namespaces parser -sequences source-files.errors vocabs.hierarchy vocabs words -classes locals tools.errors listener ; +USING: assocs classes combinators command-line continuations fry +help help.lint.checks help.topics io kernel listener locals +namespaces parser sequences source-files.errors system +tools.errors vocabs vocabs.hierarchy ; IN: help.lint SYMBOL: lint-failures @@ -97,3 +97,12 @@ PRIVATE> [ word-help ] reject [ article-parent ] filter [ predicate? ] reject ; + +: test-lint-main ( -- ) + command-line get [ load ] each + help-lint-all + lint-failures get assoc-empty? + [ [ "==== FAILING LINT" print :lint-failures flush ] unless ] + [ 0 1 ? exit ] bi ; + +MAIN: test-lint-main diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index e52486d3ee..635b459d0d 100644 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -42,7 +42,7 @@ GENERIC: valid-article? ( topic -- ? ) GENERIC: article-title ( topic -- string ) GENERIC: article-name ( topic -- string ) GENERIC: article-content ( topic -- content ) -GENERIC: article-parent ( topic -- parent ) +GENERIC: article-parent ( topic -- parent/f ) GENERIC: set-article-parent ( parent topic -- ) M: object article-name article-title ; diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor old mode 100755 new mode 100644 diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor old mode 100755 new mode 100644 diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor index caf2913cf2..db49a4bdd0 100644 --- a/basis/io/directories/directories-docs.factor +++ b/basis/io/directories/directories-docs.factor @@ -20,7 +20,7 @@ $nl "This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ; HELP: make-parent-directories -{ $values { "path" "a pathname string" } } +{ $values { "filename" "a pathname string" } } { $description "Creates all parent directories of the path which do not yet exist." } { $errors "Throws an error if the directories could not be created." } ; diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor old mode 100755 new mode 100644 diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor old mode 100755 new mode 100644 index f1f5593128..585ab4e18e --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -8,7 +8,7 @@ io.files.types io.pathnames io.ports io.streams.c io.streams.null io.timeouts kernel libc literals locals math math.bitwise namespaces sequences specialized-arrays system threads tr vectors windows windows.errors windows.handles windows.kernel32 windows.shell32 -windows.time windows.types windows.winsock ; +windows.time windows.types windows.winsock splitting ; SPECIALIZED-ARRAY: ushort IN: io.files.windows @@ -326,11 +326,14 @@ M: windows root-directory? ( path -- ? ) [ drop f ] } cond ; -: prepend-prefix ( string -- string' ) +: prepend-unicode-prefix ( string -- string' ) dup unicode-prefix head? [ unicode-prefix prepend ] unless ; +: remove-unicode-prefix ( string -- string' ) + unicode-prefix ?head drop ; + TR: normalize-separators "/" "\\" ; +M: windows canonicalize-path + remove-unicode-prefix canonicalize-path* ; + +M: object root-path remove-unicode-prefix root-path* ; + +M: object relative-path remove-unicode-prefix relative-path* ; + M: windows normalize-path ( string -- string' ) dup unc-path? [ normalize-separators ] [ absolute-path normalize-separators - prepend-prefix + prepend-unicode-prefix ] if ; : with-process-reader ( desc encoding quot -- ) with-process-reader* check-success ; inline +: process-lines ( desc -- lines ) + utf8 stream-lines ; + >command [ "err2" ".txt" unique-file ] with-temp-directory [ err-path set-global ] keep >>stderr - utf8 stream-lines first + process-lines first ] with-directory ] unit-test diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor old mode 100755 new mode 100644 diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor old mode 100755 new mode 100644 diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor old mode 100755 new mode 100644 diff --git a/basis/io/servers/servers.factor b/basis/io/servers/servers.factor old mode 100755 new mode 100644 diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor old mode 100755 new mode 100644 diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index ac9e053985..fa43da2186 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -109,11 +109,11 @@ HELP: lappend-lazy { $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link lazy-append } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ; HELP: lfrom-by -{ $values { "n" integer } { "quot" { $quotation ( n -- o ) } } { "lazy-from-by" "a lazy list of integers" } } +{ $values { "n" integer } { "quot" { $quotation ( n -- o ) } } { "result" "a lazy list of integers" } } { $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to the previous value." } ; HELP: lfrom -{ $values { "n" integer } { "list" "a lazy list of integers" } } +{ $values { "n" integer } { "result" "a lazy list of integers" } } { $description "Return an infinite lazy list of incrementing integers starting from n." } ; HELP: sequence-tail>list diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor old mode 100755 new mode 100644 diff --git a/basis/math/floats/env/x86/x86-tests.factor b/basis/math/floats/env/x86/x86-tests.factor old mode 100755 new mode 100644 diff --git a/basis/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor index 3855357b46..f82fef7c85 100644 --- a/basis/math/matrices/matrices-tests.factor +++ b/basis/math/matrices/matrices-tests.factor @@ -383,3 +383,12 @@ CONSTANT: test-points { { t } [ { { 1 2 } { 3 4 } } square-matrix? ] unit-test { f } [ { { 1 } { 2 3 } } square-matrix? ] unit-test { f } [ { { 1 2 } } square-matrix? ] unit-test + +{ 9 } +[ { { 2 -2 1 } { 1 3 -1 } { 2 -4 2 } } m-1norm ] unit-test + +{ 8 } +[ { { 2 -2 1 } { 1 3 -1 } { 2 -4 2 } } m-infinity-norm ] unit-test + +{ 2.0 } +[ { { 1 1 } { 1 1 } } frobenius-norm ] unit-test diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 0cab9a1472..ef5a06a22f 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -141,6 +141,9 @@ IN: math.matrices : mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; : mnorm ( m -- n ) dup mmax abs m/n ; +: m-infinity-norm ( m -- n ) [ [ abs ] map-sum ] map supremum ; +: m-1norm ( m -- n ) flip m-infinity-norm ; +: frobenius-norm ( m -- n ) [ [ sq ] map-sum ] map-sum sqrt ; : cross ( vec1 vec2 -- vec3 ) [ [ { 1 2 0 } vshuffle ] [ { 2 0 1 } vshuffle ] bi* v* ] diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 2a5bfb31f7..1cd001c36e 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -304,7 +304,7 @@ HELP: vmin { $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ; HELP: vclamp -{ $values { "v" "a sequence of real numbers" } { "min" "a sequence of real numbers" } { "max" "a sequence of real numbers" } } +{ $values { "v" "a sequence of real numbers" } { "min" "a sequence of real numbers" } { "max" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } { $description "Creates a sequence where each element is clamped to the minimum and maximum elements of the " { $snippet "min" } " and " { $snippet "max" } " sequences." } { $examples { $example diff --git a/basis/opengl/shaders/shaders-docs.factor b/basis/opengl/shaders/shaders-docs.factor index 7051364386..7b314f92ed 100644 --- a/basis/opengl/shaders/shaders-docs.factor +++ b/basis/opengl/shaders/shaders-docs.factor @@ -6,6 +6,7 @@ HELP: (gl-program) { $values { "shaders" sequence } { "quot" quotation } + { "program" "a new " { $link gl-program } } } { $description "Creates a gl program and attaches the shaders to it. Then applies the quotation to the program and finally links it." } diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor old mode 100755 new mode 100644 diff --git a/basis/suffix-arrays/suffix-arrays-docs.factor b/basis/suffix-arrays/suffix-arrays-docs.factor index 55692aaedd..ce1ae6d609 100644 --- a/basis/suffix-arrays/suffix-arrays-docs.factor +++ b/basis/suffix-arrays/suffix-arrays-docs.factor @@ -7,7 +7,7 @@ IN: suffix-arrays HELP: >suffix-array { $values { "seq" sequence } - { "array" array } } + { "suffix-array" array } } { $description "Creates a suffix array from the input sequence. Suffix arrays are arrays of slices." } ; HELP: \SA{ diff --git a/basis/system-info/linux/linux.factor b/basis/system-info/linux/linux.factor index ab16ddc366..e1cdc85474 100644 --- a/basis/system-info/linux/linux.factor +++ b/basis/system-info/linux/linux.factor @@ -26,3 +26,4 @@ M: linux cpus parse-proc-cpuinfo sort-cpus cpu-counts 2drop ; M: linux hyperthreads ( -- n ) parse-proc-cpuinfo sort-cpus cpu-counts 2nip ; M: linux cpu-mhz parse-proc-cpuinfo first cpu-mhz>> 1,000,000 * ; M: linux physical-mem parse-proc-meminfo mem-total>> ; +M: linux computer-name nodename ; \ No newline at end of file diff --git a/basis/system-info/macosx/macosx.factor b/basis/system-info/macosx/macosx.factor index 38463a004c..4b845ad3ac 100644 --- a/basis/system-info/macosx/macosx.factor +++ b/basis/system-info/macosx/macosx.factor @@ -1,12 +1,10 @@ ! Copyright (C) 2008 Doug Coleman, John Benediktsson. ! See http://factorcode.org/license.txt for BSD license. - -USING: alien alien.c-types alien.data alien.strings alien.syntax -arrays assocs byte-arrays combinators core-foundation io.binary -io.encodings.utf8 libc kernel math namespaces sequences -specialized-arrays system system-info unix ; +USING: alien.c-types alien.data alien.strings alien.syntax +arrays assocs byte-arrays core-foundation io.binary +io.encodings.utf8 kernel libc sequences specialized-arrays +splitting system system-info ; SPECIALIZED-ARRAY: int - IN: system-info.macosx string write bl ] [ write ] bi* ; diff --git a/basis/system-info/windows/windows.factor b/basis/system-info/windows/windows.factor index 67fd38211e..1e7bc07d69 100644 --- a/basis/system-info/windows/windows.factor +++ b/basis/system-info/windows/windows.factor @@ -96,7 +96,7 @@ M: windows total-virtual-mem ( -- n ) M: windows available-virtual-mem ( -- n ) memory-status ullAvailVirtual>> ; -: computer-name ( -- string ) +M: windows computer-name ( -- string ) MAX_COMPUTERNAME_LENGTH 1 + [ dup ] keep uint GetComputerName win32-error=0/f alien>native-string ; diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor old mode 100755 new mode 100644 diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor old mode 100755 new mode 100644 diff --git a/basis/tools/deploy/windows/ico/ico.factor b/basis/tools/deploy/windows/ico/ico.factor old mode 100755 new mode 100644 diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor old mode 100755 new mode 100644 diff --git a/basis/tools/directory-to-file/authors.txt b/basis/tools/directory-to-file/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/tools/directory-to-file/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/tools/directory-to-file/directory-to-file.factor b/basis/tools/directory-to-file/directory-to-file.factor new file mode 100644 index 0000000000..eab46ddb8a --- /dev/null +++ b/basis/tools/directory-to-file/directory-to-file.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2018 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs base64 command-line escape-strings fry io.backend +io.directories io.directories.search io.encodings.binary +io.encodings.utf8 io.files io.files.info io.pathnames kernel +math namespaces sequences sequences.extras splitting ; +IN: tools.directory-to-file + +: file-is-binary? ( path -- ? ) + binary file-contents [ 127 <= ] all? ; + +: directory-to-string ( path -- string ) + normalize-path + [ path-separator = ] trim-tail "/" append + [ recursive-directory-files [ file-info directory? ] reject ] keep + dup '[ + [ _ ?head drop ] map + [ + dup file-is-binary? [ + utf8 file-contents escape-string + ] [ + binary file-contents >base64 "" like escape-string + "base64" prepend + ] if + ] map-zip + ] with-directory + [ + first2 + [ escape-string "FILE: " prepend ] dip " " glue + ] map "\n\n" join ; + +: directory-to-file ( path -- ) + [ directory-to-string ] keep ".modern" append + utf8 set-file-contents ; + +: directory-to-file-main ( -- ) + command-line get dup length 1 = [ "oops" throw ] unless first + directory-to-file ; + +MAIN: directory-to-file-main diff --git a/basis/tools/file-to-directory/authors.txt b/basis/tools/file-to-directory/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/tools/file-to-directory/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/tools/file-to-directory/file-to-directory.factor b/basis/tools/file-to-directory/file-to-directory.factor new file mode 100644 index 0000000000..ead612c0f9 --- /dev/null +++ b/basis/tools/file-to-directory/file-to-directory.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2018 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: base64 command-line fry io.directories +io.encodings.binary io.encodings.utf8 io.files io.pathnames +kernel modern modern.out namespaces sequences splitting strings ; +IN: tools.file-to-directory + +ERROR: expected-one-path got ; +ERROR: expected-modern-path got ; + +: write-directory-files ( path -- ) + [ ".modern" ?tail drop dup make-directories ] + [ path>literals ] bi + '[ + _ [ + second first2 [ third >string ] dip + + [ third ] [ + first "base64" head? + [ [ >string ] [ base64> ] bi* swap binary ] + [ [ >string ] bi@ swap utf8 ] if + ] bi + [ dup parent-directory make-directories ] dip set-file-contents + ] each + ] with-directory ; + +: get-file-to-directory-path ( array -- path ) + dup length 1 = [ expected-one-path ] unless + first dup ".modern" tail? [ expected-modern-path ] unless ; + +: file-to-directory ( -- ) + command-line get get-file-to-directory-path write-directory-files ; + +MAIN: file-to-directory diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index b3eeb1fb08..ba93fc5954 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -316,6 +316,8 @@ M: test-failure error. ( error -- ) : test-main ( -- ) command-line get [ [ load ] [ test ] bi ] each - test-failures get empty? [ 0 ] [ 1 ] if exit ; + test-failures get empty? + [ [ "==== FAILING TESTS" print flush :test-failures ] unless ] + [ 0 1 ? exit ] bi ; MAIN: test-main diff --git a/basis/ui/backend/gtk/gtk-docs.factor b/basis/ui/backend/gtk/gtk-docs.factor index 83e214dd4f..2e436341cb 100644 --- a/basis/ui/backend/gtk/gtk-docs.factor +++ b/basis/ui/backend/gtk/gtk-docs.factor @@ -12,14 +12,14 @@ HELP: icon-data HELP: key-sym { $values - { "event" GdkEventKey } - { "sym/f" { $maybe string } } + { "keyval" GdkEventKey } + { "string/f" { $maybe string } } { "action?" boolean } } { $description "Gets the key symbol and action indicator from a " { $link GdkEventKey } " struct. If 'action?' is " { $link t } ", then the key is one of the special keys in " { $link codes } "." } ; HELP: on-configure { $values - { "win" alien } + { "window" alien } { "event" alien } { "user-data" alien } { "?" boolean } diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor old mode 100755 new mode 100644 index f15b1ec90c..aabe7ab882 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -578,7 +578,7 @@ M: windows-ui-backend do-events 0 >>cbWndExtra f GetModuleHandle >>hInstance f GetModuleHandle "APPICON" native-string>alien LoadIcon >>hIcon - f IDC_ARROW LoadCursor >>hCursor + f IDC_ARROW MAKEINTRESOURCE LoadCursor >>hCursor class-name-ptr >>lpszClassName RegisterClassEx win32-error=0/f diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 274c4d3d3b..4e089e4e87 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -193,6 +193,6 @@ completion-popup H{ [ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ; M: completion-popup handle-gesture ( gesture completion -- ? ) - 2dup completion-gesture dup [ + 2dup completion-gesture [ [ nip hide-glass ] [ invoke-command ] 2bi* f - ] [ 2drop call-next-method ] if ; + ] [ drop call-next-method ] if* ; diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index dd968d0abe..0613ff0c87 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -46,6 +46,8 @@ M: interactor manifest>> GENERIC: (word-at-caret) ( token completion-mode -- obj ) +M: object (word-at-caret) 2drop f ; + M: vocab-completion (word-at-caret) drop [ dup vocab-exists? [ >vocab-link ] [ drop f ] if ] @@ -59,12 +61,6 @@ M: word-completion (word-at-caret) M: vocab-word-completion (word-at-caret) vocab-name>> lookup-word ; -M: char-completion (word-at-caret) 2drop f ; - -M: path-completion (word-at-caret) 2drop f ; - -M: color-completion (word-at-caret) 2drop f ; - : word-at-caret ( token interactor -- obj ) completion-mode (word-at-caret) ; diff --git a/basis/vocabs/metadata/metadata-docs.factor b/basis/vocabs/metadata/metadata-docs.factor index 3fe93916b6..9081619e6c 100644 --- a/basis/vocabs/metadata/metadata-docs.factor +++ b/basis/vocabs/metadata/metadata-docs.factor @@ -39,7 +39,7 @@ ARTICLE: "vocabs.metadata" "Vocabulary metadata" ABOUT: "vocabs.metadata" HELP: vocab-file-lines -{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "lines" { $maybe { $sequence "lines" } } } } +{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "lines/f" { $maybe { $sequence "lines" } } } } { $description "Outputs the lines of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; HELP: set-vocab-file-lines diff --git a/basis/vocabs/platforms/authors.txt b/basis/vocabs/platforms/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/vocabs/platforms/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/vocabs/platforms/platforms.factor b/basis/vocabs/platforms/platforms.factor new file mode 100644 index 0000000000..4cab775310 --- /dev/null +++ b/basis/vocabs/platforms/platforms.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2018 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors compiler.units kernel multiline parser +sequences splitting system vocabs.parser ; +IN: vocabs.platforms + +: with-vocabulary ( quot suffix -- ) + [ + [ [ current-vocab name>> ] dip ?tail drop ] + [ append ] bi set-current-vocab + call + ] [ + [ current-vocab name>> ] dip ?tail drop set-current-vocab + ] bi ; inline + +: parse-platform-section ( string suffix -- ) + [ + [ [ string-lines parse-lines ] curry with-nested-compilation-unit ] + curry + ] dip with-vocabulary drop ; inline + +SYNTAX: " parse-multiline-string + os unix? [ ".unix" parse-platform-section ] [ drop ] if ; + +SYNTAX: " parse-multiline-string + os macosx? [ ".macosx" parse-platform-section ] [ drop ] if ; + +SYNTAX: " parse-multiline-string + os linux? [ ".linux" parse-platform-section ] [ drop ] if ; + +SYNTAX: " parse-multiline-string + os windows? [ ".windows" parse-platform-section ] [ drop ] if ; diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor old mode 100755 new mode 100644 index 7f3e878005..0981c55524 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1317,7 +1317,14 @@ FUNCTION: LONG RegDeleteKeyExW ( ALIAS: RegDeleteKeyEx RegDeleteKeyExW ! : RegDeleteValueA ; -! : RegDeleteValueW ; + +FUNCTION: LONG RegDeleteValueW ( + HKEY hKey, + LPCWSTR lpValueName + ) + +ALIAS: RegDeleteValue RegDeleteValueW + ! : RegDisablePredefinedCache ; ! : RegEnumKeyA ; ! : RegEnumKeyExA ; diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor old mode 100755 new mode 100644 diff --git a/basis/windows/ddk/hid/hid.factor b/basis/windows/ddk/hid/hid.factor old mode 100755 new mode 100644 diff --git a/basis/windows/ddk/setupapi/setupapi.factor b/basis/windows/ddk/setupapi/setupapi.factor old mode 100755 new mode 100644 diff --git a/basis/windows/ddk/winusb/winusb.factor b/basis/windows/ddk/winusb/winusb.factor old mode 100755 new mode 100644 diff --git a/basis/windows/directx/dinput/constants/constants.factor b/basis/windows/directx/dinput/constants/constants.factor old mode 100755 new mode 100644 diff --git a/basis/windows/directx/dwrite/dwrite.factor b/basis/windows/directx/dwrite/dwrite.factor old mode 100755 new mode 100644 diff --git a/basis/windows/directx/dxfile/dxfile.factor b/basis/windows/directx/dxfile/dxfile.factor old mode 100755 new mode 100644 diff --git a/basis/windows/directx/xinput/xinput.factor b/basis/windows/directx/xinput/xinput.factor old mode 100755 new mode 100644 diff --git a/basis/windows/dwmapi/dwmapi.factor b/basis/windows/dwmapi/dwmapi.factor old mode 100755 new mode 100644 diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor old mode 100755 new mode 100644 diff --git a/basis/windows/registry/authors.txt b/basis/windows/registry/authors.txt index 7c1b2f2279..d652f68ac8 100644 --- a/basis/windows/registry/authors.txt +++ b/basis/windows/registry/authors.txt @@ -1 +1,2 @@ Doug Coleman +Alexander Ilin diff --git a/basis/windows/registry/registry-tests.factor b/basis/windows/registry/registry-tests.factor index 17662bf75a..839f2eecd3 100644 --- a/basis/windows/registry/registry-tests.factor +++ b/basis/windows/registry/registry-tests.factor @@ -1,7 +1,27 @@ ! Copyright (C) 2010 Doug Coleman. +! Copyright (C) 2018 Alexander Ilin. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test windows.advapi32 windows.registry ; +USING: byte-arrays io.encodings.string io.encodings.utf16n +kernel sequences tools.test windows.advapi32 windows.kernel32 +windows.registry ; IN: windows.registry.tests [ ] [ HKEY_CURRENT_USER "SOFTWARE\\\\Microsoft" read-registry drop ] unit-test + +[ t ] +[ + HKEY_CURRENT_USER "Environment" KEY_SET_VALUE [ + "factor-test" "value" utf16n encode dup length set-reg-sz + ] with-open-registry-key + HKEY_CURRENT_USER "Environment" "factor-test" [ + "test-string" ";" glue + ] change-registry-value + HKEY_CURRENT_USER "Environment" KEY_QUERY_VALUE [ + "factor-test" f f MAX_PATH reg-query-value-ex + utf16n decode "value;test-string\0" = + ] with-open-registry-key + HKEY_CURRENT_USER "Environment" KEY_SET_VALUE [ + "factor-test" delete-value + ] with-open-registry-key +] unit-test diff --git a/basis/windows/registry/registry.factor b/basis/windows/registry/registry.factor index 06bd370f0e..4fd46f23be 100644 --- a/basis/windows/registry/registry.factor +++ b/basis/windows/registry/registry.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2010 Doug Coleman. +! Copyright (C) 2018 Alexander Ilin. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types byte-arrays kernel locals sequences -windows.advapi32 windows.errors math windows -windows.kernel32 windows.time accessors alien.data -windows.types classes.struct continuations ; +USING: accessors alien.c-types alien.data byte-arrays +classes.struct continuations io.encodings.string +io.encodings.utf16n kernel literals locals math sequences sets +splitting windows windows.advapi32 windows.errors +windows.kernel32 windows.time windows.types ; IN: windows.registry ERROR: open-key-failed key subkey mode error-string ; @@ -66,22 +68,31 @@ CONSTANT: registry-value-max-length 16384 : grow-buffer ( byte-array -- byte-array' ) length 2 * ; -:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer ) +PRIVATE> + +:: reg-query-value-ex ( key value-name ptr1 lpType buffer -- buffer ) buffer length uint :> pdword - key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep + key value-name ptr1 lpType buffer pdword [ RegQueryValueEx ] 2keep rot :> ret ret ERROR_SUCCESS = [ uint deref head ] [ ret ERROR_MORE_DATA = [ 2drop - key subkey ptr1 ptr2 buffer + key value-name ptr1 lpType buffer grow-buffer reg-query-value-ex ] [ ret n>win32-error-string throw ] if ] if ; +: delete-value ( key value-name -- ) + RegDeleteValue dup ERROR_SUCCESS = [ + drop + ] [ + n>win32-error-string throw + ] if ; + TUPLE: registry-info key class-name @@ -184,11 +195,30 @@ TUPLE: registry-enum-key ; : set-reg-sz ( hkey value lpdata cbdata -- ) [ REG_SZ ] 2dip set-reg-key ; -PRIVATE> - : windows-performance-data ( -- byte-array ) HKEY_PERFORMANCE_DATA "Global" f f 21 2^ reg-query-value-ex ; : read-registry ( key subkey -- registry-info ) KEY_READ [ reg-query-info-key ] with-open-registry-key ; + +:: change-registry-value ( key subkey value-name quot: ( value -- value' ) -- ) + 0 DWORD :> type + key subkey KEY_QUERY_VALUE KEY_SET_VALUE bitor [ + dup :> hkey value-name f type MAX_PATH + reg-query-value-ex + type DWORD deref ${ REG_SZ REG_EXPAND_SZ REG_MULTI_SZ } in? + dup :> string-type? [ + utf16n decode type DWORD deref REG_MULTI_SZ = [ + "\0" split 2 + ] [ 1 ] if head* + ] when + quot call( x -- x' ) + string-type? [ + type DWORD deref REG_MULTI_SZ = [ + "\0" join 2 + ] [ 1 ] if [ CHAR: \0 suffix ] times utf16n encode + ] when + [ hkey value-name type DWORD deref ] dip dup length + set-reg-key + ] with-open-registry-key ; diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor old mode 100755 new mode 100644 diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 4b8fa0566a..da4e731516 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -1813,16 +1813,14 @@ FUNCTION: HACCEL LoadAcceleratorsW ( HINSTANCE hInstance, LPCTSTR lpTableName ) ! FUNCTION: LoadCursorFromFileW -! FUNCTION: HCURSOR LoadCursorW ( HINSTANCE hInstance, LPCWSTR lpCursorName ) -FUNCTION: HCURSOR LoadCursorW ( HINSTANCE hInstance, ushort lpCursorName ) +FUNCTION: HCURSOR LoadCursorW ( HINSTANCE hInstance, LPCWSTR lpCursorName ) ALIAS: LoadCursor LoadCursorW -! FUNCTION: HICON LoadIconA ( HINSTANCE hInstance, LPCTSTR lpIconName ) -FUNCTION: HICON LoadIconW ( HINSTANCE hInstance, LPCTSTR lpIconName ) +FUNCTION: HICON LoadIconW ( HINSTANCE hInstance, LPCWSTR lpIconName ) ALIAS: LoadIcon LoadIconW ! FUNCTION: LoadImageA -FUNCTION: HANDLE LoadImageW ( HINSTANCE hinst, LPCTSTR lpszName, UINT uType, int cxDesired, int cyDesired, UINT fuLoad ) +FUNCTION: HANDLE LoadImageW ( HINSTANCE hinst, LPCWSTR lpszName, UINT uType, int cxDesired, int cyDesired, UINT fuLoad ) ALIAS: LoadImage LoadImageW ! FUNCTION: LoadKeyboardLayoutA ! FUNCTION: LoadKeyboardLayoutEx diff --git a/basis/wrap/words/words-docs.factor b/basis/wrap/words/words-docs.factor index 30e9d88e37..7a170a0696 100644 --- a/basis/wrap/words/words-docs.factor +++ b/basis/wrap/words/words-docs.factor @@ -14,7 +14,7 @@ ARTICLE: "wrap.words" "Word object wrapping" } ; HELP: wrap-words -{ $values { "words" { "a sequence of " { $instance wrapping-word } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } +{ $values { "words" { "a sequence of " { $instance wrapping-word } "s" } } { "width" integer } { "lines" "a sequence of sequences of words" } } { $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; HELP: wrapping-word diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index 0f6b7f5a94..fd4e345750 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup strings math kernel ; +USING: arrays help.markup help.syntax kernel math strings ; IN: wrap ABOUT: "wrap" @@ -19,5 +19,5 @@ HELP: element } ; HELP: wrap -{ $values { "elements" { $sequence element } } { "width" real } } +{ $values { "elements" { $sequence element } } { "width" real } { "array" array } } { $description "Break the " { $snippet "elements" } " into lines such that the total width of each line tries to be less than " { $snippet "width" } " while attempting to minimize the raggedness represented by the amount of space at the end of each line. Returns an array of lines." } ; diff --git a/build.sh b/build.sh index fb14532669..320c6c1b1a 100755 --- a/build.sh +++ b/build.sh @@ -132,23 +132,6 @@ semver_into() { fi } -# issue 1440 -gcc_version_ok() { - GCC_VERSION=`gcc -dumpversion` - local GCC_MAJOR local GCC_MINOR local GCC_PATCH local GCC_SPECIAL - semver_into $GCC_VERSION GCC_MAJOR GCC_MINOR GCC_PATCH GCC_SPECIAL - - if [[ $GCC_MAJOR -lt 4 - || ( $GCC_MAJOR -eq 4 && $GCC_MINOR -lt 7 ) - || ( $GCC_MAJOR -eq 4 && $GCC_MINOR -eq 7 && $GCC_PATCH -lt 3 ) - || ( $GCC_MAJOR -eq 4 && $GCC_MINOR -eq 8 && $GCC_PATCH -eq 0 ) - ]] ; then - echo "gcc version required >= 4.7.3, != 4.8.0, >= 4.8.1, got $GCC_VERSION" - return 1 - fi - return 0 -} - clang_version_ok() { CLANG_VERSION=`clang --version | head -n1` CLANG_VERSION_RE='^[a-zA-Z0-9 ]* version (.*)$' # 3.3-5 @@ -177,7 +160,7 @@ set_cc() { fi test_programs_installed gcc g++ - if [[ $? -ne 0 ]] && gcc_version_ok ; then + if [[ $? -ne 0 ]] ; then [ -z "$CC" ] && CC=gcc [ -z "$CXX" ] && CXX=g++ return @@ -593,10 +576,10 @@ set_boot_image_vars() { } set_current_branch() { - if [ -z ${TRAVIS_BRANCH} ]; then - CURRENT_BRANCH=$(current_git_branch) + if [ -n "${CI_BRANCH}" ]; then + CURRENT_BRANCH="${CI_BRANCH}" else - CURRENT_BRANCH=${TRAVIS_BRANCH} + CURRENT_BRANCH=$(current_git_branch) fi } diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index cc88feed20..43b425b53e 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -95,7 +95,7 @@ HELP: c-ptr { $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects all can be used as values of " { $link pointer } " C types." } ; HELP: alien-invoke -{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } { "return..." "the return value of the function, if not " { $link void } } } +{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } { "varargs?" boolean } { "return..." "the return value of the function, if not " { $link void } } } { $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected." } { $notes "C type names are documented in " { $link "c-types-specs" } "." } { $errors "Throws an " { $link callsite-not-compiled } " if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler." } ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor old mode 100755 new mode 100644 diff --git a/core/alien/libraries/libraries-docs.factor b/core/alien/libraries/libraries-docs.factor index a844ef0c65..5801f6386f 100644 --- a/core/alien/libraries/libraries-docs.factor +++ b/core/alien/libraries/libraries-docs.factor @@ -72,7 +72,7 @@ HELP: library } ; HELP: library-dll -{ $values { "name" string } { "dll" "a DLL handle" } } +{ $values { "obj" object } { "dll" "a DLL handle" } } { $description "Looks up a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } "." } ; HELP: remove-library diff --git a/core/alien/libraries/libraries-tests.factor b/core/alien/libraries/libraries-tests.factor old mode 100755 new mode 100644 diff --git a/core/alien/libraries/libraries.factor b/core/alien/libraries/libraries.factor old mode 100755 new mode 100644 index 9e319cb881..274dd9d189 --- a/core/alien/libraries/libraries.factor +++ b/core/alien/libraries/libraries.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.strings assocs compiler.errors -io.backend kernel namespaces destructors sequences strings -system io.pathnames fry combinators vocabs ; +destructors kernel namespaces sequences strings system ; IN: alien.libraries PRIMITIVE: dll-valid? ( dll -- ? ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor old mode 100755 new mode 100644 diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 950060567a..bd039022e9 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -455,7 +455,7 @@ HELP: bad-superclass { $error-description "Thrown if an attempt is made to subclass a class that is not a tuple class, or a tuple class declared " { $link postpone: final } "." } ; HELP: ?offset-of-slot -{ $values { "name" string } { "tuple" tuple } { "n" { $maybe integer } } } +{ $values { "name" string } { "tuple" tuple } { "n/f" { $maybe integer } } } { $description "Returns the offset of a tuple slot accessed by " { $snippet "name" } ", or " { $link f } " if no slot with that name." } ; HELP: offset-of-slot diff --git a/core/cpu/architecture/architecture-docs.factor b/core/cpu/architecture/architecture-docs.factor index e73fb7f8eb..82d672d465 100644 --- a/core/cpu/architecture/architecture-docs.factor +++ b/core/cpu/architecture/architecture-docs.factor @@ -75,6 +75,7 @@ init-relocation [ RAX RBX 3 -14 RCX RDX %write-barrier ] B{ } make disassemble HELP: %alien-invoke { $values + { "varargs?" boolean } { "reg-inputs" sequence } { "stack-inputs" sequence } { "reg-outputs" sequence } @@ -292,12 +293,18 @@ HELP: %store-memory-imm HELP: %test-imm-branch { $values { "label" "branch destination" } + { "cc" "comparison symbol" } { "src1" "register" } { "src2" "immediate" } - { "cc" "comparison symbol" } } { $description "Emits a TEST instruction with a register and an immediate, followed by a branch." } ; HELP: %unbox +{ $values + { "dst" "destination register" } + { "src" "source register" } + { "func" "function?" } + { "rep" representation } +} { $description "Call a function to convert a tagged pointer into a value that can be passed to a C function, or returned from a callback." } ; HELP: %vector>scalar diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 05818de773..5b7fd237ef 100644 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -521,7 +521,7 @@ HOOK: fused-unboxing? cpu ( -- ? ) HOOK: immediate-arithmetic? cpu ( n -- ? ) HOOK: immediate-bitwise? cpu ( n -- ? ) HOOK: immediate-comparand? cpu ( n -- ? ) -HOOK: immediate-store? cpu ( obj -- ? ) +HOOK: immediate-store? cpu ( n -- ? ) M: object immediate-comparand? ( n -- ? ) { diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor old mode 100755 new mode 100644 diff --git a/core/grouping/grouping-docs.factor b/core/grouping/grouping-docs.factor index 83b6dcbdb9..0126935806 100644 --- a/core/grouping/grouping-docs.factor +++ b/core/grouping/grouping-docs.factor @@ -123,7 +123,9 @@ HELP: circular-clump { $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements, wrapping around the end of the sequence, and collects the clumps into a new array." } { $notes "For an empty sequence, the result is an empty sequence." } { $examples - { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 circular-clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } { 7 3 } }" } + { $example "USING: grouping prettyprint ;" + "{ 3 1 3 3 7 } 2 circular-clump ." + "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } { 7 3 } }" } } ; HELP: diff --git a/core/io/pathnames/pathnames-tests.factor b/core/io/pathnames/pathnames-tests.factor index 719170ecca..6265feb22d 100644 --- a/core/io/pathnames/pathnames-tests.factor +++ b/core/io/pathnames/pathnames-tests.factor @@ -1,6 +1,6 @@ USING: io.backend io.directories io.files.private io.files.temp -io.files.unique io.pathnames kernel locals math namespaces -system tools.test ; +io.files.unique io.pathnames kernel locals math multiline +namespaces sequences system tools.test ; { "passwd" } [ "/etc/passwd" file-name ] unit-test { "awk" } [ "/usr/libexec/awk/" file-name ] unit-test @@ -81,3 +81,80 @@ H{ { t } [ "~" home [ "foo" append-path ] bi@ [ normalize-path ] same? ] unit-test { t } [ os windows? "~\\~/" "~/~/" ? "~" "~" append-path [ path-components ] same? ] unit-test + +! Absolute paths +os windows? [ + { "c:/" } [ "c:/" canonicalize-path ] unit-test + { "c:/" } [ "c:/." canonicalize-path ] unit-test + { "c:/" } [ "c:/.." canonicalize-path ] unit-test + { "c:/" } [ "c:/Users/.." canonicalize-path ] unit-test + { "c:/" } [ "c:/Users/../" canonicalize-path ] unit-test + { "c:/" } [ "c:/Users/../." canonicalize-path ] unit-test + { "c:/" } [ "c:/Users/.././" canonicalize-path ] unit-test + { "c:/" } [ "c:/Users/.././././././" canonicalize-path ] unit-test + { "c:/" } [ "c:/Users/../././/////./././/././././//././././././." canonicalize-path ] unit-test + { "c:/" } [ "c:/Users/../../../..////.././././././/../" canonicalize-path ] unit-test + { "c:/Users" } [ "c:/Users/../../../Users" canonicalize-path ] unit-test + + { "c:/Users" } [ "c:/Users" canonicalize-path ] unit-test + { "c:/Users" } [ "c:/Users/." canonicalize-path ] unit-test + { "c:/Users\\foo\\bar" } [ "c:/Users/foo/bar" canonicalize-path ] unit-test +] [ + { "/" } [ "/" canonicalize-path ] unit-test + { "/" } [ "/." canonicalize-path ] unit-test + { "/" } [ "/.." canonicalize-path ] unit-test + { "/" } [ "/Users/.." canonicalize-path ] unit-test + { "/" } [ "/Users/../" canonicalize-path ] unit-test + { "/" } [ "/Users/../." canonicalize-path ] unit-test + { "/" } [ "/Users/.././" canonicalize-path ] unit-test + { "/" } [ "/Users/.././././././" canonicalize-path ] unit-test + { "/" } [ "/Users/../././/////./././/././././//././././././." canonicalize-path ] unit-test + { "/" } [ "/Users/../../../..////.././././././/../" canonicalize-path ] unit-test + { "/Users" } [ "/Users/../../../Users" canonicalize-path ] unit-test + + { "/Users" } [ "/Users" canonicalize-path ] unit-test + { "/Users" } [ "/Users/." canonicalize-path ] unit-test + { "/Users/foo/bar" } [ "/Users/foo/bar" canonicalize-path ] unit-test +] if + + +! Relative paths +{ "." } [ f canonicalize-path ] unit-test +{ "." } [ "" canonicalize-path ] unit-test +{ "." } [ "." canonicalize-path ] unit-test +{ "." } [ "./" canonicalize-path ] unit-test +{ "." } [ "./." canonicalize-path ] unit-test +{ ".." } [ ".." canonicalize-path ] unit-test +{ ".." } [ "../" canonicalize-path ] unit-test +{ ".." } [ "../." canonicalize-path ] unit-test +{ ".." } [ ".././././././//." canonicalize-path ] unit-test + +{ t } [ "../.." canonicalize-path { "../.." "..\\.." } member? ] unit-test +{ t } [ "../../" canonicalize-path { "../.." "..\\.." } member? ] unit-test +{ t } [ "../.././././/./././" canonicalize-path { "../.." "..\\.." } member? ] unit-test + + +! Root paths +os windows? [ + { "d:\\" } [ "d:\\" root-path ] unit-test + { "d:\\" } [ "d:\\\\\\\\//////" root-path ] unit-test + { "c:\\" } [ "c:\\Users\\merlen" root-path ] unit-test + { "c:\\" } [ "c:\\\\\\//Users//\\//merlen//" root-path ] unit-test + { "d:\\" } [ "d:\\././././././/../../../" root-path ] unit-test + { "d:\\" } [ "d:\\merlen\\dog" root-path ] unit-test + + { "d:\\" } [ "\\\\?\\d:\\" root-path ] unit-test + { "d:\\" } [ "\\\\?\\d:\\\\\\\\//////" root-path ] unit-test + { "c:\\" } [ "\\\\?\\c:\\Users\\merlen" root-path ] unit-test + { "c:\\" } [ "\\\\?\\c:\\\\\\//Users//\\//merlen//" root-path ] unit-test + { "d:\\" } [ "\\\\?\\d:\\././././././/../../../" root-path ] unit-test + { "d:\\" } [ "\\\\?\\d:\\merlen\\dog" root-path ] unit-test +] [ + { "/" } [ "/" root-path ] unit-test + { "/" } [ "//" root-path ] unit-test + { "/" } [ "/Users" root-path ] unit-test + { "/" } [ "//Users" root-path ] unit-test + { "/" } [ "/Users/foo/bar////././." root-path ] unit-test + { "/" } [ "/Users/foo/bar////.//../../../../../../////./." root-path ] unit-test + { "/" } [ "/Users/////" root-path ] unit-test +] if \ No newline at end of file diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index b5e317a262..5e434391f4 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -166,10 +166,57 @@ M: string absolute-path M: object normalize-path ( path -- path' ) absolute-path ; +: root-path* ( path -- path' ) + dup absolute-path? [ + dup [ path-separator? ] find + drop 1 + head + ] when ; + +HOOK: root-path os ( path -- path' ) + +M: object root-path root-path* ; + +: relative-path* ( path -- relative-path ) + dup absolute-path? [ + dup [ path-separator? ] find + drop 1 + tail + ] when ; + +HOOK: relative-path os ( path -- path' ) + +M: object relative-path relative-path* ; + +: canonicalize-path* ( path -- path' ) + [ + relative-path + [ path-separator? ] split-when + [ { "." "" } member? ] reject + V{ } clone [ + dup ".." = [ + over empty? + [ over push ] + [ over ?last ".." = [ over push ] [ drop dup pop* ] if ] if + ] [ + over push + ] if + ] reduce + ] keep dup absolute-path? [ + [ + [ ".." = ] trim-head + path-separator join + ] dip root-path prepend-path + ] [ + drop path-separator join [ "." ] when-empty + ] if ; + +HOOK: canonicalize-path io-backend ( path -- path' ) + +M: object canonicalize-path canonicalize-path* ; + TUPLE: pathname string ; C: pathname M: pathname absolute-path string>> absolute-path ; -M: pathname <=> [ string>> ] compare ; +M: pathname <=> [ string>> ] compare ; \ No newline at end of file diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index f4e83c5a5e..75c49f9aea 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -794,7 +794,7 @@ HELP: curried { curry curried compose prepose composed } related-words HELP: 2curry -{ $values { "obj1" object } { "obj2" object } { "quot" callable } { "curry" curried } } +{ $values { "obj1" object } { "obj2" object } { "quot" callable } { "curried" curried } } { $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } " and " { $snippet "obj2" } " and then calls " { $snippet "quot" } "." } { $notes "This operation is efficient and does not copy the quotation." } { $examples @@ -802,12 +802,12 @@ HELP: 2curry } ; HELP: 3curry -{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" callable } { "curry" curried } } +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" callable } { "curried" curried } } { $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } ", and then calls " { $snippet "quot" } "." } { $notes "This operation is efficient and does not copy the quotation." } ; HELP: with -{ $values { "param" object } { "obj" object } { "quot" { $quotation ( param elt -- ... ) } } { "curry" curried } } +{ $values { "param" object } { "obj" object } { "quot" { $quotation ( param elt -- ... ) } } { "curried" curried } } { $description "Partial application on the left. The following two lines are equivalent:" { $code "swap [ swap A ] curry B" } { $code "[ A ] with B" } @@ -825,7 +825,7 @@ HELP: 2with { "param2" object } { "obj" object } { "quot" { $quotation ( param1 param2 elt -- ... ) } } - { "curry" curried } + { "curried" curried } } { $description "Partial application on the left of two parameters." } ; @@ -842,7 +842,7 @@ HELP: compose } ; HELP: prepose -{ $values { "quot1" callable } { "quot2" callable } { "compose" composed } } +{ $values { "quot1" callable } { "quot2" callable } { "composed" composed } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot2" } " followed by " { $snippet "quot1" } "." } { $notes "See " { $link compose } " for details." } ; diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 12a2be1398..bb1d9e1d03 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -23,10 +23,13 @@ IN: kernel.tests } } [ 1 2 10 [ 3array ] 2with map ] unit-test + ! Don't leak extra roots if error is thrown { } [ 1000 [ [ 3 throw ] ignore-errors ] times ] unit-test -{ } [ 1000 [ [ -1 f ] ignore-errors ] times ] unit-test +[ -1 f ] must-fail +{ } [ 10 [ [ -1 f ] ignore-errors ] times ] unit-test +! { } [ 1000 [ [ -1 f ] ignore-errors ] times ] unit-test ! Travis CI fails ! Make sure we report the correct error on stack underflow [ clear drop ] [ diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index a41611664f..1dae66d2d9 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -48,6 +48,10 @@ SYMBOL: header-bits : cell-bits ( -- n ) 8 cells ; inline +: 32bit? ( -- ? ) cell-bits 32 = ; inline + +: 64bit? ( -- ? ) cell-bits 64 = ; inline + : bootstrap-cell ( -- n ) \ cell get cell or ; inline : bootstrap-cells ( m -- n ) bootstrap-cell * ; inline diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index c37e788efa..236ba6f4cc 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -277,7 +277,7 @@ HELP: if-zero HELP: when-zero { $values - { "n" number } { "quot" "the first quotation of an " { $link if-zero } } } + { "n" number } { "quot" "the first quotation of an " { $link if-zero } } { "x" object } } { $description "Makes an implicit check if the number is zero. A zero is dropped and the " { $snippet "quot" } " is called." } { $examples "This word is equivalent to " { $link if-zero } " with an empty second quotation:" { $example diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 0495963fa1..aad2110277 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1209,12 +1209,12 @@ HELP: supremum { min max supremum infimum } related-words HELP: shortest -{ $values { "seq" sequence } { "elt" object } } -{ $description "Outputs the shortest element of " { $snippet "seq" } "." } ; +{ $values { "seqs" sequence } { "elt" object } } +{ $description "Outputs the shortest sequence from " { $snippet "seqs" } "." } ; HELP: longest -{ $values { "seq" sequence } { "elt" object } } -{ $description "Outputs the longest element of " { $snippet "seq" } "." } ; +{ $values { "seqs" sequence } { "elt" object } } +{ $description "Outputs the longest sequence from " { $snippet "seqs" } "." } ; { shortest longest } related-words diff --git a/core/stack-checker/dependencies/dependencies-docs.factor b/core/stack-checker/dependencies/dependencies-docs.factor index d80880ad70..2f5167eb8a 100644 --- a/core/stack-checker/dependencies/dependencies-docs.factor +++ b/core/stack-checker/dependencies/dependencies-docs.factor @@ -11,7 +11,7 @@ HELP: +definition+ { $description "Word that indicates that the dependency is a definition dependency. It is a dependency among two words in which one word depends on the definition of the another. For example, if two words are defined as " { $snippet ": o ( -- ) i ;" } " and " { $snippet ": i ( -- ) ; inline" } ", then 'o' has a definition dependency to 'i' because 'i' is inline. If the definition of 'i' changes 'o' must be recompiled." } ; HELP: add-depends-on-class -{ $values { "obj" classoid } } +{ $values { "classoid" classoid } } { $description "Adds a " { $link +conditional+ } " dependency from the word to the classes mentioned in the classoid." } ; HELP: conditional-dependencies diff --git a/core/system/system.factor b/core/system/system.factor index 975f567b65..4fcdefc024 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007, 2010 slava pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs continuations init io kernel kernel.private make -math math.parser namespaces sequences ; +USING: accessors assocs continuations init io kernel +kernel.private make math.parser namespaces sequences splitting ; IN: system PRIMITIVE: (exit) ( n -- * ) @@ -27,10 +27,10 @@ UNION: unix macosx linux ; : vm-git-label ( -- string ) \ vm-git-label get-global ; : vm-git-ref ( -- string ) - vm-git-label char: - over last-index head ; + vm-git-label "-" split1-last drop ; : vm-git-id ( -- string ) - vm-git-label char: - over last-index 1 + tail ; + vm-git-label "-" split1-last nip ; : vm-compiler ( -- string ) \ vm-compiler get-global ; diff --git a/core/typed/typed-docs.factor b/core/typed/typed-docs.factor index 945d212500..6e674a48b5 100644 --- a/core/typed/typed-docs.factor +++ b/core/typed/typed-docs.factor @@ -32,13 +32,13 @@ HELP: \TYPED:: { $example "USING: kernel math math.libm prettyprint typed ; IN: scratchpad - +<< TYPED:: quadratic-roots ( a: float b: float c: float -- q1: float q2: float ) b neg b sq 4.0 a * c * - fsqrt [ + ] [ - ] 2bi [ 2.0 a * / ] bi@ ; - +>> 1 0 -9/4 quadratic-roots [ . ] bi@" "1.5 -1.5" } } ; diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor old mode 100755 new mode 100644 diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index fef4f162b8..fa00981dea 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -9,13 +9,15 @@ SYMBOL: vocab-roots SYMBOL: add-vocab-root-hook +CONSTANT: default-vocab-roots { + "resource:core" + "resource:basis" + "resource:extra" + "resource:work" +} + [ - V{ - "resource:core" - "resource:basis" - "resource:extra" - "resource:work" - } clone vocab-roots set-global + default-vocab-roots V{ } like vocab-roots set-global [ drop ] add-vocab-root-hook set-global ] "vocabs.loader" add-startup-hook diff --git a/extra/alien/fortran/fortran.factor b/extra/alien/fortran/fortran.factor old mode 100755 new mode 100644 diff --git a/extra/assocs/extras/extras.factor b/extra/assocs/extras/extras.factor index 12cd4a9a51..3c303f459b 100644 --- a/extra/assocs/extras/extras.factor +++ b/extra/assocs/extras/extras.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2012 John Benediktsson, Doug Coleman ! See http://factorcode.org/license.txt for BSD license USING: arrays assocs assocs.private fry generalizations kernel -math sequences ; +math math.statistics sequences sequences.extras ; IN: assocs.extras : deep-at ( assoc seq -- value/f ) @@ -157,3 +157,12 @@ PRIVATE> : flatten-values ( assoc -- assoc' ) dup any-multi-value? [ expand-values-set-at flatten-values ] when ; + +: intersect-keys ( assoc seq -- elts ) + [ of ] with map-zip sift-values ; inline + +: values-of ( assoc seq -- elts ) + [ of ] with map sift ; inline + +: counts ( seq elts -- counts ) + [ histogram ] dip intersect-keys ; \ No newline at end of file diff --git a/extra/ci/docker/authors.txt b/extra/ci/docker/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/ci/docker/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/ci/docker/docker.factor b/extra/ci/docker/docker.factor new file mode 100644 index 0000000000..d66eb6e5de --- /dev/null +++ b/extra/ci/docker/docker.factor @@ -0,0 +1,78 @@ +! Copyright (C) 2018 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files.links io.launcher io.standard-paths json.reader +kernel literals namespaces sequences strings system ; +IN: ci.docker + +SYMBOL: docker-username +SYMBOL: docker-password + +: docker-path ( -- path ) + "docker" find-in-standard-login-path ; + +: docker-machine-path ( -- path ) + "docker-machine" find-in-standard-login-path ; + +: vboxmanage-path ( -- path ) + "VBoxManage" find-in-standard-login-path ; + +: sudo-linux ( seq -- seq' ) + os linux? [ "sudo" prefix ] when ; + +: docker-lines ( seq -- lines ) + docker-path prefix sudo-linux process-lines ; + +: docker-machine-lines ( seq -- lines ) + docker-machine-path prefix process-lines ; + + +: docker-command ( seq -- ) + docker-path prefix sudo-linux try-output-process ; + +: docker-machine-command ( seq -- ) + docker-machine-path prefix try-output-process ; + + +: docker-version ( -- string ) + { "version" } docker-lines ; + +: docker-machine-version ( -- string ) + { "version" } docker-machine-lines ?first ; + + + +: docker-machine-inspect ( string -- json ) + { "inspect" } swap suffix docker-machine-lines "" join json> ; + + +: docker-machines ( -- seq ) + { "ls" "-q" } docker-machine-lines ; + +: docker-machine-status ( string -- status ) + { "status" } swap suffix docker-machine-lines ; + + +: docker-image-names ( -- seq ) + { "image" "ls" "-q" } docker-lines ; + +: docker-image-ls ( -- seq ) + { "image" "ls" } docker-lines ; + +: docker-login ( -- ) + ${ + "sudo" + docker-path "login" + "-p" docker-password get-global + "-u" docker-username get-global + } run-process drop ; + +GENERIC: docker-pull ( obj -- ) + +M: string docker-pull ( string -- ) + { "pull" } swap suffix docker-command ; + +M: sequence docker-pull ( seq -- ) + [ docker-pull ] each ; + +: docker-hello-world ( -- ) + { "run" "hello-world" } docker-command ; diff --git a/extra/ci/run-process/authors.txt b/extra/ci/run-process/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/ci/run-process/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/ci/run-process/platforms.txt b/extra/ci/run-process/platforms.txt new file mode 100644 index 0000000000..509143d863 --- /dev/null +++ b/extra/ci/run-process/platforms.txt @@ -0,0 +1 @@ +unix diff --git a/extra/ci/run-process/run-process.factor b/extra/ci/run-process/run-process.factor new file mode 100644 index 0000000000..425afdf18f --- /dev/null +++ b/extra/ci/run-process/run-process.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2018 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs calendar combinators environment +escape-strings fry io io.pathnames io.streams.string kernel math +math.parser namespaces prettyprint prettyprint.config sequences +tools.deploy.backend tools.time unix.groups unix.users uuid ; +IN: ci.run-process + +TUPLE: process-autopsy + timestamp os-envs + cwd uid euid gid egid out elapsed os-envs-after process ; + +: ci-run-process ( process -- timestamp os-envs cwd uid euid gid egid out elapsed os-envs' process ) + [ + [ + gmt os-envs current-directory get + real-user-id effective-user-id + real-group-id effective-group-id + ] dip [ + '[ _ run-with-output ] with-string-writer + ] benchmark os-envs + ] keep ; + +: ci-run-process>autopsy ( process -- autopsy ) + ci-run-process process-autopsy boa ; + +: unparse-full ( obj -- str ) + [ unparse ] without-limits ; + +: autopsy. ( autopsy -- ) + { + [ drop "> timestamp>unix-time >float number>string + "unix-time" tag-payload print nl + ] + [ + bl bl elapsed>> number>string "elapsed-nanos" tag-payload print nl + ] + [ + bl bl cwd>> "cwd" tag-payload print nl + ] + [ + bl bl uid>> number>string "uid" tag-payload print nl + ] + [ + bl bl euid>> number>string "euid" tag-payload print nl + ] + [ + bl bl gid>> number>string "gid" tag-payload print nl + ] + [ + bl bl egid>> number>string "egid" tag-payload print nl + ] + [ + bl bl os-envs>> unparse-full "os-envs" tag-payload print nl + ] + [ + bl bl os-envs>> unparse-full "os-envs-after" tag-payload print nl + ] + [ + bl bl [ os-envs-after>> ] [ os-envs>> ] bi assoc-diff unparse-full "os-envs-diff" tag-payload print nl + ] + [ + bl bl [ os-envs>> ] [ os-envs-after>> ] bi assoc-diff unparse-full "os-envs-swap-diff" tag-payload print nl + ] + [ + bl bl process>> unparse-full "process" tag-payload print nl + ] + [ + bl bl out>> "out" tag-payload print nl + ] + [ drop ";AUTOPSY>" print ] + } cleave ; \ No newline at end of file diff --git a/extra/cli/git/git.factor b/extra/cli/git/git.factor index 1b589a008f..f91ad6aa23 100644 --- a/extra/cli/git/git.factor +++ b/extra/cli/git/git.factor @@ -9,6 +9,9 @@ IN: cli.git SYMBOL: cli-git-num-parallel cli-git-num-parallel [ cpus 2 * ] initialize +: git-command>string ( quot -- string ) + utf8 stream-contents [ blank? ] trim-tail ; + : git-clone-as ( uri path -- process ) [ { "git" "clone" } ] 2dip 2array append run-process ; : git-clone ( uri -- process ) [ { "git" "clone" } ] dip suffix run-process ; : git-pull* ( -- process ) { "git" "pull" } run-process ; @@ -27,16 +30,19 @@ cli-git-num-parallel [ cpus 2 * ] initialize : git-remote-add ( path remote uri -- process ) '[ _ _ git-remote-add* ] with-directory ; : git-remote-get-url* ( remote -- process ) [ { "git" "remote" "get-url" } ] dip suffix run-process ; : git-remote-get-url ( path remote -- process ) '[ _ git-remote-get-url* ] with-directory ; +: git-rev-parse* ( branch -- string ) [ { "git" "rev-parse" } ] dip suffix git-command>string ; +: git-rev-parse ( path branch -- string ) '[ _ git-rev-parse* ] with-directory ; +: git-diff-name-only* ( from to -- lines ) + [ { "git" "diff" "--name-only" } ] 2dip 2array append process-lines ; +: git-diff-name-only ( path from to -- lines ) + '[ _ _ git-diff-name-only* ] with-directory ; : git-repository? ( directory -- ? ) ".git" append-path current-directory get prepend-path ?file-info dup [ directory? ] when ; : git-current-branch* ( -- name ) - ! { "git" "rev-parse" "--abbrev-ref" "HEAD" } - { "git" "name-rev" "--name-only" "HEAD" } - utf8 stream-contents - [ blank? ] trim-tail ; + { "git" "rev-parse" "--abbrev-ref" "HEAD" } git-command>string ; : git-current-branch ( directory -- name ) [ git-current-branch* ] with-directory ; diff --git a/extra/ctags/ctags-docs.factor b/extra/ctags/ctags-docs.factor index 64a645df64..c4312dcf48 100644 --- a/extra/ctags/ctags-docs.factor +++ b/extra/ctags/ctags-docs.factor @@ -20,7 +20,7 @@ HELP: write-ctags } ; HELP: ctags -{ $values { "alist" "ctags" } } +{ $values { "ctags" "alist" } } { $description "Make a sequence of ctags from " { $link all-words } ", sorted by word name." } ; ABOUT: "ctags" diff --git a/extra/fuel/help/help-docs.factor b/extra/fuel/help/help-docs.factor index 6cbdcc27cc..0aff60a5c7 100644 --- a/extra/fuel/help/help-docs.factor +++ b/extra/fuel/help/help-docs.factor @@ -6,7 +6,7 @@ HELP: article-parents { $description "All the parent articles for the article and ensures that the ancestor always is 'handbook'." } ; HELP: get-article -{ $values { "name" string } { "str" string } } +{ $values { "name" string } { "element" string } } { $description "If an article and a vocab share name, we render the vocab instead." } ; HELP: find-word diff --git a/extra/fuel/help/help-tests.factor b/extra/fuel/help/help-tests.factor index 9448e0009f..ef1f26fae4 100644 --- a/extra/fuel/help/help-tests.factor +++ b/extra/fuel/help/help-tests.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fuel.help fuel.help.private help help.topics sequences tools.test ; +USE: io.servers ! required for a test to pass { { diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor old mode 100755 new mode 100644 diff --git a/extra/gap-buffer/authors.txt b/extra/gap-buffer/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/gap-buffer/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/gap-buffer/gap-buffer-tests.factor b/extra/gap-buffer/gap-buffer-tests.factor new file mode 100644 index 0000000000..fbf2364cc6 --- /dev/null +++ b/extra/gap-buffer/gap-buffer-tests.factor @@ -0,0 +1,82 @@ +USING: kernel sequences tools.test gap-buffer strings math ; + +! test copy-elements +{ { 0 3 4 3 4 5 } } +[ { 0 1 2 3 4 5 } dup [ -2 3 5 ] dip copy-elements ] unit-test + +{ { 0 1 2 1 2 5 } } +[ { 0 1 2 3 4 5 } dup [ 2 2 0 ] dip copy-elements ] unit-test + +{ "01234567856" } +[ "01234567890" dup [ 4 6 4 ] dip copy-elements ] unit-test + +! test sequence protocol (like, length, nth, set-nth) +{ "gap buffers are cool" } +[ "gap buffers are cool" "" like ] unit-test + +! test move-gap-back-inside +{ t f } +[ 5 "0123456" move-gap-forward? [ move-gap-back-inside? 2nip ] dip ] unit-test + +{ "0123456" } +[ "0123456" 5 over move-gap >string ] unit-test + +! test move-gap-forward-inside +{ t } +[ "I once ate a spaniel" 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test + +{ "I once ate a spaniel" } +[ "I once ate a spaniel" 15 over move-gap 17 over move-gap >string ] unit-test + +! test move-gap-back-around +{ f f } +[ 2 "terriers are ok too" move-gap-forward? [ move-gap-back-inside? 2nip ] dip ] unit-test + +{ "terriers are ok too" } +[ "terriers are ok too" 2 over move-gap >string ] unit-test + +! test move-gap-forward-around +{ f t } +[ + "god is nam's best friend" + 2 over move-gap 22 over position>index swap move-gap-forward? + [ move-gap-forward-inside? 2nip ] dip +] unit-test + +{ "god is nam's best friend" } +[ "god is nam's best friend" 2 over move-gap 22 over move-gap >string ] unit-test + +! test changing buffer contents +{ "factory" } +[ "factor" CHAR: y 6 pick insert* >string ] unit-test + +! test inserting multiple elements in different places. buffer should grow +{ "refractory" } +[ "factor" CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test + +! test deleting elements. buffer should shrink +{ "for" } +[ "factor" 3 [ 1 over delete* ] times >string ] unit-test + +! more testing of nth and set-nth +{ "raptor" } +[ "factor" CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test + +! test stack/queue operations +{ "slaughter" } +[ "laughter" CHAR: s over push-start >string ] unit-test + +{ "pantonio" } +[ "pant" "onio" over push-end >string ] unit-test + +{ CHAR: f "actor" } +[ "factor" dup pop-start swap >string ] unit-test + +{ CHAR: s "pant" } +[ "pants" dup pop-end swap >string ] unit-test + +{ "end this is the " } +[ "this is the end " 4 over rotate >string ] unit-test + +{ "your jedi training is finished " } +[ "finished your jedi training is " -9 over rotate >string ] unit-test diff --git a/extra/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor new file mode 100644 index 0000000000..5da01b2491 --- /dev/null +++ b/extra/gap-buffer/gap-buffer.factor @@ -0,0 +1,288 @@ +! Copyright (C) 2007 Alex Chapman All Rights Reserved. +! See http://factorcode.org/license.txt for BSD license. +! +! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain +! for a good introduction see: +! https://common-lisp.net/project/flexichain/download/StrandhVilleneuveMoore.pdf +USING: accessors arrays circular fry kernel math math.functions +math.order multiline sequences sequences.private ; +IN: gap-buffer + +! gap-start -- the first element of the gap +! gap-end -- the first element after the gap +! expand-factor -- should be > 1 + + +! min-size -- < 5 is not sensible + +TUPLE: gb + seq + gap-start + gap-end + expand-factor + min-size ; + +: required-space ( n gb -- n ) + [ expand-factor>> * ceiling >fixnum ] + [ min-size>> ] bi max ; + +: ( seq -- gb ) + gb new + 5 >>min-size + 1.5 >>expand-factor + swap + [ length >>gap-start ] keep + [ length over required-space >>gap-end ] keep + over gap-end>> swap { } like resize-array >>seq ; + +M: gb like ( seq gb -- seq ) drop ; + +: gap-length ( gb -- n ) [ gap-end>> ] keep gap-start>> - ; + +: buffer-length ( gb -- n ) seq>> length ; + +M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ; + +: valid-position? ( pos gb -- ? ) + ! one element past the end of the buffer is a valid position when we're inserting + length -1 swap between? ; + +: valid-index? ( i gb -- ? ) + buffer-length -1 swap between? ; + +ERROR: position-out-of-bounds position gap-buffer ; + +: position>index ( pos gb -- i ) + 2dup valid-position? [ + 2dup gap-start>> >= [ + gap-length + + ] [ drop ] if + ] [ + position-out-of-bounds + ] if ; + +TUPLE: index-out-of-bounds index gap-buffer ; +C: index-out-of-bounds + +: index>position ( i gb -- pos ) + 2dup valid-index? [ + 2dup gap-end>> >= [ + gap-length - + ] [ drop ] if + ] [ + throw + ] if ; + +M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep seq>> ; + +M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ; + +M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ; + +M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ; + +M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ; + +M: gb virtual-exemplar seq>> ; + +INSTANCE: gb virtual-sequence + +! ------------- moving the gap ------------------------------- + +: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ; + +: copy-element ( dst start seq -- ) [ [ + ] keep ] dip (copy-element) ; + +: copy-elements-back ( dst start seq n -- ) + dup 0 > [ + [ [ copy-element ] 3keep [ 1 + ] dip ] dip 1 - copy-elements-back + ] [ 3drop drop ] if ; + +: copy-elements-forward ( dst start seq n -- ) + dup 0 > [ + [ [ copy-element ] 3keep [ 1 - ] dip ] dip 1 - copy-elements-forward + ] [ 3drop drop ] if ; + +: copy-elements ( dst start end seq -- ) + pick pick > [ + [ dupd - ] dip swap copy-elements-forward + ] [ + [ over - ] dip swap copy-elements-back + ] if ; + +! the gap can be moved either forward or back. Moving the gap 'inside' means +! moving elements across the gap. Moving the gap 'around' means changing the +! start of the circular buffer to avoid moving as many elements. + +! We decide which method (inside or around) to pick based on the number of +! elements that will need to be moved. We always try to move as few elements as +! possible. + +: move-gap? ( i gb -- i gb ? ) 2dup gap-end>> = not ; + +: move-gap-forward? ( i gb -- i gb ? ) 2dup gap-start>> >= ; + +: move-gap-back-inside? ( i gb -- i gb ? ) + ! is it cheaper to move the gap inside than around? + 2dup [ gap-start>> swap 2 * - ] keep [ buffer-length ] keep gap-end>> - <= ; + +: move-gap-forward-inside? ( i gb -- i gb ? ) + ! is it cheaper to move the gap inside than around? + 2dup [ gap-end>> [ 2 * ] dip - ] keep [ gap-start>> ] keep buffer-length + <= ; + +: move-gap-forward-inside ( i gb -- ) + [ dup gap-length neg swap gap-end>> rot ] keep seq>> copy-elements ; + +: move-gap-back-inside ( i gb -- ) + [ dup gap-length swap gap-start>> 1 - rot 1 - ] keep seq>> copy-elements ; + +: move-gap-forward-around ( i gb -- ) + 0 over move-gap-back-inside [ + dup buffer-length [ + swap gap-length - neg swap + ] keep + ] keep [ + seq>> copy-elements + ] keep dup gap-length swap seq>> change-circular-start ; + +: move-gap-back-around ( i gb -- ) + dup buffer-length over move-gap-forward-inside [ + length swap -1 + ] keep [ + seq>> copy-elements + ] keep dup length swap seq>> change-circular-start ; + +: move-gap-forward ( i gb -- ) + move-gap-forward-inside? [ + move-gap-forward-inside + ] [ + move-gap-forward-around + ] if ; + +: move-gap-back ( i gb -- ) + move-gap-back-inside? [ + move-gap-back-inside + ] [ + move-gap-back-around + ] if ; + +: (move-gap) ( i gb -- ) + move-gap? [ + move-gap-forward? [ + move-gap-forward + ] [ + move-gap-back + ] if + ] [ 2drop ] if ; + +: fix-gap ( n gb -- ) + 2dup [ gap-length + ] keep gap-end<< gap-start<< ; + +! moving the gap to position 5 means that the element in position 5 will be immediately after the gap +GENERIC: move-gap ( n gb -- ) + +M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ; + +! ------------ resizing ------------------------------------- + +: enough-room? ( n gb -- ? ) + ! is there enough room to add 'n' elements to gb? + tuck length + swap buffer-length <= ; + +: set-new-gap-end ( array gb -- ) + [ buffer-length swap length swap - ] keep + [ gap-end>> + ] keep gap-end<< ; + +: after-gap ( gb -- gb ) + dup seq>> swap gap-end>> tail ; + +: before-gap ( gb -- gb ) + dup gap-start>> head ; + +: copy-after-gap ( array gb -- ) + ! copy everything after the gap in 'gb' into the end of 'array', + ! and change 'gb's gap-end to reflect the gap-end in 'array' + dup after-gap [ 2dup set-new-gap-end gap-end>> swap ] dip -rot copy ; + +: copy-before-gap ( array gb -- ) + ! copy everything before the gap in 'gb' into the start of 'array' + before-gap 0 rot copy ; ! gap start doesn't change + +: resize-buffer ( gb new-size -- ) + f swap 2dup copy-before-gap 2dup copy-after-gap + [ ] dip seq<< ; + +: decrease-buffer-size ( gb -- ) + ! the gap is too big, so resize to something sensible + dup length over required-space resize-buffer ; + +: increase-buffer-size ( n gb -- ) + ! increase the buffer to fit at least 'n' more elements + tuck length + over required-space resize-buffer ; + +: gb-too-big? ( gb -- ? ) + dup buffer-length over min-size>> > [ + dup length over buffer-length rot expand-factor>> sq / < + ] [ drop f ] if ; + +: ?decrease ( gb -- ) + dup gb-too-big? [ + decrease-buffer-size + ] [ drop ] if ; + +: ensure-room ( n gb -- ) + ! ensure that ther will be enough room for 'n' more elements + 2dup enough-room? [ 2drop ] [ + increase-buffer-size + ] if ; + +! ------- editing operations --------------- + +GENERIC#: insert* 2 ( seq position gb -- ) + +: prepare-insert ( seq position gb -- seq gb ) + tuck move-gap over length over ensure-room ; + +: insert-elements ( seq gb -- ) + dup gap-start>> swap seq>> copy ; + +: increment-gap-start ( gb n -- ) + over gap-start>> + swap gap-start<< ; + +! generic dispatch identifies numbers as sequences before numbers... +M: number insert* ( elem position gb -- ) [ 1array ] 2dip insert* ; +! : number-insert ( num position gb -- ) [ 1array ] 2dip insert* ; + +M: sequence insert* ( seq position gb -- ) + prepare-insert [ insert-elements ] 2keep swap length increment-gap-start ; + +: (delete*) ( gb -- ) + dup gap-end>> 1 + over gap-end<< ?decrease ; + +GENERIC: delete* ( pos gb -- ) + +M: gb delete* ( position gb -- ) + tuck move-gap (delete*) ; + +! -------- stack/queue operations ----------- + +: push-start ( obj gb -- ) 0 swap insert* ; + +: push-end ( obj gb -- ) [ length ] keep insert* ; + +: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ; + +: pop-start ( gb -- elem ) 0 swap pop-elem ; + +: pop-end ( gb -- elem ) [ length 1 - ] keep pop-elem ; + +: rotate-right ( gb -- ) + dup [ pop-end ] keep push-start drop ; + +: rotate-left ( gb -- ) + dup [ pop-start ] keep push-end drop ; + +: rotate ( n gb -- ) + over 0 > [ + '[ _ rotate-right ] times + ] [ + [ neg ] dip '[ _ rotate-left ] times + ] if ; diff --git a/extra/gap-buffer/summary.txt b/extra/gap-buffer/summary.txt new file mode 100644 index 0000000000..0da4c0075d --- /dev/null +++ b/extra/gap-buffer/summary.txt @@ -0,0 +1 @@ +Gap buffer data structure diff --git a/extra/gap-buffer/tags.txt b/extra/gap-buffer/tags.txt new file mode 100644 index 0000000000..57de004d91 --- /dev/null +++ b/extra/gap-buffer/tags.txt @@ -0,0 +1 @@ +collections sequences diff --git a/extra/gdbm/ffi/ffi.factor b/extra/gdbm/ffi/ffi.factor old mode 100755 new mode 100644 diff --git a/extra/gpu/gpu.factor b/extra/gpu/gpu.factor old mode 100755 new mode 100644 diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor old mode 100755 new mode 100644 diff --git a/extra/gpu/shaders/shaders-docs.factor b/extra/gpu/shaders/shaders-docs.factor index 4d93263459..a6e249d53f 100644 --- a/extra/gpu/shaders/shaders-docs.factor +++ b/extra/gpu/shaders/shaders-docs.factor @@ -31,6 +31,7 @@ HELP: { "vertex-buffer" "a vertex buffer" } { "program-instance" program-instance } { "format" vertex-format } + { "vertex-array" vertex-array } } { $description "Creates a new vertex array object." } ; diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor old mode 100755 new mode 100644 diff --git a/extra/gpu/state/state.factor b/extra/gpu/state/state.factor old mode 100755 new mode 100644 diff --git a/extra/help/lint/coverage/coverage-tests.factor b/extra/help/lint/coverage/coverage-tests.factor index d0e09cda89..ada199ab67 100644 --- a/extra/help/lint/coverage/coverage-tests.factor +++ b/extra/help/lint/coverage/coverage-tests.factor @@ -1,6 +1,7 @@ -USING: accessors help.lint.coverage help.lint.coverage.private -help.markup help.syntax kernel literals math math.matrices -sequences sorting tools.test vocabs ; +USING: accessors english eval help.lint.coverage +help.lint.coverage.private help.markup help.syntax kernel +literals math math.matrices multiline sequences sorting +tools.test vocabs ; IN: help.lint.coverage.tests ! make sure this doesn't throw an error (would signify an issue with ignored-words) ! the contents of all-words is not important { } [ all-words [ ] map drop ] unit-test + + +! Lint system is written weirdly, there's no way to invoke it and get the output +! Instead, it writes to lint-failures. +{ t } +[ + [[ + USING: assocs definitions math kernel namespaces help.syntax + help.lint help.lint.private continuations compiler.units ; + IN: help.lint.tests + << + : add-stuff ( x y -- z ) + ; + + HELP: add-stuff ; + >> + [ + H{ } clone lint-failures [ + \ add-stuff check-word lint-failures get + assoc-empty? [ "help-lint is broken" throw ] when + ] with-variable t + ] [ + [ \ add-stuff forget ] with-compilation-unit + ] [ + f + ] cleanup + ]] eval( -- ? ) +] unit-test + + +! clean up broken words +[[ + USING: definitions compiler.units ; + IN: help.lint.coverage.tests.private +[ + \ empty forget + \ nonexistent forget + \ defined forget +] with-compilation-unit +]] eval( -- ) diff --git a/extra/images/ppm/ppm.factor b/extra/images/ppm/ppm.factor old mode 100755 new mode 100644 diff --git a/extra/images/testing/tiff/rgb.tiff b/extra/images/testing/tiff/rgb.tiff old mode 100755 new mode 100644 diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor old mode 100755 new mode 100644 diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor old mode 100755 new mode 100644 diff --git a/extra/modern/modern-tests.factor b/extra/modern/modern-tests.factor index 68e43dc65a..ff71231544 100644 --- a/extra/modern/modern-tests.factor +++ b/extra/modern/modern-tests.factor @@ -132,7 +132,7 @@ IN: modern.tests [ "char: [" string>literals >strings ] must-fail [ "char: {" string>literals >strings ] must-fail [ "char: \"" string>literals >strings ] must-fail -{ { { "char:" { "\\\\" } } } } [ "char: \\\\" string>literals >strings ] unit-test +! { { { "char:" { "\\\\" } } } } [ "char: \\\\" string>literals >strings ] unit-test [ "char: \\" string>literals >strings ] must-fail ! char: \ should be legal eventually diff --git a/extra/modern/modern.factor b/extra/modern/modern.factor index 026464b862..f79b169651 100644 --- a/extra/modern/modern.factor +++ b/extra/modern/modern.factor @@ -348,7 +348,7 @@ DEFER: lex-factor-top* over "\\" head? [ drop ! \ foo - dup "\\" sequence= [ (read-backslash) ] [ merge-slice-til-whitespace ] if + dup [ char: \\ = ] all? [ (read-backslash) ] [ merge-slice-til-whitespace ] if ] [ ! foo\ or foo\bar (?) over "\\" tail? [ drop (read-backslash) ] [ lex-factor-top* ] if @@ -488,7 +488,7 @@ ERROR: compound-syntax-disallowed n seq obj ; : failed-lexing ( assoc -- assoc' ) [ nip array? ] assoc-reject ; -: lex-core ( -- assoc ) core-bootstrap-vocabs lex-vocabs ; +: lex-core ( -- assoc ) core-vocabs lex-vocabs ; : lex-basis ( -- assoc ) basis-vocabs lex-vocabs ; : lex-extra ( -- assoc ) extra-vocabs lex-vocabs ; : lex-roots ( -- assoc ) lex-core lex-basis lex-extra 3append ; diff --git a/extra/modern/out/out.factor b/extra/modern/out/out.factor index 86a8cf81d9..735f6aefeb 100644 --- a/extra/modern/out/out.factor +++ b/extra/modern/out/out.factor @@ -1,10 +1,6 @@ ! Copyright (C) 2017 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators.short-circuit -constructors continuations io io.encodings.utf8 io.files -io.streams.string kernel modern modern.paths modern.slices -prettyprint sequences sequences.extras splitting strings -vocabs.loader ; +USING: accessors arrays assocs combinators.short-circuit ; IN: modern.out : token? ( obj -- ? ) @@ -84,7 +80,7 @@ DEFER: map-literals ]] : strings-core-to-file ( -- ) - core-bootstrap-vocabs + core-vocabs [ ".private" ?tail drop vocab-source-path utf8 file-contents ] map-zip [ "[========[" dup matching-delimiter-string surround ] assoc-map [ @@ -95,7 +91,7 @@ DEFER: map-literals "\n;VOCAB-ROOT>" surround "resource:core-strings.factor" utf8 set-file-contents ; : parsed-core-to-file ( -- ) - core-bootstrap-vocabs + core-vocabs [ vocab>literals ] map-zip [ first2 [ "> ] map ; -: core-vocabs ( -- seq ) "resource:core" vocabs-from ; -: less-core-test-vocabs ( seq -- seq' ) - { +CONSTANT: core-broken-vocabs + { "vocabs.loader.test.a" "vocabs.loader.test.b" "vocabs.loader.test.c" @@ -30,10 +29,10 @@ ERROR: not-a-source-path path ; "vocabs.loader.test.n" "vocabs.loader.test.o" "vocabs.loader.test.p" - } diff ; + } -: core-bootstrap-vocabs ( -- seq ) - core-vocabs less-core-test-vocabs ; +: core-vocabs ( -- seq ) + "resource:core" vocabs-from core-broken-vocabs diff ; : basis-vocabs ( -- seq ) "resource:basis" vocabs-from ; : extra-vocabs ( -- seq ) "resource:extra" vocabs-from ; diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor old mode 100755 new mode 100644 diff --git a/extra/odbc/odbc-docs.factor b/extra/odbc/odbc-docs.factor index 52a9ee8c48..6f1c6448bc 100644 --- a/extra/odbc/odbc-docs.factor +++ b/extra/odbc/odbc-docs.factor @@ -77,7 +77,7 @@ HELP: odbc-number-of-columns HELP: odbc-describe-column { $values { "statement" "an ODBC statement handle" } - { "n" "a column number starting from one" } + { "columnNumber" "a column number starting from one" } { "column" "a column object" } } { $description @@ -88,7 +88,7 @@ HELP: odbc-describe-column HELP: odbc-get-field { $values { "statement" "an ODBC statement handle" } - { "column" "a column number starting from one or a object" } + { "column!" "a column number starting from one or a object" } { "field" "a object" } } { $description diff --git a/extra/odbc/platforms.txt b/extra/odbc/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/extra/odbc/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/extra/openal/alut/alut.factor b/extra/openal/alut/alut.factor old mode 100755 new mode 100644 diff --git a/extra/openal/alut/backend/backend.factor b/extra/openal/alut/backend/backend.factor old mode 100755 new mode 100644 diff --git a/extra/openal/alut/macosx/macosx.factor b/extra/openal/alut/macosx/macosx.factor old mode 100755 new mode 100644 diff --git a/extra/openal/alut/other/other.factor b/extra/openal/alut/other/other.factor old mode 100755 new mode 100644 diff --git a/extra/openal/example/example.factor b/extra/openal/example/example.factor old mode 100755 new mode 100644 diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor old mode 100755 new mode 100644 diff --git a/extra/roms/space-invaders/space-invaders.factor b/extra/roms/space-invaders/space-invaders.factor old mode 100755 new mode 100644 diff --git a/extra/rosetta-code/metronome/metronome.factor b/extra/rosetta-code/metronome/metronome.factor old mode 100755 new mode 100644 diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor index 9eeb2b764d..135078170e 100644 --- a/extra/sequences/extras/extras-tests.factor +++ b/extra/sequences/extras/extras-tests.factor @@ -273,3 +273,11 @@ tools.test vectors vocabs ; { "a_b" } [ "ab" char: _ interleaved ] unit-test { "a_b_c" } [ "abc" char: _ interleaved ] unit-test { "a_b_c_d" } [ "abcd" char: _ interleaved ] unit-test + +{ 0 } [ { 1 2 3 4 } [ 5 > ] count-head ] unit-test +{ 2 } [ { 1 2 3 4 } [ 3 < ] count-head ] unit-test +{ 4 } [ { 1 2 3 4 } [ 5 < ] count-head ] unit-test + +{ 0 } [ { 1 2 3 4 } [ 5 > ] count-tail ] unit-test +{ 2 } [ { 1 2 3 4 } [ 2 > ] count-tail ] unit-test +{ 4 } [ { 1 2 3 4 } [ 5 < ] count-tail ] unit-test diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor index c328faa22d..1153a99976 100644 --- a/extra/sequences/extras/extras.factor +++ b/extra/sequences/extras/extras.factor @@ -629,7 +629,7 @@ PRIVATE> [ dup length ] unless* tail-slice ; inline : count-head ( seq quot -- n ) - [ not ] compose find drop ; inline + [ not ] compose [ find drop ] 2keep drop length or ; inline : count-tail ( seq quot -- n ) [ not ] compose [ find-last drop ] 2keep drop diff --git a/extra/slots/syntax/syntax-docs.factor b/extra/slots/syntax/syntax-docs.factor old mode 100755 new mode 100644 diff --git a/extra/slots/syntax/syntax-tests.factor b/extra/slots/syntax/syntax-tests.factor old mode 100755 new mode 100644 diff --git a/extra/slots/syntax/syntax.factor b/extra/slots/syntax/syntax.factor old mode 100755 new mode 100644 diff --git a/extra/snake-game/_resources/background.png b/extra/snake-game/_resources/background.png old mode 100755 new mode 100644 diff --git a/extra/snake-game/_resources/body.png b/extra/snake-game/_resources/body.png old mode 100755 new mode 100644 diff --git a/extra/snake-game/_resources/food.png b/extra/snake-game/_resources/food.png old mode 100755 new mode 100644 diff --git a/extra/snake-game/_resources/head.png b/extra/snake-game/_resources/head.png old mode 100755 new mode 100644 diff --git a/extra/snake-game/_resources/tail.png b/extra/snake-game/_resources/tail.png old mode 100755 new mode 100644 diff --git a/extra/successor/successor-docs.factor b/extra/successor/successor-docs.factor index ce8edbe319..5e3ad573a3 100644 --- a/extra/successor/successor-docs.factor +++ b/extra/successor/successor-docs.factor @@ -6,7 +6,7 @@ USING: help.markup help.syntax successor strings ; IN: succesor HELP: successor -{ $values { "str" string } } +{ $values { "str" string } { "str'" string } } { $description "Returns the successor to " { $snippet "str" } ". The successor is calculated by incrementing characters starting from the rightmost alphanumeric (or the rightmost character if there are no alphanumerics) in the string. Incrementing a digit always results in another digit, and incrementing a letter results in another letter of the same case. " $nl diff --git a/extra/synth/example/example.factor b/extra/synth/example/example.factor old mode 100755 new mode 100644 diff --git a/extra/synth/synth.factor b/extra/synth/synth.factor old mode 100755 new mode 100644 diff --git a/extra/tools/cat/cat.factor b/extra/tools/cat/cat.factor index ea90e42a38..45694598df 100644 --- a/extra/tools/cat/cat.factor +++ b/extra/tools/cat/cat.factor @@ -1,16 +1,15 @@ ! Copyright (C) 2010 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: command-line formatting kernel io io.encodings.binary -io.files namespaces sequences strings ; +USING: command-line formatting fry io io.encodings +io.encodings.binary io.files kernel namespaces sequences ; IN: tools.cat -: cat-lines ( -- ) - [ print flush ] each-line ; - : cat-stream ( -- ) - [ >string write flush ] each-block ; + input-stream get binary re-decode + output-stream get binary re-encode + '[ _ stream-write ] each-stream-block ; : cat-file ( path -- ) dup exists? [ @@ -18,9 +17,9 @@ IN: tools.cat ] [ "%s: not found\n" printf flush ] if ; : cat-files ( paths -- ) - [ dup "-" = [ drop cat-lines ] [ cat-file ] if ] each ; + [ dup "-" = [ drop cat-stream ] [ cat-file ] if ] each ; : run-cat ( -- ) - command-line get [ cat-lines ] [ cat-files ] if-empty ; + command-line get [ cat-stream ] [ cat-files ] if-empty ; MAIN: run-cat diff --git a/extra/tools/wc/wc.factor b/extra/tools/wc/wc.factor index c254ddf75e..42ed2945d4 100644 --- a/extra/tools/wc/wc.factor +++ b/extra/tools/wc/wc.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2016 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: accessors alien.data command-line formatting io -io.encodings io.encodings.binary io.files kernel math -math.bitwise math.vectors math.vectors.simd namespaces sequences +USING: alien.data command-line formatting io io.encodings +io.encodings.binary io.files kernel math math.bitwise +math.vectors math.vectors.simd namespaces sequences specialized-arrays ; SPECIALIZED-ARRAY: uchar-16 @@ -27,7 +27,7 @@ IN: tools.wc ] each-block-slice ; inline : wc-stdin ( -- n ) - input-stream get dup decoder? [ stream>> ] when + input-stream get binary re-decode [ count-lines ] with-input-stream* ; PRIVATE> diff --git a/extra/trees/trees-docs.factor b/extra/trees/trees-docs.factor index b46cd2adbe..b3af391251 100644 --- a/extra/trees/trees-docs.factor +++ b/extra/trees/trees-docs.factor @@ -177,14 +177,14 @@ HELP: first-key HELP: pop-tree-left { $values { "tree" tree } - { "pair/f" { $maybe pair } } + { "node/f" { $maybe pair } } } { $description "Removes and returns a key-value mapping associated with the lowest key in this map, or " { $link f } " if the map is empty." } ; HELP: pop-tree-right { $values { "tree" tree } - { "pair/f" { $maybe pair } } + { "node/f" { $maybe pair } } } { $description "Removes and returns a key-value mapping associated with the highest key in this map, or " { $link f } " if the map is empty." } ; diff --git a/extra/ui/gadgets/charts/lines/lines-docs.factor b/extra/ui/gadgets/charts/lines/lines-docs.factor index a6ddb18d28..b5cbf16624 100644 --- a/extra/ui/gadgets/charts/lines/lines-docs.factor +++ b/extra/ui/gadgets/charts/lines/lines-docs.factor @@ -56,6 +56,12 @@ $nl HELP: y-at { $description "Given two points on a straight line and an " { $snippet "x" } " coordinate, calculate the " { $snippet "y" } " coordinate at " { $snippet "x" } " on that line." } +{ $values + { "x" object } + { "point1" object } + { "point2" object } + { "y" object } +} { $examples { $example "USING: ui.gadgets.charts.lines.private prettyprint ;" @@ -76,6 +82,12 @@ HELP: y-at HELP: calc-x { $description "Given the " { $snippet "slope" } " of a line and a random " { $snippet "point" } " belonging to that line, calculate the " { $snippet "x" } " coordinate corresponding to the given " { $snippet "y" } "." } +{ $values + { "slope" object } + { "y" object } + { "point" object } + { "x" object } +} { $examples { $example "USING: ui.gadgets.charts.lines.private prettyprint ;" @@ -91,6 +103,12 @@ HELP: calc-x HELP: calc-y { $description "Given the " { $snippet "slope" } " of a line and a random " { $snippet "point" } " belonging to that line, calculate the " { $snippet "y" } " coordinate corresponding to the given " { $snippet "x" } "." } +{ $values + { "slope" object } + { "x" object } + { "point" object } + { "y" object } +} { $examples { $example "USING: ui.gadgets.charts.lines.private prettyprint ;" @@ -106,6 +124,11 @@ HELP: calc-y HELP: calc-line-slope { $description "Given the two points belonging to a straight line, calculate the " { $snippet "slope" } " of the line, assuming the line equation is " { $snippet "y(x) = slope * x + b" } "." +{ $values + { "point1" object } + { "point2" object } + { "slope" object } +} $nl "The formula for the calculation is " { $snippet "slope = (y1-y2) / (x1-x2)" } ", therefore it'll throw a division by zero error if both points have the same " { $snippet "x" } " coordinate." } { $examples diff --git a/extra/web-services/github/github.factor b/extra/web-services/github/github.factor index 2bb14e77a3..289e341179 100644 --- a/extra/web-services/github/github.factor +++ b/extra/web-services/github/github.factor @@ -1,9 +1,7 @@ ! Copyright (C) 2017 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs cli.git concurrency.combinators -concurrency.semaphores formatting fry http.client io -io.directories io.pathnames json.reader kernel locals math -namespaces sequences ; +USING: assocs cli.git formatting http.client io.pathnames +json.reader kernel math namespaces sequences ; IN: web-services.github SYMBOL: github-username diff --git a/extra/windows/fullscreen/fullscreen.factor b/extra/windows/fullscreen/fullscreen.factor old mode 100755 new mode 100644 diff --git a/extra/yaml/yaml-docs.factor b/extra/yaml/yaml-docs.factor index 23b14b2b02..a9b13c9e25 100644 --- a/extra/yaml/yaml-docs.factor +++ b/extra/yaml/yaml-docs.factor @@ -153,7 +153,7 @@ ARTICLE: "yaml-keys" "Special mapping keys" "See " { $url "http://yaml.org/type/merge.html" } $nl "As per " { $url "http://sourceforge.net/p/yaml/mailman/message/12308050" } ", the merge key is implemented bottom up:" $nl -{ $example "USING: yaml prettyprint ; +{ $unchecked-example "USING: yaml prettyprint ; \" foo: 1 <<: @@ -164,7 +164,7 @@ foo: 1 "H{ { \"baz\" 3 } { \"foo\" 1 } { \"bar\" 2 } }" } { $heading "!!value" } "See " { $url "http://yaml.org/type/value.html" } $nl -{ $example "USING: yaml prettyprint ; +{ $unchecked-example "USING: yaml prettyprint ; \" --- # Old schema link with: @@ -201,7 +201,7 @@ ARTICLE: "yaml" "YAML serialization" } { $examples { $heading "Input" } - { $example "USING: prettyprint yaml ;" + { $unchecked-example "USING: prettyprint yaml ;" "\"- true - null - ! 42 @@ -214,7 +214,7 @@ ARTICLE: "yaml" "YAML serialization" "{ t f \"42\" \"42\" 42 42 42 42.0 42.0 }" } { $heading "Output -- human readable" } - { $example "USING: yaml yaml.config ;" + { $unchecked-example "USING: yaml yaml.config ;" "t implicit-tags set t implicit-start set t implicit-end set @@ -245,7 +245,7 @@ t emitter-unicode set " } { $heading "Output -- verbose" } - { $example "USING: yaml yaml.config ;" + { $unchecked-example "USING: yaml yaml.config ;" "f implicit-tags set f implicit-start set f implicit-end set diff --git a/extra/zealot/cli-changed-vocabs/authors.txt b/extra/zealot/cli-changed-vocabs/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/zealot/cli-changed-vocabs/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/zealot/cli-changed-vocabs/cli-changed-vocabs.factor b/extra/zealot/cli-changed-vocabs/cli-changed-vocabs.factor new file mode 100644 index 0000000000..c14bbedc78 --- /dev/null +++ b/extra/zealot/cli-changed-vocabs/cli-changed-vocabs.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2018 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io sequences zealot.factor ; +IN: zealot.cli-changed-vocabs + +: zealot-changed-vocabs ( -- ) ci-vocabs-to-test [ print ] each ; + +MAIN: zealot-changed-vocabs \ No newline at end of file diff --git a/extra/zealot/cli-test-changed-vocabs/authors.txt b/extra/zealot/cli-test-changed-vocabs/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/zealot/cli-test-changed-vocabs/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/zealot/cli-test-changed-vocabs/cli-test-changed-vocabs.factor b/extra/zealot/cli-test-changed-vocabs/cli-test-changed-vocabs.factor new file mode 100644 index 0000000000..200313c55e --- /dev/null +++ b/extra/zealot/cli-test-changed-vocabs/cli-test-changed-vocabs.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2018 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences tools.test vocabs zealot.factor ; +IN: zealot.cli-test-changed-vocabs + +: zealot-test-changed-vocabs ( -- ) + ci-vocabs-to-test [ + [ require ] each + ] [ + [ test ] each + ] bi ; + +MAIN: zealot-test-changed-vocabs \ No newline at end of file diff --git a/extra/zealot/factor/factor.factor b/extra/zealot/factor/factor.factor index 741e715851..56a9c1105f 100644 --- a/extra/zealot/factor/factor.factor +++ b/extra/zealot/factor/factor.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2017 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays bootstrap.image calendar cli.git -combinators concurrency.combinators formatting fry http.client -io io.directories io.launcher io.pathnames kernel math.parser -memory modern.paths namespaces parser.notes prettyprint -sequences sequences.extras system system-info threads tools.test -vocabs vocabs.hierarchy vocabs.hierarchy.private vocabs.loader -zealot ; +USING: accessors arrays assocs bootstrap.image calendar cli.git +combinators concurrency.combinators environment formatting +http.client io io.directories io.launcher io.pathnames kernel +math.parser memory modern.paths namespaces parser.notes +prettyprint sequences sequences.extras sets splitting system +system-info threads tools.test vocabs vocabs.hierarchy +vocabs.hierarchy.private vocabs.loader vocabs.metadata zealot ; IN: zealot.factor : download-boot-checksums ( path branch -- ) @@ -168,3 +168,46 @@ M: windows factor-path "./factor.com" ; [ "ZEALOT LOADING ROOTS" print flush drop zealot-load-commands ] [ "ZEALOT TESTING ROOTS" print flush drop zealot-test-commands ] } 2cleave ; + +: factor-clean-branch ( -- str ) + os cpu [ name>> ] bi@ { { char: . char: - } } substitute + "-" glue "origin/clean-" prepend ; + +: vocab-path>vocab ( path -- vocab ) + [ parent-directory ] map + [ "/" split1 nip ] map + [ path-separator split harvest "." join ] map ; + +: changed-factor-vocabs ( old-rev new-rev -- vocabs ) + [ + default-vocab-roots + [ ":" split1 nip ] map + [ "/" append ] map + ] 2dip git-diff-name-only* + [ ".factor" tail? ] filter + [ swap [ head? ] with any? ] with filter + [ parent-directory ] map + [ "/" split1 nip ] map + [ path-separator split harvest "." join ] map members ; + +: changed-factor-vocabs-from-master ( -- vocabs ) + "HEAD" "origin/master" changed-factor-vocabs ; + +: changed-factor-vocabs-from-clean ( -- vocabs ) + "HEAD" factor-clean-branch changed-factor-vocabs ; + +: testing-a-branch? ( -- ? ) + "CI_BRANCH" os-env "master" or + "master" = not ; + +: reject-unloadable-vocabs ( vocabs -- vocabs' ) + [ don't-load? ] reject ; + +! Test changes from a CI_BRANCH against origin/master +! Test master against last clean build, e.g. origin/clean-linux-x86-64 +: ci-vocabs-to-test ( -- vocabs ) + testing-a-branch? [ + changed-factor-vocabs-from-master + ] [ + changed-factor-vocabs-from-clean + ] if reject-unloadable-vocabs ; diff --git a/vm/callstack.cpp b/vm/callstack.cpp index bd0d6c67cc..2d183e8028 100644 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -56,6 +56,8 @@ void factor_vm::primitive_callstack_to_array() { cell size, code_block* owner, cell addr) { + (void)frame_top; + (void)size; data_root executing_quot(owner->owner_quot(), this); data_root executing(owner->owner, this); data_root scan(owner->scan(this, addr), this); diff --git a/vm/code_blocks.hpp b/vm/code_blocks.hpp index 09b0dc4a47..baa0faa6c9 100644 --- a/vm/code_blocks.hpp +++ b/vm/code_blocks.hpp @@ -62,7 +62,7 @@ struct code_block { header = (header & 0xFFFFFF) | (frame_size << 20); } - template cell size(Fixup fixup) const { return size(); } + template cell size(Fixup fixup) const { (void)fixup; return size(); } cell entry_point() const { return (cell)(this + 1); } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 23a28c07f3..ad507c2e78 100644 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -71,6 +71,8 @@ void code_heap::sweep() { void code_heap::verify_all_blocks_set() { auto all_blocks_set_verifier = [&](code_block* block, cell size) { + (void)block; + (void)size; FACTOR_ASSERT(all_blocks.find((cell)block) != all_blocks.end()); }; allocator->iterate(all_blocks_set_verifier, no_fixup()); @@ -102,6 +104,7 @@ cell code_heap::frame_predecessor(cell frame_top) { void code_heap::initialize_all_blocks_set() { all_blocks.clear(); auto all_blocks_set_inserter = [&](code_block* block, cell size) { + (void)size; all_blocks.insert((cell)block); }; allocator->iterate(all_blocks_set_inserter, no_fixup()); @@ -115,6 +118,7 @@ void code_heap::initialize_all_blocks_set() { // If generic words were redefined, inline caches need to be reset. void factor_vm::update_code_heap_words(bool reset_inline_caches) { auto word_updater = [&](code_block* block, cell size) { + (void)size; update_word_references(block, reset_inline_caches); }; each_code_block(word_updater); @@ -182,6 +186,7 @@ void factor_vm::primitive_code_room() { void factor_vm::primitive_strip_stack_traces() { auto stack_trace_stripper = [](code_block* block, cell size) { + (void)size; block->owner = false_object; }; each_code_block(stack_trace_stripper); @@ -191,6 +196,7 @@ void factor_vm::primitive_strip_stack_traces() { void factor_vm::primitive_code_blocks() { std::vector objects; auto code_block_accumulator = [&](code_block* block, cell size) { + (void)size; objects.push_back(block->owner); objects.push_back(block->parameters); objects.push_back(block->relocation); diff --git a/vm/compaction.cpp b/vm/compaction.cpp index 027be093bd..7a2aed6172 100644 --- a/vm/compaction.cpp +++ b/vm/compaction.cpp @@ -109,6 +109,8 @@ void factor_vm::collect_compact_impl() { // Slide everything in tenured space up, and update data and code heap // pointers inside objects. auto compact_object_func = [&](object* old_addr, object* new_addr, cell size) { + (void)old_addr; + (void)size; forwarder.visit_slots(new_addr); forwarder.visit_object_code_block(new_addr); tenured->starts.record_object_start_offset(new_addr); @@ -120,6 +122,7 @@ void factor_vm::collect_compact_impl() { auto compact_code_func = [&](code_block* old_addr, code_block* new_addr, cell size) { + (void)size; forwarder.visit_code_block_objects(new_addr); cell old_entry_point = old_addr->entry_point(); forwarder.visit_instruction_operands(new_addr, old_entry_point); @@ -136,6 +139,7 @@ void factor_vm::collect_compact_impl() { // the code heap. Since the code heap has now been compacted, those // pointers are invalid and we need to update them. auto callback_updater = [&](code_block* stub, cell size) { + (void)size; callbacks->update(stub); }; callbacks->allocator->iterate(callback_updater, no_fixup()); diff --git a/vm/contexts.cpp b/vm/contexts.cpp index d0e528722e..48afadaa27 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -38,6 +38,10 @@ void context::fill_stack_seg(cell top_ptr, segment* seg, cell pattern) { cell clear_start = top_ptr + sizeof(cell); cell clear_size = seg->end - clear_start; memset_cell((void*)clear_start, pattern, clear_size); +#else + (void)top_ptr; + (void)seg; + (void)pattern; #endif } diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index e077bf0cd7..a0d83b5d78 100644 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -3,7 +3,7 @@ namespace factor { #define CALLSTACK_BOTTOM(ctx) \ (ctx->callstack_seg->end - sizeof(cell) * 5) -inline static void flush_icache(cell start, cell len) {} +inline static void flush_icache(cell start, cell len) { (void)start; (void)len; } // In the instruction sequence: diff --git a/vm/debug.cpp b/vm/debug.cpp index 24ad2d260c..085c85e3c6 100644 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -62,6 +62,7 @@ void factor_vm::print_alien(ostream& out, alien* alien, cell nesting) { } void factor_vm::print_byte_array(ostream& out, byte_array* array, cell nesting) { + (void)nesting; cell length = array->capacity; cell i; bool trimmed; diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 4bf5e70f3e..1927a8d988 100644 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -84,7 +84,10 @@ FACTOR_STDCALL(struct bar) ffi_test_19(long x, long y, long z) { } void ffi_test_20(double x1, double x2, double x3, double y1, double y2, - double y3, double z1, double z2, double z3) {} + double y3, double z1, double z2, double z3) { + (void) x1, (void) x2, (void) x3, (void) y1, (void) y2, + (void) y3, (void) z1, (void) z2, (void) z3; +} long long ffi_test_21(long x, long y) { return (long long) x * (long long) y; } @@ -309,7 +312,7 @@ unsigned long long ffi_test_60(unsigned long long x) { /* C99 features */ #ifndef _MSC_VER -struct bool_and_ptr ffi_test_61() { +struct bool_and_ptr ffi_test_61(void) { struct bool_and_ptr bap; bap.b = true; bap.ptr = NULL; @@ -318,14 +321,14 @@ struct bool_and_ptr ffi_test_61() { #endif -struct uint_pair ffi_test_62() { +struct uint_pair ffi_test_62(void) { struct uint_pair uip; uip.a = 0xabcdefab; uip.b = 0x12345678; return uip; } -struct ulonglong_pair ffi_test_63() { +struct ulonglong_pair ffi_test_63(void) { struct ulonglong_pair ullp; ullp.a = 0xabcdefabcdefabcd; ullp.b = 0x1234567891234567; @@ -360,6 +363,8 @@ void* bug1021_test_1(void* x, int y) { } int bug1021_test_2(int x, char *y, void *z) { + (void) x; + (void) z; return y[0]; } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index c359811e65..1c7ae7ddb3 100644 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -161,7 +161,7 @@ struct test_struct_16 { FACTOR_EXPORT struct test_struct_16 ffi_test_43(float x, int a); -FACTOR_EXPORT struct test_struct_14 ffi_test_44(); +FACTOR_EXPORT struct test_struct_14 ffi_test_44(void); /* C99 features */ #ifndef _MSC_VER @@ -211,7 +211,7 @@ struct bool_and_ptr { void* ptr; }; -FACTOR_EXPORT struct bool_and_ptr ffi_test_61(); +FACTOR_EXPORT struct bool_and_ptr ffi_test_61(void); #endif @@ -220,14 +220,14 @@ struct uint_pair { unsigned int b; }; -FACTOR_EXPORT struct uint_pair ffi_test_62(); +FACTOR_EXPORT struct uint_pair ffi_test_62(void); struct ulonglong_pair { unsigned long long a; unsigned long long b; }; -FACTOR_EXPORT struct ulonglong_pair ffi_test_63(); +FACTOR_EXPORT struct ulonglong_pair ffi_test_63(void); FACTOR_EXPORT int ffi_test_64(int n, ...); FACTOR_EXPORT double ffi_test_65(int n, ...); diff --git a/vm/free_list.hpp b/vm/free_list.hpp index d19dea5b15..a996ee834a 100644 --- a/vm/free_list.hpp +++ b/vm/free_list.hpp @@ -263,7 +263,7 @@ void free_list_allocator::sweep(Iterator& iter) { } template void free_list_allocator::sweep() { - auto null_sweep = [](Block* free_block, cell size) { }; + auto null_sweep = [](Block* free_block, cell size) { (void)free_block; (void)size; }; sweep(null_sweep); } diff --git a/vm/image.cpp b/vm/image.cpp index 55bac23afa..f29ca779a3 100644 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -177,6 +177,7 @@ void factor_vm::fixup_heaps(cell data_offset, cell code_offset) { visitor.visit_all_roots(); auto start_object_updater = [&](object *obj, cell size) { + (void)size; data->tenured->starts.record_object_start_offset(obj); visitor.visit_slots(obj); switch (obj->type()) { @@ -201,6 +202,7 @@ void factor_vm::fixup_heaps(cell data_offset, cell code_offset) { data->tenured->iterate(start_object_updater, fixup); auto updater = [&](code_block* compiled, cell size) { + (void)size; visitor.visit_code_block_objects(compiled); cell rel_base = compiled->entry_point() - fixup.code_offset; visitor.visit_instruction_operands(compiled, rel_base); diff --git a/vm/main-windows.cpp b/vm/main-windows.cpp index e0a1d0ae5f..4d6eddedd8 100644 --- a/vm/main-windows.cpp +++ b/vm/main-windows.cpp @@ -16,6 +16,10 @@ VM_C_API int wmain(int argc, wchar_t** argv) { int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow) { + (void)hInstance; + (void)hPrevInstance; + (void)lpCmdLine; + (void)nCmdShow; int argc; wchar_t** argv = CommandLineToArgvW(GetCommandLine(), &argc); wmain(argc, argv); diff --git a/vm/objects.cpp b/vm/objects.cpp index 1f821cbe39..bc85899465 100644 --- a/vm/objects.cpp +++ b/vm/objects.cpp @@ -111,6 +111,7 @@ void factor_vm::primitive_become() { each_object(object_become_func); auto code_block_become_func = [&](code_block* compiled, cell size) { + (void)size; visitor.visit_code_block_objects(compiled); visitor.visit_embedded_literals(compiled); code->write_barrier(compiled); diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 08651a1bd5..d5ecad1d09 100644 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -194,6 +194,8 @@ typedef enum _EXCEPTION_DISPOSITION { LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void* frame, PCONTEXT c, void* dispatch) { + (void)frame; + (void)dispatch; switch (e->ExceptionCode) { case EXCEPTION_ACCESS_VIOLATION: set_memory_protection_error(e->ExceptionInformation[1], c->EIP); @@ -242,7 +244,7 @@ VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void* frame, PCONTEXT c, // On Unix SIGINT (ctrl-c) automatically interrupts blocking io system // calls. It doesn't on Windows, so we need to manually send some // cancellation requests to unblock the thread. -VOID CALLBACK dummy_cb (ULONG_PTR dwParam) { } +VOID CALLBACK dummy_cb(ULONG_PTR dwParam) { (void)dwParam; } // CancelSynchronousIo is not in Windows XP #if _WIN32_WINNT >= 0x0600 @@ -261,7 +263,7 @@ static void wake_up_thread(HANDLE thread) { } } #else -static void wake_up_thread(HANDLE thread) {} +static void wake_up_thread(HANDLE thread) { (void)thread; } #endif static BOOL WINAPI ctrl_handler(DWORD dwCtrlType) { diff --git a/vm/quotations.hpp b/vm/quotations.hpp index dd80c94882..3c659126dc 100644 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -10,7 +10,6 @@ struct quotation_jit : public jit { elements(false_object, vm), compiling(compiling), relocate(relocate) {} - ; cell nth(cell index); void init_quotation(cell quot); diff --git a/vm/sampling_profiler.cpp b/vm/sampling_profiler.cpp index 30680b73f0..4a36ccb7c1 100644 --- a/vm/sampling_profiler.cpp +++ b/vm/sampling_profiler.cpp @@ -73,6 +73,9 @@ void factor_vm::record_sample(bool prolog_p) { bool skip_p = prolog_p; auto recorder = [&](cell frame_top, cell size, code_block* owner, cell addr) { + (void)frame_top; + (void)size; + (void)addr; if (skip_p) skip_p = false; else { diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp index 1d6b9255c7..79bc3eb367 100644 --- a/vm/slot_visitor.hpp +++ b/vm/slot_visitor.hpp @@ -206,6 +206,7 @@ template void slot_visitor::visit_all_roots() { } auto callback_slot_visitor = [&](code_block* stub, cell size) { + (void)size; visit_handle(&stub->owner); }; parent->callbacks->allocator->iterate(callback_slot_visitor, no_fixup()); @@ -245,6 +246,7 @@ template struct call_frame_slot_visitor { // [size] void operator()(cell frame_top, cell size, code_block* owner, cell addr) { + (void)size; cell return_address = owner->offset(addr); code_block* compiled = @@ -359,7 +361,8 @@ template struct call_frame_code_block_visitor { call_frame_code_block_visitor(Fixup fixup) : fixup(fixup) {} void operator()(cell frame_top, cell size, code_block* owner, cell addr) { - code_block* compiled = + (void)size; + code_block* compiled = Fixup::translated_code_block_map ? owner : fixup.fixup_code(owner); cell fixed_addr = compiled->address_for_offset(owner->offset(addr));