Merge branch 'master' into hashcode
commit
2e144daa6e
4
Makefile
4
Makefile
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )"
|
||||
|
|
|
@ -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? [
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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? ( -- ? )
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Eric Mertens
|
File diff suppressed because it is too large
Load Diff
|
@ -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
|
|
@ -0,0 +1,2 @@
|
|||
The Great Computer Language Shootout's knucleotide benchmark to test
|
||||
hashtables.
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ( -- )
|
||||
|
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
|
@ -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" }
|
|
@ -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
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
Delegation and mimicking on top of the Factor object system
|
|
@ -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
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
EditPadPro editor integration
|
|
@ -0,0 +1 @@
|
|||
Aaron Schaefer
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
EditPlus editor integration
|
|
@ -0,0 +1 @@
|
|||
Emacs editor integration
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
EmEditor integration
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
gVim editor integration
|
|
@ -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* ;
|
|
@ -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* ;
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
Notepad++ editor integration
|
|
@ -0,0 +1 @@
|
|||
SciTE editor integration
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1 @@
|
|||
TED Notepad integration
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
Textmate editor integration
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1 @@
|
|||
UltraEdit editor integration
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
Vim editor integration
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1 @@
|
|||
Wordpad editor integration
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
||||
|
|
|
@ -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> ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Unix shell-style glob pattern matching
|
|
@ -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 )
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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)" }
|
||||
|
|
18
extra/browser/analyzer/analyzer.factor → extra/html/parser/analyzer/analyzer.factor
Normal file → Executable file
18
extra/browser/analyzer/analyzer.factor → extra/html/parser/analyzer/analyzer.factor
Normal file → Executable 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
|
|
@ -1,4 +1,4 @@
|
|||
USING: browser.parser kernel tools.test ;
|
||||
USING: html.parser kernel tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[
|
|
@ -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)
|
||||
[
|
|
@ -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
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
|
@ -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
|
|
@ -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) ( -- )
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
Loading…
Reference in New Issue