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

Resolve conflict

release
U-SLAVA-FB3999113\Slava 2007-10-21 15:28:35 -04:00
parent 507d0ca150 1ccca6cac0
commit 024cf03a1b
48 changed files with 424 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
core/bootstrap/image/image.factor
View File

@ -153,17 +153,11 @@ GENERIC: ' ( obj -- ptr )
: bignum-radix bignum-bits 2^ 1- ;
: (bignum>seq) ( n -- )
dup zero? [
drop
] [
dup bignum-radix bitand ,
bignum-bits neg shift (bignum>seq)
] if ;
: bignum>seq ( n -- seq )
#! n is positive or zero.
[ (bignum>seq) ] { } make ;
[ dup 0 > ]
[ dup bignum-bits neg shift swap bignum-radix bitand ]
{ } unfold ;
: emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq

10
core/classes/classes.factor
View File

@ -127,15 +127,13 @@ DEFER: (class<)
curry* subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
: (sort-classes) ( vec -- )
dup empty?
[ drop ]
[ dup largest-class , over delete-nth (sort-classes) ] if ;
PRIVATE>
: sort-classes ( seq -- newseq )
[ >vector (sort-classes) ] { } make ;
>vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
{ } unfold ;
: class-or ( class1 class2 -- class )
{

5
core/cpu/x86/assembler/assembler.factor
View File

@ -255,9 +255,8 @@ UNION: operand register indirect ;
: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
: opcode-or ( opcode mask -- opcode' )
over array?
[ 1 rot cut* first rot bitor add ]
[ bitor ] if ;
swap dup array?
[ 1 cut* first rot bitor add ] [ bitor ] if ;
: 1-operand ( op reg rex.w opcode -- )
#! The 'reg' is not really a register, but a value for the

2
core/effects/effects.factor
View File

@ -53,7 +53,7 @@ M: effect clone
[ effect-in clone ] keep effect-out clone <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
effect-in length swap cut* ;
effect-in length cut* ;
: load-shuffle ( stack shuffle -- )
effect-in [ set ] 2each ;

2
core/generator/registers/registers.factor
View File

@ -296,7 +296,7 @@ M: phantom-retainstack finalize-height
GENERIC: cut-phantom ( n phantom -- seq )
M: phantom-stack cut-phantom
[ delegate cut* swap ] keep set-delegate ;
[ delegate swap cut* swap ] keep set-delegate ;
: phantom-append ( seq stack -- )
over length over adjust-phantom push-all ;

4
core/io/io.factor
View File

@ -85,10 +85,8 @@ SYMBOL: stdio
: write-object ( str obj -- )
presented associate format ;
: lines-loop ( -- ) readln [ , lines-loop ] when* ;
: lines ( stream -- seq )
[ [ lines-loop ] { } make ] with-stream ;
[ [ readln dup ] [ ] { } unfold ] with-stream ;
: contents ( stream -- str )
2048 <sbuf> [ stream-copy ] keep >string ;

5
core/kernel/kernel.factor
View File

@ -60,6 +60,11 @@ DEFER: if
: 2apply ( x y quot -- ) tuck 2slip call ; inline
: while ( pred body tail -- )
>r >r dup slip r> r> roll
[ >r tuck 2slip r> while ]
[ 2nip call ] if ; inline
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )

4
core/prettyprint/backend/backend.factor
View File

@ -44,10 +44,10 @@ M: word pprint*
dup parsing? [
\ POSTPONE: [ pprint-word ] pprint-prefix
] [
dup "break-before" word-prop break
dup "break-before" word-prop line-break
dup pprint-word
dup ?start-group dup ?end-group
"break-after" word-prop break
"break-after" word-prop line-break
] if ;
M: real pprint* number>string text ;

2
core/prettyprint/prettyprint-docs.factor
View File

@ -72,7 +72,7 @@ $nl
"Once the output sections have been generated, the tree of sections is traversed and intelligent decisions are made about indentation and line breaks. Finally, text is output."
{ $subsection section }
"Adding leaf sections:"
{ $subsection break }
{ $subsection line-break }
{ $subsection text }
{ $subsection styled-text }
"Nesting and denesting sections:"

4
core/prettyprint/prettyprint.factor
View File

@ -120,7 +120,7 @@ SYMBOL: ->
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
1+ swap cut [ (remove-breakpoints) ] 2apply
1+ cut [ (remove-breakpoints) ] 2apply
[ -> ] swap 3append
] [
drop
@ -227,7 +227,7 @@ M: mixin-class see-class*
\ MIXIN: pprint-word
dup pprint-word <block
dup members [
hard break
hard line-break
\ INSTANCE: pprint-word pprint-word pprint-word
] curry* each block> ;

14
core/prettyprint/sections/sections-docs.factor
View File

@ -30,10 +30,10 @@ HELP: fresh-line
{ $description "Advances the prettyprinter by one line unless the current line is empty. If the line limit is exceeded, escapes the prettyprinter by restoring a continuation captured in " { $link do-pprint } "." } ;
HELP: soft
{ $description "Possible input parameter to " { $link break } "." } ;
{ $description "Possible input parameter to " { $link line-break } "." } ;
HELP: hard
{ $description "Possible input parameter to " { $link break } "." } ;
{ $description "Possible input parameter to " { $link line-break } "." } ;
{ soft hard } related-words
@ -70,7 +70,7 @@ HELP: section
{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various classes which delegate to this class:"
{ $list
{ $link text }
{ $link break }
{ $link line-break }
{ $link block }
{ $link inset }
{ $link flow }
@ -123,7 +123,7 @@ HELP: pprint-section
{ $contract "Prints a section, performing wrapping and indentation using available formatting information." }
$prettyprinting-note ;
HELP: break
HELP: line-break
{ $values { "type" { $link soft } " or " { $link hard } } }
{ $description "Adds a section introducing a line break to the current block. If the block is output as a " { $link short-section } ", all breaks are ignored. Otherwise, hard breaks introduce unconditional newlines, and soft breaks introduce a newline if the position is more than half of the " { $link margin } "." }
$prettyprinting-note ;
@ -158,11 +158,11 @@ HELP: save-end-position
HELP: pprint-sections
{ $values { "block" block } { "advancer" "a quotation with stack effect " { $snippet "( block -- )" } } }
{ $description "Prints child sections of a block, ignoring any " { $link break } " sections. The " { $snippet "advancer" } " quotation is called between every pair of sections." } ;
{ $description "Prints child sections of a block, ignoring any " { $link line-break } " sections. The " { $snippet "advancer" } " quotation is called between every pair of sections." } ;
HELP: do-break
{ $values { "break" break } }
{ $description "Prints a break section as per the policy outlined in " { $link break } "." } ;
{ $values { "break" line-break } }
{ $description "Prints a break section as per the policy outlined in " { $link line-break } "." } ;
HELP: empty-block?
{ $values { "block" block } { "?" "a boolean" } }

24
core/prettyprint/sections/sections.factor
View File

@ -124,15 +124,16 @@ M: object short-section? section-fits? ;
] if ;
! Break section
TUPLE: break type ;
TUPLE: line-break type ;
: <break> ( type -- section )
: <line-break> ( type -- section )
H{ } 0 <section>
{ set-break-type set-delegate } \ break construct ;
{ set-line-break-type set-delegate }
\ line-break construct ;
M: break short-section drop ;
M: line-break short-section drop ;
M: break long-section drop ;
M: line-break long-section drop ;
! Block sections
TUPLE: block sections ;
@ -149,7 +150,8 @@ TUPLE: block sections ;
pprinter-block block-sections push ;
: last-section ( -- section )
pprinter-block block-sections [ break? not ] find-last nip ;
pprinter-block block-sections
[ line-break? not ] find-last nip ;
: start-group ( -- )
t last-section set-section-start-group? ;
@ -162,13 +164,13 @@ TUPLE: block sections ;
swap short-section? and
[ bl ] when ;
: break ( type -- ) [ <break> add-section ] when* ;
: line-break ( type -- ) [ <line-break> add-section ] when* ;
M: block section-fits? ( section -- ? )
line-limit? [ drop t ] [ delegate section-fits? ] if ;
: pprint-sections ( block advancer -- )
swap block-sections [ break? not ] subset
swap block-sections [ line-break? not ] subset
unclip pprint-section [
dup rot call pprint-section
] curry* each ; inline
@ -177,7 +179,7 @@ M: block short-section ( block -- )
[ advance ] pprint-sections ;
: do-break ( break -- )
dup break-type hard eq?
dup line-break-type hard eq?
over section-end last-newline get - margin get 2/ > or
[ <fresh-line ] [ drop ] if ;
@ -284,7 +286,7 @@ M: colon unindent-first-line? drop t ;
! Long section layout algorithm
: chop-break ( seq -- seq )
dup peek break? [ 1 head-slice* chop-break ] when ;
dup peek line-break? [ 1 head-slice* chop-break ] when ;
SYMBOL: prev
SYMBOL: next
@ -322,7 +324,7 @@ M: block long-section ( block -- )
[
block-sections chop-break group-flow [
dup ?break-group [
dup break? [
dup line-break? [
do-break
] [
dup advance pprint-section

6
core/sequences/sequences-docs.factor
View File

@ -904,17 +904,17 @@ HELP: tail?
{ delete-nth remove delete } related-words
HELP: cut-slice
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "before" sequence } { "after" "a slice" } }
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before" sequence } { "after" "a slice" } }
{ $description "Outputs a pair of sequences, where " { $snippet "before" } " consists of the first " { $snippet "n" } " elements of " { $snippet "seq" } " and has the same type, while " { $snippet "after" } " is a slice of the remaining elements." }
{ $notes "Unlike " { $link cut } ", the run time of this word is proportional to the length of " { $snippet "before" } ", not " { $snippet "after" } ", so it is suitable for use in an iterative algorithm which cuts successive pieces off a sequence." } ;
HELP: cut
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "before" sequence } { "after" sequence } }
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before" sequence } { "after" sequence } }
{ $description "Outputs a pair of sequences, where " { $snippet "before" } " consists of the first " { $snippet "n" } " elements of " { $snippet "seq" } ", while " { $snippet "after" } " holds the remaining elements. Both output sequences have the same type as " { $snippet "seq" } "." }
{ $notes "Since this word copies the entire tail of the sequence, it should not be used in a loop. If this is important, consider using " { $link cut-slice } " instead, since it returns a slice for the tail instead of copying." } ;
HELP: cut*
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "before" sequence } { "after" sequence } }
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before" sequence } { "after" sequence } }
{ $description "Outputs a pair of sequences, where " { $snippet "after" } " consists of the last " { $snippet "n" } " elements of " { $snippet "seq" } ", while " { $snippet "before" } " holds the remaining elements. Both output sequences have the same type as " { $snippet "seq" } "." } ;
HELP: start*

19
core/sequences/sequences.factor
View File

@ -414,6 +414,13 @@ PRIVATE>
: interleave ( seq between quot -- )
[ (interleave) ] 2curry iterate-seq 2each ; inline
: unfold ( obj pred quot exemplar -- seq )
[
10 swap new-resizable [
[ push ] curry compose [ drop ] while
] keep
] keep like ; inline
: index ( obj seq -- n )
[ = ] curry* find drop ;
@ -604,14 +611,14 @@ M: sequence <=>
tuck length tail-slice* sequence=
] if ;
: cut-slice ( n seq -- before after )
swap [ head ] 2keep tail-slice ;
: cut-slice ( seq n -- before after )
[ head ] 2keep tail-slice ;
: cut ( n seq -- before after )
swap [ head ] 2keep tail ;
: cut ( seq n -- before after )
[ head ] 2keep tail ;
: cut* ( n seq -- before after )
swap [ head* ] 2keep tail* ;
: cut* ( seq n -- before after )
[ head* ] 2keep tail* ;
<PRIVATE

5
core/tuples/tuples.factor
View File

@ -30,7 +30,7 @@ M: tuple class class-of-tuple ;
swap [ index ] curry map ;
: reshape-tuple ( oldtuple permutation -- newtuple )
>r tuple>array 2 swap cut r>
>r tuple>array 2 cut r>
[ [ swap ?nth ] [ drop f ] if* ] curry* map
append (>tuple) ;
@ -106,7 +106,8 @@ M: tuple equal?
: (delegates) ( obj -- )
[ dup , delegate (delegates) ] when* ;
: delegates ( obj -- seq ) [ (delegates) ] { } make ;
: delegates ( obj -- seq )
[ dup ] [ [ delegate ] keep ] { } unfold ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline

2
extra/base64/base64.factor
View File

@ -33,7 +33,7 @@ PRIVATE>
: >base64 ( seq -- base64 )
#! cut string into two pieces, convert 3 bytes at a time
#! pad string with = when not enough bits
[ length dup 3 mod - ] keep cut swap
dup length dup 3 mod - cut swap
[
3 group [ encode3 % ] each
dup empty? [ drop ] [ >base64-rem % ] if

12
extra/concurrency/concurrency.factor
View File

@ -40,17 +40,11 @@ PRIVATE>
(mailbox-block-if-empty)
mailbox-data dlist-pop-front ;
<PRIVATE
: (mailbox-get-all) ( mailbox -- )
dup mailbox-empty? [
drop
] [
dup mailbox-data dlist-pop-front , (mailbox-get-all)
] if ;
PRIVATE>
: mailbox-get-all ( mailbox -- array )
(mailbox-block-if-empty)
[ (mailbox-get-all) ] { } make ;
[ dup mailbox-empty? ]
[ dup mailbox-data dlist-pop-front ]
{ } unfold ;
: while-mailbox-empty ( mailbox quot -- )
over mailbox-empty? [

38
extra/destructors/destructors-docs.factor
View File

@ -1,25 +1,31 @@
USING: help.markup help.syntax kernel destructors ;
USING: help.markup help.syntax libc kernel destructors ;
IN: destructors
HELP: add-destructor
{ $values { "obj" "an object" }
{ "quot" "a quotation" }
{ "always?" "always cleanup?" }
} { $description "Adds a destructor to be invoked by the " { $link call-destructors } " word to the current dynamic scope. Setting the 'always cleanup?' flag to f allows for keeping resources, such as a successfully opened file descriptor, open after a call to " { $link with-destructors } "." }
{ $notes "The use of the " { $link with-destructors } " word is preferred over calling " { $link call-destructors } " manually." $nl
"Destructors are not allowed to throw exceptions. No exceptions." }
{ $see-also call-destructors with-destructors } ;
HELP: free-always
{ $values { "alien" "alien returned by malloc" } }
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " ends." }
{ $see-also free-later } ;
HELP: call-destructors
{ $description "Iterates through a sequence of destructor tuples, calling the destructor quotation on each one." }
{ $notes "The use of the " { $link with-destructors } " word is preferred over calling " { $link call-destructors } " manually." }
{ $see-also add-destructor with-destructors } ;
HELP: free-later
{ $values { "alien" "alien returned by malloc" } }
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." }
{ $see-also free-always } ;
HELP: close-always
{ $values { "handle" "an OS-dependent handle" } }
{ $description "Adds a destructor that will close the system resource upon reaching the end of the quotation passed to " { $link with-destructors } "." }
{ $see-also close-later } ;
HELP: close-later
{ $values { "handle" "an OS-dependent handle" } }
{ $description "Adds a destructor that will close the system resource if an error occurs in the quotation passed to " { $link with-destructors } ". Otherwise, manual cleanup of the resource is required later." }
{ $see-also close-always } ;
HELP: with-destructors
{ $values { "quot" "a quotation" } }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by calling " { $link add-destructor } ". After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link (destruct) } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
{ $examples
{ $code "[ 10 malloc dup [ free \"free 10 bytes\" print ] t add-destructor drop ] with-destructors" }
{ $code "[ 10 malloc free-always ] with-destructors" }
}
{ $see-also add-destructor call-destructors } ;
{ $see-also } ;

24
extra/destructors/destructors-tests.factor
View File

@ -3,27 +3,39 @@ IN: temporary
TUPLE: dummy-obj destroyed? ;
TUPLE: dummy-destructor ;
: <dummy-destructor> ( obj ? -- newobj )
<destructor> dummy-destructor construct-delegate ;
M: dummy-destructor (destruct) ( obj -- )
destructor-obj t swap set-dummy-obj-destroyed? ;
: <dummy-obj>
\ dummy-obj construct-empty ;
: destroy-always
t <dummy-destructor> push-destructor ;
: destroy-later
f <dummy-destructor> push-destructor ;
[ t ] [
[
<dummy-obj>
dup [ t swap set-dummy-obj-destroyed? ] t add-destructor
<dummy-obj> dup destroy-always
] with-destructors dummy-obj-destroyed?
] unit-test
[ f ] [
[
<dummy-obj>
dup [ t swap set-dummy-obj-destroyed? ] f add-destructor
<dummy-obj> dup destroy-later
] with-destructors dummy-obj-destroyed?
] unit-test
[ t ] [
<dummy-obj> [
[
dup [ t swap set-dummy-obj-destroyed? ] t add-destructor
dup destroy-always
"foo" throw
] with-destructors
] catch drop dummy-obj-destroyed?
@ -32,7 +44,7 @@ TUPLE: dummy-obj destroyed? ;
[ t ] [
<dummy-obj> [
[
dup [ t swap set-dummy-obj-destroyed? ] f add-destructor
dup destroy-later
"foo" throw
] with-destructors
] catch drop dummy-obj-destroyed?

88
extra/destructors/destructors.factor Normal file → Executable file
View File

@ -1,38 +1,90 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations kernel namespaces sequences vectors ;
USING: continuations io.backend libc kernel namespaces
sequences system vectors ;
IN: destructors
SYMBOL: destructors
SYMBOL: errored?
TUPLE: destructor obj quot always? ;
<PRIVATE
TUPLE: destructor obj always? destroyed? ;
: filter-destructors ( -- )
errored? get [
destructors [ [ destructor-always? ] subset ] change
] unless ;
: <destructor> ( obj always? -- newobj )
{
set-destructor-obj
set-destructor-always?
} destructor construct ;
PRIVATE>
: push-destructor ( obj -- )
destructors [ ?push ] change ;
: add-destructor ( obj quot always? -- )
\ destructor construct-boa destructors [ ?push ] change ;
GENERIC: (destruct) ( obj -- )
: call-destructors ( -- )
destructors get [
dup destructor-obj swap destructor-quot call
] each ;
: destruct ( obj -- )
dup destructor-destroyed? [
drop
] [
[ (destruct) t ] keep set-destructor-destroyed?
] if ;
: destruct-always ( destructor -- )
dup destructor-always? [
destruct
] [
drop
] if ;
: with-destructors ( quot -- )
[
[ call ] [ errored? on ] recover
filter-destructors call-destructors
errored? get [ rethrow ] when
[ call ]
[ destructors get [ destruct-always ] each ]
[ destructors get [ destruct ] each ] cleanup
] with-scope ; inline
TUPLE: memory-destructor ;
: <memory-destructor> ( obj ? -- newobj )
<destructor> memory-destructor construct-delegate ;
TUPLE: handle-destructor ;
: <handle-destructor> ( obj ? -- newobj )
<destructor> handle-destructor construct-delegate ;
TUPLE: socket-destructor ;
: <socket-destructor> ( obj ? -- newobj )
<destructor> socket-destructor construct-delegate ;
M: memory-destructor (destruct) ( obj -- )
destructor-obj free ;
HOOK: (handle-destructor) io-backend ( obj -- )
HOOK: (socket-destructor) io-backend ( obj -- )
M: handle-destructor (destruct) ( obj -- ) (handle-destructor) ;
M: socket-destructor (destruct) ( obj -- ) (socket-destructor) ;
: free-always ( alien -- )
t <memory-destructor> push-destructor ;
: free-later ( alien -- )
f <memory-destructor> push-destructor ;
: close-always ( handle -- )
t <handle-destructor> push-destructor ;
: close-later ( handle -- )
f <handle-destructor> push-destructor ;
: close-socket-always ( handle -- )
t <socket-destructor> push-destructor ;
: close-socket-later ( handle -- )
f <socket-destructor> push-destructor ;
! : add-destructor ( word quot -- )
! >quotation
! "slot-destructor" set-word-prop ;

5
extra/help/crossref/crossref.factor
View File

@ -13,11 +13,8 @@ M: link uses
{ $subsection $link $see-also }
collect-elements [ \ f or ] map ;
: (help-path) ( topic -- )
article-parent [ dup , (help-path) ] when* ;
: help-path ( topic -- seq )
[ (help-path) ] { } make ;
[ dup ] [ [ article-parent ] keep ] { } unfold 1 tail ;
: set-article-parents ( parent article -- )
article-children [ set-article-parent ] curry* each ;

2
extra/help/markup/markup.factor
View File

@ -113,7 +113,7 @@ M: f print-element drop ;
"Examples" $heading print-element ;
: $example ( element -- )
1 swap cut* swap "\n" join dup <input> [
1 cut* swap "\n" join dup <input> [
input-style get format nl print-element
] ($code) ;

7
extra/html/html.factor Normal file → Executable file
View File

@ -35,8 +35,11 @@ TUPLE: html-sub-stream style stream ;
stdio get delegate stream-write ;
: object-link-tag ( style quot -- )
presented pick at browser-link-href
[ <a =href a> call </a> ] [ call ] if* ; inline
presented pick at [
browser-link-href [
<a =href a> call </a>
] [ call ] if*
] [ call ] if* ; inline
: hex-color, ( triplet -- )
3 head-slice

7
extra/io/sniffer/bsd/bsd.factor
View File

@ -7,6 +7,9 @@ sequences ;
QUALIFIED: unix
IN: io.sniffer.bsd
M: unix-io (handle-destructor) ( obj -- )
destructor-obj close drop ;
C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ;
C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ;
@ -50,7 +53,7 @@ C: <sniffer-spec> sniffer-spec
: make-ifreq-props ( ifname -- ifreq )
"ifreq" <c-object>
12 <short> 16 0 pad-right over set-ifreq-props
swap malloc-char-string dup [ free ] t add-destructor
swap malloc-char-string dup free-always
over set-ifreq-name ;
: make-ioctl-buffer ( fd -- buffer )
@ -77,7 +80,7 @@ M: unix-io <sniffer> ( obj -- sniffer )
[
sniffer-spec-path
open-read
dup [ unix:close ] f add-destructor
dup close-later
] keep
dupd sniffer-spec-ifname ioctl-sniffer-fd
dup make-ioctl-buffer

2
extra/io/sniffer/filter/bsd/bsd.factor
View File

@ -11,7 +11,7 @@ IN: io.sniffer.filter.bsd
"long" heap-size 1- [ + ] keep bitnot bitand ;
M: unix-io packet. ( string -- )
18 swap cut swap >byte-array bpfh.
18 cut swap >byte-array bpfh.
(packet.) ;
M: unix-io sniffer-loop ( stream -- )

7
extra/io/sockets/impl/impl.factor
View File

@ -94,11 +94,10 @@ M: f parse-sockaddr nip ;
swap addrinfo-family addrspec-of-family
parse-sockaddr ;
: addrspec, ( addrinfo -- )
[ dup addrinfo>addrspec , addrinfo-next addrspec, ] when* ;
: parse-addrinfo-list ( addrinfo -- seq )
[ addrspec, ] { } make [ ] subset ;
[ dup ]
[ dup addrinfo-next swap addrinfo>addrspec ]
{ } unfold [ ] subset ;
M: object resolve-host ( host serv passive? -- seq )
>r dup integer? [ number>string ] when

30
extra/io/windows/launcher/launcher.factor Normal file → Executable file
View File

@ -1,7 +1,10 @@
USING: alien alien.c-types destructors io.windows libc
USING: alien alien.c-types arrays continuations
destructors io.windows libc
io.nonblocking io.streams.duplex windows.types math
windows.kernel32 windows namespaces io.launcher kernel
io.windows.nt.backend ;
sequences io.windows.nt.backend windows.errors ;
USE: io
USE: prettyprint
IN: io.windows.launcher
! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
@ -88,35 +91,44 @@ C: <pipe> pipe
: ERROR_PIPE_CONNECT 535 ; inline
: pipe-connect-error? ( n -- ? )
ERROR_SUCCESS ERROR_PIPE_CONNECT 2array member? not ;
! clear "ls" <process-stream> contents
M: windows-nt-io <process-stream> ( command -- stream )
[
break
default-CreateProcess-args
TRUE over set-CreateProcess-args-bInheritHandles
! over set-CreateProcess-args-stdin-pipe
dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
factor-pipe-name create-named-pipe
global [ "Named pipe: " write dup . ] bind
dup t set-inherit
[ add-completion ] keep
! CreateFile
! factor-pipe-name open-pipe-r/w
factor-pipe-name GENERIC_READ GENERIC_WRITE bitor 0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f CreateFile dup invalid-handle? dup [ CloseHandle drop ] f add-destructor
factor-pipe-name GENERIC_READ GENERIC_WRITE bitor
0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f
CreateFile
global [ "Created File: " write dup . ] bind
dup invalid-handle? dup close-later
dup add-completion
swap (make-overlapped) ConnectNamedPipe zero? [
GetLastError ERROR_PIPE_CONNECT = [
GetLastError pipe-connect-error? [
win32-error-string throw
] unless
] when
] when
dup t set-inherit
! ERROR_PIPE_CONNECTED
[ pick set-CreateProcess-args-stdin-pipe ] keep
global [ "Setting the stdios to: " write dup . ] bind
[ over set-STARTUPINFO-hStdOutput ] keep
[ over set-STARTUPINFO-hStdInput ] keep
swap set-STARTUPINFO-hStdError
@ -134,7 +146,7 @@ M: windows-nt-io <process-stream> ( command -- stream )
0
CreatePipe win32-error=0/f
] 2keep
[ *void* dup [ CloseHandle ] f add-destructor ] 2apply <pipe> ;
[ *void* dup close-later ] 2apply <pipe> ;
M: windows-ce-io <process-stream>
[

8
extra/io/windows/mmap/mmap.factor
View File

@ -31,7 +31,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
"TOKEN_PRIVILEGES" <c-object>
1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
"LUID_AND_ATTRIBUTES" malloc-array
dup [ free ] t add-destructor over set-TOKEN_PRIVILEGES-Privileges
dup free-always over set-TOKEN_PRIVILEGES-Privileges
swap [
SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
@ -60,10 +60,10 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
>r >r open-file dup f r> 0 0 f
CreateFileMapping [ win32-error=0/f ] keep
dup [ CloseHandle drop ] f add-destructor
dup close-later
dup
r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep
dup [ CloseHandle drop ] f add-destructor
dup close-later
] with-privileges ;
M: windows-io <mapped-file> ( path length -- mmap )
@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
M: windows-io close-mapped-file ( mapped-file -- )
[
dup mapped-file-handle [
[ CloseHandle drop ] t add-destructor
close-always
] each
mapped-file-address UnmapViewOfFile win32-error=0/f
] with-destructors ;

2
extra/io/windows/nt/backend/backend.factor Normal file → Executable file
View File

@ -40,7 +40,7 @@ TUPLE: io-callback port continuation ;
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
"OVERLAPPED" malloc-object dup [ free ] t add-destructor
"OVERLAPPED" malloc-object dup free-always
0 over set-OVERLAPPED-internal
0 over set-OVERLAPPED-internal-high
0 over set-OVERLAPPED-offset-high

20
extra/io/windows/nt/sockets/sockets.factor Normal file → Executable file
View File

@ -81,7 +81,7 @@ TUPLE: AcceptEx-args port
: init-accept-buffer ( server-port AcceptEx -- )
>r server-port-addr sockaddr-type heap-size 16 +
dup dup 2 * malloc dup [ free ] t add-destructor r>
dup dup 2 * malloc dup free-always r>
[ set-AcceptEx-args-lpOutputBuffer* ] keep
[ set-AcceptEx-args-dwLocalAddressLength* ] keep
set-AcceptEx-args-dwRemoteAddressLength* ;
@ -174,17 +174,17 @@ TUPLE: WSARecvFrom-args port
set-WSARecvFrom-args-s*
] 2keep [
>r datagram-port-addr sockaddr-type heap-size r>
2dup >r malloc dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFrom*
>r malloc-int dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFromLen*
2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom*
>r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen*
] keep
"WSABUF" malloc-object dup [ free ] t add-destructor
"WSABUF" malloc-object dup free-always
2dup swap set-WSARecvFrom-args-lpBuffers*
default-buffer-size [ malloc dup [ free ] t add-destructor ] keep
default-buffer-size [ malloc dup free-always ] keep
pick set-WSABUF-len
swap set-WSABUF-buf
1 over set-WSARecvFrom-args-dwBufferCount*
0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpFlags*
0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags*
0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
(make-overlapped) [ over set-WSARecvFrom-args-lpOverlapped* ] keep
swap WSARecvFrom-args-port set-port-overlapped ;
@ -230,14 +230,14 @@ TUPLE: WSASendTo-args port
set-WSASendTo-args-s*
] keep [
>r make-sockaddr >r
malloc-byte-array dup [ free ] t add-destructor
malloc-byte-array dup free-always
r> heap-size r>
[ set-WSASendTo-args-iToLen* ] keep
set-WSASendTo-args-lpTo*
] keep [
"WSABUF" malloc-object dup [ free ] t add-destructor
"WSABUF" malloc-object dup free-always
dup rot set-WSASendTo-args-lpBuffers*
swap [ malloc-byte-array dup [ free ] t add-destructor ] keep length
swap [ malloc-byte-array dup free-always ] keep length
rot [ set-WSABUF-len ] keep
set-WSABUF-buf
] keep

10
extra/io/windows/windows.factor
View File

@ -10,6 +10,12 @@ TUPLE: windows-nt-io ;
TUPLE: windows-ce-io ;
UNION: windows-io windows-nt-io windows-ce-io ;
M: windows-io (handle-destructor) ( obj -- )
destructor-obj CloseHandle drop ;
M: windows-io (socket-destructor) ( obj -- )
destructor-obj closesocket drop ;
M: windows-io root-directory? ( path -- ? )
[ path-separator? ] rtrim
dup length 2 = [
@ -48,7 +54,7 @@ M: win32-file init-handle ( handle -- ) drop ;
: open-file ( path access-mode create-mode -- handle )
[
>r share-mode f r> CreateFile-flags f CreateFile
dup invalid-handle? dup [ CloseHandle drop ] f add-destructor
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
@ -168,7 +174,7 @@ USE: windows.winsock
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> open-socket
dup [ closesocket drop ] f add-destructor
dup close-socket-later
dup rot make-sockaddr heap-size bind socket-error ;
USE: namespaces

2
extra/irc/irc.factor
View File

@ -77,7 +77,7 @@ SYMBOL: irc-client
trim-: "!" split first ;
: irc-split ( string -- seq )
1 swap [ [ CHAR: : = ] find* ] keep
swap [ cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-:
swap [ swap cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-:
" " split r> [ 1array append ] when* ;
: me? ( name -- ? )
irc-client get irc-client-nick nick-name = ;

4
extra/models/models-docs.factor
View File

@ -83,7 +83,7 @@ HELP: filter
{ $examples
"The following code displays a label showing the result of applying " { $link sq } " to the value 5:"
{ $code
"USING: models gadgets-labels gadgets-panes ;"
"USING: models ui.gadgets.labels ui.gadgets.panes ;"
"5 <model> [ sq ] <filter> [ number>string ] <filter>"
"<label-control> gadget."
}
@ -142,7 +142,7 @@ HELP: delay
{ $examples
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
{ $code
"USING: models gadgets-labels gadgets-sliders gadgets-panes ;"
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
": <funny-slider>"
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
"<funny-slider> dup gadget."

10
extra/serialize/serialize-tests.factor
View File

@ -59,3 +59,13 @@ C: <serialize-test> serialize-test
[ t ] [ objects [ check-serialize-2 ] all? ] unit-test
[ t ] [ pi check-serialize-1 ] unit-test
[ t ] [
{ 1 2 3 } [
[
dup (serialize) (serialize)
] with-serialized
] string-out [
deserialize-sequence all-eq?
] string-in
] unit-test

5
extra/serialize/serialize.factor
View File

@ -260,11 +260,8 @@ DEFER: (deserialize) ( -- obj )
: with-serialized ( quot -- )
V{ } clone serialized rot with-variable ; inline
: (deserialize-sequence)
deserialize* [ , (deserialize-sequence) ] [ drop ] if ;
: deserialize-sequence ( -- seq )
[ (deserialize-sequence) ] { } make ;
[ [ deserialize* ] [ ] { } unfold ] with-serialized ;
: deserialize ( -- obj )
[ (deserialize) ] with-serialized ;

2
extra/store/blob/blob.factor
View File

@ -11,7 +11,7 @@ IN: store.blob
: (load-blob) ( path -- seq/f )
dup exists? [
<file-reader> [
[ deserialize-sequence ] with-serialized
deserialize-sequence
] with-stream
] [
drop f

2
extra/tar/tar.factor
View File

@ -34,7 +34,7 @@ linkname magic version uname gname devmajor devminor prefix ;
155 read-c-string* over set-tar-header-prefix ;
: header-checksum ( seq -- x )
148 swap cut-slice 8 tail-slice
148 cut-slice 8 tail-slice
[ 0 [ + ] reduce ] 2apply + 256 + ;
TUPLE: checksum-error ;

4
extra/tools/interpreter/interpreter.factor
View File

@ -98,7 +98,7 @@ PRIVATE>
2dup nth \ break = [
nip
] [
>r 1+ r> cut [ break ] swap 3append
swap 1+ cut [ break ] swap 3append
] if
] (step) ;
@ -107,7 +107,7 @@ PRIVATE>
: step-into ( interpreter -- )
[
cut [
swap cut [
swap % unclip literalize , \ (step-into) , %
] [ ] make
] (step) ;

10
extra/ui/gadgets/gadgets.factor
View File

@ -285,11 +285,8 @@ M: gadget ungraft* drop ;
: add-gadgets ( seq parent -- )
swap [ over (add-gadget) ] each relayout ;
: (parents) ( gadget -- )
[ dup , gadget-parent (parents) ] when* ;
: parents ( gadget -- seq )
[ (parents) ] { } make ;
[ dup ] [ [ gadget-parent ] keep ] { } unfold ;
: each-parent ( gadget quot -- ? )
>r parents r> all? ; inline
@ -335,11 +332,8 @@ M: f request-focus-on 2drop ;
: request-focus ( gadget -- )
dup focusable-child swap request-focus-on ;
: (focus-path) ( gadget -- )
[ dup , gadget-focus (focus-path) ] when* ;
: focus-path ( world -- seq )
[ (focus-path) ] { } make ;
[ dup ] [ [ gadget-focus ] keep ] { } unfold ;
: make-gadget ( quot gadget -- gadget )
[ \ make-gadget rot with-variable ] keep ; inline

2
extra/ui/tools/interactor/interactor.factor
View File

@ -137,7 +137,7 @@ M: interactor stream-read-partial
[ restore-vars parse ] keep save-vars
] [
>r f swap set-interactor-busy? drop r>
dup [ unexpected-eof? ] is? [ drop f ] when
dup delegate unexpected-eof? [ drop f ] when
] recover
] with-scope ;

9
extra/webapps/help/help.factor
View File

@ -20,8 +20,8 @@ IN: webapps.help
} define-action
M: link browser-link-href
link-name
dup word? [
link-name
dup word? over f eq? or [
browser-link-href
] [
dup array? [ " " join ] when
@ -32,10 +32,13 @@ M: link browser-link-href
lookup show-help ;
\ show-word {
{ "vocab" "kernel" v-default }
{ "word" "call" v-default }
{ "vocab" "kernel" v-default }
} define-action
M: f browser-link-href
drop \ f browser-link-href ;
M: word browser-link-href
dup word-name swap word-vocabulary
[ show-word ] 2curry quot-link ;

119
extra/webapps/planet/planet.factor Normal file
View File

@ -0,0 +1,119 @@
USING: sequences rss arrays concurrency kernel sorting
html.elements io assocs namespaces math threads vocabs html
furnace http.server.templating calendar math.parser splitting
continuations debugger ;
IN: webapps.planet
TUPLE: posting author title date link body ;
: diagnostic write print flush ;
: fetch-feed ( pair -- feed )
second
dup "Fetching " diagnostic
dup news-get feed-entries
swap "Done fetching " diagnostic ;
: fetch-blogroll ( blogroll -- entries )
#! entries is an array of { author entries } pairs.
dup [
[ fetch-feed ] [ error. drop f ] recover
] parallel-map [ ] subset
[ [ >r first r> 2array ] curry* map ] 2map concat ;
: sort-entries ( entries -- entries' )
[ [ second entry-pub-date ] compare ] sort <reversed> ;
: <posting> ( pair -- posting )
#! pair has shape { author entry }
first2
{ entry-title entry-pub-date entry-link entry-description }
get-slots posting construct-boa ;
: print-posting-summary ( posting -- )
<p "news" =class p>
<b> dup posting-title write </b> <br/>
"- " write
dup posting-author write bl
<a posting-link =href "more" =class a>
"Read More..." write
</a>
</p> ;
: print-posting-summaries ( postings -- )
[ print-posting-summary ] each ;
: print-blogroll ( blogroll -- )
<ul "description" =class ul>
[
<li> <a dup third =href a> first write </a> </li>
] each
</ul> ;
: format-date ( date -- string )
10 head "-" split [ string>number ] map
first3 0 0 0 0 <timestamp>
[
dup timestamp-day #
" " %
dup timestamp-month month-abbreviations nth %
", " %
timestamp-year #
] "" make ;
: print-posting ( posting -- )
<h2 "posting-title" =class h2>
<a dup posting-link =href a>
dup posting-title write
" - " write
dup posting-author write
</a>
</h2>
<p "posting-body" =class p> dup posting-body write-html </p>
<p "posting-date" =class p> posting-date format-date write </p> ;
: print-postings ( postings -- )
[ print-posting ] each ;
: browse-webapp-source ( vocab -- )
<a f >vocab-link browser-link-href =href a>
"Browse source" write
</a> ;
SYMBOL: default-blogroll
SYMBOL: cached-postings
: update-cached-postings ( -- )
default-blogroll get fetch-blogroll sort-entries
[ <posting> ] map
cached-postings set-global ;
: mini-planet-factor ( -- )
cached-postings get 4 head print-posting-summaries ;
: planet-factor ( -- )
[
"resource:extra/webapps/planet/planet.fhtml"
run-template-file
] with-html-stream ;
\ planet-factor { } define-action
{
{ "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "http://www.bluishcoder.co.nz/" }
{ "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
{ "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
{ "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
{ "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
{ "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
} default-blogroll set-global
: update-thread ( -- )
[ update-cached-postings ] try
10 60 * 1000 * sleep
update-thread ;
: start-update-thread ( -- )
[ update-thread ] in-thread ;
"planet" "planet-factor" "extra/webapps/planet" web-app

39
extra/webapps/planet/planet.fhtml Normal file
View File

@ -0,0 +1,39 @@
<% USING: namespaces html.elements webapps.planet sequences ; %>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
<title>planet-factor</title>
<link rel="stylesheet" href="/responder/file/css/news.css" type="text/css" media="screen" title="no title" charset="utf-8" />
</head>
<body id="index">
<h1 class="planet-title">[ planet-factor ]</h1>
<table width="100%" cellpadding="10">
<tr>
<td> <% cached-postings get 20 head print-postings %> </td>
<td valign="top" width="25%" class="infobox">
<p>
<b>planet-factor</b> is an Atom/RSS aggregator that collects the
contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It is inspired by
<a href="http://planet.lisp.org">Planet Lisp</a>.
</p>
<p>
This webapp is written in <a href="http://factorcode.org/">Factor</a>.
<% "webapps.planet" browse-webapp-source %>
</p>
<h2 class="blogroll-title">Blogroll</h2>
<% default-blogroll get print-blogroll %>
<p>
If you want your weblog added to the blogroll, <a href="http://factorcode.org/gethelp.fhtml">just ask</a>.
</p>
</td>
</tr>
</table>
</body>
</html>

7
extra/windows/kernel32/kernel32.factor
View File

@ -16,13 +16,6 @@ IN: windows.kernel32
: GENERIC_EXECUTE HEX: 20000000 ; inline
: GENERIC_ALL HEX: 10000000 ; inline
: DELETE HEX: 00010000 ; inline
: READ_CONTROL HEX: 00020000 ; inline
: WRITE_DAC HEX: 00040000 ; inline
: WRITE_OWNER HEX: 00080000 ; inline
: SYNCHRONIZE HEX: 00100000 ; inline
: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
: CREATE_NEW 1 ; inline
: CREATE_ALWAYS 2 ; inline
: OPEN_EXISTING 3 ; inline

2
extra/xml-rpc/xml-rpc.factor
View File

@ -35,7 +35,7 @@ M: string item>xml ! This should change < and &
2array "member" build-tag* ;
M: hashtable item>xml
[ [ struct-member , ] assoc-each ] { } make
[ struct-member ] { } assoc>map
"struct" build-tag* ;
M: array item>xml

1
extra/xml/test/test.factor
View File

@ -42,3 +42,4 @@ SYMBOL: xml-file
] unit-test
[ "foo" ] [ "<x y='foo'/>" string>xml "y" <name-tag> over
at swap "z" <name-tag> >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test

2
extra/xml/tokenize/tokenize.factor
View File

@ -137,7 +137,7 @@ SYMBOL: ns-stack
CHAR: > expect ;
: take-cdata ( -- string )
"[CDATA[" expect-string "]]>" take-string next ;
"[CDATA[" expect-string "]]>" take-string ;
: take-directive ( -- directive )
CHAR: > take-char <directive> next ;

2
extra/xml/xml.factor
View File

@ -93,7 +93,7 @@ M: closer process
: make-xml-doc ( prolog seq -- xml-doc )
dup [ tag? ] find
>r assure-tags swap cut 1 tail
>r assure-tags cut 1 tail
no-pre/post no-post-tags
r> swap <xml> ;