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:
- 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'"

View File

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

View File

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

View File

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

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." } ;
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." ;

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.
! 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 ;

View File

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

View File

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

View File

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

View File

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

View File

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

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?
] unit-test
cell-bits 32 = [
32bit? [
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?

View File

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

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
{ $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 } "." } } ;

View File

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

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
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 -- ? )

View File

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

View File

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

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." } ;
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." } ;

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
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 "/" "\\" ;
<PRIVATE
@ -340,13 +343,20 @@ TR: normalize-separators "/" "\\" ;
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' )
dup unc-path? [
normalize-separators
] [
absolute-path
normalize-separators
prepend-prefix
prepend-unicode-prefix
] if ;
<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* check-success ; inline
: process-lines ( desc -- lines )
utf8 <process-reader> stream-lines ;
<PRIVATE
: (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
[ "err2" ".txt" unique-file ] with-temp-directory
[ err-path set-global ] keep >>stderr
utf8 <process-reader> stream-lines first
process-lines first
] with-directory
] 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." } ;
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

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

View File

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

View File

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

View File

@ -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."
}

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

View File

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

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

View File

@ -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
<PRIVATE
@ -102,3 +100,5 @@ M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ;
: 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: available-virtual-mem os ( -- n )
HOOK: available-virtual-extended-mem os ( -- n )
HOOK: computer-name os ( -- string )
: write-unit ( x n str -- )
[ 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 )
memory-status ullAvailVirtual>> ;
: computer-name ( -- string )
M: windows computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep uint <ref>
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 ( -- )
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

View File

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

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

View File

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

View File

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

View File

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

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
! : RegDeleteValueA ;
! : RegDeleteValueW ;
FUNCTION: LONG RegDeleteValueW (
HKEY hKey,
LPCWSTR lpValueName
)
ALIAS: RegDeleteValue RegDeleteValueW
! : RegDisablePredefinedCache ;
! : RegEnumKeyA ;
! : 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
Alexander Ilin

View File

@ -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 <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) 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 * <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
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^ <byte-array> 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 <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: 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

View File

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

View File

@ -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." } ;

View File

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

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." } ;
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." } ;

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

View File

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

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