Merge remote-tracking branch 'origin/master' into modern-harvey2

modern-harvey2
Doug Coleman 2018-08-02 07:57:42 -04:00
commit 7730fc5c64
205 changed files with 1325 additions and 234 deletions

View File

@ -11,6 +11,14 @@ group: deprecated-2017Q4
services: services:
- postgresql - postgresql
- redis-server - 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: addons:
apt: apt:
packages: 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 redis; fi
- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew services start postgresql; 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 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 && 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 ) && ( cd udis86-1.7.2/ && ./autogen.sh && ./configure --enable-shared=yes && make && sudo make install ) &&
( [[ "$TRAVIS_OS_NAME" != "osx" ]] && sudo ldconfig || true ) ( [[ "$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: 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 - 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'"

View File

@ -32,9 +32,9 @@
<key>CFBundlePackageType</key> <key>CFBundlePackageType</key>
<string>APPL</string> <string>APPL</string>
<key>CFBundleVersion</key> <key>CFBundleVersion</key>
<string>0.98</string> <string>0.99</string>
<key>NSHumanReadableCopyright</key> <key>NSHumanReadableCopyright</key>
<string>Copyright © 2003-2017 Factor developers</string> <string>Copyright © 2003-2018 Factor developers</string>
<key>NSServices</key> <key>NSServices</key>
<array> <array>
<dict> <dict>

View File

@ -1,5 +1,5 @@
ifdef CONFIG ifdef CONFIG
VERSION = 0.98 VERSION = 0.99
GIT_LABEL = $(shell echo `git describe --all`-`git rev-parse HEAD`) GIT_LABEL = $(shell echo `git describe --all`-`git rev-parse HEAD`)
BUNDLE = Factor.app BUNDLE = Factor.app

View File

@ -1,4 +1,4 @@
VERSION = 0.98 VERSION = 0.99
# Crazy hack to do shell commands # Crazy hack to do shell commands
# We do it in Nmakefile because that way we don't have to invoke build through build.cmd # We do it in Nmakefile because that way we don't have to invoke build through build.cmd

0
basis/alien/parser/parser.factor Executable file → Normal file
View File

0
basis/alien/syntax/syntax.factor Executable file → Normal file
View File

0
basis/bootstrap/image/image.factor Executable file → Normal file
View File

View File

@ -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." } ; { $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" 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 $nl
{ $link all-primitives } " is an assoc where all primitives are declared. See that constant for a description of the format." ; { $link all-primitives } " is an assoc where all primitives are declared. See that constant for a description of the format." ;

0
basis/cache/cache-tests.factor vendored Executable file → Normal file
View File

0
basis/cache/cache.factor vendored Executable file → Normal file
View File

View File

@ -1,8 +1,9 @@
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar calendar.english combinators io USING: accessors arrays calendar calendar.english combinators
io.streams.string kernel macros math math.order math.parser fry io io.streams.string kernel macros math math.order
math.parser.private present quotations sequences typed words ; math.parser math.parser.private present quotations sequences
typed words ;
IN: calendar.format IN: calendar.format
MACRO: formatted ( spec -- quot ) MACRO: formatted ( spec -- quot )
@ -16,6 +17,9 @@ MACRO: formatted ( spec -- quot )
: pad-00 ( n -- str ) number>string 2 char: 0 pad-head ; : 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-0000 ( n -- str ) number>string 4 char: 0 pad-head ;
: pad-00000 ( n -- str ) number>string 5 char: 0 pad-head ; : pad-00000 ( n -- str ) number>string 5 char: 0 pad-head ;

View File

@ -2,13 +2,13 @@ USING: help.markup help.syntax strings alien ;
IN: cocoa.messages IN: cocoa.messages
HELP: send 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." } { $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." } { $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." } ; { $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 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 } "." } ; { $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 HELP: objc-class

View File

@ -1,7 +1,7 @@
USING: assocs compiler.cfg compiler.cfg.builder.blocks USING: arrays assocs compiler.cfg compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stacks.local compiler.tree compiler.cfg.instructions compiler.cfg.stacks.local
help.markup help.syntax kernel literals math multiline quotations compiler.tree help.markup help.syntax kernel literals math
sequences vectors words ; multiline quotations sequences vectors words ;
IN: compiler.cfg.builder 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 } "." } ; { $description "Ends the word by adding a basic block containing a " { $link ##return } " instructions to the " { $link cfg } "." } ;
HELP: height-changes 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." } { $description "Returns a two-tuple which represents how much the " { $link #shuffle } " node increases or decreases the data and retainstacks." }
{ $examples { $examples
{ $example { $example
@ -115,7 +115,7 @@ HELP: height-changes
} ; } ;
HELP: out-vregs/stack 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." } ; { $description "Returns a sequence of what vregs are on which stack locations after the shuffle instruction." } ;
HELP: trivial-branch? HELP: trivial-branch?

View File

@ -72,7 +72,7 @@ HELP: vreg>reg
{ $see-also lookup-spill-slot pending-interval-assoc } ; { $see-also lookup-spill-slot pending-interval-assoc } ;
HELP: vregs>regs 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." } ; { $description "Creates a mapping of virtual registers to registers." } ;
HELP: vreg>spill-slot HELP: vreg>spill-slot

View File

@ -33,7 +33,7 @@ SYMBOL: pending-interval-assoc
: remove-pending ( live-interval -- ) : remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ; vreg>> pending-interval-assoc get delete-at ;
: vreg>spill-slot ( vreg -- slot ) : vreg>spill-slot ( vreg -- spill-slot )
dup rep-of lookup-spill-slot ; dup rep-of lookup-spill-slot ;
: vreg>reg ( vreg -- reg/spill-slot ) : vreg>reg ( vreg -- reg/spill-slot )

View File

@ -51,7 +51,7 @@ HELP: height-state
{ $see-also inc-stack reset-incs } ; { $see-also inc-stack reset-incs } ;
HELP: height-state>insns 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." } { $description "Converts a " { $link height-state } " tuple to 0-2 stack height change instructions." }
{ $examples { $examples
"In this example the datastacks height is increased by 4 and the retainstacks decreased by 2." "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." } ; { $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 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 } "." } ; { $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 HELP: loc>vreg
@ -76,10 +76,11 @@ HELP: loc>vreg
HELP: local-kill-set HELP: local-kill-set
{ $values { $values
{ "ds-height" integer } { "ds-begin" integer }
{ "ds-inc" integer } { "ds-inc" integer }
{ "rs-height" integer } { "rs-begin" integer }
{ "rs-inc" 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." } { $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 } ; { $see-also compute-local-kill-set } ;

0
basis/compiler/codegen/codegen.factor Executable file → Normal file
View File

0
basis/compiler/tests/alien.factor Executable file → Normal file
View File

View File

@ -225,7 +225,7 @@ M: float detect-float ;
{ shift fixnum-shift } inlined? { shift fixnum-shift } inlined?
] unit-test ] unit-test
cell-bits 32 = [ 32bit? [
[ t ] [ [ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ] [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined? \ shift inlined?

View File

@ -492,7 +492,7 @@ IN: compiler.tree.propagation.tests
[ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes
] unit-test ] unit-test
cell-bits 32 = [ 32bit? [
[ V{ integer } ] [ [ V{ integer } ] [
[ { fixnum } declare 1 swap 31 bitand shift ] [ { fixnum } declare 1 swap 31 bitand shift ]
final-classes final-classes

0
basis/compression/lzw/lzw.factor Executable file → Normal file
View File

0
basis/concurrency/count-downs/count-downs.factor Executable file → Normal file
View File

0
basis/concurrency/mailboxes/debugger/debugger.factor Executable file → Normal file
View File

0
basis/concurrency/mailboxes/mailboxes.factor Executable file → Normal file
View File

0
basis/cpu/x86/32/32.factor Executable file → Normal file
View File

0
basis/debugger/debugger.factor Executable file → Normal file
View File

View File

@ -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
: <reload-editor-button> ( editor -- button )
dup '[ drop [ _ reload ] \ run call-listener ] <border-button> ;
: <editor-reloader> ( -- gadget )
<filled-pile> { 2 2 } >>gap available-editors
[ <reload-editor-button> add-gadget ] each ;
MAIN-WINDOW: editor-window { { title "Editors" } }
<editor-reloader> { 2 2 } <border> <scroller> >>gadgets ;

View File

@ -110,7 +110,7 @@ HELP: count-of-things
} ; } ;
HELP: ?pluralize 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." } { $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 } } { $notes { $list $keep-case $0-plurality } }
{ $examples { $examples
@ -189,7 +189,7 @@ HELP: comma-list
} ; } ;
HELP: or-markup-example 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 } "." } { $description "Used to implement " { $link $or-markup-example } " and demonstrate " { $link comma-list } "." }
{ $examples { "See the examples in " { $link $or-markup-example } "." } } ; { $examples { "See the examples in " { $link $or-markup-example } "." } } ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2017 John Benediktsson, Doug Coleman. ! Copyright (C) 2017 John Benediktsson, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math math.order math.statistics USING: assocs assocs.extras combinators kernel math math.order
sequences sequences.extras sets ; math.statistics sequences sequences.extras sets ;
IN: escape-strings IN: escape-strings
: find-escapes ( str -- set ) : find-escapes ( str -- set )
@ -26,16 +26,14 @@ IN: escape-strings
dup find-escapes lowest-missing escape-string* ; dup find-escapes lowest-missing escape-string* ;
: escape-strings ( strs -- str ) : escape-strings ( strs -- str )
dup [ find-escapes ] map [ escape-string ] map concat escape-string ;
[
[ lowest-missing ] map : tag-payload ( str tag -- str' )
[ escape-string* ] 2map concat [ escape-string ] dip prepend ;
] [
[ ] [ union ] map-reduce : escape-simplest ( str -- str' )
] bi dup { char: \' char: \" char: \r char: \n char: \s } counts {
dup cardinality 0 = [ { [ dup { char: \' char: \r char: \n char: \s } values-of sum 0 = ] [ drop "'" prepend ] }
drop 1 { [ dup char: \" of not ] [ drop "\"" "\"" surround ] }
] [ [ drop escape-string ]
members minmax nip 2 + } cond ;
] if
escape-string* ;

0
basis/formatting/formatting-docs.factor Executable file → Normal file
View File

0
basis/formatting/formatting-tests.factor Executable file → Normal file
View File

0
basis/game/input/dinput/dinput.factor Executable file → Normal file
View File

0
basis/globs/globs-tests.factor Executable file → Normal file
View File

View File

View File

@ -4,10 +4,10 @@ USING: accessors arrays assocs classes classes.struct
classes.tuple combinators combinators.short-circuit classes.tuple combinators combinators.short-circuit
combinators.smart continuations debugger definitions effects combinators.smart continuations debugger definitions effects
eval formatting fry grouping help help.markup help.topics io eval formatting fry grouping help help.markup help.topics io
io.streams.string kernel macros math namespaces parser.notes io.streams.string kernel macros math math.statistics namespaces
prettyprint sequences sequences.deep sets splitting strings parser.notes prettyprint sequences sequences.deep sets splitting
summary tools.destructors unicode vocabs vocabs.loader words strings summary tools.destructors unicode vocabs vocabs.loader
words.constant words.symbol ; words words.constant words.symbol ;
IN: help.lint.checks IN: help.lint.checks
ERROR: simple-lint-error message ; ERROR: simple-lint-error message ;
@ -26,6 +26,7 @@ SYMBOL: vocab-articles
"line" ! core-text "line" ! core-text
"layout" ! ui.text.pango "layout" ! ui.text.pango
"script-string" ! windows.uniscribe "script-string" ! windows.uniscribe
"linux-monitor" ! github issue #2014, race condition in disposing of child monitors
} member? } member?
] reject ; ] reject ;
@ -50,9 +51,13 @@ SYMBOL: vocab-articles
] keep ] keep
last assert= last assert=
] vocabs-quot get call( quot -- ) ] vocabs-quot get call( quot -- )
] leaks members no-ui-disposables length [ ] leaks members no-ui-disposables
"%d disposable(s) leaked in example" sprintf simple-lint-error dup length 0 > [
] unless-zero ; dup [ class-of ] histogram-by
[ "Leaked resources: " write ... ] with-string-writer simple-lint-error
] [
drop
] if ;
: check-examples ( element -- ) : check-examples ( element -- )
\ $example swap elements [ check-example ] each ; \ $example swap elements [ check-example ] each ;
@ -99,7 +104,7 @@ SYMBOL: vocab-articles
[ parsing-word? ] [ parsing-word? ]
[ "declared-effect" word-prop not ] [ "declared-effect" word-prop not ]
[ constant? ] [ constant? ]
[ "word-help" word-prop not ] [ "help" word-prop not ]
} 1|| ; } 1|| ;
: skip-check-values? ( word element -- ? ) : skip-check-values? ( word element -- ? )

View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs combinators continuations fry help USING: assocs classes combinators command-line continuations fry
help.lint.checks help.topics io kernel namespaces parser help help.lint.checks help.topics io kernel listener locals
sequences source-files.errors vocabs.hierarchy vocabs words namespaces parser sequences source-files.errors system
classes locals tools.errors listener ; tools.errors vocabs vocabs.hierarchy ;
IN: help.lint IN: help.lint
SYMBOL: lint-failures SYMBOL: lint-failures
@ -97,3 +97,12 @@ PRIVATE>
[ word-help ] reject [ word-help ] reject
[ article-parent ] filter [ article-parent ] filter
[ predicate? ] reject ; [ 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

View File

@ -42,7 +42,7 @@ GENERIC: valid-article? ( topic -- ? )
GENERIC: article-title ( topic -- string ) GENERIC: article-title ( topic -- string )
GENERIC: article-name ( topic -- string ) GENERIC: article-name ( topic -- string )
GENERIC: article-content ( topic -- content ) GENERIC: article-content ( topic -- content )
GENERIC: article-parent ( topic -- parent ) GENERIC: article-parent ( topic -- parent/f )
GENERIC: set-article-parent ( parent topic -- ) GENERIC: set-article-parent ( parent topic -- )
M: object article-name article-title ; M: object article-name article-title ;

0
basis/io/backend/unix/unix.factor Executable file → Normal file
View File

0
basis/io/backend/windows/windows.factor Executable file → Normal file
View File

View File

@ -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." } ; "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 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." } { $description "Creates all parent directories of the path which do not yet exist." }
{ $errors "Throws an error if the directories could not be created." } ; { $errors "Throws an error if the directories could not be created." } ;

0
basis/io/files/info/windows/windows.factor Executable file → Normal file
View File

16
basis/io/files/windows/windows.factor Executable file → Normal file
View File

@ -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 io.timeouts kernel libc literals locals math math.bitwise namespaces
sequences specialized-arrays system threads tr vectors windows sequences specialized-arrays system threads tr vectors windows
windows.errors windows.handles windows.kernel32 windows.shell32 windows.errors windows.handles windows.kernel32 windows.shell32
windows.time windows.types windows.winsock ; windows.time windows.types windows.winsock splitting ;
SPECIALIZED-ARRAY: ushort SPECIALIZED-ARRAY: ushort
IN: io.files.windows IN: io.files.windows
@ -326,11 +326,14 @@ M: windows root-directory? ( path -- ? )
[ drop f ] [ drop f ]
} cond ; } cond ;
: prepend-prefix ( string -- string' ) : prepend-unicode-prefix ( string -- string' )
dup unicode-prefix head? [ dup unicode-prefix head? [
unicode-prefix prepend unicode-prefix prepend
] unless ; ] unless ;
: remove-unicode-prefix ( string -- string' )
unicode-prefix ?head drop ;
TR: normalize-separators "/" "\\" ; TR: normalize-separators "/" "\\" ;
<PRIVATE <PRIVATE
@ -340,13 +343,20 @@ TR: normalize-separators "/" "\\" ;
PRIVATE> PRIVATE>
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' ) M: windows normalize-path ( string -- string' )
dup unc-path? [ dup unc-path? [
normalize-separators normalize-separators
] [ ] [
absolute-path absolute-path
normalize-separators normalize-separators
prepend-prefix prepend-unicode-prefix
] if ; ] if ;
<PRIVATE <PRIVATE

3
basis/io/launcher/launcher.factor Executable file → Normal file
View File

@ -236,6 +236,9 @@ PRIVATE>
: with-process-reader ( desc encoding quot -- ) : with-process-reader ( desc encoding quot -- )
with-process-reader* check-success ; inline with-process-reader* check-success ; inline
: process-lines ( desc -- lines )
utf8 <process-reader> stream-lines ;
<PRIVATE <PRIVATE
: (process-writer) ( desc encoding -- stream process ) : (process-writer) ( desc encoding -- stream process )

View File

@ -144,7 +144,7 @@ SYMBOLS: out-path err-path ;
console-vm-path "-script" "stderr.factor" 3array >>command console-vm-path "-script" "stderr.factor" 3array >>command
[ "err2" ".txt" unique-file ] with-temp-directory [ "err2" ".txt" unique-file ] with-temp-directory
[ err-path set-global ] keep >>stderr [ err-path set-global ] keep >>stderr
utf8 <process-reader> stream-lines first process-lines first
] with-directory ] with-directory
] unit-test ] unit-test

0
basis/io/launcher/windows/windows.factor Executable file → Normal file
View File

0
basis/io/monitors/linux/linux.factor Executable file → Normal file
View File

0
basis/io/monitors/recursive/recursive.factor Executable file → Normal file
View File

0
basis/io/servers/servers.factor Executable file → Normal file
View File

0
basis/io/sockets/windows/windows.factor Executable file → Normal file
View File

View File

@ -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." } ; { $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 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." } ; { $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 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." } ; { $description "Return an infinite lazy list of incrementing integers starting from n." } ;
HELP: sequence-tail>list HELP: sequence-tail>list

0
basis/math/floats/env/env-tests.factor vendored Executable file → Normal file
View File

0
basis/math/floats/env/x86/x86-tests.factor vendored Executable file → Normal file
View File

View File

@ -383,3 +383,12 @@ CONSTANT: test-points {
{ t } [ { { 1 2 } { 3 4 } } square-matrix? ] unit-test { t } [ { { 1 2 } { 3 4 } } square-matrix? ] unit-test
{ f } [ { { 1 } { 2 3 } } square-matrix? ] unit-test { f } [ { { 1 } { 2 3 } } square-matrix? ] unit-test
{ f } [ { { 1 2 } } 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

View File

@ -141,6 +141,9 @@ IN: math.matrices
: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; : mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ; : 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 ) : cross ( vec1 vec2 -- vec3 )
[ [ { 1 2 0 } vshuffle ] [ { 2 0 1 } vshuffle ] bi* v* ] [ [ { 1 2 0 } vshuffle ] [ { 2 0 1 } vshuffle ] bi* v* ]

View File

@ -304,7 +304,7 @@ HELP: vmin
{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ; { $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ;
HELP: vclamp 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." } { $description "Creates a sequence where each element is clamped to the minimum and maximum elements of the " { $snippet "min" } " and " { $snippet "max" } " sequences." }
{ $examples { $examples
{ $example { $example

View File

@ -6,6 +6,7 @@ HELP: (gl-program)
{ $values { $values
{ "shaders" sequence } { "shaders" sequence }
{ "quot" quotation } { "quot" quotation }
{ "program" "a new " { $link gl-program } }
} { $description } { $description
"Creates a gl program and attaches the shaders to it. Then applies the quotation to the program and finally links it." "Creates a gl program and attaches the shaders to it. Then applies the quotation to the program and finally links it."
} }

0
basis/random/windows/windows.factor Executable file → Normal file
View File

View File

@ -7,7 +7,7 @@ IN: suffix-arrays
HELP: >suffix-array HELP: >suffix-array
{ $values { $values
{ "seq" sequence } { "seq" sequence }
{ "array" array } } { "suffix-array" array } }
{ $description "Creates a suffix array from the input sequence. Suffix arrays are arrays of slices." } ; { $description "Creates a suffix array from the input sequence. Suffix arrays are arrays of slices." } ;
HELP: \SA{ HELP: \SA{

View File

@ -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 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 cpu-mhz parse-proc-cpuinfo first cpu-mhz>> 1,000,000 * ;
M: linux physical-mem parse-proc-meminfo mem-total>> ; M: linux physical-mem parse-proc-meminfo mem-total>> ;
M: linux computer-name nodename ;

View File

@ -1,12 +1,10 @@
! Copyright (C) 2008 Doug Coleman, John Benediktsson. ! Copyright (C) 2008 Doug Coleman, John Benediktsson.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data alien.strings alien.syntax
USING: alien alien.c-types alien.data alien.strings alien.syntax arrays assocs byte-arrays core-foundation io.binary
arrays assocs byte-arrays combinators core-foundation io.binary io.encodings.utf8 kernel libc sequences specialized-arrays
io.encodings.utf8 libc kernel math namespaces sequences splitting system system-info ;
specialized-arrays system system-info unix ;
SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: int
IN: system-info.macosx IN: system-info.macosx
<PRIVATE <PRIVATE
@ -102,3 +100,5 @@ M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ; : tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ; M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ;
: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ; : available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
M: macosx computer-name { 1 10 } sysctl-query-string "." split1 drop ;

View File

@ -16,6 +16,7 @@ HOOK: available-page-file os ( -- n )
HOOK: total-virtual-mem os ( -- n ) HOOK: total-virtual-mem os ( -- n )
HOOK: available-virtual-mem os ( -- n ) HOOK: available-virtual-mem os ( -- n )
HOOK: available-virtual-extended-mem os ( -- n ) HOOK: available-virtual-extended-mem os ( -- n )
HOOK: computer-name os ( -- string )
: write-unit ( x n str -- ) : write-unit ( x n str -- )
[ 2^ /f number>string write bl ] [ write ] bi* ; [ 2^ /f number>string write bl ] [ write ] bi* ;

View File

@ -96,7 +96,7 @@ M: windows total-virtual-mem ( -- n )
M: windows available-virtual-mem ( -- n ) M: windows available-virtual-mem ( -- n )
memory-status ullAvailVirtual>> ; memory-status ullAvailVirtual>> ;
: computer-name ( -- string ) M: windows computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1 + MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep uint <ref> [ <byte-array> dup ] keep uint <ref>
GetComputerName win32-error=0/f alien>native-string ; GetComputerName win32-error=0/f alien>native-string ;

0
basis/tools/deploy/deploy-docs.factor Executable file → Normal file
View File

0
basis/tools/deploy/shaker/shaker.factor Executable file → Normal file
View File

0
basis/tools/deploy/windows/ico/ico.factor Executable file → Normal file
View File

0
basis/tools/deploy/windows/windows.factor Executable file → Normal file
View File

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -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

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -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

View File

@ -316,6 +316,8 @@ M: test-failure error. ( error -- )
: test-main ( -- ) : test-main ( -- )
command-line get [ [ load ] [ test ] bi ] each 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 MAIN: test-main

View File

@ -12,14 +12,14 @@ HELP: icon-data
HELP: key-sym HELP: key-sym
{ $values { $values
{ "event" GdkEventKey } { "keyval" GdkEventKey }
{ "sym/f" { $maybe string } } { "string/f" { $maybe string } }
{ "action?" boolean } { "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 } "." } ; } { $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 HELP: on-configure
{ $values { $values
{ "win" alien } { "window" alien }
{ "event" alien } { "event" alien }
{ "user-data" alien } { "user-data" alien }
{ "?" boolean } { "?" boolean }

2
basis/ui/backend/windows/windows.factor Executable file → Normal file
View File

@ -578,7 +578,7 @@ M: windows-ui-backend do-events
0 >>cbWndExtra 0 >>cbWndExtra
f GetModuleHandle >>hInstance f GetModuleHandle >>hInstance
f GetModuleHandle "APPICON" native-string>alien LoadIcon >>hIcon f GetModuleHandle "APPICON" native-string>alien LoadIcon >>hIcon
f IDC_ARROW LoadCursor >>hCursor f IDC_ARROW MAKEINTRESOURCE LoadCursor >>hCursor
class-name-ptr >>lpszClassName class-name-ptr >>lpszClassName
RegisterClassEx win32-error=0/f RegisterClassEx win32-error=0/f

View File

@ -193,6 +193,6 @@ completion-popup H{
[ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ; [ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ;
M: completion-popup handle-gesture ( gesture completion -- ? ) M: completion-popup handle-gesture ( gesture completion -- ? )
2dup completion-gesture dup [ 2dup completion-gesture [
[ nip hide-glass ] [ invoke-command ] 2bi* f [ nip hide-glass ] [ invoke-command ] 2bi* f
] [ 2drop call-next-method ] if ; ] [ drop call-next-method ] if* ;

View File

@ -46,6 +46,8 @@ M: interactor manifest>>
GENERIC: (word-at-caret) ( token completion-mode -- obj ) GENERIC: (word-at-caret) ( token completion-mode -- obj )
M: object (word-at-caret) 2drop f ;
M: vocab-completion (word-at-caret) M: vocab-completion (word-at-caret)
drop drop
[ dup vocab-exists? [ >vocab-link ] [ drop f ] if ] [ 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) M: vocab-word-completion (word-at-caret)
vocab-name>> lookup-word ; 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 ) : word-at-caret ( token interactor -- obj )
completion-mode (word-at-caret) ; completion-mode (word-at-caret) ;

View File

@ -39,7 +39,7 @@ ARTICLE: "vocabs.metadata" "Vocabulary metadata"
ABOUT: "vocabs.metadata" ABOUT: "vocabs.metadata"
HELP: vocab-file-lines 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." } ; { $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 HELP: set-vocab-file-lines

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -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: <UNIX
"UNIX>" parse-multiline-string
os unix? [ ".unix" parse-platform-section ] [ drop ] if ;
SYNTAX: <MACOSX
"MACOSX>" parse-multiline-string
os macosx? [ ".macosx" parse-platform-section ] [ drop ] if ;
SYNTAX: <LINUX
"LINUX>" parse-multiline-string
os linux? [ ".linux" parse-platform-section ] [ drop ] if ;
SYNTAX: <WINDOWS
"WINDOWS>" parse-multiline-string
os windows? [ ".windows" parse-platform-section ] [ drop ] if ;

9
basis/windows/advapi32/advapi32.factor Executable file → Normal file
View File

@ -1317,7 +1317,14 @@ FUNCTION: LONG RegDeleteKeyExW (
ALIAS: RegDeleteKeyEx RegDeleteKeyExW ALIAS: RegDeleteKeyEx RegDeleteKeyExW
! : RegDeleteValueA ; ! : RegDeleteValueA ;
! : RegDeleteValueW ;
FUNCTION: LONG RegDeleteValueW (
HKEY hKey,
LPCWSTR lpValueName
)
ALIAS: RegDeleteValue RegDeleteValueW
! : RegDisablePredefinedCache ; ! : RegDisablePredefinedCache ;
! : RegEnumKeyA ; ! : RegEnumKeyA ;
! : RegEnumKeyExA ; ! : RegEnumKeyExA ;

0
basis/windows/com/syntax/syntax.factor Executable file → Normal file
View File

0
basis/windows/ddk/hid/hid.factor Executable file → Normal file
View File

0
basis/windows/ddk/setupapi/setupapi.factor Executable file → Normal file
View File

0
basis/windows/ddk/winusb/winusb.factor Executable file → Normal file
View File

View File

0
basis/windows/directx/dwrite/dwrite.factor Executable file → Normal file
View File

0
basis/windows/directx/dxfile/dxfile.factor Executable file → Normal file
View File

0
basis/windows/directx/xinput/xinput.factor Executable file → Normal file
View File

0
basis/windows/dwmapi/dwmapi.factor Executable file → Normal file
View File

0
basis/windows/errors/errors.factor Executable file → Normal file
View File

View File

@ -1 +1,2 @@
Doug Coleman Doug Coleman
Alexander Ilin

View File

@ -1,7 +1,27 @@
! Copyright (C) 2010 Doug Coleman. ! Copyright (C) 2010 Doug Coleman.
! Copyright (C) 2018 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: windows.registry.tests
[ ] [ ]
[ HKEY_CURRENT_USER "SOFTWARE\\\\Microsoft" read-registry drop ] unit-test [ 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 <byte-array> 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

View File

@ -1,9 +1,11 @@
! Copyright (C) 2010 Doug Coleman. ! Copyright (C) 2010 Doug Coleman.
! Copyright (C) 2018 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types byte-arrays kernel locals sequences USING: accessors alien.c-types alien.data byte-arrays
windows.advapi32 windows.errors math windows classes.struct continuations io.encodings.string
windows.kernel32 windows.time accessors alien.data io.encodings.utf16n kernel literals locals math sequences sets
windows.types classes.struct continuations ; splitting windows windows.advapi32 windows.errors
windows.kernel32 windows.time windows.types ;
IN: windows.registry IN: windows.registry
ERROR: open-key-failed key subkey mode error-string ; 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' ) : grow-buffer ( byte-array -- byte-array' )
length 2 * <byte-array> ; length 2 * <byte-array> ;
:: 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 <ref> :> pdword buffer length uint <ref> :> pdword
key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep key value-name ptr1 lpType buffer pdword [ RegQueryValueEx ] 2keep
rot :> ret rot :> ret
ret ERROR_SUCCESS = [ ret ERROR_SUCCESS = [
uint deref head uint deref head
] [ ] [
ret ERROR_MORE_DATA = [ ret ERROR_MORE_DATA = [
2drop 2drop
key subkey ptr1 ptr2 buffer key value-name ptr1 lpType buffer
grow-buffer reg-query-value-ex grow-buffer reg-query-value-ex
] [ ] [
ret n>win32-error-string throw ret n>win32-error-string throw
] if ] if
] if ; ] if ;
: delete-value ( key value-name -- )
RegDeleteValue dup ERROR_SUCCESS = [
drop
] [
n>win32-error-string throw
] if ;
TUPLE: registry-info TUPLE: registry-info
key key
class-name class-name
@ -184,11 +195,30 @@ TUPLE: registry-enum-key ;
: set-reg-sz ( hkey value lpdata cbdata -- ) : set-reg-sz ( hkey value lpdata cbdata -- )
[ REG_SZ ] 2dip set-reg-key ; [ REG_SZ ] 2dip set-reg-key ;
PRIVATE>
: windows-performance-data ( -- byte-array ) : windows-performance-data ( -- byte-array )
HKEY_PERFORMANCE_DATA "Global" f f HKEY_PERFORMANCE_DATA "Global" f f
21 2^ <byte-array> reg-query-value-ex ; 21 2^ <byte-array> reg-query-value-ex ;
: read-registry ( key subkey -- registry-info ) : read-registry ( key subkey -- registry-info )
KEY_READ [ reg-query-info-key ] with-open-registry-key ; KEY_READ [ reg-query-info-key ] with-open-registry-key ;
:: change-registry-value ( key subkey value-name quot: ( value -- value' ) -- )
0 DWORD <ref> :> type
key subkey KEY_QUERY_VALUE KEY_SET_VALUE bitor [
dup :> hkey value-name f type MAX_PATH <byte-array>
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 ;

0
basis/windows/uniscribe/uniscribe.factor Executable file → Normal file
View File

View File

@ -1813,16 +1813,14 @@ FUNCTION: HACCEL LoadAcceleratorsW ( HINSTANCE hInstance, LPCTSTR lpTableName )
! FUNCTION: LoadCursorFromFileW ! FUNCTION: LoadCursorFromFileW
! FUNCTION: HCURSOR LoadCursorW ( HINSTANCE hInstance, LPCWSTR lpCursorName ) FUNCTION: HCURSOR LoadCursorW ( HINSTANCE hInstance, LPCWSTR lpCursorName )
FUNCTION: HCURSOR LoadCursorW ( HINSTANCE hInstance, ushort lpCursorName )
ALIAS: LoadCursor LoadCursorW ALIAS: LoadCursor LoadCursorW
! FUNCTION: HICON LoadIconA ( HINSTANCE hInstance, LPCTSTR lpIconName ) FUNCTION: HICON LoadIconW ( HINSTANCE hInstance, LPCWSTR lpIconName )
FUNCTION: HICON LoadIconW ( HINSTANCE hInstance, LPCTSTR lpIconName )
ALIAS: LoadIcon LoadIconW ALIAS: LoadIcon LoadIconW
! FUNCTION: LoadImageA ! 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 ALIAS: LoadImage LoadImageW
! FUNCTION: LoadKeyboardLayoutA ! FUNCTION: LoadKeyboardLayoutA
! FUNCTION: LoadKeyboardLayoutEx ! FUNCTION: LoadKeyboardLayoutEx

View File

@ -14,7 +14,7 @@ ARTICLE: "wrap.words" "Word object wrapping"
} ; } ;
HELP: wrap-words 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." } ; { $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 HELP: wrapping-word

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg ! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: wrap
ABOUT: "wrap" ABOUT: "wrap"
@ -19,5 +19,5 @@ HELP: element
} ; } ;
HELP: wrap 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." } ; { $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." } ;

View File

@ -132,23 +132,6 @@ semver_into() {
fi 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_ok() {
CLANG_VERSION=`clang --version | head -n1` CLANG_VERSION=`clang --version | head -n1`
CLANG_VERSION_RE='^[a-zA-Z0-9 ]* version (.*)$' # 3.3-5 CLANG_VERSION_RE='^[a-zA-Z0-9 ]* version (.*)$' # 3.3-5
@ -177,7 +160,7 @@ set_cc() {
fi fi
test_programs_installed gcc g++ test_programs_installed gcc g++
if [[ $? -ne 0 ]] && gcc_version_ok ; then if [[ $? -ne 0 ]] ; then
[ -z "$CC" ] && CC=gcc [ -z "$CC" ] && CC=gcc
[ -z "$CXX" ] && CXX=g++ [ -z "$CXX" ] && CXX=g++
return return
@ -593,10 +576,10 @@ set_boot_image_vars() {
} }
set_current_branch() { set_current_branch() {
if [ -z ${TRAVIS_BRANCH} ]; then if [ -n "${CI_BRANCH}" ]; then
CURRENT_BRANCH=$(current_git_branch) CURRENT_BRANCH="${CI_BRANCH}"
else else
CURRENT_BRANCH=${TRAVIS_BRANCH} CURRENT_BRANCH=$(current_git_branch)
fi fi
} }

View File

@ -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." } ; { $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 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." } { $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" } "." } { $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." } ; { $errors "Throws an " { $link callsite-not-compiled } " if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler." } ;

0
core/alien/alien.factor Executable file → Normal file
View File

View File

@ -72,7 +72,7 @@ HELP: library
} ; } ;
HELP: library-dll 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 } "." } ; { $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 HELP: remove-library

Some files were not shown because too many files have changed in this diff Show More