steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into modern-harvey2

modern-harvey2
Doug Coleman 2018-03-15 11:48:24 -05:00
parent e7cd3e3635 653af68a8e
commit ddfe23ccca
23 changed files with 333 additions and 181 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
basis/cocoa/cocoa.factor
View File

@ -1,20 +1,22 @@
! 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: cocoa.messages compiler.units core-foundation.bundles USING: assocs cocoa.messages compiler.units core-foundation.bundles
hashtables init io kernel lexer namespaces sequences vocabs ; hashtables init io kernel lexer namespaces sequences vocabs ;
IN: cocoa IN: cocoa
SYMBOL: sent-messages SYMBOL: sent-messages
: (remember-send) ( selector variable -- ) sent-messages [ H{ } clone ] initialize
[ dupd ?set-at ] change-global ;
: remember-send ( selector -- ) : remember-send ( selector -- )
sent-messages (remember-send) ; dup sent-messages get set-at ;
SYNTAX: \send: scan-token unescape-token dup remember-send suffix! \ send suffix! ; SYNTAX: \send: scan-token unescape-token dup remember-send suffix! \ send suffix! ;
SYNTAX: \?send: scan-token unescape-token dup remember-send suffix! \ ?send suffix! ; SYNTAX: \?send:
dup last cache-stubs
scan-token unescape-token dup remember-send
suffix! \ ?send suffix! ;
SYNTAX: \selector: SYNTAX: \selector:
scan-token unescape-token scan-token unescape-token
@ -23,11 +25,14 @@ SYNTAX: \selector:
SYMBOL: super-sent-messages SYMBOL: super-sent-messages
super-sent-messages [ H{ } clone ] initialize
: remember-super-send ( selector -- ) : remember-super-send ( selector -- )
super-sent-messages (remember-send) ; dup super-sent-messages get set-at ;
SYNTAX: \super: scan-token unescape-token dup remember-super-send suffix! \ super-send suffix! ;
SYNTAX: \super:
scan-token unescape-token dup remember-super-send
suffix! \ super-send suffix! ;
SYMBOL: frameworks SYMBOL: frameworks
frameworks [ V{ } clone ] initialize frameworks [ V{ } clone ] initialize

72
basis/cocoa/messages/messages.factor
View File

@ -4,8 +4,8 @@ USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs classes.struct cocoa.runtime cocoa.types arrays assocs classes.struct cocoa.runtime cocoa.types
combinators core-graphics.types fry generalizations combinators core-graphics.types fry generalizations
io.encodings.utf8 kernel layouts libc locals macros make math io.encodings.utf8 kernel layouts libc locals macros make math
memoize namespaces quotations sequences specialized-arrays memoize namespaces quotations sequences sets specialized-arrays
stack-checker strings words ; splitting stack-checker strings words ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages IN: cocoa.messages
@ -44,7 +44,11 @@ super-message-senders [ H{ } clone ] initialize
TUPLE: selector-tuple name object ; TUPLE: selector-tuple name object ;
MEMO: <selector> ( name -- sel ) f \ selector-tuple boa ; : selector-name ( name -- name' )
CHAR: . over index [ 0 > [ "." split1 nip ] when ] when* ;
MEMO: <selector> ( name -- sel )
selector-name f selector-tuple boa ;
: selector ( selector -- alien ) : selector ( selector -- alien )
dup object>> expired? [ dup object>> expired? [
@ -63,38 +67,24 @@ objc-methods [ H{ } clone ] initialize
ERROR: no-objc-method name ; ERROR: no-objc-method name ;
: ?lookup-method ( selector -- method/f ) : ?lookup-method ( selector -- signature/f )
objc-methods get at ; objc-methods get at ;
: lookup-method ( selector -- method ) : lookup-method ( selector -- signature )
dup ?lookup-method [ ] [ no-objc-method ] ?if ; dup ?lookup-method [ ] [ no-objc-method ] ?if ;
: lookup-sender ( name -- method ) MEMO: make-prepare-send ( selector signature super? -- quot )
lookup-method message-senders get at ;
MEMO: make-prepare-send ( selector method super? -- quot )
[ [
[ \ <super> , ] when swap <selector> , \ selector , [ \ <super> , ] when swap <selector> , \ selector ,
] [ ] make ] [ ] make swap second length 2 - '[ _ _ ndip ] ;
swap second length 2 - '[ _ _ ndip ] ;
MACRO: (send) ( selector super? -- quot ) MACRO: (send) ( signature selector super? -- quot )
[ dup lookup-method ] dip swapd [ make-prepare-send ] 2keep
[ make-prepare-send ] 2keep super-message-senders message-senders ? get at suffix ;
super-message-senders message-senders ? get at
1quotation append ;
: send ( receiver args... selector -- return... ) f (send) ; inline : send ( receiver args... signature selector -- return... ) f (send) ; inline
MACRO:: (?send) ( effect selector super? -- quot ) : super-send ( receiver args... signature selector -- return... ) t (send) ; inline
selector dup ?lookup-method effect or super?
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
[ 1quotation append ] [ effect selector sender-stub 1quotation append ] if* ;
: ?send ( receiver args... selector effect -- return... ) f (?send) ; inline
: super-send ( receiver args... selector -- return... ) t (send) ; inline
! Runtime introspection ! Runtime introspection
SYMBOL: class-init-hooks SYMBOL: class-init-hooks
@ -231,19 +221,33 @@ ERROR: no-objc-type name ;
[ utf8 alien>string parse-objc-type ] keep [ utf8 alien>string parse-objc-type ] keep
(free) ; (free) ;
: method-signature ( method -- signature )
[ method-return-type ] [ method-arg-types ] bi 2array ;
: method-name ( method -- name ) : method-name ( method -- name )
method_getName sel_getName ; method_getName sel_getName ;
: register-objc-method ( method -- ) :: register-objc-method ( classname method -- )
[ method-name ] method method-signature :> signature
[ [ method-return-type ] [ method-arg-types ] bi 2array ] bi method method-name :> name
[ nip cache-stubs ] [ swap objc-methods get set-at ] 2bi ; classname "." name 3append :> fullname
signature cache-stubs
signature name objc-methods get set-at
signature fullname objc-methods get set-at ;
: each-method-in-class ( class quot -- ) : method-collisions ( -- collisions )
[ { uint } [ class_copyMethodList ] with-out-parameters ] dip objc-methods get >alist
over 0 = [ 3drop ] [ [ first CHAR: . swap member? ] filter
[ first "." split1 nip ] collect-by
[ nip values members length 1 > ] assoc-filter ;
: each-method-in-class ( class quot: ( classname method -- ) -- )
[
[ class_getName ] keep
{ uint } [ class_copyMethodList ] with-out-parameters
] dip over 0 = [ 4drop ] [
[ void* <c-direct-array> ] dip [ void* <c-direct-array> ] dip
[ each ] [ drop (free) ] 2bi [ with each ] [ drop (free) ] 2bi
] if ; inline ] if ; inline
: register-objc-methods ( class -- ) : register-objc-methods ( class -- )

2
basis/editors/visual-studio-code/visual-studio-code.factor
View File

@ -33,7 +33,7 @@ M: linux find-visual-studio-code-invocation
{ {
[ "code" which ] [ "code" which ]
[ "Code" which ] [ "Code" which ]
[ "~/VSCode-linux-x64/Code" ] [ home "VSCode-linux-x64/Code" append-path ]
[ "/usr/share/code/code" ] [ "/usr/share/code/code" ]
} [ [ exists? ] ?1arg ] map-compose 0|| ; } [ [ exists? ] ?1arg ] map-compose 0|| ;

6
basis/tools/cocoa/cocoa.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays cocoa.messages cocoa.runtime combinators USING: cocoa.messages cocoa.runtime combinators
prettyprint combinators.smart ; combinators.smart kernel prettyprint ;
IN: tools.cocoa IN: tools.cocoa
: method. ( method -- ) : method. ( method -- )
@ -15,4 +15,4 @@ IN: tools.cocoa
] output>array . ; ] output>array . ;
: methods. ( class -- ) : methods. ( class -- )
[ method. ] each-method-in-class ; [ nip method. ] each-method-in-class ;

16
basis/tools/hexdump/deploy.factor Normal file
View File

@ -0,0 +1,16 @@
USING: tools.deploy.config ;
H{
{ deploy-c-types? f }
{ deploy-help? f }
{ deploy-name "hexdump" }
{ "stop-after-last-window?" t }
{ deploy-unicode? f }
{ deploy-console? t }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-ui? f }
{ deploy-word-defs? f }
{ deploy-threads? t }
{ deploy-math? t }
{ deploy-word-props? f }
}

37
basis/tools/hexdump/hexdump-tests.factor
View File

@ -1,10 +1,39 @@
USING: tools.hexdump kernel sequences tools.test byte-arrays ; USING: tools.hexdump kernel sequences tools.test byte-arrays ;
{ t } [ B{ } hexdump "Length: 0, 0h\n" = ] unit-test { "00000000\n" } [ B{ } hexdump ] unit-test
{ t } [ "abcdefghijklmnopqrstuvwxyz" >byte-array hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
{ t } [ 256 <iota> [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test {
"00000000 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop
00000010 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz
0000001a
" } [
"abcdefghijklmnopqrstuvwxyz" >byte-array hexdump
] unit-test
{
"00000000 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................
00000010 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................
00000020 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./
00000030 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?
00000040 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO
00000050 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_
00000060 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno
00000070 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.
00000080 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................
00000090 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................
000000a0 a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................
000000b0 b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................
000000c0 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................
000000d0 d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................
000000e0 e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................
000000f0 f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................
00000100
" } [
256 <iota> [ ] B{ } map-as hexdump
] unit-test
{ {
"Length: 3, 3h\n00000000h: 01 02 03 ...\n" } [ B{ 1 2 3 } hexdump ] unit-test "00000000 01 02 03 ...
00000003
" } [ B{ 1 2 3 } hexdump ] unit-test

92
basis/tools/hexdump/hexdump.factor
View File

@ -1,52 +1,94 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii byte-arrays byte-vectors command-line
grouping io io.encodings.binary io.files io.streams.string USING: accessors ascii byte-arrays byte-vectors combinators
kernel math math.parser namespaces sequences splitting strings ; command-line destructors fry io io.encodings io.encodings.binary
io.files io.streams.string kernel literals locals math
math.parser namespaces sequences sequences.private strings typed ;
IN: tools.hexdump IN: tools.hexdump
<PRIVATE <PRIVATE
: write-header ( len -- ) CONSTANT: line# "00000000 "
"Length: " write
[ number>string write ", " write ]
[ >hex write "h" write nl ] bi ;
: write-offset ( lineno -- ) : inc-line# ( -- )
16 * >hex 8 char: 0 pad-head write "h: " write ; 7 [ char: 0 = over 0 > and ] [
1 - dup line# [
{
{ char: 9 [ char: a ] }
{ char: f [ char: 0 ] }
[ 1 + ]
} case dup
] change-nth-unsafe
] do while drop ;
: >hex-digit ( digit -- str ) : reset-line# ( -- )
>hex 2 char: 0 pad-head ; 8 [ char: 0 swap line# set-nth ] each-integer ;
: >hex-digits ( bytes -- str ) CONSTANT: hex-digits $[
[ >hex-digit " " append ] { } map-as concat 256 <iota> [ >hex 2 char: 0 pad-head " " append ] map
48 char: \s pad-tail ; ]
: >ascii ( bytes -- str ) : all-bytes ( bytes -- from to bytes )
[ [ printable? ] keep char: . ? ] "" map-as ; [ 0 swap length ] keep ; inline
: write-hex-line ( bytes lineno -- ) : each-byte ( from to bytes quot: ( elt -- ) -- )
write-offset [ >hex-digits write ] [ >ascii write ] bi nl ; '[ _ nth-unsafe @ ] (each-integer) ; inline
: hexdump-bytes ( bytes -- ) : write-bytes ( from to bytes stream -- )
[ length write-header ] '[ hex-digits nth-unsafe _ stream-write ] each-byte ; inline
[ 16 <groups> [ write-hex-line ] each-index ] bi ;
: write-space ( from to bytes stream -- )
[ drop - 16 + ] dip '[
3 * char: \s <string> _ stream-write
] unless-zero ; inline
: write-ascii ( from to bytes stream -- )
dup stream-bl '[
[ printable? ] keep char: . ? _ stream-write1
] each-byte ; inline
TYPED: write-hex-line ( from: fixnum to: fixnum bytes: byte-array -- )
line# write inc-line# output-stream get {
[ write-bytes ]
[ write-space ]
[ write-ascii ]
} 4cleave nl ;
:: hexdump-bytes ( from to bytes -- )
reset-line#
to from - :> len
len 16 /mod
[ [ 16 * dup 16 + bytes write-hex-line ] each-integer ]
[ [ len swap - len bytes write-hex-line ] unless-zero ] bi*
len >hex 8 char: 0 pad-head print ;
: hexdump-stream ( stream -- )
reset-line# 0 swap [
all-bytes [ write-hex-line ] [ length + ] bi
] 16 (each-stream-block) >hex 8 char: 0 pad-head print ;
PRIVATE> PRIVATE>
GENERIC: hexdump. ( byte-array -- ) GENERIC: hexdump. ( byte-array -- )
M: byte-array hexdump. hexdump-bytes ; M: byte-array hexdump. all-bytes hexdump-bytes ;
M: byte-vector hexdump. hexdump-bytes ; M: byte-vector hexdump. all-bytes underlying>> hexdump-bytes ;
: hexdump ( byte-array -- str ) : hexdump ( byte-array -- str )
[ hexdump. ] with-string-writer ; [ hexdump. ] with-string-writer ;
: hexdump-file ( path -- ) : hexdump-file ( path -- )
binary file-contents hexdump. ; binary <file-reader> [ hexdump-stream ] with-disposal ;
: hexdump-main ( -- ) : hexdump-main ( -- )
command-line get [ hexdump-file ] each ; command-line get [
input-stream get dup decoder? [ stream>> ] when
hexdump-stream
] [
[ hexdump-file ] each
] if-empty ;
MAIN: hexdump-main MAIN: hexdump-main

15
basis/tools/scaffold/scaffold-docs.factor
View File

@ -101,16 +101,22 @@ HELP: scaffold-vocab
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file and an authors.txt file." } ; { $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file and an authors.txt file." } ;
HELP: scaffold-emacs HELP: scaffold-emacs
{ $description "Touches the " { $snippet ".emacs" } " file in your home directory and provides a clickable link to open it in an editor." } ; { $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;
HELP: scaffold-factor-boot-rc HELP: scaffold-factor-boot-rc
{ $description "Touches the " { $snippet ".factor-boot-rc" } " file in your home directory and provides a clickable link to open it in an editor." } ; { $description "Touches the .factor-boot-rc file in your home directory and provides a clickable link to open it in an editor." } ;
HELP: scaffold-factor-rc HELP: scaffold-factor-rc
{ $description "Touches the " { $snippet ".factor-rc" } " file in your home directory and provides a clickable link to open it in an editor." } ; { $description "Touches the .factor-rc file in your home directory and provides a clickable link to open it in an editor." } ;
HELP: scaffold-factor-roots HELP: scaffold-factor-roots
{ $description "Touches the " { $snippet ".factor-roots" } " file in your home directory and provides a clickable link to open it in an editor." } ; { $description "Touches the .factor-roots file in your home directory and provides a clickable link to open it in an editor." } ;
HELP: scaffold-rc
{ $values
{ "path" "a pathname string" }
}
{ $description "Touches the given path in your home directory and provides a clickable link to open it in an editor." } ;
HELP: using HELP: using
{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ; { $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
@ -131,6 +137,7 @@ ARTICLE: "tools.scaffold" "Scaffold tool"
"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead." $nl "Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead." $nl
"Scaffolding a configuration file:" "Scaffolding a configuration file:"
{ $subsections { $subsections
scaffold-rc
scaffold-factor-boot-rc scaffold-factor-boot-rc
scaffold-factor-rc scaffold-factor-rc
scaffold-factor-roots scaffold-factor-roots

31
basis/tools/scaffold/scaffold.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays assocs byte-arrays calendar USING: accessors alien arrays assocs byte-arrays calendar
classes combinators combinators.short-circuit fry hashtables classes classes.error combinators combinators.short-circuit fry
help.markup interpolate io io.directories io.encodings.utf8 hashtables help.markup interpolate io io.directories
io.files io.pathnames io.streams.string kernel math math.parser io.encodings.utf8 io.files io.pathnames io.streams.string kernel
namespaces prettyprint quotations sequences sets sorting math math.parser namespaces prettyprint quotations sequences
splitting strings system timers unicode urls vocabs sets sorting splitting strings system timers unicode urls vocabs
vocabs.loader vocabs.metadata words words.symbol ; vocabs.loader vocabs.metadata words words.symbol ;
IN: tools.scaffold IN: tools.scaffold
@ -183,6 +183,13 @@ M: object add-using ( object -- )
] if ] if
] when* ; ] when* ;
: error-description. ( word -- )
[ $values. ] [
"{ $description \"Throws " write
name>> dup a/an write " \" { $link " write
write " } \" error.\" }" print
] bi "{ $error-description \"\" } ;" print ;
: class-description. ( word -- ) : class-description. ( word -- )
drop "{ $class-description \"\" } ;" print ; drop "{ $class-description \"\" } ;" print ;
@ -194,6 +201,7 @@ M: object add-using ( object -- )
: docs-body. ( word/symbol -- ) : docs-body. ( word/symbol -- )
{ {
{ [ dup error-class? ] [ error-description. ] }
{ [ dup class? ] [ class-description. ] } { [ dup class? ] [ class-description. ] }
{ [ dup symbol? ] [ symbol-description. ] } { [ dup symbol? ] [ symbol-description. ] }
[ [ $values. ] [ $description. ] bi ] [ [ $values. ] [ $description. ] bi ]
@ -352,18 +360,21 @@ ${example-indent}}
[ touch-file ] [ touch-file ]
[ "Click to edit: " write <pathname> . ] bi ; [ "Click to edit: " write <pathname> . ] bi ;
: scaffold-rc ( path -- )
[ home ] dip append-path scaffold-file ;
: scaffold-factor-boot-rc ( -- ) : scaffold-factor-boot-rc ( -- )
"~/.factor-boot-rc" scaffold-file ; ".factor-boot-rc" scaffold-rc ;
: scaffold-factor-rc ( -- ) : scaffold-factor-rc ( -- )
"~/.factor-rc" scaffold-file ; ".factor-rc" scaffold-rc ;
: scaffold-mason-rc ( -- ) : scaffold-mason-rc ( -- )
"~/.factor-mason-rc" scaffold-file ; ".factor-mason-rc" scaffold-rc ;
: scaffold-factor-roots ( -- ) : scaffold-factor-roots ( -- )
"~/.factor-roots" scaffold-file ; ".factor-roots" scaffold-rc ;
HOOK: scaffold-emacs os ( -- ) HOOK: scaffold-emacs os ( -- )
M: unix scaffold-emacs ( -- ) "~/.emacs" scaffold-file ; M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ;

10
basis/ui/backend/cocoa/views/views.factor
View File

@ -189,11 +189,9 @@ M: send-touchbar-command send-queued-gesture
self selector: \setWantsBestResolutionOpenGLSurface: self selector: \setWantsBestResolutionOpenGLSurface:
send: \respondsToSelector: c-bool> [ send: \respondsToSelector: c-bool> [
self selector: \setWantsBestResolutionOpenGLSurface: 1 self 1 { void { id SEL char } } ?send: setWantsBestResolutionOpenGLSurface:
void f "objc_msgSend" { id SEL char } f alien-invoke
self selector: backingScaleFactor self { double { id SEL } } ?send: backingScaleFactor
double f "objc_msgSend" { id SEL } f alien-invoke
dup 1.0 > [ dup 1.0 > [
gl-scale-factor set-global t retina? set-global gl-scale-factor set-global t retina? set-global
@ -213,13 +211,13 @@ M: send-touchbar-command send-queued-gesture
COCOA-METHOD: void touchBarCommand6 [ 6 touchbar-invoke-command ] ; COCOA-METHOD: void touchBarCommand6 [ 6 touchbar-invoke-command ] ;
COCOA-METHOD: void touchBarCommand7 [ 7 touchbar-invoke-command ] ; COCOA-METHOD: void touchBarCommand7 [ 7 touchbar-invoke-command ] ;
COCOA-METHOD: Class makeTouchBar [ COCOA-METHOD: id makeTouchBar [
touchbar-commands drop [ touchbar-commands drop [
length 8 min <iota> [ number>string ] map length 8 min <iota> [ number>string ] map
] [ { } ] if* self make-touchbar ] [ { } ] if* self make-touchbar
] ; ] ;
COCOA-METHOD: Class touchBar: Class touchbar makeItemForIdentifier: Class string [ COCOA-METHOD: id touchBar: id touchbar makeItemForIdentifier: id string [
touchbar-commands drop [ touchbar-commands drop [
[ self string CFString>string dup string>number ] dip nth [ self string CFString>string dup string>number ] dip nth
second name>> "com-" ?head drop over second name>> "com-" ?head drop over

28
basis/unicode/collation/collation.factor
View File

@ -52,12 +52,12 @@ ducet get-global insert-helpers
! Unicode TR10 - Computing Implicit Weights ! Unicode TR10 - Computing Implicit Weights
: base ( char -- base ) : base ( char -- base )
{ {
{ [ dup 0x3400 0x4DB5 between? ] [ drop 0xFB80 ] } ! Extension A { [ dup 0x03400 0x04DB5 between? ] [ drop 0xFB80 ] } ! Extension A
{ [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B { [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B
{ [ dup 0x2A700 0x2B734 between? ] [ drop 0xFB80 ] } ! Extension C { [ dup 0x2A700 0x2B734 between? ] [ drop 0xFB80 ] } ! Extension C
{ [ dup 0x2B740 0x2B81D between? ] [ drop 0xFB80 ] } ! Extension D { [ dup 0x2B740 0x2B81D between? ] [ drop 0xFB80 ] } ! Extension D
{ [ dup 0x2B820 0x2CEA1 between? ] [ drop 0xFB80 ] } ! Extension E { [ dup 0x2B820 0x2CEA1 between? ] [ drop 0xFB80 ] } ! Extension E
{ [ dup 0x4E00 0x9FD5 between? ] [ drop 0xFB40 ] } ! CJK { [ dup 0x04E00 0x09FD5 between? ] [ drop 0xFB40 ] } ! CJK
[ drop 0xFBC0 ] ! Other [ drop 0xFBC0 ] ! Other
} cond ; } cond ;
@ -73,16 +73,26 @@ ducet get-global insert-helpers
: BBBB ( char -- weight-levels ) : BBBB ( char -- weight-levels )
0x7FFF bitand 0x8000 bitor 0 0 <weight-levels> ; inline 0x7FFF bitand 0x8000 bitor 0 0 <weight-levels> ; inline
: illegal? ( char -- ? )
{
[ "Noncharacter_Code_Point" property? ]
[ category "Cs" = ]
} 1|| ;
: derive-weight ( 1string -- weight-levels-pair ) : derive-weight ( 1string -- weight-levels-pair )
first first
dup tangut-block? [ dup tangut-block? [
[ tangut-AAAA ] [ tangut-BBBB ] bi [ tangut-AAAA ] [ tangut-BBBB ] bi 2array
] [ ] [
[ AAAA ] [ BBBB ] bi first dup illegal? [
] if 2array ; drop { }
] [
[ AAAA ] [ BBBB ] bi 2array
] if
] if ;
: building-last ( -- char ) : building-last ( -- char )
building get empty? [ 0 ] [ building get last last ] if ; building get [ 0 ] [ last last ] if-empty ;
: blocked? ( char -- ? ) : blocked? ( char -- ? )
combining-class dup { 0 f } member? combining-class dup { 0 f } member?
@ -138,7 +148,11 @@ ducet get-global insert-helpers
PRIVATE> PRIVATE>
: completely-ignorable? ( weight -- ? ) : completely-ignorable? ( weight -- ? )
{ [ primary>> zero? ] [ secondary>> zero? ] [ tertiary>> zero? ] } 1&& ; {
[ primary>> zero? ]
[ secondary>> zero? ]
[ tertiary>> zero? ]
} 1&& ;
: filter-ignorable ( weights -- weights' ) : filter-ignorable ( weights -- weights' )
f swap [ f swap [

4
build.cmd
View File

@ -3,8 +3,8 @@ setlocal
: Check which branch we are on, or just assume master if we are not in a git repository : Check which branch we are on, or just assume master if we are not in a git repository
for /f %%z in ('git rev-parse --abbrev-ref HEAD') do set GIT_BRANCH=%%z for /f %%z in ('git rev-parse --abbrev-ref HEAD') do set GIT_BRANCH=%%z
if %GIT_BRANCH% =="" ( if not defined GIT_BRANCH (
GIT_BRANCH = "master" set GIT_BRANCH=master
) )
if "%1"=="/?" ( if "%1"=="/?" (

6
core/command-line/command-line-docs.factor
View File

@ -126,9 +126,9 @@ ARTICLE: "rc-files" "Running code on startup"
$nl $nl
"If you are unsure where the files should be located, evaluate the following code:" "If you are unsure where the files should be located, evaluate the following code:"
{ $code { $code
"USING: io io.pathnames ;" "USE: command-line"
"\"~/.factor-rc\" absolute-path print" "\".factor-rc\" rc-path print"
"\"~/.factor-boot-rc\" absolute-path print" "\".factor-boot-rc\" rc-path print"
} }
"Here is an example " { $snippet ".factor-boot-rc" } " which sets up your developer name:" "Here is an example " { $snippet ".factor-boot-rc" } " which sets up your developer name:"
{ $code { $code

9
core/command-line/command-line.factor
View File

@ -24,6 +24,9 @@ SYMBOL: command-line
: (command-line) ( -- args ) : (command-line) ( -- args )
OBJ-ARGS special-object sift [ alien>native-string ] map ; OBJ-ARGS special-object sift [ alien>native-string ] map ;
: rc-path ( name -- path )
home prepend-path ;
: try-user-init ( file -- ) : try-user-init ( file -- )
"user-init" get swap '[ "user-init" get swap '[
_ [ ?run-file ] [ _ [ ?run-file ] [
@ -34,14 +37,14 @@ SYMBOL: command-line
] when ; ] when ;
: run-bootstrap-init ( -- ) : run-bootstrap-init ( -- )
"~/.factor-boot-rc" try-user-init ; ".factor-boot-rc" rc-path try-user-init ;
: run-user-init ( -- ) : run-user-init ( -- )
"~/.factor-rc" try-user-init ; ".factor-rc" rc-path try-user-init ;
: load-vocab-roots ( -- ) : load-vocab-roots ( -- )
"user-init" get [ "user-init" get [
"~/.factor-roots" dup exists? [ ".factor-roots" rc-path dup exists? [
utf8 file-lines harvest [ add-vocab-root ] each utf8 file-lines harvest [ add-vocab-root ] each
] [ drop ] if ] [ drop ] if
"roots" get [ "roots" get [

2
extra/cpu/8080/emulator/emulator.factor
View File

@ -453,7 +453,7 @@ SYMBOL: rom-root
: rom-dir ( -- string ) : rom-dir ( -- string )
rom-root get [ rom-root get [
"~/roms" dup exists? [ drop f ] unless home "roms" append-path dup exists? [ drop f ] unless
] unless* ; ] unless* ;
: load-rom* ( seq cpu -- ) : load-rom* ( seq cpu -- )

95
extra/game-of-life/game-of-life.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2018 John Benediktsson ! Copyright (C) 2018 John Benediktsson
! See http://factorcode.org/license.txt for BSD license ! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays assocs bit-arrays calendar USING: accessors arrays assocs bit-arrays byte-arrays calendar
colors.constants combinators combinators.short-circuit fry colors.constants combinators fry kernel kernel.private locals
kernel kernel.private locals math math.order math.private math math.order math.ranges namespaces opengl random sequences
math.ranges namespaces opengl random sequences sequences.private sequences.private timers ui ui.commands ui.gadgets
timers ui ui.commands ui.gadgets ui.gadgets.toolbar ui.gadgets.toolbar ui.gadgets.tracks ui.gestures ui.render words
ui.gadgets.tracks ui.gestures ui.render words ; ;
IN: game-of-life IN: game-of-life
@ -16,44 +16,48 @@ IN: game-of-life
: grid-dim ( grid -- rows cols ) : grid-dim ( grid -- rows cols )
[ length ] [ first length ] bi ; [ length ] [ first length ] bi ;
:: wraparound ( x min max -- y ) : random-grid! ( grid -- )
x min fixnum< [ max ] [ x max fixnum> min x ? ] if ; inline [
[ length>> ] [ underlying>> length random-bytes ] bi
bit-array boa
] map! drop ;
:: count-neighbors ( grid -- counts ) :: count-neighbors ( grid -- counts )
grid grid-dim { fixnum fixnum } declare :> ( rows cols ) grid grid-dim { fixnum fixnum } declare :> ( rows cols )
rows <iota> [| j | rows 1 - { fixnum } declare :> max-rows
cols <iota> [| i | cols 1 - { fixnum } declare :> max-cols
{ -1 0 1 } [ rows [ cols <byte-array> ] replicate :> neighbors
{ -1 0 1 } [ grid { array } declare [| row j |
2dup [ 0 eq? ] both? [ 2drop f ] [ j 0 eq? [ max-rows ] [ j 1 - ] if
[ i fixnum+fast 0 cols 1 - wraparound ] j
[ j fixnum+fast 0 rows 1 - wraparound ] bi* j max-rows eq? [ 0 ] [ j 1 + ] if
{ fixnum fixnum } declare grid [ neighbors nth-unsafe { byte-array } declare ] tri@ :>
{ array } declare nth-unsafe ( above same below )
{ bit-array } declare nth-unsafe
] if row { bit-array } declare [| cell i |
] with count cell [
] map-sum i 0 eq? [ max-cols ] [ i 1 - ] if
] map i
] map ; i max-cols eq? [ 0 ] [ i 1 + ] if
[ [ above [ 1 + ] change-nth-unsafe ] tri@ ]
[ nip [ same [ 1 + ] change-nth-unsafe ] bi@ ]
[ [ below [ 1 + ] change-nth-unsafe ] tri@ ]
3tri
] when
] each-index
] each-index neighbors ;
:: next-step ( grid -- ) :: next-step ( grid -- )
grid count-neighbors :> neighbors grid count-neighbors { array } declare :> neighbors
grid [| row j | grid { array } declare [| row j |
row [| cell i | j neighbors nth-unsafe { byte-array } declare :> neighbor-row
i j neighbors row { bit-array } declare [| cell i |
{ array } declare nth-unsafe i neighbor-row nth-unsafe
{ array } declare nth-unsafe
cell [ cell [
2 3 between? i j grid 2 3 between? i row set-nth-unsafe
{ array } declare nth-unsafe
{ bit-array } declare set-nth-unsafe
] [ ] [
3 = [ 3 = [ t i row set-nth-unsafe ] when
t i j grid
{ array } declare nth-unsafe
{ bit-array } declare set-nth-unsafe
] when
] if ] if
] each-index ] each-index
] each-index ; ] each-index ;
@ -94,8 +98,8 @@ M: grid-gadget pref-dim*
:: draw-cells ( gadget -- ) :: draw-cells ( gadget -- )
COLOR: black gl-color COLOR: black gl-color
gadget size>> :> size gadget size>> :> size
gadget grid>> [| row j | gadget grid>> { array } declare [| row j |
row [| cell i | row { bit-array } declare [| cell i |
cell [ cell [
i j [ size * ] bi@ 2array i j [ size * ] bi@ 2array
{ size size } gl-fill-rect { size size } gl-fill-rect
@ -151,28 +155,21 @@ SYMBOL: last-click
] change-size relayout-1 ; ] change-size relayout-1 ;
:: com-play ( gadget -- ) :: com-play ( gadget -- )
gadget timer>> thread>> [ gadget timer>> restart-timer ;
gadget timer>> start-timer
] unless ;
:: com-step ( gadget -- ) :: com-step ( gadget -- )
gadget grid>> next-step gadget grid>> next-step
gadget relayout-1 ; gadget relayout-1 ;
:: com-stop ( gadget -- ) :: com-stop ( gadget -- )
gadget timer>> thread>> [ gadget timer>> stop-timer ;
gadget timer>> stop-timer
] when ;
:: com-clear ( gadget -- ) :: com-clear ( gadget -- )
gadget grid>> [ clear-bits ] each gadget grid>> [ clear-bits ] each
gadget relayout-1 ; gadget relayout-1 ;
:: com-random ( gadget -- ) :: com-random ( gadget -- )
gadget grid>> [ gadget grid>> random-grid! gadget relayout-1 ;
[ length>> ] [ underlying>> length random-bytes ] bi
bit-array boa
] map! drop gadget relayout-1 ;
:: com-glider ( gadget -- ) :: com-glider ( gadget -- )
gadget grid>> :> grid gadget grid>> :> grid

20
extra/help/pdf/pdf.factor
View File

@ -29,7 +29,7 @@ IN: help.pdf
[ topic>pdf ] map <pb> 1array join ; [ topic>pdf ] map <pb> 1array join ;
: write-pdf ( pdf name -- ) : write-pdf ( pdf name -- )
[ pdf>string ] dip utf8 set-file-contents ; [ pdf>string ] dip home prepend-path utf8 set-file-contents ;
PRIVATE> PRIVATE>
@ -41,19 +41,19 @@ PRIVATE>
] [ write-pdf ] bi* ; ] [ write-pdf ] bi* ;
: cookbook-pdf ( -- ) : cookbook-pdf ( -- )
"cookbook" "~/cookbook.pdf" article-pdf ; "cookbook" "cookbook.pdf" article-pdf ;
: first-program-pdf ( -- ) : first-program-pdf ( -- )
"first-program" "~/first-program.pdf" article-pdf ; "first-program" "first-program.pdf" article-pdf ;
: handbook-pdf ( -- ) : handbook-pdf ( -- )
"handbook-language-reference" "~/handbook.pdf" article-pdf ; "handbook-language-reference" "handbook.pdf" article-pdf ;
: system-pdf ( -- ) : system-pdf ( -- )
"handbook-system-reference" "~/system.pdf" article-pdf ; "handbook-system-reference" "system.pdf" article-pdf ;
: tools-pdf ( -- ) : tools-pdf ( -- )
"handbook-tools-reference" "~/tools.pdf" article-pdf ; "handbook-tools-reference" "tools" article-pdf ;
: index-pdf ( -- ) : index-pdf ( -- )
{ {
@ -62,13 +62,13 @@ PRIVATE>
"primitive-index" "primitive-index"
"error-index" "error-index"
"class-index" "class-index"
} topics>pdf "~/index.pdf" write-pdf ; } topics>pdf "index.pdf" write-pdf ;
: furnace-pdf ( -- ) : furnace-pdf ( -- )
"furnace" "~/furnace.pdf" article-pdf ; "furnace" "furnace.pdf" article-pdf ;
: alien-pdf ( -- ) : alien-pdf ( -- )
"alien" "~/alien.pdf" article-pdf ; "alien" "alien.pdf" article-pdf ;
: io-pdf ( -- ) : io-pdf ( -- )
"io" "~/io.pdf" article-pdf ; "io" "io.pdf" article-pdf ;

14
extra/mason/config/config.factor
View File

@ -5,7 +5,10 @@ IN: mason.config
! (Optional) Location for build directories ! (Optional) Location for build directories
SYMBOL: builds-dir SYMBOL: builds-dir
builds-dir [ "~/builds" ] initialize
builds-dir get-global [
home "builds" append-path builds-dir set-global
] unless
! Who sends build report e-mails. ! Who sends build report e-mails.
SYMBOL: builder-from SYMBOL: builder-from
@ -15,11 +18,13 @@ SYMBOL: builder-recipients
! (Optional) CPU architecture to build for. ! (Optional) CPU architecture to build for.
SYMBOL: target-cpu SYMBOL: target-cpu
target-cpu [ cpu ] initialize
target-cpu get-global [ cpu target-cpu set-global ] unless
! (Optional) OS to build for. ! (Optional) OS to build for.
SYMBOL: target-os SYMBOL: target-os
target-os [ os ] initialize
target-os get-global [ os target-os set-global ] unless
! (Optional) Architecture variant suffix. ! (Optional) Architecture variant suffix.
SYMBOL: target-variant SYMBOL: target-variant
@ -32,10 +37,12 @@ SYMBOL: builder-debug
! URL for counter notifications. ! URL for counter notifications.
SYMBOL: counter-url SYMBOL: counter-url
counter-url [ "http://builds.factorcode.org/counter" ] initialize counter-url [ "http://builds.factorcode.org/counter" ] initialize
! URL for status notifications. ! URL for status notifications.
SYMBOL: status-url SYMBOL: status-url
status-url [ "http://builds.factorcode.org/status-update" ] initialize status-url [ "http://builds.factorcode.org/status-update" ] initialize
! Password for status notifications. ! Password for status notifications.
@ -56,6 +63,7 @@ SYMBOL: docs-directory
! URL to notify server about new docs ! URL to notify server about new docs
SYMBOL: docs-update-url SYMBOL: docs-update-url
docs-update-url [ "http://builds.factorcode.org/docs-update" ] initialize docs-update-url [ "http://builds.factorcode.org/docs-update" ] initialize
! Boolean. Do we upload package binaries? ! Boolean. Do we upload package binaries?

1
extra/mason/release/release.factor
View File

@ -12,6 +12,7 @@ IN: mason.release
sign-factor-app sign-factor-app
archive-name { archive-name {
[ make-archive ] [ make-archive ]
[ sign-archive ]
[ upload ] [ upload ]
[ save-archive ] [ save-archive ]
[ notify-release ] [ notify-release ]

21
extra/mason/release/sign/sign.factor
View File

@ -19,9 +19,11 @@ HOOK: cert-path os ( -- path/f )
M: object cert-path f ; M: object cert-path f ;
M: macosx cert-path "~/config/mac_app.cer" ; M: macosx cert-path
home "config/mac_app.cer" append-path ;
M: windows cert-path "~/config/FactorSPC.pfx" ; M: windows cert-path
home "config/FactorSPC.pfx" append-path ;
>> >>
HOOK: sign-factor-app os ( -- ) HOOK: sign-factor-app os ( -- )
@ -47,3 +49,18 @@ M:: windows sign-factor-app ( -- )
} }
] dip make-factor-path suffix short-running-process ] dip make-factor-path suffix short-running-process
] each ; ] each ;
HOOK: sign-archive os ( path -- )
M: object sign-archive drop ;
! Sign the .dmg on macOS as well to avoid Gatekeeper marking
! the xattrs as quarantined.
! https://github.com/factor/factor/issues/1896
M: macosx sign-archive ( path -- )
${
"codesign" "--force" "--sign"
"Developer ID Application"
cert-path
} swap suffix
short-running-process ;

2
extra/mason/test/test.factor
View File

@ -94,7 +94,7 @@ M: method word-vocabulary "method-generic" word-prop word-vocabulary ;
: run-mason-rc ( -- ) : run-mason-rc ( -- )
t "user-init" [ t "user-init" [
"~/.factor-mason-rc" try-user-init ".factor-mason-rc" rc-path try-user-init
] with-variable ; ] with-variable ;
: check-user-init-errors ( -- ? ) : check-user-init-errors ( -- ? )

2
extra/webapps/mason/backend/backend.factor
View File

@ -82,7 +82,7 @@ counter "COUNTER" {
: os/cpu ( builder -- string ) : os/cpu ( builder -- string )
[ os>> ] [ cpu>> ] bi "/" glue ; [ os>> ] [ cpu>> ] bi "/" glue ;
: mason-db ( -- db ) "~/mason.db" <sqlite-db> ; : mason-db ( -- db ) home "mason.db" append-path <sqlite-db> ;
: with-mason-db ( quot -- ) : with-mason-db ( quot -- )
mason-db [ with-transaction ] with-db ; inline mason-db [ with-transaction ] with-db ; inline

8
extra/websites/concatenative/concatenative.factor
View File

@ -31,7 +31,7 @@ webapps.mason.backend.watchdog
websites.factorcode ; websites.factorcode ;
IN: websites.concatenative IN: websites.concatenative
: website-db ( -- db ) "~/website.db" <sqlite-db> ; : website-db ( -- db ) home "website.db" append-path <sqlite-db> ;
: init-factor-db ( -- ) : init-factor-db ( -- )
mason-db [ init-mason-db ] with-db mason-db [ init-mason-db ] with-db
@ -107,9 +107,9 @@ SYMBOLS: key-password key-file dh-file ;
<pastebin> <factor-recaptcha> <login-config> <factor-boilerplate> website-db <alloy> "paste.factorcode.org" add-responder <pastebin> <factor-recaptcha> <login-config> <factor-boilerplate> website-db <alloy> "paste.factorcode.org" add-responder
<planet> <login-config> <factor-boilerplate> website-db <alloy> "planet.factorcode.org" add-responder <planet> <login-config> <factor-boilerplate> website-db <alloy> "planet.factorcode.org" add-responder
<mason-app> <login-config> <factor-boilerplate> website-db <alloy> "builds.factorcode.org" add-responder <mason-app> <login-config> <factor-boilerplate> website-db <alloy> "builds.factorcode.org" add-responder
"~/docs" <help-webapp> "docs.factorcode.org" add-responder home "docs" append-path <help-webapp> "docs.factorcode.org" add-responder
"~/cgi" <gitweb> "gitweb.factorcode.org" add-responder home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
"~/irclogs" <static> t >>allow-listings "irclogs.factorcode.org" add-responder home "irclogs" append-path <static> t >>allow-listings "irclogs.factorcode.org" add-responder
main-responder set-global ; main-responder set-global ;
: <factor-secure-config> ( -- config ) : <factor-secure-config> ( -- config )