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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-03-15 21:28:01 -05:00
parent 32223de89c e8b8b9e446
commit caa6eb0397
345 changed files with 4618 additions and 3475 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
README.txt
View File

@ -24,7 +24,7 @@ The Factor runtime is written in GNU C99, and is built with GNU make and
gcc.
Factor supports various platforms. For an up-to-date list, see
<http://factorcode.org/getfactor.fhtml>.
<http://factorcode.org>.
Factor requires gcc 3.4 or later.
@ -36,17 +36,6 @@ arguments for make.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
Compilation will yield an executable named 'factor' on Unix,
'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
* Libraries needed for compilation
For X11 support, you need recent development libraries for libc,
Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
(like Ubuntu), you can use the following line to grab everything:
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
* Bootstrapping the Factor image
Once you have compiled the Factor runtime, you must bootstrap the Factor
@ -69,6 +58,12 @@ machines.
On Unix, Factor can either run a graphical user interface using X11, or
a terminal listener.
For X11 support, you need recent development libraries for libc,
Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
(like Ubuntu), you can use the following line to grab everything:
sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
If your DISPLAY environment variable is set, the UI will start
automatically:
@ -78,14 +73,6 @@ To run an interactive terminal listener:
./factor -run=listener
If you're inside a terminal session, you can start the UI with one of
the following two commands:
ui
[ ui ] in-thread
The latter keeps the terminal listener running.
* Running Factor on Mac OS X - Cocoa UI
On Mac OS X, a Cocoa UI is available in addition to the terminal
@ -110,7 +97,7 @@ When compiling Factor, pass the X11=1 parameter:
Then bootstrap with the following switches:
./factor -i=boot.<cpu>.image -ui-backend=x11
./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
Now if $DISPLAY is set, running ./factor will start the UI.
@ -126,6 +113,12 @@ the command prompt using the console application:
factor.com -i=boot.<cpu>.image
Before bootstrapping, you will need to download the DLLs for the Pango
text rendering library. The required DLLs are listed in
build-support/dlls.txt and are available from the following location:
<http://factorcode.org/dlls>
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.
@ -135,7 +128,9 @@ To run the listener in the command prompt:
* The Factor FAQ
The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
The Factor FAQ is available at the following location:
<http://concatenative.org/wiki/view/Factor/FAQ>
* Command line usage

4
basis/alien/c-types/c-types-docs.factor
View File

@ -217,6 +217,8 @@ $nl
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsection &free }
{ $subsection |free }
"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "."
$nl
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsection memcpy }
"You can copy a range of bytes from memory into a byte array:"
@ -243,4 +245,6 @@ $nl
"New C types can be defined:"
{ $subsection "c-structs" }
{ $subsection "c-unions" }
"A utility for defining " { $link "destructors" } " for deallocating memory:"
{ $subsection "alien.destructors" }
{ $see-also "aliens" } ;

30
basis/alien/destructors/destructors-docs.factor Normal file
View File

@ -0,0 +1,30 @@
IN: alien.destructors
USING: help.markup help.syntax alien destructors ;
HELP: DESTRUCTOR:
{ $syntax "DESTRUCTOR: word" }
{ $description "Defines four things:"
{ $list
{ "a tuple named " { $snippet "word" } " with a single slot holding a " { $link c-ptr } }
{ "a " { $link dispose } " method on the tuple which calls " { $snippet "word" } " with the " { $link c-ptr } }
{ "a pair of words, " { $snippet "&word" } " and " { $snippet "|word" } ", which call " { $link &dispose } " and " { $link |dispose } " with a new instance of the tuple" }
}
"The " { $snippet "word" } " must be defined in the current vocabulary, and must have stack effect " { $snippet "( c-ptr -- )" } "."
}
{ $examples
"Suppose you are writing a binding to the GLib library, which as a " { $snippet "g_object_unref" } " function. Then you can define the function and destructor like so,"
{ $code
"FUNCTION: void g_object_unref ( gpointer object ) ;"
"DESTRUCTOR: g_object_unref"
}
"Now, memory management becomes easier:"
{ $code
"[ g_new_foo &g_object_unref ... ] with-destructors"
}
} ;
ARTICLE: "alien.destructors" "Alien destructors"
"The " { $vocab-link "alien.destructors" } " vocabulary defines a utility parsing word for defining new disposable classes."
{ $subsection POSTPONE: DESTRUCTOR: } ;
ABOUT: "alien.destructors"

4
basis/ascii/ascii.factor
View File

@ -10,7 +10,7 @@ IN: ascii
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline
: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
@ -20,4 +20,4 @@ IN: ascii
: >upper ( str -- upper ) [ ch>upper ] map ;
HINTS: >lower string ;
HINTS: >upper string ;
HINTS: >upper string ;

11
basis/binary-search/binary-search.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private accessors math
math.order combinators hints arrays ;
@ -16,14 +16,19 @@ IN: binary-search
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
DEFER: (search)
: keep-searching ( seq quot -- slice )
[ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
dup length 1 <= [
finish
] [
decide {
{ +eq+ [ finish ] }
{ +lt+ [ dup midpoint@ head-slice (search) ] }
{ +gt+ [ dup midpoint@ tail-slice (search) ] }
{ +lt+ [ [ (head) ] keep-searching ] }
{ +gt+ [ [ (tail) ] keep-searching ] }
} case
] if ; inline recursive

8
basis/bitstreams/bitstreams-tests.factor
View File

@ -6,17 +6,17 @@ io.streams.byte-array ;
IN: bitstreams.tests
[ 1 t ]
[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
[ 254 8 t ]
[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
[ 4095 12 t ]
[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
[ B{ 254 } ]
[
<string-writer> <bitstream-writer> 254 8 rot
binary <byte-writer> <bitstream-writer> 254 8 rot
[ write-bits ] keep stream>> >byte-array
] unit-test

2
basis/bootstrap/image/image.factor
View File

@ -515,7 +515,7 @@ M: quotation '
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
"Building generic words..." print flush
call-remake-generics-hook
remake-generics
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush

6
basis/calendar/calendar-docs.factor
View File

@ -36,7 +36,7 @@ HELP: month-name
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: month-abbreviations
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the English abbreviated names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
@ -54,7 +54,7 @@ HELP: day-name
{ $description "Looks up the day name and returns it as a string." } ;
HELP: day-abbreviations2
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
HELP: day-abbreviation2
@ -62,7 +62,7 @@ HELP: day-abbreviation2
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
HELP: day-abbreviations3
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
HELP: day-abbreviation3

18
basis/calendar/calendar.factor
View File

@ -39,8 +39,10 @@ M: not-a-month summary
drop "Months are indexed starting at 1" ;
<PRIVATE
: check-month ( n -- n )
dup zero? [ not-a-month ] when ;
PRIVATE>
: month-names ( -- array )
@ -52,11 +54,11 @@ PRIVATE>
: month-name ( n -- string )
check-month 1- month-names nth ;
: month-abbreviations ( -- array )
CONSTANT: month-abbreviations
{
"Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
} ;
}
: month-abbreviation ( n -- string )
check-month 1- month-abbreviations nth ;
@ -70,17 +72,17 @@ CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
: day-name ( n -- string ) day-names nth ;
: day-abbreviations2 ( -- array )
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
CONSTANT: day-abbreviations2
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
: day-abbreviation2 ( n -- string )
day-abbreviations2 nth ;
day-abbreviations2 nth ; inline
: day-abbreviations3 ( -- array )
{ "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
CONSTANT: day-abbreviations3
{ "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" }
: day-abbreviation3 ( n -- string )
day-abbreviations3 nth ;
day-abbreviations3 nth ; inline
: average-month ( -- ratio ) 30+5/12 ; inline
: months-per-year ( -- integer ) 12 ; inline

2
basis/call/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Daniel Ehrenberg
Slava Pestov

18
basis/call/call-tests.factor
View File

@ -14,12 +14,20 @@ IN: call.tests
[ 1 2 \ + execute( x y -- z a ) ] must-fail
[ \ + execute( x y -- z ) ] must-infer
: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
: compile-execute(-test ( a b -- c ) \ + execute( a b -- c ) ;
[ t ] [ \ compile-execute(-test optimized>> ] unit-test
[ 4 ] [ 1 3 compile-execute(-test ] unit-test

50
basis/call/call.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel macros fry summary sequences generalizations accessors
continuations effects effects.parser parser words ;
USING: kernel macros fry summary sequences sequences.private
generalizations accessors continuations effects effects.parser
parser words ;
IN: call
ERROR: wrong-values values quot length-required ;
@ -14,17 +15,9 @@ M: wrong-values summary
: firstn-safe ( array quot n -- ... )
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
: execute-effect-unsafe ( word effect -- )
drop execute ;
: execute-effect-unsafe? ( word effect -- ? )
swap dup optimized>> [ stack-effect swap effect<= ] [ 2drop f ] if ; inline
: parse-call( ( accum word -- accum )
[ ")" parse-effect parsed ] dip parsed ;
: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
PRIVATE>
MACRO: call-effect ( effect -- quot )
@ -33,10 +26,35 @@ MACRO: call-effect ( effect -- quot )
: call( \ call-effect parse-call( ; parsing
: execute-effect ( word effect -- )
2dup execute-effect-unsafe?
[ execute-effect-unsafe ]
[ [ [ execute ] curry ] dip call-effect ]
if ; inline
<PRIVATE
: execute-effect-unsafe ( word effect -- )
drop execute ;
: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
: execute-effect-slow ( word effect -- )
[ [ execute ] curry ] dip call-effect ; inline
: cache-hit? ( word ic -- ? ) first-unsafe eq? ; inline
: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
: execute-effect-unsafe? ( word effect -- ? )
over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
: cache-miss ( word effect ic -- )
[ 2dup execute-effect-unsafe? ] dip
'[ [ drop _ set-first ] [ execute-effect-unsafe ] 2bi ]
[ execute-effect-slow ] if ; inline
: execute-effect-ic ( word effect ic -- )
#! ic is a mutable cell { effect }
3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
PRIVATE>
MACRO: execute-effect ( effect -- )
{ f } clone '[ _ _ execute-effect-ic ] ;
: execute( \ execute-effect parse-call( ; parsing

1
basis/call/tags.txt Normal file
View File

@ -0,0 +1 @@
extensions

30
basis/cocoa/plists/plists-tests.factor
View File

@ -7,4 +7,34 @@ assocs cocoa.enumeration ;
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
[ V{ "A" } ] [ { "A" } >cf &CFRelease plist> ] unit-test
[ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
[ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
[ t ] [
{
H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 4 } }
H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 5 } }
H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 6 } }
} [ >cf &CFRelease ] [ >cf &CFRelease ] bi
[ plist> ] bi@ =
] unit-test
[ t ] [
{ "DeviceUsagePage" 1 }
[ >cf &CFRelease ] [ >cf &CFRelease ] bi
[ plist> ] bi@ =
] unit-test
[ V{ "DeviceUsagePage" "Yes" } ] [
{ "DeviceUsagePage" "Yes" }
>cf &CFRelease plist>
] unit-test
[ V{ 2.0 1.0 } ] [
{ 2.0 1.0 }
>cf &CFRelease plist>
] unit-test
[ 3.5 ] [
3.5 >cf &CFRelease plist>
] unit-test
] with-destructors

2
basis/colors/constants/constants-docs.factor
View File

@ -2,7 +2,7 @@ IN: colors.constants
USING: help.markup help.syntax strings colors ;
HELP: named-color
{ $values { "string" string } { "color" color } }
{ $values { "name" string } { "color" color } }
{ $description "Outputs a named color from the " { $snippet "rgb.txt" } " database." }
{ $notes "In most cases, " { $link POSTPONE: COLOR: } " should be used instead." }
{ $errors "Throws an error if the color is not listed in " { $snippet "rgb.txt" } "." } ;

2
basis/colors/constants/constants.factor
View File

@ -27,7 +27,7 @@ PRIVATE>
ERROR: no-such-color name ;
: named-color ( name -- rgb )
: named-color ( name -- color )
dup rgb.txt at [ ] [ no-such-color ] ?if ;
: COLOR: scan named-color parsed ; parsing

7
basis/compiler/compiler-docs.factor
View File

@ -12,8 +12,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically. This can be changed:"
{ $subsection disable-compiler }
{ $subsection enable-compiler }
"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile }
"Compiling a single quotation:"
@ -46,9 +44,8 @@ HELP: (compile)
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
HELP: optimized-recompile-hook
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
{ $description "Compile a set of words." }
HELP: optimizing-compiler
{ $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
HELP: compile-call

31
basis/compiler/compiler.factor
View File

@ -1,15 +1,14 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs
generic combinators deques search-deques io stack-checker
stack-checker.state stack-checker.inlining
combinators.short-circuit compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.optimizer
continuations vocabs assocs dlists definitions math graphs generic
combinators deques search-deques macros io stack-checker
stack-checker.state stack-checker.inlining combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.linear-scan compiler.cfg.stack-frame
compiler.codegen compiler.utilities ;
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
@ -50,8 +49,12 @@ SYMBOLS: +optimized+ +unoptimized+ ;
H{ } clone generic-dependencies set
f swap compiler-error ;
: ignore-error? ( word error -- ? )
[ [ inline? ] [ macro? ] bi or ]
[ compiler-error-type +warning+ eq? ] bi* and ;
: fail ( word error -- * )
[ swap compiler-error ]
[ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
[
drop
[ compiled-unxref ]
@ -108,7 +111,7 @@ t compile-dependencies? set-global
] with-return ;
: compile-loop ( deque -- )
[ (compile) yield-hook get call ] slurp-deque ;
[ (compile) yield-hook get assert-depth ] slurp-deque ;
: decompile ( word -- )
f 2array 1array modify-code-heap ;
@ -116,7 +119,9 @@ t compile-dependencies? set-global
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
: optimized-recompile-hook ( words -- alist )
SINGLETON: optimizing-compiler
M: optimizing-compiler recompile ( words -- alist )
[
<hashed-dlist> compile-queue set
H{ } clone compiled set
@ -126,10 +131,10 @@ t compile-dependencies? set-global
] with-scope ;
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
optimizing-compiler compiler-impl set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
f compiler-impl set-global ;
: recompile-all ( -- )
forget-errors all-words compile ;

5
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -514,4 +514,9 @@ cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare = ]
\ both-fixnums? inlined?
] unit-test
[ t ] [
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
] unit-test

3
basis/compiler/tree/finalization/finalization.factor
View File

@ -46,9 +46,6 @@ M: predicate finalize-word
[ drop ]
} cond ;
! M: math-partial finalize-word
! dup primitive? [ drop ] [ nip cached-expansion ] if ;
M: word finalize-word drop ;
M: #call finalize*

2
basis/compiler/tree/propagation/info/info.factor
View File

@ -238,7 +238,7 @@ DEFER: (value-info-union)
: value-infos-union ( infos -- info )
[ null-info ]
[ dup first [ value-info-union ] reduce ] if-empty ;
[ unclip-slice [ value-info-union ] reduce ] if-empty ;
: literals<= ( info1 info2 -- ? )
{

33
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -655,3 +655,36 @@ MIXIN: empty-mixin
! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
! generalize-counter-interval wasn't being called in all the right places.
! bug found by littledan
TUPLE: littledan-1 { a read-only } ;
: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
[ ] [ [ littledan-1-test ] final-classes drop ] unit-test
TUPLE: littledan-2 { from read-only } { to read-only } ;
: (littledan-2-test) ( x -- i elt )
[ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive
: littledan-2-test ( x -- i elt )
[ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline
[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
: (littledan-3-test) ( x -- )
length 1+ f <array> (littledan-3-test) ; inline recursive
: littledan-3-test ( x -- )
0 f <array> (littledan-3-test) ; inline
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test

11
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -34,9 +34,14 @@ IN: compiler.tree.propagation.recursive
} cond interval-union nip ;
: generalize-counter ( info' initial -- info )
2dup [ class>> null-class? ] either? [ drop ] [
[ drop clone ] [ [ interval>> ] bi@ ] 2bi
generalize-counter-interval >>interval
2dup [ not ] either? [ drop ] [
2dup [ class>> null-class? ] either? [ drop ] [
[ clone ] dip
[ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
[ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
[ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
tri
] if
] if ;
: unify-recursive-stacks ( stacks initial -- infos )

9
basis/core-foundation/arrays/arrays.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel sequences ;
USING: alien.syntax kernel sequences fry ;
IN: core-foundation.arrays
TYPEDEF: void* CFArrayRef
@ -17,6 +17,5 @@ FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
: <CFArray> ( seq -- alien )
[ f swap length f CFArrayCreateMutable ] keep
[ length ] keep
[ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable
[ '[ [ _ ] 2dip swap CFArraySetValueAtIndex ] each-index ] keep ;

2
basis/core-foundation/attributed-strings/tags.txt Normal file
View File

@ -0,0 +1,2 @@
unportable
bindings

13
basis/core-text/core-text-tests.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-text core-foundation
core-foundation.dictionaries destructors
arrays kernel generalizations math accessors
core-foundation.utilities
combinators hashtables colors ;
USING: tools.test core-text core-text.fonts core-foundation
core-foundation.dictionaries destructors arrays kernel generalizations
math accessors core-foundation.utilities combinators hashtables colors
colors.constants ;
IN: core-text.tests
: test-font ( name -- font )
@ -21,8 +20,8 @@ IN: core-text.tests
: test-typographic-bounds ( string font -- ? )
[
test-font &CFRelease white <CTLine> &CFRelease
line-typographic-bounds {
test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
compute-line-metrics {
[ width>> float? ]
[ ascent>> float? ]
[ descent>> float? ]

2
basis/core-text/fonts/tags.txt Normal file
View File

@ -0,0 +1,2 @@
unportable
bindings

3
basis/cpu/x86/32/32.factor
View File

@ -309,8 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
check_sse2 ;
"-no-sse2" (command-line) member? [
[ optimized-recompile-hook ] recompile-hook
[ { check_sse2 } compile ] with-variable
optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
"Checking if your CPU supports SSE2..." print flush
sse2? [

2
basis/db/db.factor
View File

@ -149,4 +149,4 @@ M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
t in-transaction [
begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction
] with-variable ;
] with-variable ; inline

2
basis/debugger/debugger.factor
View File

@ -220,7 +220,7 @@ M: assert error.
5 line-limit set
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
] tabular-output ;
] tabular-output nl ;
M: immutable summary drop "Sequence is immutable" ;

4
basis/delegate/delegate-docs.factor
View File

@ -13,8 +13,8 @@ HELP: PROTOCOL:
{ 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." }
{ $values { "consultation" consultation } }
{ $description "Defines a class to consult, using the 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:

2
basis/delegate/delegate-tests.factor
View File

@ -1,7 +1,7 @@
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
accessors eval multiline generic.standard delegate.protocols
delegate.private assocs ;
delegate.private assocs see ;
IN: delegate.tests
TUPLE: hello this that ;

1
basis/farkup/farkup-tests.factor
View File

@ -99,6 +99,7 @@ link-no-follow? off
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com/search?q=sex\">haha</a></p>" ] [ "[[http://lol.com/search?q=sex|haha]]" convert-farkup ] unit-test
[ "<p><a href=\"Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
"/wiki/view/" relative-link-prefix [

8
basis/farkup/farkup.factor
View File

@ -165,12 +165,12 @@ CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');"
{ [ dup [ 127 > ] any? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
[ relative-link-prefix get prepend "" like ]
} cond url-encode ;
[ relative-link-prefix get prepend "" like url-encode ]
} cond ;
: write-link ( href text -- xml )
[ check-url link-no-follow? get "true" and ] dip
[XML <a href=<-> nofollow=<->><-></a> XML] ;
[ check-url link-no-follow? get "nofollow" and ] dip
[XML <a href=<-> rel=<->><-></a> XML] ;
: write-image-link ( href text -- xml )
disable-images? get [

4
basis/furnace/actions/actions-docs.factor
View File

@ -1,6 +1,6 @@
USING: assocs classes help.markup help.syntax io.streams.string
http http.server.dispatchers http.server.responses
furnace.redirection strings multiline ;
furnace.redirection strings multiline html.forms ;
IN: furnace.actions
HELP: <action>
@ -74,6 +74,8 @@ HELP: validate-params
}
} ;
{ validate-params validate-values } related-words
HELP: validation-failed
{ $description "Stops processing the current request and takes action depending on the type of the current request:"
{ $list

16
basis/furnace/actions/actions.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel assocs combinators
validators http hashtables namespaces fry continuations locals
io arrays math boxes splitting urls
io arrays math boxes splitting urls call
xml.entities
http.server
http.server.responses
@ -52,10 +52,10 @@ TUPLE: action rest init authorize display validate submit ;
'[
_ dup display>> [
{
[ init>> call ]
[ authorize>> call ]
[ init>> call( -- ) ]
[ authorize>> call( -- ) ]
[ drop restore-validation-errors ]
[ display>> call ]
[ display>> call( -- response ) ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ;
@ -81,9 +81,9 @@ CONSTANT: revalidate-url-key "__u"
: handle-post ( action -- response )
'[
_ dup submit>> [
[ validate>> call ]
[ authorize>> call ]
[ submit>> call ]
[ validate>> call( -- ) ]
[ authorize>> call( -- ) ]
[ submit>> call( -- response ) ]
tri
] [ drop <400> ] if
] with-exit-continuation ;

2
basis/furnace/auth/login/login.factor
View File

@ -53,7 +53,7 @@ M: login-realm modify-form ( responder -- )
\ successful-login DEBUG add-input-logging
: logout ( -- )
: logout ( -- response )
permit-id get [ delete-permit ] when*
URL" $realm" end-aside ;

6
basis/furnace/boilerplate/boilerplate.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Slava Pestov
! Copyright (c) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math.order namespaces combinators.short-circuit
USING: accessors kernel math.order namespaces combinators.short-circuit call
html.forms
html.templates
html.templates.chloe
@ -23,7 +23,7 @@ TUPLE: boilerplate < filter-responder template init ;
M:: boilerplate call-responder* ( path responder -- )
begin-form
path responder call-next-method
responder init>> call
responder init>> call( -- )
dup wrap-boilerplate? [
clone [| body |
[

6
basis/furnace/referrer/referrer.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel http.server http.server.filters
http.server.responses furnace.utilities ;
http.server.responses furnace.utilities call ;
IN: furnace.referrer
TUPLE: referrer-check < filter-responder quot ;
@ -9,7 +9,7 @@ TUPLE: referrer-check < filter-responder quot ;
C: <referrer-check> referrer-check
M: referrer-check call-responder*
referrer over quot>> call
referrer over quot>> call( referrer -- ? )
[ call-next-method ]
[ 2drop 403 "Bad referrer" <trivial-response> ] if ;

2
basis/furnace/utilities/utilities.factor
View File

@ -135,4 +135,4 @@ SYMBOL: exit-continuation
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
'[ exit-continuation set @ ] callcc1 exit-continuation off ; inline

1
basis/globs/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov
Daniel Ehrenberg

3
basis/globs/globs-tests.factor
View File

@ -14,5 +14,6 @@ USING: tools.test globs ;
[ 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
[ f ] [ "foo." "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.{" "*.{" glob-matches? ] unit-test

54
basis/globs/globs.factor
View File

@ -1,42 +1,42 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: parser-combinators parser-combinators.regexp lists sequences kernel
promises strings unicode.case ;
USING: sequences kernel regexp.combinators strings unicode.case
peg.ebnf regexp arrays ;
IN: globs
<PRIVATE
EBNF: <glob>
: 'char' ( -- parser )
[ ",*?" member? not ] satisfy ;
Character = "\\" .:c => [[ c 1string <literal> ]]
| !(","|"}") . => [[ 1string <literal> ]]
: 'string' ( -- parser )
'char' <+> [ >lower token ] <@ ;
RangeCharacter = !("]") .
: 'escaped-char' ( -- parser )
"\\" token any-char-parser &> [ 1token ] <@ ;
Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <char-range> ]]
| RangeCharacter => [[ 1string <literal> ]]
: 'escaped-string' ( -- parser )
'string' 'escaped-char' <|> ;
StartRange = .:a "-" RangeCharacter:b => [[ a b <char-range> ]]
| . => [[ 1string <literal> ]]
DEFER: 'term'
Ranges = StartRange:s Range*:r => [[ r s prefix ]]
: 'glob' ( -- parser )
'term' <*> [ <and-parser> ] <@ ;
CharClass = "^"?:n Ranges:e => [[ e <or> n [ <not> ] when ]]
: 'union' ( -- parser )
'glob' "," token nonempty-list-of "{" "}" surrounded-by
[ <or-parser> ] <@ ;
AlternationBody = Concatenation:c "," AlternationBody:a => [[ a c prefix ]]
| Concatenation => [[ 1array ]]
LAZY: 'term' ( -- parser )
'union'
'character-class' <|>
"?" token [ drop any-char-parser ] <@ <|>
"*" token [ drop any-char-parser <*> ] <@ <|>
'escaped-string' <|> ;
Element = "*" => [[ R/ .*/ ]]
| "?" => [[ R/ ./ ]]
| "[" CharClass:c "]" => [[ c ]]
| "{" AlternationBody:b "}" => [[ b <or> ]]
| Character
PRIVATE>
Concatenation = Element* => [[ <sequence> ]]
: <glob> ( string -- glob ) 'glob' just parse-1 just ;
End = !(.)
Main = Concatenation End
;EBNF
: glob-matches? ( input glob -- ? )
[ >lower ] [ <glob> ] bi* parse nil? not ;
[ >case-fold ] bi@ <glob> matches? ;

2
basis/help/cookbook/cookbook.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces stack-checker
help command-line multiline ;
help command-line multiline see ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"

2
basis/help/definitions/definitions-tests.factor
View File

@ -1,6 +1,6 @@
USING: math definitions help.topics help tools.test
prettyprint parser io.streams.string kernel source-files
assocs namespaces words io sequences eval accessors ;
assocs namespaces words io sequences eval accessors see ;
IN: help.definitions.tests
[ ] [ \ + >link see ] unit-test

4
basis/help/definitions/definitions.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions help help.topics help.syntax
prettyprint.backend prettyprint.custom prettyprint words kernel
effects ;
effects see ;
IN: help.definitions
! Definition protocol implementation

1
basis/help/handbook/handbook.factor
View File

@ -194,6 +194,7 @@ ARTICLE: "io" "Input and output"
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:"
{ $subsection "see" }
{ $subsection "editor" }
{ $subsection "listener" }
{ $subsection "tools.crossref" }

2
basis/help/help-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.crossref help.stylesheet help.topics
help.syntax definitions io prettyprint summary arrays math
sequences vocabs strings ;
sequences vocabs strings see ;
IN: help
ARTICLE: "printing-elements" "Printing markup elements"

8
basis/help/lint/lint.factor
View File

@ -132,6 +132,11 @@ SYMBOL: vocabs-quot
[ check-descriptions ]
} cleave ;
: check-class-description ( word element -- )
[ class? not ]
[ { $class-description } swap elements empty? not ] bi* and
[ "A word that is not a class has a $class-description" throw ] when ;
: all-word-help ( words -- seq )
[ word-help ] filter ;
@ -153,7 +158,8 @@ M: help-error error.
dup '[
_ dup word-help
[ check-values ]
[ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
[ check-class-description ]
[ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
] check-something
] [ drop ] if ;

11
basis/help/markup/markup.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots fry
sets vocabs help.stylesheet help.topics vocabs.loader quotations
combinators call ;
combinators call see ;
IN: help.markup
PREDICATE: simple-element < array
@ -13,7 +13,6 @@ PREDICATE: simple-element < array
SYMBOL: last-element
SYMBOL: span
SYMBOL: block
SYMBOL: table
: last-span? ( -- ? ) last-element get span eq? ;
: last-block? ( -- ? ) last-element get block eq? ;
@ -44,7 +43,7 @@ M: f print-element drop ;
[ print-element ] with-default-style ;
: ($block) ( quot -- )
last-element get { f table } member? [ nl ] unless
last-element get [ nl ] when
span last-element set
call
block last-element set ; inline
@ -218,7 +217,7 @@ ALIAS: $slot $snippet
table-content-style get [
swap [ last-element off call ] tabular-output
] with-style
] ($block) table last-element set ; inline
] ($block) ; inline
: $list ( element -- )
list-style get [
@ -301,7 +300,7 @@ M: f ($instance)
] with-style
] ($block) ; inline
: $see ( element -- ) first [ see ] ($see) ;
: $see ( element -- ) first [ see* ] ($see) ;
: $synopsis ( element -- ) first [ synopsis write ] ($see) ;
@ -346,6 +345,8 @@ M: f ($instance)
drop
"Throws an error if the I/O operation fails." $errors ;
FROM: prettyprint.private => with-pprint ;
: $prettyprinting-note ( children -- )
drop {
"This word should only be called from inside the "

2
basis/html/components/components-tests.factor
View File

@ -4,6 +4,8 @@ io.streams.null accessors inspector html.streams
html.components html.forms namespaces
xml.writer ;
\ render must-infer
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test

6
basis/html/forms/forms.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov
! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables io
USING: kernel accessors strings namespaces assocs hashtables io call
mirrors math fry sequences words continuations
xml.entities xml.writer xml.syntax ;
IN: html.forms
@ -96,7 +96,7 @@ C: <validation-error> validation-error
>hashtable "validators" set-word-prop ;
: validate ( value quot -- result )
[ <validation-error> ] recover ; inline
'[ _ call( value -- validated ) ] [ <validation-error> ] recover ;
: validate-value ( name value quot -- )
validate

6
basis/html/templates/templates.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
arrays strings html io.streams.string assocs
arrays strings html io.streams.string assocs call
quotations xml.data xml.writer xml.syntax ;
IN: html.templates
@ -12,7 +12,7 @@ GENERIC: call-template* ( template -- )
M: string call-template* write ;
M: callable call-template* call ;
M: callable call-template* call( -- ) ;
M: xml call-template* write-xml ;

8
basis/http/http-tests.factor
View File

@ -9,14 +9,10 @@ IN: http.tests
[ "text/html" utf8 ] [ "text/html; charset=UTF-8" parse-content-type ] unit-test
[ "text/html" utf8 ] [ "text/html; charset=\"utf-8\"" parse-content-type ] unit-test
[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
[ { } ] [ "" parse-cookie ] unit-test
[ { } ] [ "" parse-set-cookie ] unit-test
! Make sure that totally invalid cookies don't confuse us
[ { } ] [ "hello world; how are you" parse-cookie ] unit-test
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1

7
basis/http/http.factor
View File

@ -34,7 +34,7 @@ IN: http
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
dup "\r\n\"" intersects?
dup "\r\n" intersects?
[ "Header injection attack" throw ] when ;
: write-header ( assoc -- )
@ -213,7 +213,10 @@ TUPLE: post-data data params content-type content-encoding ;
swap >>content-type ;
: parse-content-type-attributes ( string -- attributes )
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
" " split harvest [
"=" split1
[ >lower ] [ "\"" ?head drop "\"" ?tail drop ] bi*
] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1

16
basis/http/parsers/parsers-tests.factor Normal file
View File

@ -0,0 +1,16 @@
IN: http.parsers.tests
USING: http http.parsers tools.test ;
[ { } ] [ "" parse-cookie ] unit-test
[ { } ] [ "" parse-set-cookie ] unit-test
! Make sure that totally invalid cookies don't confuse us
[ { } ] [ "hello world; how are you" parse-cookie ] unit-test
[ { T{ cookie { name "__s" } { value "12345567" } } } ]
[ "__s=12345567" parse-cookie ]
unit-test
[ { T{ cookie { name "__s" } { value "12345567" } } } ]
[ "__s=12345567;" parse-cookie ]
unit-test

2
basis/http/parsers/parsers.factor
View File

@ -162,7 +162,7 @@ PEG: (parse-set-cookie) ( string -- alist )
'value' ,
'space' ,
] seq*
[ ";,=" member? not ] satisfy repeat1 [ drop f ] action
[ ";,=" member? not ] satisfy repeat0 [ drop f ] action
2choice ;
PEG: (parse-cookie) ( string -- alist )

4
basis/http/server/cgi/cgi.factor
View File

@ -53,9 +53,9 @@ IN: http.server.cgi
"CGI output follows" >>message
swap '[
binary encode-output
_ output-stream get swap <cgi-process> binary <process-stream> [
output-stream get _ <cgi-process> binary <process-stream> [
post-request? [ request get post-data>> data>> write flush ] when
'[ _ write ] each-block
'[ _ stream-write ] each-block
] with-stream
] >>body ;

8
basis/http/server/server.factor
View File

@ -132,15 +132,15 @@ M: response write-full-response ( request response -- )
[ content-charset>> encode-output ]
[ write-response-body ]
bi
] unless ;
] unless drop ;
M: raw-response write-response ( respose -- )
write-response-line
write-response-body
drop ;
M: raw-response write-full-response ( response -- )
write-response ;
M: raw-response write-full-response ( request response -- )
nip write-response ;
: post-request? ( -- ? ) request get method>> "POST" = ;
@ -182,7 +182,7 @@ main-responder [ <404> <trivial-responder> ] initialize
swap development? get [ make-http-error >>body ] [ drop ] if ;
: do-response ( response -- )
[ request get swap write-full-response ]
'[ request get _ write-full-response ]
[
[ \ do-response log-error ]
[

2
basis/http/server/static/static-docs.factor
View File

@ -20,7 +20,7 @@ HELP: enable-fhtml
{ $side-effects "responder" } ;
ARTICLE: "http.server.static.extend" "Hooks for dynamic content"
"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- )" } "."
"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- response )" } "."
$nl
"A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:"
{ $subsection enable-fhtml }

10
basis/http/server/static/static.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar kernel math math.order math.parser namespaces
parser sequences strings assocs hashtables debugger mime.types
@ -6,7 +6,7 @@ sorting logging calendar.format accessors splitting io io.files
io.files.info io.directories io.pathnames io.encodings.binary
fry xml.entities destructors urls html xml.syntax
html.templates.fhtml http http.server http.server.responses
http.server.redirection xml.writer ;
http.server.redirection xml.writer call ;
IN: http.server.static
TUPLE: file-responder root hook special allow-listings ;
@ -42,7 +42,9 @@ TUPLE: file-responder root hook special allow-listings ;
: serve-static ( filename mime-type -- response )
over modified-since?
[ file-responder get hook>> call ] [ 2drop <304> ] if ;
[ file-responder get hook>> call( filename mime-type -- response ) ]
[ 2drop <304> ]
if ;
: serving-path ( filename -- filename )
[ file-responder get root>> trim-tail-separators "/" ] dip
@ -51,7 +53,7 @@ TUPLE: file-responder root hook special allow-listings ;
: serve-file ( filename -- response )
dup mime-type
dup file-responder get special>> at
[ call ] [ serve-static ] ?if ;
[ call( filename -- response ) ] [ serve-static ] ?if ;
\ serve-file NOTICE add-input-logging

21
basis/images/bitmap/bitmap-tests.factor
View File

@ -1,18 +1,15 @@
USING: images.bitmap images.viewer io.encodings.binary
io.files io.files.unique kernel tools.test images.loader ;
io.files io.files.unique kernel tools.test images.loader
literals sequences ;
IN: images.bitmap.tests
: test-bitmap24 ( -- path )
"vocab:images/test-images/thiswayup24.bmp" ;
CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
: test-bitmap8 ( -- path )
"vocab:images/test-images/rgb8bit.bmp" ;
CONSTANT: test-bitmap8 "vocab:images/test-images/rgb8bit.bmp"
: test-bitmap4 ( -- path )
"vocab:images/test-images/rgb4bit.bmp" ;
CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp"
: test-bitmap1 ( -- path )
"vocab:images/test-images/1bit.bmp" ;
CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
[ t ]
[
@ -22,3 +19,9 @@ IN: images.bitmap.tests
"test-bitmap24" unique-file
[ save-bitmap ] [ binary file-contents ] bi =
] unit-test
{
$ test-bitmap8
$ test-bitmap24
"vocab:ui/render/test/reference.bmp"
} [ [ ] swap [ load-image drop ] curry unit-test ] each

177
basis/images/bitmap/bitmap.factor
View File

@ -3,17 +3,26 @@
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary io.files
kernel macros math math.bitwise math.functions namespaces sequences
strings images endian summary ;
strings images endian summary locals ;
IN: images.bitmap
TUPLE: bitmap-image < image
magic size reserved offset header-length width
: assert-sequence= ( a b -- )
2dup sequence= [ 2drop ] [ assert ] if ;
: read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
TUPLE: bitmap-image < image ;
! Used to construct the final bitmap-image
TUPLE: loading-bitmap
size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index ;
! Currently can only handle 24/32bit bitmaps.
! Handles row-reversed bitmaps (their height is negative)
ERROR: bitmap-magic magic ;
M: bitmap-magic summary
@ -21,40 +30,34 @@ M: bitmap-magic summary
<PRIVATE
: array-copy ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ;
: 8bit>buffer ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
ERROR: bmp-not-supported n ;
: raw-bitmap>buffer ( bitmap -- array )
: reverse-lines ( byte-array width -- byte-array )
3 * <sliced-groups> <reversed> concat ; inline
: raw-bitmap>seq ( loading-bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
{ 24 [ color-index>> ] }
{ 16 [ bmp-not-supported ] }
{ 8 [ 8bit>buffer ] }
{ 4 [ bmp-not-supported ] }
{ 2 [ bmp-not-supported ] }
{ 1 [ bmp-not-supported ] }
{ 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
{ 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
[ bmp-not-supported ]
} case >byte-array ;
: read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ;
: parse-file-header ( bitmap -- bitmap )
2 read dup "BM" sequence= [ bitmap-magic ] unless >>magic
: parse-file-header ( loading-bitmap -- loading-bitmap )
2 read "BM" assert-sequence=
read4 >>size
read4 >>reserved
read4 >>offset ;
: parse-bitmap-header ( bitmap -- bitmap )
: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
read4 >>header-length
read4 >>width
read4 >>height
read4 32 >signed >>height
read2 >>planes
read2 >>bit-count
read4 >>compression
@ -64,10 +67,10 @@ ERROR: bmp-not-supported n ;
read4 >>color-used
read4 >>color-important ;
: rgb-quads-length ( bitmap -- n )
: rgb-quads-length ( loading-bitmap -- n )
[ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( bitmap -- n )
: color-index-length ( loading-bitmap -- n )
{
[ width>> ]
[ planes>> * ]
@ -75,21 +78,37 @@ ERROR: bmp-not-supported n ;
[ height>> abs * ]
} cleave ;
: parse-bitmap ( bitmap -- bitmap )
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index ;
: image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
: load-bitmap-data ( path bitmap -- bitmap )
:: fixup-color-index ( loading-bitmap -- loading-bitmap )
loading-bitmap width>> :> width
loading-bitmap height>> abs :> height
loading-bitmap color-index>> length :> color-index-length
height 3 * :> height*3
color-index-length width height*3 * - height*3 /i :> misaligned
misaligned 0 > [
loading-bitmap [
loading-bitmap width>> misaligned + 3 * <sliced-groups>
[ 3 misaligned * head* ] map concat
] change-color-index
] [
loading-bitmap
] if ;
: parse-bitmap ( loading-bitmap -- loading-bitmap )
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index
fixup-color-index ;
: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
[ binary ] dip '[
_ parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ;
: process-bitmap-data ( bitmap -- bitmap )
dup raw-bitmap>buffer >>bitmap ;
ERROR: unknown-component-order bitmap ;
: bitmap>component-order ( bitmap -- object )
: bitmap>component-order ( loading-bitmap -- object )
bit-count>> {
{ 32 [ BGRA ] }
{ 24 [ BGR ] }
@ -97,65 +116,67 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
: fill-image-slots ( bitmap -- bitmap )
dup {
[ [ width>> ] [ height>> ] bi 2array >>dim ]
: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
[ bitmap-image new ] dip
{
[ raw-bitmap>seq >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
[ height>> 0 < [ t >>upside-down? ] when ]
[ bitmap>component-order >>component-order ]
[ bitmap>> >>bitmap ]
} cleave ;
M: bitmap-image load-image* ( path bitmap -- bitmap )
load-bitmap-data process-bitmap-data
fill-image-slots ;
M: bitmap-image normalize-scan-line-order
dup dim>> '[
_ first 4 * <sliced-groups> reverse concat
] change-bitmap ;
MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[
bitmap-image new
2over * _ * >>size-image
swap >>height
swap >>width
swap array-copy [ >>bitmap ] [ >>color-index ] bi
_ >>bit-count fill-image-slots
] ;
: bgr>bitmap ( array height width -- bitmap )
24 (nbits>bitmap) ;
: bgra>bitmap ( array height width -- bitmap )
32 (nbits>bitmap) ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
drop loading-bitmap new
load-bitmap-data
loading-bitmap>bitmap-image ;
PRIVATE>
: save-bitmap ( bitmap path -- )
: bitmap>color-index ( bitmap-array -- byte-array )
4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
: save-bitmap ( image path -- )
binary [
B{ CHAR: B CHAR: M } write
[
color-index>> length 14 + 40 + write4
bitmap>> bitmap>color-index length 14 + 40 + write4
0 write4
54 write4
40 write4
] [
{
[ width>> write4 ]
[ height>> write4 ]
[ planes>> 1 or write2 ]
[ bit-count>> 24 or write2 ]
[ compression>> 0 or write4 ]
[ size-image>> write4 ]
[ x-pels>> 0 or write4 ]
[ y-pels>> 0 or write4 ]
[ color-used>> 0 or write4 ]
[ color-important>> 0 or write4 ]
[ rgb-quads>> write ]
[ color-index>> write ]
! width height
[ dim>> first2 [ write4 ] bi@ ]
! planes
[ drop 1 write2 ]
! bit-count
[ drop 24 write2 ]
! compression
[ drop 0 write4 ]
! size-image
[ bitmap>> bitmap>color-index length write4 ]
! x-pels
[ drop 0 write4 ]
! y-pels
[ drop 0 write4 ]
! color-used
[ drop 0 write4 ]
! color-important
[ drop 0 write4 ]
! rgb-quads
[
[ bitmap>> bitmap>color-index ] [ dim>> first ] bi
reverse-lines write
]
} cleave
] bi
] with-file-writer ;

31
basis/images/images.factor
View File

@ -27,7 +27,7 @@ R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
{ R32G32B32A32 [ 16 ] }
} case ;
TUPLE: image dim component-order bitmap ;
TUPLE: image dim component-order upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
@ -61,32 +61,41 @@ M: R16G16B16A16 normalize-component-order*
M: R16G16B16 normalize-component-order*
drop RGB16>8 add-dummy-alpha ;
: BGR>RGB ( bitmap bytes-per-pixel -- pixels )
<groups> [ 3 cut [ reverse ] dip append ] map B{ } join ; inline
: BGR>RGB ( bitmap -- pixels )
3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
: BGRA>RGBA ( bitmap -- pixels )
4 <sliced-groups>
[ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
M: BGRA normalize-component-order*
drop 4 BGR>RGB ;
drop BGRA>RGBA ;
M: RGB normalize-component-order*
drop add-dummy-alpha ;
M: BGR normalize-component-order*
drop 3 BGR>RGB add-dummy-alpha ;
drop BGR>RGB add-dummy-alpha ;
: ARGB>RGBA ( bitmap -- bitmap' )
4 <groups> [ unclip suffix ] map B{ } join ;
4 <groups> [ unclip suffix ] map B{ } join ; inline
M: ARGB normalize-component-order*
drop ARGB>RGBA ;
M: ABGR normalize-component-order*
drop ARGB>RGBA 4 BGR>RGB ;
drop ARGB>RGBA BGRA>RGBA ;
GENERIC: normalize-scan-line-order ( image -- image )
M: image normalize-scan-line-order ;
: normalize-scan-line-order ( image -- image )
dup upside-down?>> [
dup dim>> first 4 * '[
_ <groups> reverse concat
] change-bitmap
f >>upside-down?
] when ;
: normalize-image ( image -- image )
[ >byte-array ] change-bitmap
normalize-component-order
normalize-scan-line-order ;
normalize-scan-line-order
RGBA >>component-order ;

47
basis/images/png/png.factor
View File

@ -2,15 +2,18 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors constructors images io io.binary io.encodings.ascii
io.encodings.binary io.encodings.string io.files io.files.info kernel
sequences io.streams.limited ;
sequences io.streams.limited fry combinators arrays math
checksums checksums.crc32 ;
IN: images.png
TUPLE: png-image < image chunks ;
TUPLE: png-image < image chunks
width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ;
CONSTRUCTOR: png-image ( -- image )
V{ } clone >>chunks ;
TUPLE: png-chunk length type data crc ;
TUPLE: png-chunk length type data ;
CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
@ -23,19 +26,47 @@ ERROR: bad-png-header header ;
bad-png-header
] unless drop ;
ERROR: bad-checksum ;
: read-png-chunks ( image -- image )
<png-chunk>
4 read be> >>length
4 read ascii decode >>type
dup length>> read >>data
4 read >>crc
4 read be> [ >>length ] [ 4 + ] bi
read dup crc32 checksum-bytes
4 read = [ bad-checksum ] unless
4 cut-slice
[ ascii decode >>type ]
[ B{ } like >>data ] bi*
[ over chunks>> push ]
[ type>> ] bi "IEND" =
[ read-png-chunks ] unless ;
: find-chunk ( image string -- chunk )
[ chunks>> ] dip '[ type>> _ = ] find nip ;
: parse-ihdr-chunk ( image -- image )
dup "IHDR" find-chunk data>> {
[ [ 0 4 ] dip subseq be> >>width ]
[ [ 4 8 ] dip subseq be> >>height ]
[ [ 8 ] dip nth >>bit-depth ]
[ [ 9 ] dip nth >>color-type ]
[ [ 10 ] dip nth >>compression-method ]
[ [ 11 ] dip nth >>filter-method ]
[ [ 12 ] dip nth >>interlace-method ]
} cleave ;
: find-compressed-bytes ( image -- bytes )
chunks>> [ type>> "IDAT" = ] filter
[ data>> ] map concat ;
: fill-image-data ( image -- image )
dup [ width>> ] [ height>> ] bi 2array >>dim ;
: load-png ( path -- image )
[ binary <file-reader> ] [ file-info size>> ] bi stream-throws <limited-stream> [
[ binary <file-reader> ] [ file-info size>> ] bi
stream-throws <limited-stream> [
<png-image>
read-png-header
read-png-chunks
parse-ihdr-chunk
fill-image-data
] with-input-stream ;

2
basis/images/tiff/tiff.factor
View File

@ -503,7 +503,7 @@ ERROR: unknown-component-order ifd ;
: ifd>image ( ifd -- image )
{
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order ]
[ ifd-component-order f ]
[ bitmap>> ]
} cleave tiff-image boa ;

2
basis/inspector/inspector-tests.factor
View File

@ -8,7 +8,7 @@ f describe
H{ } describe
H{ } describe
[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test
[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
[ ] [ H{ } clone inspect ] unit-test

4
basis/inspector/inspector.factor
View File

@ -9,7 +9,7 @@ IN: inspector
SYMBOL: +number-rows+
: summary. ( obj -- ) [ summary ] keep write-object nl ;
: print-summary ( obj -- ) [ summary ] keep write-object ;
<PRIVATE
@ -40,7 +40,7 @@ M: mirror fix-slot-names
: (describe) ( obj assoc -- keys )
t pprint-string-cells? [
[ summary. ] [
[ print-summary nl ] [
dup hashtable? [ sort-unparsed-keys ] when
[ fix-slot-names add-numbers simple-table. ] [ keys ] bi
] bi*

4
basis/inverse/inverse.factor
View File

@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors splitting
combinators.short-circuit fry words.symbol generalizations ;
combinators.short-circuit fry words.symbol generalizations call ;
RENAME: _ fry => __
IN: inverse
@ -122,7 +122,7 @@ M: math-inverse inverse
M: pop-inverse inverse
[ "pop-length" word-prop cut-slice swap >quotation ]
[ "pop-inverse" word-prop ] bi compose call ;
[ "pop-inverse" word-prop ] bi compose call( -- quot ) ;
: (undo) ( revquot -- )
[ unclip-slice inverse % (undo) ] unless-empty ;

10
basis/io/directories/search/search-tests.factor
View File

@ -8,3 +8,13 @@ IN: io.directories.search.tests
current-temporary-directory get [ ] find-all-files
] with-unique-directory drop [ natural-sort ] bi@ =
] unit-test
[ f ] [
{ "omg you shoudnt have a directory called this" "or this" }
t
[ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
] unit-test
[ f ] [
{ } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
] unit-test

4
basis/io/directories/search/search.factor
View File

@ -61,8 +61,8 @@ PRIVATE>
ERROR: file-not-found ;
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
[
'[ _ _ find-file [ file-not-found ] unless* ] attempt-all
'[
_ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
] [
drop f
] recover ;

2
basis/io/encodings/big5/big5.factor
View File

@ -3,7 +3,7 @@
USING: io.encodings.iana io.encodings.euc ;
IN: io.encodings.big5
EUC: big5 "vocab:io/encodings/big5/CP950.txt"
EUC: big5 "vocab:io/encodings/big5/CP950.TXT"
big5 "Big5" register-encoding

9
basis/io/encodings/euc-kr/euc-kr-docs.factor
View File

@ -3,8 +3,11 @@
USING: help.syntax help.markup ;
IN: io.encodings.euc-kr
ABOUT: euc-kr
HELP: euc-kr
{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR, in practice." }
{ $class-description "This encoding class implements Microsoft's CP949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatible with EUC-KR in practice." }
{ $see-also "encodings-introduction" } ;
ARTICLE: "io.encodings.euc-kr" "EUC-KR encoding"
{ $subsection euc-kr } ;
ABOUT: "io.encodings.euc-kr"

7
basis/io/encodings/johab/johab-docs.factor
View File

@ -3,7 +3,10 @@
USING: help.syntax help.markup ;
IN: io.encodings.johab
ABOUT: johab
HELP: johab
{ $class-description "Korean Johab encoding (KSC5601-1992). This encoding is not commonly used anymore." } ;
ARTICLE: "io.encodings.johab" "Korean Johab encoding"
{ $subsection johab } ;
ABOUT: "io.encodings.johab"

4
basis/io/ports/ports.factor
View File

@ -27,6 +27,8 @@ TUPLE: buffered-port < port { buffer buffer } ;
TUPLE: input-port < buffered-port ;
M: input-port stream-element-type drop +byte+ ;
: <input-port> ( handle -- input-port )
input-port <buffered-port> ;
@ -102,6 +104,8 @@ TUPLE: output-port < buffered-port ;
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
M: output-port stream-element-type stream>> stream-element-type ;
M: output-port stream-write1
dup check-disposed
1 over wait-to-write

6
basis/io/servers/connection/connection.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint
@ -7,7 +7,7 @@ fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads make concurrency.combinators
concurrency.semaphores concurrency.flags
combinators.short-circuit ;
combinators.short-circuit call ;
IN: io.servers.connection
TUPLE: threaded-server
@ -69,7 +69,7 @@ GENERIC: handle-client* ( threaded-server -- )
[ [ remote-address set ] [ local-address set ] bi* ]
2bi ;
M: threaded-server handle-client* handler>> call ;
M: threaded-server handle-client* handler>> call( -- ) ;
: handle-client ( client remote local -- )
'[

4
basis/io/streams/byte-array/byte-array.factor
View File

@ -5,6 +5,8 @@ sequences io namespaces io.encodings.private accessors sequences.private
io.streams.sequence destructors math combinators ;
IN: io.streams.byte-array
M: byte-vector stream-element-type drop +byte+ ;
: <byte-writer> ( encoding -- stream )
512 <byte-vector> swap <encoder> ;
@ -14,6 +16,8 @@ IN: io.streams.byte-array
TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
M: byte-reader stream-element-type drop +byte+ ;
M: byte-reader stream-read-partial stream-read ;
M: byte-reader stream-read sequence-read ;
M: byte-reader stream-read1 sequence-read1 ;

5
basis/io/streams/duplex/duplex.factor
View File

@ -15,6 +15,11 @@ CONSULT: formatted-output-stream-protocol duplex-stream out>> ;
: >duplex-stream< ( stream -- in out ) [ in>> ] [ out>> ] bi ; inline
M: duplex-stream stream-element-type
[ in>> ] [ out>> ] bi
[ stream-element-type ] bi@
2dup eq? [ drop ] [ "Cannot determine element type" throw ] if ;
M: duplex-stream set-timeout
>duplex-stream< [ set-timeout ] bi-curry@ bi ;

2
basis/io/streams/memory/memory.factor
View File

@ -8,6 +8,8 @@ TUPLE: memory-stream alien index ;
: <memory-stream> ( alien -- stream )
0 memory-stream boa ;
M: memory-stream stream-element-type drop +byte+ ;
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;

40
basis/io/streams/string/string.factor
View File

@ -5,41 +5,33 @@ strings generic splitting continuations destructors sequences.private
io.streams.plain io.encodings math.order growable io.streams.sequence ;
IN: io.streams.string
<PRIVATE
SINGLETON: null-encoding
M: null-encoding decode-char drop stream-read1 ;
PRIVATE>
M: growable dispose drop ;
M: growable stream-write1 push ;
M: growable stream-write push-all ;
M: growable stream-flush drop ;
: <string-writer> ( -- stream )
512 <sbuf> ;
: with-string-writer ( quot -- str )
<string-writer> swap [ output-stream get ] compose with-output-stream*
>string ; inline
! New implementation
! Readers
TUPLE: string-reader { underlying string read-only } { i array-capacity } ;
M: string-reader stream-element-type drop +character+ ;
M: string-reader stream-read-partial stream-read ;
M: string-reader stream-read sequence-read ;
M: string-reader stream-read1 sequence-read1 ;
M: string-reader stream-read-until sequence-read-until ;
M: string-reader dispose drop ;
<PRIVATE
SINGLETON: null-encoding
M: null-encoding decode-char drop stream-read1 ;
PRIVATE>
: <string-reader> ( str -- stream )
0 string-reader boa null-encoding <decoder> ;
: with-string-reader ( str quot -- )
[ <string-reader> ] dip with-input-stream ; inline
INSTANCE: growable plain-writer
! Writers
M: sbuf stream-element-type drop +character+ ;
: <string-writer> ( -- stream )
512 <sbuf> ;
: with-string-writer ( quot -- str )
<string-writer> swap [ output-stream get ] compose with-output-stream*
>string ; inline

4
basis/io/styles/styles.factor
View File

@ -48,6 +48,8 @@ CONSULT: output-stream-protocol filter-writer stream>> ;
CONSULT: formatted-output-stream-protocol filter-writer stream>> ;
M: filter-writer stream-element-type stream>> stream-element-type ;
M: filter-writer dispose stream>> dispose ;
TUPLE: ignore-close-stream < filter-writer ;
@ -97,7 +99,7 @@ M: plain-writer make-block-stream
nip <ignore-close-stream> ;
M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-output-stream* ;
[ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;

2
basis/listener/listener.factor
View File

@ -84,7 +84,7 @@ SYMBOL: max-stack-items
bi
] with-row
] each
] tabular-output
] tabular-output nl
] unless-empty ;
: trimmed-stack. ( seq -- )

2
basis/lists/lists-docs.factor
View File

@ -21,7 +21,7 @@ ARTICLE: { "lists" "protocol" } "The list protocol"
{ $subsection cdr }
{ $subsection nil? } ;
ARTICLE: { "lists" "strict" } "Strict lists"
ARTICLE: { "lists" "strict" } "Constructing strict lists"
"Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:"
{ $subsection cons }
{ $subsection swons }

2
basis/locals/definitions/definitions.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions effects generic kernel locals
macros memoize prettyprint prettyprint.backend words ;
macros memoize prettyprint prettyprint.backend see words ;
IN: locals.definitions
PREDICATE: lambda-word < word "lambda" word-prop >boolean ;

2
basis/locals/locals-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.syntax help.markup kernel macros prettyprint
memoize combinators arrays generalizations ;
memoize combinators arrays generalizations see ;
IN: locals
HELP: [|

2
basis/locals/locals-tests.factor
View File

@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions
definitions compiler.units fry lexer words.symbol ;
definitions compiler.units fry lexer words.symbol see ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;

2
basis/logging/analysis/analysis.factor
View File

@ -41,7 +41,7 @@ SYMBOL: message-histogram
[ >alist sort-values <reversed> ] dip [
[ swapd with-cell pprint-cell ] with-row
] curry assoc-each
] tabular-output ;
] tabular-output ; inline
: log-entry. ( entry -- )
"====== " write

2
basis/logging/logging.factor
View File

@ -80,7 +80,7 @@ ERROR: bad-log-message-parameters msg word level ;
PRIVATE>
: (define-logging) ( word level quot -- )
[ dup ] 2dip 2curry annotate ;
[ dup ] 2dip 2curry annotate ; inline
: call-logging-quot ( quot word level -- quot' )
[ "called" ] 2dip [ log-message ] 3curry prepose ;

2
basis/macros/macros-tests.factor
View File

@ -1,6 +1,6 @@
IN: macros.tests
USING: tools.test macros math kernel arrays
vectors io.streams.string prettyprint parser eval ;
vectors io.streams.string prettyprint parser eval see ;
MACRO: see-test ( a b -- c ) + ;

2
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -84,7 +84,7 @@ M: word integer-op-input-classes
: define-integer-op-word ( fix-word big-word triple -- )
[
[ 2nip integer-op-word ] [ integer-op-quot ] 3bi
[ 2nip integer-op-word dup make-foldable ] [ integer-op-quot ] 3bi
(( x y -- z )) define-declared
] [
2nip

2
basis/memoize/memoize-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel memoize tools.test parser generalizations
prettyprint io.streams.string sequences eval namespaces ;
prettyprint io.streams.string sequences eval namespaces see ;
IN: memoize.tests
MEMO: fib ( m -- n )

2
basis/models/models-docs.factor
View File

@ -137,7 +137,7 @@ $nl
{ $subsection "models-delay" } ;
ARTICLE: "models-impl" "Implementing models"
"New types of models can be defined, for example see " { $vocab-link "models.filter" } "."
"New types of models can be defined, for example see " { $vocab-link "models.arrow" } "."
$nl
"Models can execute hooks when activated:"
{ $subsection model-activated }

22
basis/opengl/textures/textures-tests.factor
View File

@ -5,15 +5,19 @@ images kernel namespaces ;
IN: opengl.textures.tests
[ ] [
{ 3 5 }
RGB
B{
1 2 3 4 5 6 7 8 9
10 11 12 13 14 15 16 17 18
19 20 21 22 23 24 25 26 27
28 29 30 31 32 33 34 35 36
37 38 39 40 41 42 43 44 45
} image boa "image" set
T{ image
{ dim { 3 5 } }
{ component-order RGB }
{ bitmap
B{
1 2 3 4 5 6 7 8 9
10 11 12 13 14 15 16 17 18
19 20 21 22 23 24 25 26 27
28 29 30 31 32 33 34 35 36
37 38 39 40 41 42 43 44 45
}
}
} "image" set
] unit-test
[

6
basis/opengl/textures/textures.factor
View File

@ -11,14 +11,16 @@ IN: opengl.textures
TUPLE: texture loc dim texture-coords texture display-list disposed ;
<PRIVATE
GENERIC: component-order>format ( component-order -- format type )
M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
<PRIVATE
: repeat-last ( seq n -- seq' )
over peek pad-tail concat ;

64
basis/peg/ebnf/ebnf.factor
View File

@ -5,7 +5,7 @@ sequences quotations vectors namespaces make math assocs
continuations peg peg.parsers unicode.categories multiline
splitting accessors effects sequences.deep peg.search
combinators.short-circuit lexer io.streams.string stack-checker
io combinators parser ;
io combinators parser call ;
IN: peg.ebnf
: rule ( name word -- parser )
@ -36,7 +36,7 @@ TUPLE: tokenizer any one many ;
: TOKENIZER:
scan search [ "Tokenizer not found" throw ] unless*
execute \ tokenizer set-global ; parsing
execute( -- tokenizer ) \ tokenizer set-global ; parsing
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
@ -128,28 +128,28 @@ PEG: escaper ( string -- ast )
#! in the EBNF syntax itself.
[
{
[ dup blank? ]
[ dup CHAR: " = ]
[ dup CHAR: ' = ]
[ dup CHAR: | = ]
[ dup CHAR: { = ]
[ dup CHAR: } = ]
[ dup CHAR: = = ]
[ dup CHAR: ) = ]
[ dup CHAR: ( = ]
[ dup CHAR: ] = ]
[ dup CHAR: [ = ]
[ dup CHAR: . = ]
[ dup CHAR: ! = ]
[ dup CHAR: & = ]
[ dup CHAR: * = ]
[ dup CHAR: + = ]
[ dup CHAR: ? = ]
[ dup CHAR: : = ]
[ dup CHAR: ~ = ]
[ dup CHAR: < = ]
[ dup CHAR: > = ]
} 0|| not nip
[ blank? ]
[ CHAR: " = ]
[ CHAR: ' = ]
[ CHAR: | = ]
[ CHAR: { = ]
[ CHAR: } = ]
[ CHAR: = = ]
[ CHAR: ) = ]
[ CHAR: ( = ]
[ CHAR: ] = ]
[ CHAR: [ = ]
[ CHAR: . = ]
[ CHAR: ! = ]
[ CHAR: & = ]
[ CHAR: * = ]
[ CHAR: + = ]
[ CHAR: ? = ]
[ CHAR: : = ]
[ CHAR: ~ = ]
[ CHAR: < = ]
[ CHAR: > = ]
} 1|| not
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
@ -161,9 +161,9 @@ PEG: escaper ( string -- ast )
#! Parse a valid foreign parser name
[
{
[ dup blank? ]
[ dup CHAR: > = ]
} 0|| not nip
[ blank? ]
[ CHAR: > = ]
} 1|| not
] satisfy repeat1 [ >string ] action ;
: 'foreign' ( -- parser )
@ -391,7 +391,7 @@ M: ebnf-choice (transform) ( ast -- parser )
options>> [ (transform) ] map choice ;
M: ebnf-any-character (transform) ( ast -- parser )
drop tokenizer any>> call ;
drop tokenizer any>> call( -- parser ) ;
M: ebnf-range (transform) ( ast -- parser )
pattern>> range-pattern ;
@ -469,17 +469,17 @@ ERROR: bad-effect quot effect ;
M: ebnf-action (transform) ( ast -- parser )
[ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
string-lines parse-lines check-action-effect action ;
[ string-lines parse-lines ] call( string -- quot ) check-action-effect action ;
M: ebnf-semantic (transform) ( ast -- parser )
[ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
string-lines parse-lines semantic ;
[ string-lines parse-lines ] call( string -- quot ) semantic ;
M: ebnf-var (transform) ( ast -- parser )
parser>> (transform) ;
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> tokenizer one>> call ;
symbol>> tokenizer one>> call( symbol -- parser ) ;
M: ebnf-foreign (transform) ( ast -- parser )
dup word>> search
@ -487,7 +487,7 @@ M: ebnf-foreign (transform) ( ast -- parser )
swap rule>> [ main ] unless* over rule [
nip
] [
execute
execute( -- parser )
] if* ;
: parser-not-found ( name -- * )

2
basis/peg/peg-tests.factor
View File

@ -5,6 +5,8 @@ USING: kernel tools.test strings namespaces make arrays sequences
peg peg.private peg.parsers accessors words math accessors ;
IN: peg.tests
\ parse must-infer
[ ] [ reset-pegs ] unit-test
[

8
basis/peg/peg.factor
View File

@ -4,7 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs
io vectors arrays math.parser math.order vectors combinators
classes sets unicode.categories compiler.units parser words
quotations effects memoize accessors locals effects splitting
combinators.short-circuit generalizations ;
combinators.short-circuit generalizations call ;
IN: peg
TUPLE: parse-result remaining ast ;
@ -298,7 +298,7 @@ SYMBOL: delayed
#! Work through all delayed parsers and recompile their
#! words to have the correct bodies.
delayed get [
call compile-parser 1quotation (( -- result )) define-declared
call( -- parser ) compile-parser 1quotation (( -- result )) define-declared
] assoc-each ;
: compile ( parser -- word )
@ -309,7 +309,7 @@ SYMBOL: delayed
] with-compilation-unit ;
: compiled-parse ( state word -- result )
swap [ execute [ error-stack get first throw ] unless* ] with-packrat ; inline
swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ;
: (parse) ( input parser -- result )
dup word? [ compile ] unless compiled-parse ;
@ -527,7 +527,7 @@ M: box-parser (compile) ( peg -- quot )
#! to produce the parser to be compiled.
#! This differs from 'delay' which calls
#! it at run time.
quot>> call compile-parser 1quotation ;
quot>> call( -- parser ) compile-parser 1quotation ;
PRIVATE>

2
basis/peg/search/search-tests.factor
View File

@ -17,3 +17,5 @@ IN: peg.search.tests
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
] unit-test
\ search must-infer
\ replace must-infer

58
basis/prettyprint/prettyprint-docs.factor
View File

@ -1,6 +1,7 @@
USING: prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections prettyprint.private help.markup help.syntax
io kernel words definitions quotations strings generic classes ;
io kernel words definitions quotations strings generic classes
prettyprint.private ;
IN: prettyprint
ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
@ -149,10 +150,6 @@ $nl
{ $subsection unparse-use }
"Utility for tabular output:"
{ $subsection pprint-cell }
"Printing a definition (see " { $link "definitions" } "):"
{ $subsection see }
"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
{ $subsection see-methods }
"More prettyprinter usage:"
{ $subsection "prettyprint-numbers" }
{ $subsection "prettyprint-stacks" }
@ -160,7 +157,7 @@ $nl
{ $subsection "prettyprint-variables" }
{ $subsection "prettyprint-extension" }
{ $subsection "prettyprint-limitations" }
{ $see-also "number-strings" } ;
{ $see-also "number-strings" "see" } ;
ABOUT: "prettyprint"
@ -232,51 +229,4 @@ HELP: .s
HELP: in.
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Prettyprints a " { $snippet "IN:" } " declaration." }
$prettyprinting-note ;
HELP: synopsis
{ $values { "defspec" "a definition specifier" } { "str" string } }
{ $contract "Prettyprints the prologue of a definition." } ;
HELP: synopsis*
{ $values { "defspec" "a definition specifier" } }
{ $contract "Adds sections to the current block corresponding to a the prologue of a definition, in source code-like form." }
{ $notes "This word should only be called from inside the " { $link with-pprint } " combinator. Client code should call " { $link synopsis } " instead." } ;
HELP: comment.
{ $values { "string" "a string" } }
{ $description "Prettyprints some text with the comment style." }
$prettyprinting-note ;
HELP: see
{ $values { "defspec" "a definition specifier" } }
{ $contract "Prettyprints a definition." } ;
HELP: see-methods
{ $values { "word" "a " { $link generic } " or a " { $link class } } }
{ $contract "Prettyprints the methods defined on a generic word or class." } ;
HELP: definer
{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
{ $contract "Outputs the parsing words which delimit the definition." }
{ $examples
{ $example "USING: definitions prettyprint ;"
"IN: scratchpad"
": foo ; \\ foo definer . ."
";\nPOSTPONE: :"
}
{ $example "USING: definitions prettyprint ;"
"IN: scratchpad"
"SYMBOL: foo \\ foo definer . ."
"f\nPOSTPONE: SYMBOL:"
}
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;
HELP: definition
{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } }
{ $contract "Outputs the body of a definition." }
{ $examples
{ $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" }
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;
$prettyprinting-note ;

2
basis/prettyprint/prettyprint-tests.factor
View File

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval
accessors make vocabs.parser ;
accessors make vocabs.parser see ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test

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