Merge branch 'master' into hashcode

db4
Daniel Ehrenberg 2007-12-13 13:06:57 -05:00
commit 2e144daa6e
436 changed files with 70141 additions and 2936 deletions

View File

@ -57,6 +57,7 @@ default:
@echo "openbsd-x86-32"
@echo "openbsd-x86-64"
@echo "macosx-x86-32"
@echo "macosx-x86-64"
@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
@ -92,6 +93,9 @@ macosx-ppc: macosx-freetype
macosx-x86-32: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86.32

View File

@ -5,8 +5,7 @@ hashtables kernel math namespaces sequences words
inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators
init ;
kernel.private threads continuations.private libc combinators ;
IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect
@ -302,7 +301,7 @@ M: alien-indirect generate-node
! this hashtable, they will all be blown away by code GC, beware
SYMBOL: callbacks
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
callbacks global [ H{ } assoc-like ] change-at
: register-callback ( word -- ) dup callbacks get set-at ;

2
core/alien/syntax/syntax.factor Normal file → Executable file
View File

@ -59,4 +59,4 @@ M: alien pprint*
{ [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] }
} cond ;
M: dll pprint* dll-path dup "DLL\" " pprint-string ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

View File

@ -87,3 +87,9 @@ unit-test
[ H{ { 1 2 } { 3 4 } } ]
[ "hi" 5 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ]
unit-test
[
H{ { 1.0 1.0 } { 2.0 2.0 } }
] [
F{ 1.0 2.0 } [ dup ] H{ } map>assoc
] unit-test

View File

@ -135,7 +135,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ 0 or + ] change-at ;
: map>assoc ( seq quot exemplar -- assoc )
>r [ 2array ] compose map r> assoc-like ; inline
>r [ 2array ] compose { } map-as r> assoc-like ; inline
M: assoc >alist [ 2array ] { } assoc>map ;

View File

@ -79,6 +79,10 @@ M: sequence hashcode*
dup empty? [
drop
] [
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append
dup length 4 <= [
case>quot
] [
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append
] if
] if ;

View File

@ -16,9 +16,10 @@ M: object inference-error-major? drop t ;
: begin-batch ( seq -- )
batch-mode on
[
"Compiling " % length # " words..." %
] "" make print flush
"quiet" get [ drop ] [
[ "Compiling " % length # " words..." % ] "" make
print flush
] if
V{ } clone compile-errors set-global ;
: compile-error. ( pair -- )

View File

@ -50,7 +50,7 @@ IN: temporary
global keys =
] unit-test
[ 3 ] [ 1 2 [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test
[ 3 ] [ 1 [ 2 ] [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test
[ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test

View File

@ -56,3 +56,8 @@ IN: temporary
\ recursive compile
[ ] [ t recursive ] unit-test
! Make sure error reporting works
[ [ dup ] compile-1 ] unit-test-fails
[ [ drop ] compile-1 ] unit-test-fails

View File

@ -418,17 +418,6 @@ IN: cpu.arm.intrinsics
{ +output+ { "out" } }
} define-intrinsic
\ curry [
\ curry 3 cells %allot
"obj" operand 1 %set-slot
"quot" operand 2 %set-slot
"out" get object %store-tagged
] H{
{ +input+ { { f "obj" } { f "quot" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum

View File

@ -580,18 +580,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "vector" } }
} define-intrinsic
\ curry [
\ curry 3 cells %allot
"obj" operand 11 1 cells STW
"quot" operand 11 2 cells STW
! Store tagged ptr in reg
"curry" get object %store-tagged
] H{
{ +input+ { { f "obj" } { f "quot" } } }
{ +scratch+ { { f "curry" } } }
{ +output+ { "curry" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum

View File

@ -485,19 +485,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "vector" } }
} define-intrinsic
\ curry [
\ curry 3 cells [
1 object@ "obj" operand MOV
2 object@ "quot" operand MOV
! Store tagged ptr in reg
"curry" get object %store-tagged
] %allot
] H{
{ +input+ { { f "obj" } { f "quot" } } }
{ +scratch+ { { f "curry" } } }
{ +output+ { "curry" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand %untag-fixnum

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
IN: io.files
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings arrays definitions system
combinators splitting ;
memory namespaces sequences strings assocs arrays definitions
system combinators splitting ;
HOOK: <file-reader> io-backend ( path -- stream )
@ -97,7 +97,9 @@ TUPLE: no-parent-directory path ;
] }
} cond drop ;
: copy-file ( from to -- )
HOOK: copy-file io-backend ( from to -- )
M: object copy-file
dup parent-directory make-directories
<file-writer> [
stdio get swap
@ -124,3 +126,34 @@ TUPLE: pathname string ;
C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
HOOK: library-roots io-backend ( -- seq )
HOOK: binary-roots io-backend ( -- seq )
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
: find-library ( str -- path/f )
library-roots swap find-file ;
: find-binary ( str -- path/f )
binary-roots swap find-file ;
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] curry* map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;

View File

@ -32,7 +32,7 @@ $nl
{ $subsection >r }
{ $subsection r> }
"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
{ $example "1 2 3 >r .s r>" "2\n1" }
{ $example "1 2 3 >r .s r>" "1\n2" }
"Words must not leave objects on the retain stack, nor expect values to be there on entry. The retain stack is for local storage within a word only, and occurrences of " { $link >r } " and " { $link r> } " must be balanced inside a single quotation. One exception is the following trick involving " { $link if } "; values may be pushed on the retain stack before the condition value is computed, as long as both branches of the " { $link if } " pop the values off the retain stack before returning:"
{ $code
": foo ( m ? n -- m+n/n )"

View File

@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match
float-arrays combinators.private ;
float-arrays combinators.private combinators ;
! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input
@ -50,6 +50,20 @@ float-arrays combinators.private ;
{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
} define-optimizers
: literal-member? ( #call -- ? )
node-in-d peek dup value?
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
[ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot splice-quot ;
\ member? {
{ [ dup literal-member? ] [ expand-member ] }
} define-optimizers
! if the result of eq? is t and the second input is a literal,
! the first input is equal to the second
\ eq? [

View File

@ -111,7 +111,7 @@ optimizer.def-use generic.standard ;
: post-process ( class interval node -- classes intervals )
dupd won't-overflow?
[ >r dup { f integer } memq? [ drop fixnum ] when r> ] when
[ >r dup { f integer } member? [ drop fixnum ] when r> ] when
[ dup [ 1array ] when ] 2apply ;
: math-output-interval-1 ( node word -- interval )

View File

@ -89,19 +89,20 @@ M: f pprint* drop \ f pprint-word ;
{ 0.3 0.3 0.3 1.0 } foreground set
] H{ } make-assoc ;
: unparse-string ( str prefix -- str )
[
% do-string-limit [ unparse-ch ] each CHAR: " ,
] "" make ;
: unparse-string ( str prefix suffix -- str )
[ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ;
: pprint-string ( obj str prefix -- )
: pprint-string ( obj str prefix suffix -- )
unparse-string swap string-style styled-text ;
M: string pprint* dup "\"" pprint-string ;
M: string pprint*
dup "\"" "\"" pprint-string ;
M: sbuf pprint* dup "SBUF\" " pprint-string ;
M: sbuf pprint*
dup "SBUF\" " "\"" pprint-string ;
M: pathname pprint* dup pathname-string "P\" " pprint-string ;
M: pathname pprint*
dup pathname-string "P\" " "\"" pprint-string ;
! Sequences
: nesting-limit? ( -- ? )

2
core/quotations/quotations-docs.factor Normal file → Executable file
View File

@ -22,7 +22,7 @@ $nl
ABOUT: "quotations"
HELP: callable
{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations, " { $link f } " (which behaves like an empty quotation), and composed quotations built up with " { $link curry } "." } ;
{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations and composed quotations built up with " { $link curry } " or " { $link compose } "." } ;
HELP: quotation
{ $description "The class of quotations. See " { $link "syntax-quots" } " for syntax and " { $link "quotations" } " for general information." } ;

View File

@ -1,8 +1,8 @@
USING: math kernel quotations tools.test sequences ;
IN: temporary
[ [ 3 ] ] [ 3 f curry ] unit-test
[ [ \ + ] ] [ \ + f curry ] unit-test
[ [ 3 ] ] [ 3 [ ] curry ] unit-test
[ [ \ + ] ] [ \ + [ ] curry ] unit-test
[ [ \ + = ] ] [ \ + [ = ] curry ] unit-test
[ [ 1 + 2 + 3 + ] ] [
@ -14,3 +14,5 @@ IN: temporary
[ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
[ 1 \ + curry ] unit-test-fails

View File

@ -1,6 +1,6 @@
USING: kernel parser namespaces quotations vectors strings
sequences assocs tuples math combinators ;
USING: kernel parser namespaces quotations arrays vectors strings
sequences assocs tuples math combinators ;
IN: bake
@ -22,6 +22,10 @@ C: <splice-quot> splice-quot
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ,u ( seq -- seq ) unclip building get push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: exemplar
: reset-building ( -- ) 1024 <vector> building set ;
@ -35,6 +39,7 @@ DEFER: bake
: bake-item ( item -- )
{ { [ dup \ , = ] [ drop , ] }
{ [ dup \ % = ] [ drop % ] }
{ [ dup \ ,u = ] [ drop ,u ] }
{ [ dup insert-quot? ] [ insert-quot-expr call , ] }
{ [ dup splice-quot? ] [ splice-quot-expr call % ] }
{ [ dup integer? ] [ , ] }
@ -48,4 +53,9 @@ DEFER: bake
: bake-items ( seq -- ) [ bake-item ] each ;
: bake ( seq -- seq )
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing

View File

@ -0,0 +1 @@
Eric Mertens

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,64 @@
USING: kernel io io.files splitting strings
hashtables sequences assocs math namespaces prettyprint
math.parser combinators arrays sorting ;
IN: benchmark.knucleotide
: float>string ( float places -- string )
swap >float number>string
"." split1 rot
over length over <
[ CHAR: 0 pad-right ]
[ head ] if "." swap 3append ;
: discard-lines ( -- )
readln
[ ">THREE" head? [ discard-lines ] unless ] when* ;
: read-input ( -- input )
discard-lines
">" read-until drop
CHAR: \n swap remove >upper ;
: tally ( x exemplar -- b )
clone tuck
[
[ [ 1+ ] [ 1 ] if* ] change-at
] curry each ;
: small-groups ( x n -- b )
swap
[ length swap - 1+ ] 2keep
[ >r over + r> subseq ] 2curry map ;
: handle-table ( inputs n -- )
small-groups
[ length ] keep
H{ } tally >alist
sort-values reverse
[
dup first write bl
second 100 * over / 3 float>string print
] each
drop ;
: handle-n ( inputs x -- )
tuck length
small-groups H{ } tally
at [ 0 ] unless*
number>string 8 CHAR: \s pad-right write ;
: process-input ( input -- )
dup 1 handle-table nl
dup 2 handle-table nl
{ "GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT" }
[ [ dupd handle-n ] keep print ] each
drop ;
: knucleotide ( -- )
"extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
<file-reader>
[ read-input ] with-stream
process-input ;
MAIN: knucleotide

View File

@ -0,0 +1,2 @@
The Great Computer Language Shootout's knucleotide benchmark to test
hashtables.

View File

@ -64,7 +64,7 @@ SYMBOL: cols
building get >string
] with-scope ;
: mandel-main ( file -- )
: mandel-main ( -- )
"mandel.ppm" resource-path <file-writer>
[ mandel write ] with-stream ;

View File

@ -26,6 +26,8 @@ HINTS: do-trans-map string ;
over push
] if ;
HINTS: do-line vector string ;
: (reverse-complement) ( seq -- )
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;

View File

@ -49,7 +49,7 @@ IN: benchmark.spectral-norm
HINTS: spectral-norm fixnum ;
: spectral-norm-main ( n -- )
: spectral-norm-main ( -- )
2000 spectral-norm . ;
MAIN: spectral-norm-main

View File

@ -4,7 +4,7 @@ IN: benchmark.sum-file
: sum-file-loop ( n -- n' )
readln [ string>number + sum-file-loop ] when* ;
: sum-file ( file -- n )
: sum-file ( file -- )
<file-reader> [ 0 sum-file-loop ] with-stream . ;
: sum-file-main ( -- )

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io io.streams.string kernel math
math.vectors math.functions math.parser
namespaces sequences strings tuples system ;
math.vectors math.functions math.parser namespaces sequences
strings tuples system debugger ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
@ -316,7 +316,28 @@ M: timestamp <=> ( ts1 ts2 -- n )
: timestamp>rfc3339 ( timestamp -- str )
>gmt [
(timestamp>rfc3339)
] string-out ;
] string-out ;
: expect read1 assert= ;
: (rfc3339>timestamp) ( -- timestamp )
4 read string>number ! year
CHAR: - expect
2 read string>number ! month
CHAR: - expect
2 read string>number ! day
CHAR: T expect
2 read string>number ! hour
CHAR: : expect
2 read string>number ! minute
CHAR: : expect
2 read string>number ! second
0 <timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[
(rfc3339>timestamp)
] string-in ;
: file-time-string ( timestamp -- string )
[

View File

@ -58,8 +58,9 @@ SYMBOL: super-sent-messages
"NSSavePanel"
"NSView"
"NSWindow"
"NSWorkspace"
} [
f import-objc-class
[ ] import-objc-class
] each
: <NSString> ( str -- alien ) <CFString> -> autorelease ;

View File

@ -4,7 +4,7 @@ USING: alien alien.c-types alien.compiler
arrays assocs combinators compiler inference.transforms kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
memoize ;
memoize debugger ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -201,8 +201,11 @@ H{
: import-objc-class ( name quot -- )
2dup unless-defined
dupd define-objc-class-word
dup objc-class register-objc-methods
objc-meta-class register-objc-methods ;
[
dup
objc-class register-objc-methods
objc-meta-class register-objc-methods
] curry try ;
: root-class ( class -- root )
dup objc-class-super-class [ root-class ] [ ] ?if ;

View File

@ -58,3 +58,5 @@ IN: temporary
[ dup array? ] [ dup vector? ] [ dup float? ]
} || nip
] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

View File

@ -67,6 +67,9 @@ MACRO: napply ( n -- )
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
MACRO: nfirst ( n -- )
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ;

View File

@ -0,0 +1 @@
Daniel Ehrenberg

View File

@ -0,0 +1,52 @@
USING: delegate help.syntax help.markup ;
HELP: define-protocol
{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } }
{ $description "Defines a symbol as a protocol." }
{ $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ;
HELP: PROTOCOL:
{ $syntax "PROTOCOL: protocol-name words... ;" }
{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ;
{ define-protocol POSTPONE: PROTOCOL: } related-words
HELP: define-consult
{ $values { "class" "a class" } { "group" "a protocol, generic word or tuple class" } { "quot" "a quotation" } }
{ $description "Defines a class to consult, using the given quotation, on the generic words contained in the group." }
{ $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ;
HELP: CONSULT:
{ $syntax "CONSULT: group class getter... ;" }
{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } }
{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ;
{ define-consult POSTPONE: CONSULT: } related-words
HELP: define-mimic
{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." }
{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ;
HELP: MIMIC:
{ $syntax "MIMIC: group mimicker mimicked" }
{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ;
HELP: group-words
{ $values { "group" "a group" } { "words" "an array of words" } }
{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ;
ARTICLE: { "delegate" "intro" } "Delegation module"
"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use"
{ $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol }
"One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are"
{ $subsection POSTPONE: CONSULT: }
{ $subsection define-consult }
"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are"
{ $subsection POSTPONE: MIMIC: }
{ $subsection define-mimic } ;
IN: delegate
ABOUT: { "delegate" "intro" }

View File

@ -0,0 +1,26 @@
USING: delegate kernel arrays tools.test ;
TUPLE: hello this that ;
C: <hello> hello
TUPLE: goodbye these those ;
C: <goodbye> goodbye
GENERIC: foo ( x -- y )
GENERIC: bar ( a -- b )
PROTOCOL: baz foo bar ;
CONSULT: baz goodbye goodbye-these ;
M: hello foo hello-this ;
M: hello bar dup hello? swap hello-that 2array ;
GENERIC: bing ( c -- d )
CONSULT: hello goodbye goodbye-these ;
M: hello bing dup hello? swap hello-that 2array ;
MIMIC: bing goodbye hello
[ 1 { t 0 } ] [ 1 0 <hello> [ foo ] keep bar ] unit-test
[ { t 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
[ { t 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
[ { f 0 } ] [ 1 0 <hello> f <goodbye> bing ] unit-test

View File

@ -0,0 +1,73 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots io definitions
sequences sequences.private assocs prettyprint.sections arrays ;
IN: delegate
: define-protocol ( wordlist protocol -- )
swap { } like "protocol-words" set-word-prop ;
: PROTOCOL:
CREATE dup reset-generic dup define-symbol
parse-definition swap define-protocol ; parsing
PREDICATE: word protocol "protocol-words" word-prop ;
GENERIC: group-words ( group -- words )
M: protocol group-words
"protocol-words" word-prop ;
M: generic group-words
1array ;
M: tuple-class group-words
"slots" word-prop 1 tail ! The first slot is the delegate
! 1 tail should be removed when the delegate slot is removed
dup [ slot-spec-reader ] map
swap [ slot-spec-writer ] map append ;
: spin ( x y z -- z y x )
swap rot ;
: define-consult-method ( word class quot -- )
pick add <method> spin define-method ;
: define-consult ( class group quot -- )
>r group-words r>
swapd [ define-consult-method ] 2curry each ;
: CONSULT:
scan-word scan-word parse-definition swapd define-consult ; parsing
PROTOCOL: sequence-protocol
clone clone-like like new new-resizable nth nth-unsafe
set-nth set-nth-unsafe length immutable set-length lengthen ;
PROTOCOL: assoc-protocol
at* assoc-size >alist assoc-find set-at
delete-at clear-assoc new-assoc assoc-like ;
PROTOCOL: stream-protocol
stream-close stream-read1 stream-read stream-read-until
stream-flush stream-write1 stream-write stream-format
stream-nl make-span-stream make-block-stream stream-readln
make-cell-stream stream-write-table set-timeout ;
PROTOCOL: definition-protocol
where set-where forget uses redefined*
synopsis* definer definition ;
PROTOCOL: prettyprint-section-protocol
section-fits? indent-section? unindent-first-line?
newline-after? short-section? short-section long-section
<section> delegate>block add-section ;
: define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [
pick "methods" word-prop at dup
[ method-def <method> spin define-method ] [ 3drop ] if
] 2curry each ;
: MIMIC:
scan-word scan-word scan-word define-mimic ; parsing

View File

@ -0,0 +1 @@
Delegation and mimicking on top of the Factor object system

6
extra/documents/documents.factor Normal file → Executable file
View File

@ -167,6 +167,12 @@ M: char-elt prev-elt
M: char-elt next-elt
drop [ drop 1 +col ] (next-char) ;
TUPLE: one-char-elt ;
M: one-char-elt prev-elt 2drop ;
M: one-char-elt next-elt 2drop ;
: (word-elt) ( loc document quot -- loc )
pick >r
>r >r first2 swap r> doc-line r> call

View File

@ -1,21 +1,36 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces sequences definitions io.files
inspector continuations tuples tools.crossref io prettyprint
source-files ;
inspector continuations tuples tools.crossref tools.browser
io prettyprint source-files assocs vocabs vocabs.loader ;
IN: editors
TUPLE: no-edit-hook ;
M: no-edit-hook summary drop "No edit hook is set" ;
M: no-edit-hook summary
drop "You must load one of the below vocabularies before using editor integration:" ;
SYMBOL: edit-hook
: available-editors ( -- seq )
"editors" all-child-vocabs
values concat [ vocab-name ] map ;
: editor-restarts ( -- alist )
available-editors
[ "Load " over append swap ] { } map>assoc ;
: no-edit-hook ( -- )
\ no-edit-hook construct-empty
editor-restarts throw-restarts
require ;
: edit-location ( file line -- )
>r ?resource-path r>
edit-hook get dup [
\ no-edit-hook construct-empty throw
] if ;
edit-hook get [
>r >r ?resource-path r> r> call
] [
no-edit-hook edit-location
] if* ;
: edit ( defspec -- )
where [ first2 edit-location ] when* ;

View File

@ -1,8 +1,15 @@
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher ;
namespaces editors io.launcher windows.shell32 io.files
io.paths strings ;
IN: editors.editpadpro
: editpadpro-path
\ editpadpro-path get-global [
program-files "JGsoft" path+ walk-dir
[ >lower "editpadpro.exe" tail? ] find nip
] unless* ;
: editpadpro ( file line -- )
[ "editpadpro.exe /l" % # " \"" % % "\"" % ] "" make run-process ;
[ editpadpro-path % " /l" % # " \"" % % "\"" % ] "" make run-detached ;
[ editpadpro ] edit-hook set-global

View File

@ -0,0 +1 @@
EditPadPro editor integration

View File

@ -0,0 +1 @@
Aaron Schaefer

View File

@ -0,0 +1,15 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
program-files "\\EditPlus 2\\editplus.exe" append
] unless* ;
: editplus ( file line -- )
[
editplus-path % " -cursor " % # " " % %
] "" make run-detached ;
[ editplus ] edit-hook set-global

View File

@ -0,0 +1 @@
EditPlus editor integration

View File

@ -0,0 +1 @@
Emacs editor integration

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,16 @@
USING: editors hardware-info.windows io.files io.launcher
kernel math.parser namespaces sequences windows.shell32 ;
IN: editors.emeditor
: emeditor-path ( -- path )
\ emeditor-path get-global [
program-files "\\EmEditor\\EmEditor.exe" path+
] unless* ;
: emeditor ( file line -- )
[
emeditor-path % " /l " % #
" " % "\"" % % "\"" %
] "" make run-detached ;
[ emeditor ] edit-hook set-global

View File

@ -0,0 +1 @@
EmEditor integration

View File

@ -1,14 +1,18 @@
USING: kernel math math.parser namespaces editors.vim ;
USING: io.backend io.files kernel math math.parser
namespaces editors.vim sequences system ;
IN: editors.gvim
TUPLE: gvim ;
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string )
[
"\"" % vim-path get % "\"" %
vim-switches get [ % ] when*
"+" % # " \"" % % "\"" %
] "" make ;
[ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
t vim-detach set-global ! don't block the ui
T{ gvim } vim-editor set-global
"gvim" vim-path set-global
USE-IF: unix? editors.gvim.unix
USE-IF: windows? editors.gvim.windows

View File

@ -0,0 +1 @@
gVim editor integration

View File

@ -0,0 +1,7 @@
USING: editors.gvim io.unix.backend kernel namespaces ;
IN: editors.gvim.unix
M: unix-io gvim-path
\ gvim-path get-global [
"gvim"
] unless* ;

View File

@ -0,0 +1,8 @@
USING: editors.gvim io.files io.windows kernel namespaces
sequences windows.shell32 ;
IN: editors.gvim.windows
M: windows-io gvim-path
\ gvim-path get-global [
program-files walk-dir [ "gvim.exe" tail? ] find nip
] unless* ;

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,15 @@
USING: editors io.files io.launcher kernel math.parser
namespaces windows.shell32 ;
IN: editors.notepadpp
: notepadpp-path
\ notepadpp-path get-global [
program-files "notepad++\\notepad++.exe" path+
] unless* ;
: notepadpp ( file line -- )
[
notepadpp-path % " -n" % # " " % %
] "" make run-detached ;
[ notepadpp ] edit-hook set-global

View File

@ -0,0 +1 @@
Notepad++ editor integration

View File

@ -0,0 +1 @@
SciTE editor integration

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1 @@
TED Notepad integration

View File

@ -0,0 +1,16 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
IN: editors.ted-notepad
: ted-notepad-path
\ ted-notepad-path get-global [
program-files "\\TED Notepad\\TedNPad.exe" path+
] unless* ;
: ted-notepad ( file line -- )
[
ted-notepad-path % " /l" % #
" " % %
] "" make run-detached ;
[ ted-notepad ] edit-hook set-global

View File

@ -0,0 +1 @@
Textmate editor integration

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1 @@
UltraEdit editor integration

View File

@ -0,0 +1,17 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
IN: editors.ultraedit
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
program-files
"\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+
] unless* ;
: ultraedit ( file line -- )
[
ultraedit-path % " " % swap % "/" % # "/1" %
] "" make run-detached ;
[ ultraedit ] edit-hook set-global

View File

@ -0,0 +1 @@
Vim editor integration

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1 @@
Wordpad editor integration

View File

@ -0,0 +1,15 @@
USING: editors hardware-info.windows io.launcher kernel
math.parser namespaces sequences windows.shell32 ;
IN: editors.wordpad
: wordpad-path ( -- path )
\ wordpad-path get [
program-files "\\Windows NT\\Accessories\\wordpad.exe" append
] unless* ;
: wordpad ( file line -- )
[
wordpad-path % drop " " % "\"" % % "\"" %
] "" make run-detached ;
[ wordpad ] edit-hook set-global

114
extra/faq/faq.factor Normal file
View File

@ -0,0 +1,114 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml kernel sequences xml.utilities combinators.lib
math xml.data arrays assocs xml.generator xml.writer namespaces
math.parser io ;
IN: faq
: find-after ( seq quot -- elem after )
over >r find r> rot 1+ tail ; inline
: tag-named? ( tag name -- ? )
assure-name swap (get-tag) ;
! Questions
TUPLE: q/a question answer ;
C: <q/a> q/a
: li>q/a ( li -- q/a )
[ "br" tag-named? not ] subset
[ "strong" tag-named? ] find-after
>r tag-children r> <q/a> ;
: q/a>li ( q/a -- li )
[ q/a-question "strong" build-tag* f "br" build-tag* 2array ] keep
q/a-answer append "li" build-tag* ;
: xml>q/a ( xml -- q/a )
[ "question" tag-named tag-children ] keep
"answer" tag-named tag-children <q/a> ;
: q/a>xml ( q/a -- xml )
[ q/a-question "question" build-tag* ] keep
q/a-answer "answer" build-tag*
"\n" swap 3array "qa" build-tag* ;
! Lists of questions
TUPLE: question-list title seq ;
C: <question-list> question-list
: xml>question-list ( list -- question-list )
[ "title" swap at ] keep
tag-children [ tag? ] subset [ xml>q/a ] map
<question-list> ;
: question-list>xml ( question-list -- list )
[ question-list-seq [ q/a>xml "\n" swap 2array ]
map concat "list" build-tag* ] keep
question-list-title [ "title" pick set-at ] when* ;
: html>question-list ( h3 ol -- question-list )
>r [ children>string ] [ f ] if* r>
children-tags [ li>q/a ] map <question-list> ;
: question-list>h3 ( id question-list -- h3 )
question-list-title [
"h3" build-tag
swap number>string "id" pick set-at
] [ drop f ] if* ;
: question-list>html ( question-list start id -- h3/f ol )
-rot >r [ question-list>h3 ] keep
question-list-seq [ q/a>li ] map "ol" build-tag* r>
number>string "start" pick set-at
"margin-left: 5em" "style" pick set-at ;
! Overall everything
TUPLE: faq header lists ;
C: <faq> faq
: html>faq ( div -- faq )
unclip swap { "h3" "ol" } [ tags-named ] curry* map
first2 >r f add* r> [ html>question-list ] 2map <faq> ;
: header, ( faq -- )
dup faq-header ,
faq-lists first 1 -1 question-list>html nip , ;
: br, ( -- )
"br" contained, nl, ;
: toc-link, ( question-list number -- )
number>string "#" swap append "href" swap 2array 1array
"a" swap [ question-list-title , ] tag*, br, ;
: toc, ( faq -- )
"div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
"strong" [ "The big questions" , ] tag, br,
faq-lists 1 tail dup length [ toc-link, ] 2each
] tag*, ;
: faq-sections, ( question-lists -- )
unclip question-list-seq length 1+ dupd
[ question-list-seq length + ] accumulate nip
0 -rot [ pick question-list>html [ , nl, ] 2apply 1+ ] 2each drop ;
: faq>html ( faq -- div )
"div" [
dup header,
dup toc,
faq-lists faq-sections,
] make-xml ;
: xml>faq ( xml -- faq )
[ "header" tag-named children>string ] keep
"list" tags-named [ xml>question-list ] map <faq> ;
: faq>xml ( faq -- xml )
"faq" [
"header" [ dup faq-header , ] tag,
faq-lists [ question-list>xml , nl, ] each
] make-xml ;
: read-write-faq ( xml-stream -- )
read-xml xml>faq faq>html write-xml ;

28
extra/fjsc/fjsc-tests.factor Normal file → Executable file
View File

@ -4,51 +4,51 @@ USING: kernel tools.test parser-combinators lazy-lists fjsc ;
IN: temporary
{ T{ ast-expression f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"55 2abc1 100" 'expression' parse car parse-result-parsed
"55 2abc1 100" 'expression' parse-1
] unit-test
{ T{ ast-quotation f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"[ 55 2abc1 100 ]" 'quotation' parse car parse-result-parsed
"[ 55 2abc1 100 ]" 'quotation' parse-1
] unit-test
{ T{ ast-array f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"{ 55 2abc1 100 }" 'array' parse car parse-result-parsed
"{ 55 2abc1 100 }" 'array' parse-1
] unit-test
{ T{ ast-stack-effect f { } { "d" "e" "f" } } } [
"( -- d e f )" 'stack-effect' parse car parse-result-parsed
"( -- d e f )" 'stack-effect' parse-1
] unit-test
{ T{ ast-stack-effect f { "a" "b" "c" } { "d" "e" "f" } } } [
"( a b c -- d e f )" 'stack-effect' parse car parse-result-parsed
"( a b c -- d e f )" 'stack-effect' parse-1
] unit-test
{ T{ ast-stack-effect f { "a" "b" "c" } { } } } [
"( a b c -- )" 'stack-effect' parse car parse-result-parsed
"( a b c -- )" 'stack-effect' parse-1
] unit-test
{ T{ ast-stack-effect f { } { } } } [
"( -- )" 'stack-effect' parse car parse-result-parsed
"( -- )" 'stack-effect' parse-1
] unit-test
{ } [
": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop
] unit-test
{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [
"\"abcd\"" 'statement' parse car parse-result-parsed
] unit-test
{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [
"\"abcd\"" 'statement' parse-1
] unit-test
{ T{ ast-expression f { T{ ast-use f "foo" } } } } [
"USE: foo" 'statement' parse car parse-result-parsed
"USE: foo" 'statement' parse-1
] unit-test
{ T{ ast-expression f { T{ ast-in f "foo" } } } } [
"IN: foo" 'statement' parse car parse-result-parsed
"IN: foo" 'statement' parse-1
] unit-test
{ T{ ast-expression f { T{ ast-using f { "foo" "bar" } } } } } [
"USING: foo bar ;" 'statement' parse car parse-result-parsed
"USING: foo bar ;" 'statement' parse-1
] unit-test

148
extra/fjsc/fjsc.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel lazy-lists parser-combinators parser-combinators.simple
strings promises sequences math math.parser namespaces words
strings promises sequences math math.parser namespaces words
quotations arrays hashtables io io.streams.string assocs ;
IN: fjsc
@ -53,11 +53,11 @@ C: <ast-hashtable> ast-hashtable
[ CHAR: ] = not ] keep
[ CHAR: ;" = not ] keep
[ CHAR: " = not ] keep
digit? not
digit? not
and and and and and ;
LAZY: 'identifier-ends' ( -- parser )
[
LAZY: 'identifier-ends' ( -- parser )
[
[ blank? not ] keep
[ CHAR: " = not ] keep
[ CHAR: ;" = not ] keep
@ -67,23 +67,23 @@ LAZY: 'identifier-ends' ( -- parser )
and and and and and
] satisfy <!*> ;
LAZY: 'identifier-middle' ( -- parser )
LAZY: 'identifier-middle' ( -- parser )
[ identifier-middle? ] satisfy <!+> ;
LAZY: 'identifier' ( -- parser )
'identifier-ends'
'identifier-ends'
'identifier-middle' <&>
'identifier-ends' <:&>
'identifier-ends' <:&>
[ concat >string f <ast-identifier> ] <@ ;
DEFER: 'expression'
LAZY: 'effect-name' ( -- parser )
[
[
[ blank? not ] keep
CHAR: - = not
and
and
] satisfy <!+> [ >string ] <@ ;
LAZY: 'stack-effect' ( -- parser )
@ -94,24 +94,24 @@ LAZY: 'stack-effect' ( -- parser )
")" token sp <& [ first2 <ast-stack-effect> ] <@ ;
LAZY: 'define' ( -- parser )
":" token sp
":" token sp
'identifier' sp [ ast-identifier-value ] <@ &>
'stack-effect' sp <!?> <&>
'expression' <:&>
";" token sp <& [ first3 <ast-define> ] <@ ;
LAZY: 'quotation' ( -- parser )
"[" token sp
"[" token sp
'expression' [ ast-expression-values ] <@ &>
"]" token sp <& [ <ast-quotation> ] <@ ;
LAZY: 'array' ( -- parser )
"{" token sp
"{" token sp
'expression' [ ast-expression-values ] <@ &>
"}" token sp <& [ <ast-array> ] <@ ;
LAZY: 'word' ( -- parser )
"\\" token sp
"\\" token sp
'identifier' sp &> [ ast-identifier-value f <ast-word> ] <@ ;
LAZY: 'atom' ( -- parser )
@ -137,7 +137,7 @@ LAZY: 'USING:' ( -- parser )
";" token sp <& [ <ast-using> ] <@ ;
LAZY: 'hashtable' ( -- parser )
"H{" token sp
"H{" token sp
'expression' [ ast-expression-values ] <@ &>
"}" token sp <& [ <ast-hashtable> ] <@ ;
@ -147,14 +147,14 @@ LAZY: 'parsing-word' ( -- parser )
'IN:' <|> ;
LAZY: 'expression' ( -- parser )
'comment'
'parsing-word' sp <|>
'quotation' sp <|>
'comment'
'parsing-word' sp <|>
'quotation' sp <|>
'define' sp <|>
'array' sp <|>
'hashtable' sp <|>
'word' sp <|>
'atom' sp <|>
'atom' sp <|>
<*> [ <ast-expression> ] <@ ;
LAZY: 'statement' ( -- parser )
@ -163,41 +163,41 @@ LAZY: 'statement' ( -- parser )
GENERIC: (compile) ( ast -- )
GENERIC: (literal) ( ast -- )
M: ast-number (literal)
M: ast-number (literal)
ast-number-value number>string , ;
M: ast-number (compile)
"factor.push_data(" ,
(literal)
"," , ;
M: ast-string (literal)
"\"" ,
ast-string-value ,
"\"" , ;
M: ast-string (compile)
M: ast-number (compile)
"factor.push_data(" ,
(literal)
"," , ;
M: ast-identifier (literal)
M: ast-string (literal)
"\"" ,
ast-string-value ,
"\"" , ;
M: ast-string (compile)
"factor.push_data(" ,
(literal)
"," , ;
M: ast-identifier (literal)
dup ast-identifier-vocab [
"factor.get_word(\"" ,
"factor.get_word(\"" ,
dup ast-identifier-vocab ,
"\",\"" ,
ast-identifier-value ,
"\")" ,
ast-identifier-value ,
"\")" ,
] [
"factor.find_word(\"" , ast-identifier-value , "\")" ,
"factor.find_word(\"" , ast-identifier-value , "\")" ,
] if ;
M: ast-identifier (compile)
M: ast-identifier (compile)
(literal) ".execute(" , ;
M: ast-define (compile)
"factor.define_word(\"" ,
dup ast-define-name ,
M: ast-define (compile)
"factor.define_word(\"" ,
dup ast-define-name ,
"\",\"source\"," ,
ast-define-expression (compile)
"," , ;
@ -207,7 +207,7 @@ M: ast-define (compile)
unclip
dup ast-comment? not [
"function() {" ,
(compile)
(compile)
do-expressions
")}" ,
] [
@ -217,74 +217,74 @@ M: ast-define (compile)
drop "factor.cont.next" ,
] if ;
M: ast-quotation (literal)
M: ast-quotation (literal)
"factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions
")" , ;
M: ast-quotation (compile)
M: ast-quotation (compile)
"factor.push_data(factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions
")," , ;
M: ast-array (literal)
"[" ,
M: ast-array (literal)
"[" ,
ast-array-elements [ "," , ] [ (literal) ] interleave
"]" , ;
M: ast-array (compile)
M: ast-array (compile)
"factor.push_data(" , (literal) "," , ;
M: ast-hashtable (literal)
"new Hashtable().fromAlist([" ,
M: ast-hashtable (literal)
"new Hashtable().fromAlist([" ,
ast-hashtable-elements [ "," , ] [ (literal) ] interleave
"])" , ;
M: ast-hashtable (compile)
M: ast-hashtable (compile)
"factor.push_data(" , (literal) "," , ;
M: ast-expression (literal)
ast-expression-values [
(literal)
(literal)
] each ;
M: ast-expression (compile)
ast-expression-values do-expressions ;
M: ast-word (literal)
M: ast-word (literal)
dup ast-word-vocab [
"factor.get_word(\"" ,
"factor.get_word(\"" ,
dup ast-word-vocab ,
"\",\"" ,
ast-word-value ,
"\")" ,
ast-word-value ,
"\")" ,
] [
"factor.find_word(\"" , ast-word-value , "\")" ,
"factor.find_word(\"" , ast-word-value , "\")" ,
] if ;
M: ast-word (compile)
"factor.push_data(" ,
(literal)
"," , ;
M: ast-comment (compile)
drop ;
M: ast-stack-effect (compile)
drop ;
M: ast-use (compile)
M: ast-use (compile)
"factor.use(\"" ,
ast-use-name ,
ast-use-name ,
"\"," , ;
M: ast-in (compile)
M: ast-in (compile)
"factor.set_in(\"" ,
ast-in-name ,
ast-in-name ,
"\"," , ;
M: ast-using (compile)
M: ast-using (compile)
"factor.using([" ,
ast-using-names [
"," ,
@ -308,17 +308,17 @@ M: string (parse-factor-quotation) ( object -- ast )
<ast-string> ;
M: quotation (parse-factor-quotation) ( object -- ast )
[
[
[ (parse-factor-quotation) , ] each
] { } make <ast-quotation> ;
M: array (parse-factor-quotation) ( object -- ast )
[
[
[ (parse-factor-quotation) , ] each
] { } make <ast-array> ;
M: hashtable (parse-factor-quotation) ( object -- ast )
>alist [
>alist [
[ (parse-factor-quotation) , ] each
] { } make <ast-hashtable> ;
@ -328,33 +328,33 @@ M: wrapper (parse-factor-quotation) ( object -- ast )
GENERIC: fjsc-parse ( object -- ast )
M: string fjsc-parse ( object -- ast )
'expression' parse car parse-result-parsed ;
'expression' parse-1 ;
M: quotation fjsc-parse ( object -- ast )
[
[ (parse-factor-quotation) , ] each
[ (parse-factor-quotation) , ] each
] { } make <ast-expression> ;
: fjsc-compile ( ast -- string )
[
[
[
"(" ,
(compile)
(compile)
")" ,
] { } make [ write ] each
] string-out ;
: fjsc-compile* ( string -- string )
'statement' parse car parse-result-parsed fjsc-compile ;
'statement' parse-1 fjsc-compile ;
: fc* ( string -- string )
[
'statement' parse car parse-result-parsed ast-expression-values do-expressions
'statement' parse-1 ast-expression-values do-expressions
] { } make [ write ] each ;
: fjsc-literal ( ast -- string )
[
[ (literal) ] { } make [ write ] each
] string-out ;

View File

@ -5,7 +5,7 @@ USING: kernel vectors io assocs quotations splitting strings
continuations tuples classes io.files
http http.server.templating http.basic-authentication
webapps.callback html html.elements
http.server.responders furnace.validator ;
http.server.responders furnace.validator vocabs ;
IN: furnace
SYMBOL: default-action
@ -101,36 +101,14 @@ SYMBOL: request-params
: service-post ( url -- ) "response" get swap service-request ;
: explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ;
: send-resource ( name -- )
template-path get swap path+ resource-path <file-reader>
stdio get stream-copy ;
SYMBOL: model
: call-template ( model template -- )
[
>r [ dup model set explode-tuple ] when* r>
".furnace" append resource-path run-template-file
] with-scope ;
: render-template ( model template -- )
template-path get swap path+ call-template ;
: render-page* ( model body-template head-template -- )
[
[ render-template ] [ f rot render-template ] html-document
] serve-html ;
: render-titled-page* ( model body-template head-template title -- )
[
[ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document
] serve-html ;
: render-page ( model template title -- )
[
[ render-template ] simple-html-document
] serve-html ;
: render-template ( template -- )
template-path get swap path+
".furnace" append resource-path
run-template-file ;
: web-app ( name default path -- )
[
@ -141,3 +119,22 @@ SYMBOL: model
[ service-post ] "post" set
! [ service-head ] "head" set
] make-responder ;
: explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ;
SYMBOL: model
: with-slots ( model quot -- )
[
>r [ dup model set explode-tuple ] when* r> call
] with-scope ;
: render-component ( model template -- )
swap [ render-template ] with-slots ;
: browse-webapp-source ( vocab -- )
<a f >vocab-link browser-link-href =href a>
"Browse source" write
</a> ;

1
extra/globs/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,18 @@
IN: temporary
USING: tools.test globs ;
[ f ] [ "abd" "fdf" glob-matches? ] unit-test
[ f ] [ "fdsafas" "?" glob-matches? ] unit-test
[ t ] [ "fdsafas" "*as" glob-matches? ] unit-test
[ t ] [ "fdsafas" "*a*" glob-matches? ] unit-test
[ t ] [ "fdsafas" "*a?" glob-matches? ] unit-test
[ t ] [ "fdsafas" "*?" glob-matches? ] unit-test
[ f ] [ "fdsafas" "*s?" glob-matches? ] unit-test
[ t ] [ "a" "[abc]" glob-matches? ] unit-test
[ f ] [ "a" "[^abc]" glob-matches? ] unit-test
[ t ] [ "d" "[^abc]" glob-matches? ] unit-test
[ f ] [ "foo.java" "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.txt" "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.xml" "*.{xml,txt}" glob-matches? ] unit-test
[ f ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.{" "*.{" glob-matches? ] unit-test

38
extra/globs/globs.factor Executable file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser-combinators regexp lazy-lists sequences kernel
promises strings ;
IN: globs
<PRIVATE
: 'char' [ ",*?" member? not ] satisfy ;
: 'string' 'char' <+> [ >lower token ] <@ ;
: 'escaped-char' "\\" token any-char-parser &> [ 1token ] <@ ;
: 'escaped-string' 'string' 'escaped-char' <|> ;
DEFER: 'term'
: 'glob' ( -- parser )
'term' <*> [ <and-parser> ] <@ ;
: 'union' ( -- parser )
'glob' "," token nonempty-list-of "{" "}" surrounded-by
[ <or-parser> ] <@ ;
LAZY: 'term'
'union'
'character-class' <|>
"?" token [ drop any-char-parser ] <@ <|>
"*" token [ drop any-char-parser <*> ] <@ <|>
'escaped-string' <|> ;
PRIVATE>
: <glob> 'glob' just parse-1 just ;
: glob-matches? ( input glob -- ? )
>r >lower r> <glob> parse nil? not ;

1
extra/globs/summary.txt Normal file
View File

@ -0,0 +1 @@
Unix shell-style glob pattern matching

View File

@ -1,7 +1,7 @@
USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 ;
USING: alien.c-types hardware-info hardware-info.windows
kernel math namespaces windows windows.kernel32 ;
IN: hardware-info.windows.ce
TUPLE: wince ;
T{ wince } os set-global
: memory-status ( -- MEMORYSTATUS )

View File

@ -1,8 +1,8 @@
USING: alien alien.c-types hardware-info kernel libc math namespaces
USING: alien alien.c-types hardware-info hardware-info.windows
kernel libc math namespaces
windows windows.advapi32 windows.kernel32 ;
IN: hardware-info.windows.nt
TUPLE: winnt ;
T{ winnt } os set-global
: memory-status ( -- MEMORYSTATUSEX )

View File

@ -1,5 +1,6 @@
USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32 hardware-info ;
windows windows.kernel32 windows.advapi32 hardware-info
words ;
IN: hardware-info.windows
TUPLE: wince ;
@ -53,6 +54,22 @@ M: windows cpus ( -- n )
: sse3? ( -- ? )
PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
: <u16-string-object> ( n -- obj )
"ushort" <c-array> ;
: get-directory ( word -- str )
>r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r>
execute win32-error=0/f alien>u16-string ; inline
: windows-directory ( -- str )
\ GetWindowsDirectory get-directory ;
: system-directory ( -- str )
\ GetSystemDirectory get-directory ;
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
USE-IF: wince? hardware-info.windows.ce
USE-IF: winnt? hardware-info.windows.nt

View File

@ -1,7 +1,7 @@
USING: help help.markup help.syntax help.topics
namespaces words sequences classes assocs vocabs kernel
arrays prettyprint.backend kernel.private io tools.browser
generic ;
generic math tools.profiler system ui ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
@ -222,6 +222,72 @@ ARTICLE: "handbook" "Factor documentation"
USING: io.files io.sockets float-arrays inference ;
ARTICLE: "changes" "Changes in the latest release"
{ $heading "Factor 0.91" }
{ $subheading "Performance" }
{ $list
{ "Continuations are now supported by the static stack effect system. This means that the " { $link infer } " word and the optimizing compiler now both support code which uses continuations." }
{ "Many words which previously ran in the interpreter, such as error handling and I/O, are now compiled to optimized machine code." }
{ "A non-optimizing, just-in-time compiler replaces the interpreter with no loss in functionality or introspective ability." }
{ "The non-optimizing compiler compiles quotations the first time they are called, generating a series of stack pushes and subroutine calls. It offers a 33%-50% performance increase over the interpreter." }
{ "The optimizing compiler now performs some more representation inference. Alien pointers are unboxed where possible. This improves performance of the " { $vocab-link "ogg.player" } " Ogg Theora video player." }
{ "The queue of sleeping tasks is now a sorted priority queue. This reduces overhead for workloads involving large numbers of sleeping threads (Doug Coleman)" }
{ "Improved hash code algorithm for sequences" }
{ "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
{ "New " { $link big-random } " word for generating large random numbers quickly" }
{ "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." }
{ "Calls to " { $link member? } " with a literal sequence are now open-coded. If there are four or fewer elements, a series of conditionals are generated; if there are more than four elements, there is a hash dispatch followed by conditionals in each branch." }
}
{ $subheading "IO" }
{ $list
{ "More robust Windows CE native I/O" }
{ "New " { $link os-envs } " word to get the current set of environment variables" }
{ "Redesigned " { $vocab-link "io.launcher" } " supports passing environment variables to the child process" }
{ { $link <process-stream> } " implemented on Windows (Doug Coleman)" }
{ "Updated " { $vocab-link "io.mmap" } " for new module system, now supports Windows CE (Doug Coleman)" }
{ { $vocab-link "io.sniffer" } " - packet sniffer library (Doug Coleman, Elie Chaftari)" }
{ { $vocab-link "io.server" } " - improved logging support, logs to a file by default" }
{ { $vocab-link "io.files" } " - several new file system manipulation words added" }
{ { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" }
{ { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $snippet "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
}
{ $subheading "Tools" }
{ $list
{ "Graphical deploy tool added - see " { $link "ui.tools.deploy" } }
{ "The deploy tool now supports Windows" }
{ { $vocab-link "network-clipboard" } " - clipboard synchronization with a simple TCP/IP protocol" }
}
{ $subheading "UI" }
{ $list
{ { $vocab-link "cairo" } " - updated for new module system, new features (Sampo Vuori)" }
{ { $vocab-link "springies" } " - physics simulation UI demo (Eduardo Cavazos)" }
{ { $vocab-link "ui.gadgets.buttons" } " - added check box and radio button gadgets" }
{ "Double- and triple-click-drag now supported in the editor gadget to select words or lines at a time" }
{ "Windows can be closed on request now using " { $link close-window } }
{ "New icons (Elie Chaftari)" }
}
{ $subheading "Libraries" }
{ $list
{ "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } }
{ "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." }
{ "The optimizing compiler no longer depends on the number tower and it is possible to bootstrap a minimal image by just passing " { $snippet "-include=compiler" } " to stage 2 bootstrap." }
{ { $vocab-link "benchmark.knucleotide" } " - new benchmark (Eric Mertens)" }
{ { $vocab-link "channels" } " - concurrent message passing over message channels" }
{ { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" }
{ { $vocab-link "dlists" } " - various updates (Doug Coleman)" }
{ { $vocab-link "editors.emeditor" } " - EmEditor integration (Doug Coleman)" }
{ { $vocab-link "editors.editplus" } " - EditPlus integration (Aaron Schaefer)" }
{ { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" }
{ { $vocab-link "editors.ted-notepad" } " - TED Notepad integration (Doug Coleman)" }
{ { $vocab-link "editors.ultraedit" } " - UltraEdit integration (Doug Coleman)" }
{ { $vocab-link "globs" } " - simple Unix shell-style glob patterns" }
{ { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" }
{ { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" }
{ { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" }
{ { $vocab-link "rss" } " - add Atom feed generation (Daniel Ehrenberg)" }
{ { $vocab-link "tuples.lib" } " - some utility words for working with tuples (Doug Coleman)" }
{ { $vocab-link "webapps.pastebin" } " - improved appearance, add Atom feed generation, add syntax highlighting using " { $vocab-link "xmode" } }
{ { $vocab-link "webapps.planet" } " - add Atom feed generation" }
}
{ $heading "Factor 0.90" }
{ $subheading "Core" }
{ $list
@ -249,7 +315,7 @@ ARTICLE: "changes" "Changes in the latest release"
"Most existing libraries were improved when ported to the new module system; the most notable changes include:"
{ $list
{ { $vocab-link "asn1" } ": ASN1 parser and writer. (Elie Chaftari)" }
{ { $vocab-link "benchmarks" } ": new set of benchmarks." }
{ { $vocab-link "benchmark" } ": new set of benchmarks." }
{ { $vocab-link "cfdg" } ": Context-free design grammar implementation; see " { $url "http://www.chriscoyne.com/cfdg/" } ". (Eduardo Cavazos)" }
{ { $vocab-link "cryptlib" } ": Cryptlib library binding. (Elie Chaftari)" }
{ { $vocab-link "cryptlib.streams" } ": Streams which perform SSL encryption and decryption. (Matthew Willis)" }

View File

@ -1,15 +1,23 @@
USING: assocs browser.parser kernel math sequences strings ;
IN: browser.analyzer
USING: assocs html.parser kernel math sequences strings ;
IN: html.parser.analyzer
: remove-blank-text ( vector -- vector )
: remove-blank-text ( vector -- vector' )
[
dup tag-name text = [
tag-text [ blank? not ] all?
tag-text [ blank? ] all? not
] [
drop t
] if
] subset ;
: trim-text ( vector -- vector' )
[
dup tag-name text = [
[ tag-text [ blank? ] trim ] keep
[ set-tag-text ] keep
] when
] map ;
: find-by-id ( id vector -- vector )
[ tag-attributes "id" swap at = ] curry* subset ;
@ -79,5 +87,5 @@ IN: browser.analyzer
! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html "Currency" "name" pick find-first-attribute-key-value
! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html
! "Currency" "name" pick find-first-attribute-key-value
! "Currency" "name" pick find-first-attribute-key-value
! pick find-between remove-blank-text

View File

@ -1,4 +1,4 @@
USING: browser.parser kernel tools.test ;
USING: html.parser kernel tools.test ;
IN: temporary
[

View File

@ -1,8 +1,7 @@
USING: arrays browser.utils hashtables io kernel namespaces
prettyprint quotations
USING: arrays html.parser.utils hashtables io kernel
namespaces prettyprint quotations
sequences splitting state-parser strings ;
USE: tools.interpreter
IN: browser.parser
IN: html.parser
TUPLE: tag name attributes text matched? closing? ;
@ -121,7 +120,7 @@ SYMBOL: tagstack
] unless ;
: parse-attributes ( -- hashtable )
[ (parse-attributes) ] { } make >hashtable ;
[ (parse-attributes) ] { } make >hashtable ;
: (parse-tag)
[

View File

@ -1,9 +1,9 @@
USING: assocs browser.parser browser.utils combinators
USING: assocs html.parser html.parser.utils combinators
continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
IN: browser.printer
IN: html.parser.printer
SYMBOL: no-section
SYMBOL: html
@ -42,7 +42,7 @@ HOOK: print-closing-named-tag printer ( tag -- )
M: printer print-text-tag ( tag -- )
tag-text write ;
M: printer print-comment-tag ( tag -- )
M: printer print-comment-tag ( tag -- )
"<!--" write
tag-text write
"-->" write ;
@ -67,7 +67,6 @@ M: printer print-closing-named-tag ( tag -- )
[
swap bl write "=" write ?quote write
] assoc-each ;
M: src-printer print-opening-named-tag ( tag -- )
"<" write
@ -102,7 +101,7 @@ SYMBOL: tablestack
[
V{ } clone tablestack set
] with-scope ;
! { { 1 2 } { 3 4 } }
! H{ { table-gap { 10 10 } } } [
! [ [ [ [ . ] with-cell ] each ] with-row ] each

View File

@ -2,7 +2,7 @@ USING: assocs combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings tools.test ;
USING: browser.utils ;
USING: html.parser.utils ;
IN: temporary
[ "'Rome'" ] [ "Rome" single-quote ] unit-test

View File

@ -2,8 +2,8 @@ USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
USING: browser.parser ;
IN: browser.utils
USING: html.parser ;
IN: html.parser.utils
: string-parse-end?
get-next not ;

View File

@ -20,7 +20,7 @@ IN: http
dup letter?
over LETTER? or
over digit? or
swap "/_?." member? or ; foldable
swap "/_-?." member? or ; foldable
: url-encode ( str -- str )
[

View File

@ -2,7 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: arrays combinators io io.binary io.files io.utf16 kernel math math.parser namespaces sequences splitting strings assocs ;
USING: arrays combinators io io.binary io.files io.paths
io.utf16 kernel math math.parser namespaces sequences
splitting strings assocs ;
IN: id3
@ -121,18 +123,6 @@ C: <extended-header> extended-header
: id3v2 ( filename -- tag/f )
<file-reader> [ read-tag ] with-stream ;
: append-path ( path files -- paths )
[ path+ ] curry* map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [ get-paths dup % [ (walk-dir) ] each ] [ drop ] if ;
: walk-dir ( path -- seq )
[ (walk-dir) ] { } make ;
: file? ( path -- ? )
stat 3drop not ;

View File

@ -1,18 +1,9 @@
USING: kernel words inspector slots quotations sequences assocs
math arrays inference effects shuffle continuations debugger
tuples namespaces vectors bit-arrays byte-arrays strings sbufs
math.functions macros ;
math.functions macros combinators.private combinators ;
IN: inverse
: (repeat) ( from to quot -- )
pick pick >= [
3drop
] [
[ swap >r call 1+ r> ] keep (repeat)
] if ; inline
: repeat ( n quot -- ) 0 -rot (repeat) ; inline
TUPLE: fail ;
: fail ( -- * ) \ fail construct-empty throw ;
M: fail summary drop "Unification failed" ;
@ -27,17 +18,12 @@ M: fail summary drop "Unification failed" ;
: define-inverse ( word quot -- ) "inverse" set-word-prop ;
: define-math-inverse ( word quot1 quot2 -- )
2array "math-inverse" set-word-prop ;
pick 1quotation 3array "math-inverse" set-word-prop ;
: define-pop-inverse ( word n quot -- )
>r dupd "pop-length" set-word-prop r>
"pop-inverse" set-word-prop ;
DEFER: [undo]
: make-inverse ( word -- quot )
word-def [undo] ;
TUPLE: no-inverse word ;
: no-inverse ( word -- * ) \ no-inverse construct-empty throw ;
M: no-inverse summary
@ -54,10 +40,7 @@ M: no-inverse summary
effect-in length 0 = and ;
: assure-constant ( constant -- quot )
dup word? [
dup constant-word?
[ "Badly formed math inverse" throw ] unless
] when 1quotation ;
dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
: swap-inverse ( math-inverse revquot -- revquot* quot )
next assure-constant rot second [ swap ] swap 3compose ;
@ -68,25 +51,52 @@ M: no-inverse summary
: ?word-prop ( word/object name -- value/f )
over word? [ word-prop ] [ 2drop f ] if ;
GENERIC: inverse ( revquot word -- revquot* quot )
M: word inverse
dup "inverse" word-prop [ ]
[ dup primitive? [ no-inverse ] [ make-inverse ] if ] ?if ;
: undo-literal ( object -- quot )
[ =/fail ] curry ;
PREDICATE: word normal-inverse "inverse" word-prop ;
PREDICATE: word math-inverse "math-inverse" word-prop ;
PREDICATE: word pop-inverse "pop-length" word-prop ;
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: inline-word ( word -- )
{
{ [ dup word? not over symbol? or ] [ , ] }
{ [ dup explicit-inverse? ] [ , ] }
{ [ dup compound? over { if dispatch } member? not and ]
[ word-def [ inline-word ] each ] }
{ [ drop t ] [ "Quotation is not invertible" throw ] }
} cond ;
: math-exp? ( n n word -- ? )
{ + - * / ^ } member? -rot [ number? ] 2apply and and ;
: (fold-constants) ( quot -- )
dup length 3 < [ % ] [
dup first3 3dup math-exp?
[ execute , 3 ] [ 2drop , 1 ] if
tail-slice (fold-constants)
] if ;
: fold-constants ( quot -- folded )
[ (fold-constants) ] [ ] make ;
: do-inlining ( quot -- inlined-quot )
[ [ inline-word ] each ] [ ] make fold-constants ;
GENERIC: inverse ( revquot word -- revquot* quot )
M: object inverse undo-literal ;
M: symbol inverse undo-literal ;
PREDICATE: word math-inverse "math-inverse" word-prop ;
M: normal-inverse inverse
"inverse" word-prop ;
M: math-inverse inverse
"math-inverse" word-prop
swap next dup \ swap =
[ drop swap-inverse ] [ pull-inverse ] if ;
PREDICATE: word pop-inverse "pop-length" word-prop ;
M: pop-inverse inverse
[ "pop-length" word-prop cut-slice swap ] keep
"pop-inverse" word-prop compose call ;
@ -96,11 +106,11 @@ M: pop-inverse inverse
[ unclip-slice inverse % (undo) ] if ;
: [undo] ( quot -- undo )
reverse [ (undo) ] [ ] make ;
do-inlining reverse [ (undo) ] [ ] make ;
MACRO: undo ( quot -- ) [undo] ;
! Inversions of selected words
! Inverse of selected words
\ swap [ swap ] define-inverse
\ dup [ [ =/fail ] keep ] define-inverse

View File

@ -0,0 +1,24 @@
USING: assocs io.files kernel namespaces sequences ;
IN: io.paths
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] curry* map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;

View File

@ -0,0 +1,33 @@
IN: temporary
USING: io.unix.launcher tools.test ;
[ "" tokenize-command ] unit-test-fails
[ " " tokenize-command ] unit-test-fails
[ { "a" } ] [ "a" tokenize-command ] unit-test
[ { "abc" } ] [ "abc" tokenize-command ] unit-test
[ { "abc" } ] [ "abc " tokenize-command ] unit-test
[ { "abc" } ] [ " abc" tokenize-command ] unit-test
[ { "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
[ { "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
[ { "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
[ { "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
[ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
[ "'abc def' \"hey" tokenize-command ] unit-test-fails
[ "'abc def" tokenize-command ] unit-test-fails
[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
[
{
"Hello world.app/Contents/MacOS/hello-ui"
"-i=boot.macosx-ppc.image"
"-include= math compiler ui"
"-deploy-vocab=hello-ui"
"-output-image=Hello world.app/Contents/Resources/hello-ui.image"
"-no-stack-traces"
"-no-user-init"
}
] [
"\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
] unit-test

38
extra/io/unix/launcher/launcher.factor Normal file → Executable file
View File

@ -2,17 +2,45 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io io.launcher io.unix.backend io.nonblocking
sequences kernel namespaces math system alien.c-types
debugger continuations arrays assocs combinators unix.process ;
debugger continuations arrays assocs combinators unix.process
parser-combinators memoize promises strings ;
IN: io.unix.launcher
! Search unix first
USE: unix
: get-arguments ( -- seq )
+command+ get
[ "/bin/sh" "-c" rot 3array ] [ +arguments+ get ] if* ;
! Our command line parser. Supported syntax:
! foo bar baz -- simple tokens
! foo\ bar -- escaping the space
! 'foo bar' -- quotation
! "foo bar" -- quotation
LAZY: 'escaped-char' "\\" token any-char-parser &> ;
: assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ;
LAZY: 'quoted-char' ( delimiter -- parser' )
'escaped-char'
swap [ member? not ] curry satisfy
<|> ; inline
LAZY: 'quoted' ( delimiter -- parser )
dup 'quoted-char' <!*> swap dup surrounded-by ;
LAZY: 'unquoted' ( -- parser ) " '\"" 'quoted-char' <!+> ;
LAZY: 'argument' ( -- parser )
"\"" 'quoted' "'" 'quoted' 'unquoted' <|> <|>
[ >string ] <@ ;
MEMO: 'arguments' ( -- parser )
'argument' " " token <!+> nonempty-list-of ;
: tokenize-command ( command -- arguments )
'arguments' just parse-1 ;
: get-arguments ( -- seq )
+command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
: assoc>env ( assoc -- env )
[ "=" swap 3append ] { } assoc>map ;
: (spawn-process) ( -- )
[

View File

@ -13,7 +13,7 @@ IN: io.unix.mmap
M: unix-io <mapped-file> ( path length -- obj )
swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
r> mmap-open \ mapped-file construct-boa ;
r> mmap-open f mapped-file construct-boa ;
M: unix-io (close-mapped-file) ( mmap -- )
[ mapped-file-address ] keep

View File

@ -7,7 +7,8 @@ IN: windows.ce.files
! M: windows-ce-io normalize-pathname ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
FILE_ATTRIBUTE_NORMAL bitor ;
M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- )

View File

@ -53,8 +53,11 @@ TUPLE: CreateProcess-args
CreateProcess-args-lpProcessInformation
} get-slots CreateProcess win32-error=0/f ;
: escape-argument ( str -- newstr )
[ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ;
: join-arguments ( args -- cmd-line )
[ "\"" swap "\"" 3append ] map " " join ;
[ "\"" swap escape-argument "\"" 3append ] map " " join ;
: app-name/cmd-line ( -- app-name cmd-line )
+command+ get [
@ -84,9 +87,9 @@ TUPLE: CreateProcess-args
pass-environment? [
[
get-environment
[ swap % "=" % % "\0" % ] assoc-each
[ "=" swap 3append string>u16-alien % ] assoc-each
"\0" %
] "" make >c-ushort-array
] { } make >c-ushort-array
over set-CreateProcess-args-lpEnvironment
] when ;

View File

@ -62,7 +62,7 @@ M: windows-ce-io with-privileges
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
>r >r open-file dup f r> 0 0 f
>r >r 0 open-file dup f r> 0 0 f
CreateFileMapping [ win32-error=0/f ] keep
dup close-later
dup

View File

@ -27,7 +27,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
{ [ dup ".\\" head? ] [
>r unicode-prefix cwd r> 1 tail 3append
] }
! c:\\
! c:\\foo
{ [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
! \\\\?\\c:\\foo
{ [ dup unicode-prefix head? ] [ ] }
@ -38,7 +38,8 @@ M: windows-nt-io normalize-pathname ( string -- string )
dup first CHAR: \\ = [ CHAR: \\ , ] unless %
] "" make
] }
} cond [ "/\\." member? ] right-trim ;
} cond [ "/\\." member? ] right-trim
dup peek CHAR: : = [ "\\" append ] when ;
SYMBOL: io-hash

View File

@ -3,8 +3,8 @@ io.windows.nt io.windows.nt.backend kernel libc math
threads windows windows.kernel32 ;
IN: io.windows.nt.files
M: windows-nt-io CreateFile-flags ( -- DWORD )
FILE_FLAG_OVERLAPPED ;
M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
make-overlapped ;

View File

@ -4,7 +4,7 @@ USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings io.streams.duplex kernel
math namespaces sequences windows windows.kernel32
windows.winsock splitting ;
windows.shell32 windows.winsock splitting ;
IN: io.windows
TUPLE: windows-nt-io ;
@ -23,7 +23,7 @@ TUPLE: win32-file handle ptr overlapped ;
: <win32-duplex-stream> ( in out -- stream )
>r f <win32-file> r> f <win32-file> handle>duplex-stream ;
HOOK: CreateFile-flags io-backend ( -- DWORD )
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
@ -31,7 +31,8 @@ M: windows-io normalize-directory ( string -- string )
"\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
FILE_SHARE_READ FILE_SHARE_WRITE bitor ; inline
FILE_SHARE_READ FILE_SHARE_WRITE bitor
FILE_SHARE_DELETE bitor ; foldable
M: win32-file init-handle ( handle -- )
drop ;
@ -40,24 +41,25 @@ M: win32-file close-handle ( handle -- )
win32-file-handle CloseHandle drop ;
! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode -- handle )
: open-file ( path access-mode create-mode flags -- handle )
[
>r share-mode f r> CreateFile-flags f CreateFile
>r >r >r normalize-pathname r>
share-mode f r> r> CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
: open-pipe-r/w ( path -- handle )
GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING open-file ;
GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING 0 open-file ;
: open-read ( path -- handle length )
normalize-pathname GENERIC_READ OPEN_EXISTING open-file 0 ;
GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
: open-write ( path -- handle length )
normalize-pathname GENERIC_WRITE CREATE_ALWAYS open-file 0 ;
GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
: (open-append) ( path -- handle )
normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
: set-file-pointer ( handle length -- )
dupd d>w/w <uint> FILE_BEGIN SetFilePointer
@ -109,12 +111,14 @@ M: windows-io <file-appender> ( path -- stream )
open-append <win32-file> <writer> ;
M: windows-io rename-file ( from to -- )
[ normalize-pathname ] 2apply
MoveFile win32-error=0/f ;
[ normalize-pathname ] 2apply MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- )
normalize-pathname
DeleteFile win32-error=0/f ;
normalize-pathname DeleteFile win32-error=0/f ;
M: windows-io copy-file ( from to -- )
dup parent-directory make-directories
[ normalize-pathname ] 2apply 0 CopyFile win32-error=0/f ;
M: windows-io make-directory ( path -- )
normalize-pathname

View File

@ -12,4 +12,4 @@ IN: temporary
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
[ { 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test

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