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

db4
Joe Groff 2009-03-15 21:28:01 -05:00
commit caa6eb0397
345 changed files with 4618 additions and 3475 deletions

View File

@ -24,7 +24,7 @@ The Factor runtime is written in GNU C99, and is built with GNU make and
gcc. gcc.
Factor supports various platforms. For an up-to-date list, see 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. 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. 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 * Bootstrapping the Factor image
Once you have compiled the Factor runtime, you must bootstrap the Factor 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 On Unix, Factor can either run a graphical user interface using X11, or
a terminal listener. 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 If your DISPLAY environment variable is set, the UI will start
automatically: automatically:
@ -78,14 +73,6 @@ To run an interactive terminal listener:
./factor -run=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 * Running Factor on Mac OS X - Cocoa UI
On Mac OS X, a Cocoa UI is available in addition to the terminal 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: 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. 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 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 Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI. the Factor UI.
@ -135,7 +128,9 @@ To run the listener in the command prompt:
* The Factor FAQ * 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 * Command line usage

View File

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

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"

View File

@ -10,7 +10,7 @@ IN: ascii
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline : digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ 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 : quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline : Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline : alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline

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

View File

@ -6,17 +6,17 @@ io.streams.byte-array ;
IN: bitstreams.tests IN: bitstreams.tests
[ 1 t ] [ 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 ] [ 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 ] [ 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 } ] [ B{ 254 } ]
[ [
<string-writer> <bitstream-writer> 254 8 rot binary <byte-writer> <bitstream-writer> 254 8 rot
[ write-bits ] keep stream>> >byte-array [ write-bits ] keep stream>> >byte-array
] unit-test ] unit-test

View File

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

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." } ; { $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: month-abbreviations HELP: month-abbreviations
{ $values { "array" array } } { $values { "value" array } }
{ $description "Returns an array with the English abbreviated names of all the months." } { $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." } ; { $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." } ; { $description "Looks up the day name and returns it as a string." } ;
HELP: day-abbreviations2 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." } ; { $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
HELP: day-abbreviation2 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." } ; { $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
HELP: day-abbreviations3 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." } ; { $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
HELP: day-abbreviation3 HELP: day-abbreviation3

View File

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

View File

@ -14,12 +14,20 @@ IN: call.tests
[ 1 2 \ + execute( x y -- z a ) ] must-fail [ 1 2 \ + execute( x y -- z a ) ] must-fail
[ \ + execute( x y -- z ) ] must-infer [ \ + 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 )) execute-effect-unsafe? ] unit-test
[ t ] [ \ + (( a b c -- d e )) 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 ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
[ f ] [ \ call (( x -- )) 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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel macros fry summary sequences generalizations accessors USING: kernel macros fry summary sequences sequences.private
continuations effects effects.parser parser words ; generalizations accessors continuations effects effects.parser
parser words ;
IN: call IN: call
ERROR: wrong-values values quot length-required ; ERROR: wrong-values values quot length-required ;
@ -14,17 +15,9 @@ M: wrong-values summary
: firstn-safe ( array quot n -- ... ) : firstn-safe ( array quot n -- ... )
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline 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-call( ( accum word -- accum )
[ ")" parse-effect parsed ] dip parsed ; [ ")" parse-effect parsed ] dip parsed ;
: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
PRIVATE> PRIVATE>
MACRO: call-effect ( effect -- quot ) MACRO: call-effect ( effect -- quot )
@ -33,10 +26,35 @@ MACRO: call-effect ( effect -- quot )
: call( \ call-effect parse-call( ; parsing : call( \ call-effect parse-call( ; parsing
: execute-effect ( word effect -- ) <PRIVATE
2dup execute-effect-unsafe?
[ execute-effect-unsafe ] : execute-effect-unsafe ( word effect -- )
[ [ [ execute ] curry ] dip call-effect ] drop execute ;
if ; inline
: 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 : execute( \ execute-effect parse-call( ; parsing

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

@ -0,0 +1 @@
extensions

View File

@ -7,4 +7,34 @@ assocs cocoa.enumeration ;
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
[ V{ "A" } ] [ { "A" } >cf &CFRelease plist> ] 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
[ 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 ] with-destructors

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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 and ] final-classes first false-class? ] unit-test
! [ t ] [ [ dup t xor swap 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

View File

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -13,8 +13,8 @@ HELP: PROTOCOL:
{ define-protocol POSTPONE: PROTOCOL: } related-words { define-protocol POSTPONE: PROTOCOL: } related-words
HELP: define-consult HELP: define-consult
{ $values { "class" "a class" } { "group" "a protocol, generic word or tuple class" } { "quot" "a quotation" } } { $values { "consultation" consultation } }
{ $description "Defines a class to consult, using the given quotation, on the generic words contained in the group." } { $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." } ; { $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ;
HELP: CONSULT: HELP: CONSULT:

View File

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

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><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\">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\">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 [ "<p><a href=\"Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
"/wiki/view/" relative-link-prefix [ "/wiki/view/" relative-link-prefix [

View File

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

View File

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

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

View File

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

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. ! 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.forms
html.templates html.templates
html.templates.chloe html.templates.chloe
@ -23,7 +23,7 @@ TUPLE: boilerplate < filter-responder template init ;
M:: boilerplate call-responder* ( path responder -- ) M:: boilerplate call-responder* ( path responder -- )
begin-form begin-form
path responder call-next-method path responder call-next-method
responder init>> call responder init>> call( -- )
dup wrap-boilerplate? [ dup wrap-boilerplate? [
clone [| body | clone [| body |
[ [

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

View File

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

View File

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

View File

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

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

View File

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

View File

@ -1,6 +1,6 @@
USING: math definitions help.topics help tools.test USING: math definitions help.topics help tools.test
prettyprint parser io.streams.string kernel source-files 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 IN: help.definitions.tests
[ ] [ \ + >link see ] unit-test [ ] [ \ + >link see ] unit-test

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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions help help.topics help.syntax USING: accessors definitions help help.topics help.syntax
prettyprint.backend prettyprint.custom prettyprint words kernel prettyprint.backend prettyprint.custom prettyprint words kernel
effects ; effects see ;
IN: help.definitions IN: help.definitions
! Definition protocol implementation ! Definition protocol implementation

View File

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

View File

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

View File

@ -132,6 +132,11 @@ SYMBOL: vocabs-quot
[ check-descriptions ] [ check-descriptions ]
} cleave ; } 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 ) : all-word-help ( words -- seq )
[ word-help ] filter ; [ word-help ] filter ;
@ -153,7 +158,8 @@ M: help-error error.
dup '[ dup '[
_ dup word-help _ dup word-help
[ check-values ] [ 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 ] check-something
] [ drop ] if ; ] [ drop ] if ;

View File

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

View File

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

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. ! 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 mirrors math fry sequences words continuations
xml.entities xml.writer xml.syntax ; xml.entities xml.writer xml.syntax ;
IN: html.forms IN: html.forms
@ -96,7 +96,7 @@ C: <validation-error> validation-error
>hashtable "validators" set-word-prop ; >hashtable "validators" set-word-prop ;
: validate ( value quot -- result ) : validate ( value quot -- result )
[ <validation-error> ] recover ; inline '[ _ call( value -- validated ) ] [ <validation-error> ] recover ;
: validate-value ( name value quot -- ) : validate-value ( name value quot -- )
validate validate

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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences 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 ; quotations xml.data xml.writer xml.syntax ;
IN: html.templates IN: html.templates
@ -12,7 +12,7 @@ GENERIC: call-template* ( template -- )
M: string call-template* write ; M: string call-template* write ;
M: callable call-template* call ; M: callable call-template* call( -- ) ;
M: xml call-template* write-xml ; M: xml call-template* write-xml ;

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
[ "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 [ "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 ; : lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1 STRING: read-request-test-1

View File

@ -34,7 +34,7 @@ IN: http
: check-header-string ( str -- str ) : check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
dup "\r\n\"" intersects? dup "\r\n" intersects?
[ "Header injection attack" throw ] when ; [ "Header injection attack" throw ] when ;
: write-header ( assoc -- ) : write-header ( assoc -- )
@ -213,7 +213,10 @@ TUPLE: post-data data params content-type content-encoding ;
swap >>content-type ; swap >>content-type ;
: parse-content-type-attributes ( string -- attributes ) : 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 ) : parse-content-type ( content-type -- type encoding )
";" split1 ";" split1

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

View File

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

View File

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

View File

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

View File

@ -20,7 +20,7 @@ HELP: enable-fhtml
{ $side-effects "responder" } ; { $side-effects "responder" } ;
ARTICLE: "http.server.static.extend" "Hooks for dynamic content" 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 $nl
"A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:" "A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:"
{ $subsection enable-fhtml } { $subsection enable-fhtml }

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

View File

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

View File

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

View File

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

View File

@ -2,15 +2,18 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors constructors images io io.binary io.encodings.ascii USING: accessors constructors images io io.binary io.encodings.ascii
io.encodings.binary io.encodings.string io.files io.files.info kernel 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 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 ) CONSTRUCTOR: png-image ( -- image )
V{ } clone >>chunks ; V{ } clone >>chunks ;
TUPLE: png-chunk length type data crc ; TUPLE: png-chunk length type data ;
CONSTRUCTOR: png-chunk ( -- png-chunk ) ; CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
@ -23,19 +26,47 @@ ERROR: bad-png-header header ;
bad-png-header bad-png-header
] unless drop ; ] unless drop ;
ERROR: bad-checksum ;
: read-png-chunks ( image -- image ) : read-png-chunks ( image -- image )
<png-chunk> <png-chunk>
4 read be> >>length 4 read be> [ >>length ] [ 4 + ] bi
4 read ascii decode >>type read dup crc32 checksum-bytes
dup length>> read >>data 4 read = [ bad-checksum ] unless
4 read >>crc 4 cut-slice
[ ascii decode >>type ]
[ B{ } like >>data ] bi*
[ over chunks>> push ] [ over chunks>> push ]
[ type>> ] bi "IEND" = [ type>> ] bi "IEND" =
[ read-png-chunks ] unless ; [ 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 ) : 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> <png-image>
read-png-header read-png-header
read-png-chunks read-png-chunks
parse-ihdr-chunk
fill-image-data
] with-input-stream ; ] with-input-stream ;

View File

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

View File

@ -8,7 +8,7 @@ f describe
H{ } describe H{ } 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 [ ] [ H{ } clone inspect ] unit-test

View File

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

View File

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

View File

@ -8,3 +8,13 @@ IN: io.directories.search.tests
current-temporary-directory get [ ] find-all-files current-temporary-directory get [ ] find-all-files
] with-unique-directory drop [ natural-sort ] bi@ = ] with-unique-directory drop [ natural-sort ] bi@ =
] unit-test ] 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

View File

@ -61,8 +61,8 @@ PRIVATE>
ERROR: file-not-found ; ERROR: file-not-found ;
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f ) : 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 drop f
] recover ; ] recover ;

View File

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

View File

@ -3,8 +3,11 @@
USING: help.syntax help.markup ; USING: help.syntax help.markup ;
IN: io.encodings.euc-kr IN: io.encodings.euc-kr
ABOUT: euc-kr
HELP: 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" } ; { $see-also "encodings-introduction" } ;
ARTICLE: "io.encodings.euc-kr" "EUC-KR encoding"
{ $subsection euc-kr } ;
ABOUT: "io.encodings.euc-kr"

View File

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

View File

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint 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.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads make concurrency.combinators io.encodings threads make concurrency.combinators
concurrency.semaphores concurrency.flags concurrency.semaphores concurrency.flags
combinators.short-circuit ; combinators.short-circuit call ;
IN: io.servers.connection IN: io.servers.connection
TUPLE: threaded-server TUPLE: threaded-server
@ -69,7 +69,7 @@ GENERIC: handle-client* ( threaded-server -- )
[ [ remote-address set ] [ local-address set ] bi* ] [ [ remote-address set ] [ local-address set ] bi* ]
2bi ; 2bi ;
M: threaded-server handle-client* handler>> call ; M: threaded-server handle-client* handler>> call( -- ) ;
: handle-client ( client remote local -- ) : handle-client ( client remote local -- )
'[ '[

View File

@ -5,6 +5,8 @@ sequences io namespaces io.encodings.private accessors sequences.private
io.streams.sequence destructors math combinators ; io.streams.sequence destructors math combinators ;
IN: io.streams.byte-array IN: io.streams.byte-array
M: byte-vector stream-element-type drop +byte+ ;
: <byte-writer> ( encoding -- stream ) : <byte-writer> ( encoding -- stream )
512 <byte-vector> swap <encoder> ; 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 } ; 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-partial stream-read ;
M: byte-reader stream-read sequence-read ; M: byte-reader stream-read sequence-read ;
M: byte-reader stream-read1 sequence-read1 ; M: byte-reader stream-read1 sequence-read1 ;

View File

@ -15,6 +15,11 @@ CONSULT: formatted-output-stream-protocol duplex-stream out>> ;
: >duplex-stream< ( stream -- in out ) [ in>> ] [ out>> ] bi ; inline : >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 M: duplex-stream set-timeout
>duplex-stream< [ set-timeout ] bi-curry@ bi ; >duplex-stream< [ set-timeout ] bi-curry@ bi ;

View File

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

View File

@ -5,41 +5,33 @@ strings generic splitting continuations destructors sequences.private
io.streams.plain io.encodings math.order growable io.streams.sequence ; io.streams.plain io.encodings math.order growable io.streams.sequence ;
IN: io.streams.string IN: io.streams.string
<PRIVATE ! Readers
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
TUPLE: string-reader { underlying string read-only } { i array-capacity } ; 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-partial stream-read ;
M: string-reader stream-read sequence-read ; M: string-reader stream-read sequence-read ;
M: string-reader stream-read1 sequence-read1 ; M: string-reader stream-read1 sequence-read1 ;
M: string-reader stream-read-until sequence-read-until ; M: string-reader stream-read-until sequence-read-until ;
M: string-reader dispose drop ; M: string-reader dispose drop ;
<PRIVATE
SINGLETON: null-encoding
M: null-encoding decode-char drop stream-read1 ;
PRIVATE>
: <string-reader> ( str -- stream ) : <string-reader> ( str -- stream )
0 string-reader boa null-encoding <decoder> ; 0 string-reader boa null-encoding <decoder> ;
: with-string-reader ( str quot -- ) : with-string-reader ( str quot -- )
[ <string-reader> ] dip with-input-stream ; inline [ <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

View File

@ -48,6 +48,8 @@ CONSULT: output-stream-protocol filter-writer stream>> ;
CONSULT: formatted-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 ; M: filter-writer dispose stream>> dispose ;
TUPLE: ignore-close-stream < filter-writer ; TUPLE: ignore-close-stream < filter-writer ;
@ -97,7 +99,7 @@ M: plain-writer make-block-stream
nip <ignore-close-stream> ; nip <ignore-close-stream> ;
M: plain-writer stream-write-table 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> ; M: plain-writer make-cell-stream 2drop <string-writer> ;

View File

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

View File

@ -21,7 +21,7 @@ ARTICLE: { "lists" "protocol" } "The list protocol"
{ $subsection cdr } { $subsection cdr }
{ $subsection nil? } ; { $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:" "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 cons }
{ $subsection swons } { $subsection swons }

View File

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

View File

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

View File

@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions 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 IN: locals.tests
:: foo ( a b -- a a ) a a ; :: foo ( a b -- a a ) a a ;

View File

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

View File

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

View File

@ -1,6 +1,6 @@
IN: macros.tests IN: macros.tests
USING: tools.test macros math kernel arrays 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 ) + ; MACRO: see-test ( a b -- c ) + ;

View File

@ -84,7 +84,7 @@ M: word integer-op-input-classes
: define-integer-op-word ( fix-word big-word triple -- ) : 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 (( x y -- z )) define-declared
] [ ] [
2nip 2nip

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel memoize tools.test parser generalizations 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 IN: memoize.tests
MEMO: fib ( m -- n ) MEMO: fib ( m -- n )

View File

@ -137,7 +137,7 @@ $nl
{ $subsection "models-delay" } ; { $subsection "models-delay" } ;
ARTICLE: "models-impl" "Implementing models" 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 $nl
"Models can execute hooks when activated:" "Models can execute hooks when activated:"
{ $subsection model-activated } { $subsection model-activated }

View File

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

View File

@ -11,14 +11,16 @@ IN: opengl.textures
TUPLE: texture loc dim texture-coords texture display-list disposed ; TUPLE: texture loc dim texture-coords texture display-list disposed ;
<PRIVATE
GENERIC: component-order>format ( component-order -- format type ) 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: 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: 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 ; M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
<PRIVATE
: repeat-last ( seq n -- seq' ) : repeat-last ( seq n -- seq' )
over peek pad-tail concat ; over peek pad-tail concat ;

View File

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

View File

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

View File

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

View File

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

View File

@ -1,6 +1,7 @@
USING: prettyprint.backend prettyprint.config prettyprint.custom USING: prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections prettyprint.private help.markup help.syntax 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 IN: prettyprint
ARTICLE: "prettyprint-numbers" "Prettyprinting numbers" ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
@ -149,10 +150,6 @@ $nl
{ $subsection unparse-use } { $subsection unparse-use }
"Utility for tabular output:" "Utility for tabular output:"
{ $subsection pprint-cell } { $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:" "More prettyprinter usage:"
{ $subsection "prettyprint-numbers" } { $subsection "prettyprint-numbers" }
{ $subsection "prettyprint-stacks" } { $subsection "prettyprint-stacks" }
@ -160,7 +157,7 @@ $nl
{ $subsection "prettyprint-variables" } { $subsection "prettyprint-variables" }
{ $subsection "prettyprint-extension" } { $subsection "prettyprint-extension" }
{ $subsection "prettyprint-limitations" } { $subsection "prettyprint-limitations" }
{ $see-also "number-strings" } ; { $see-also "number-strings" "see" } ;
ABOUT: "prettyprint" ABOUT: "prettyprint"
@ -233,50 +230,3 @@ HELP: in.
{ $values { "vocab" "a vocabulary specifier" } } { $values { "vocab" "a vocabulary specifier" } }
{ $description "Prettyprints a " { $snippet "IN:" } " declaration." } { $description "Prettyprints a " { $snippet "IN:" } " declaration." }
$prettyprinting-note ; $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 } "." } ;

View File

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

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