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

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

Conflicts:

	extra/math/statistics/statistics-docs.factor
db4
Aaron Schaefer 2008-01-13 10:42:38 -05:00
parent 82fd581e9f 240217f39e
commit 2af1085db1
101 changed files with 1305 additions and 850 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
README.txt
View File

@ -8,12 +8,14 @@ implementation. It is not an introduction to the language itself.
- Platform support - Platform support
- Compiling the Factor VM - Compiling the Factor VM
- Libraries needed for compilation
- Bootstrapping the Factor image - Bootstrapping the Factor image
- Running Factor on Unix with X11 - Running Factor on Unix with X11
- Running Factor on Mac OS X - Cocoa UI - Running Factor on Mac OS X - Cocoa UI
- Running Factor on Mac OS X - X11 UI - Running Factor on Mac OS X - X11 UI
- Running Factor on Windows - Running Factor on Windows
- Command line usage - Command line usage
- The Factor FAQ
- Source organization - Source organization
- Community - Community
@ -59,6 +61,17 @@ for your platform.
Compilation will yield an executable named 'factor' on Unix, Compilation will yield an executable named 'factor' on Unix,
'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE. 'factor-nt.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 line
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
to grab everything (if you're on a non-debian-derived distro please tell us
what the equivalent command is on there and it can be added :)
* Bootstrapping the Factor image * Bootstrapping the Factor image
The boot images are no longer included with the Factor distribution The boot images are no longer included with the Factor distribution
@ -148,6 +161,10 @@ To run the listener in the command prompt:
factor-nt.exe -run=listener factor-nt.exe -run=listener
* The Factor FAQ
The Factor FAQ lives online at http://factorcode.org/faq.fhtml
* Command line usage * Command line usage
The Factor VM supports a number of command line switches. To read The Factor VM supports a number of command line switches. To read

2
core/alien/alien.factor
View File

@ -93,4 +93,4 @@ TUPLE: alien-invoke library function return parameters ;
TUPLE: alien-invoke-error library symbol ; TUPLE: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... ) : alien-invoke ( ... return library function parameters -- ... )
pick pick \ alien-invoke-error construct-boa throw ; 2over \ alien-invoke-error construct-boa throw ;

215
core/alien/c-types/c-types.factor
View File

@ -3,7 +3,7 @@
USING: byte-arrays arrays generator.registers assocs USING: byte-arrays arrays generator.registers assocs
kernel kernel.private libc math namespaces parser sequences kernel kernel.private libc math namespaces parser sequences
strings words assocs splitting math.parser cpu.architecture strings words assocs splitting math.parser cpu.architecture
alien quotations system ; alien quotations system compiler.units ;
IN: alien.c-types IN: alien.c-types
TUPLE: c-type TUPLE: c-type
@ -227,130 +227,135 @@ M: long-long-type box-return ( type -- )
define-out ; define-out ;
: expand-constants ( c-type -- c-type' ) : expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around
#! staging violations
dup array? [ dup array? [
unclip >r [ dup word? [ execute ] when ] map r> add* unclip >r [ dup word? [ word-def call ] when ] map
r> add*
] when ; ] when ;
[ alien-cell ] [
[ set-alien-cell ] [ alien-cell ]
bootstrap-cell [ set-alien-cell ]
"box_alien" bootstrap-cell
"alien_offset" <primitive-type> "box_alien"
"void*" define-primitive-type "alien_offset" <primitive-type>
"void*" define-primitive-type
[ alien-signed-8 ] [ alien-signed-8 ]
[ set-alien-signed-8 ] [ set-alien-signed-8 ]
8 8
"box_signed_8" "box_signed_8"
"to_signed_8" <primitive-type> <long-long-type> "to_signed_8" <primitive-type> <long-long-type>
"longlong" define-primitive-type "longlong" define-primitive-type
[ alien-unsigned-8 ] [ alien-unsigned-8 ]
[ set-alien-unsigned-8 ] [ set-alien-unsigned-8 ]
8 8
"box_unsigned_8" "box_unsigned_8"
"to_unsigned_8" <primitive-type> <long-long-type> "to_unsigned_8" <primitive-type> <long-long-type>
"ulonglong" define-primitive-type "ulonglong" define-primitive-type
[ alien-signed-cell ] [ alien-signed-cell ]
[ set-alien-signed-cell ] [ set-alien-signed-cell ]
bootstrap-cell bootstrap-cell
"box_signed_cell" "box_signed_cell"
"to_fixnum" <primitive-type> "to_fixnum" <primitive-type>
"long" define-primitive-type "long" define-primitive-type
[ alien-unsigned-cell ] [ alien-unsigned-cell ]
[ set-alien-unsigned-cell ] [ set-alien-unsigned-cell ]
bootstrap-cell bootstrap-cell
"box_unsigned_cell" "box_unsigned_cell"
"to_cell" <primitive-type> "to_cell" <primitive-type>
"ulong" define-primitive-type "ulong" define-primitive-type
[ alien-signed-4 ] [ alien-signed-4 ]
[ set-alien-signed-4 ] [ set-alien-signed-4 ]
4 4
"box_signed_4" "box_signed_4"
"to_fixnum" <primitive-type> "to_fixnum" <primitive-type>
"int" define-primitive-type "int" define-primitive-type
[ alien-unsigned-4 ] [ alien-unsigned-4 ]
[ set-alien-unsigned-4 ] [ set-alien-unsigned-4 ]
4 4
"box_unsigned_4" "box_unsigned_4"
"to_cell" <primitive-type> "to_cell" <primitive-type>
"uint" define-primitive-type "uint" define-primitive-type
[ alien-signed-2 ] [ alien-signed-2 ]
[ set-alien-signed-2 ] [ set-alien-signed-2 ]
2 2
"box_signed_2" "box_signed_2"
"to_fixnum" <primitive-type> "to_fixnum" <primitive-type>
"short" define-primitive-type "short" define-primitive-type
[ alien-unsigned-2 ] [ alien-unsigned-2 ]
[ set-alien-unsigned-2 ] [ set-alien-unsigned-2 ]
2 2
"box_unsigned_2" "box_unsigned_2"
"to_cell" <primitive-type> "to_cell" <primitive-type>
"ushort" define-primitive-type "ushort" define-primitive-type
[ alien-signed-1 ] [ alien-signed-1 ]
[ set-alien-signed-1 ] [ set-alien-signed-1 ]
1 1
"box_signed_1" "box_signed_1"
"to_fixnum" <primitive-type> "to_fixnum" <primitive-type>
"char" define-primitive-type "char" define-primitive-type
[ alien-unsigned-1 ] [ alien-unsigned-1 ]
[ set-alien-unsigned-1 ] [ set-alien-unsigned-1 ]
1 1
"box_unsigned_1" "box_unsigned_1"
"to_cell" <primitive-type> "to_cell" <primitive-type>
"uchar" define-primitive-type "uchar" define-primitive-type
[ alien-unsigned-4 zero? not ] [ alien-unsigned-4 zero? not ]
[ 1 0 ? set-alien-unsigned-4 ] [ 1 0 ? set-alien-unsigned-4 ]
4 4
"box_boolean" "box_boolean"
"to_boolean" <primitive-type> "to_boolean" <primitive-type>
"bool" define-primitive-type "bool" define-primitive-type
[ alien-float ] [ alien-float ]
[ >r >r >float r> r> set-alien-float ] [ >r >r >float r> r> set-alien-float ]
4 4
"box_float" "box_float"
"to_float" <primitive-type> "to_float" <primitive-type>
"float" define-primitive-type "float" define-primitive-type
T{ float-regs f 4 } "float" c-type set-c-type-reg-class T{ float-regs f 4 } "float" c-type set-c-type-reg-class
[ >float ] "float" c-type set-c-type-prep [ >float ] "float" c-type set-c-type-prep
[ alien-double ] [ alien-double ]
[ >r >r >float r> r> set-alien-double ] [ >r >r >float r> r> set-alien-double ]
8 8
"box_double" "box_double"
"to_double" <primitive-type> "to_double" <primitive-type>
"double" define-primitive-type "double" define-primitive-type
T{ float-regs f 8 } "double" c-type set-c-type-reg-class T{ float-regs f 8 } "double" c-type set-c-type-reg-class
[ >float ] "double" c-type set-c-type-prep [ >float ] "double" c-type set-c-type-prep
[ alien-cell alien>char-string ] [ alien-cell alien>char-string ]
[ set-alien-cell ] [ set-alien-cell ]
bootstrap-cell bootstrap-cell
"box_char_string" "box_char_string"
"alien_offset" <primitive-type> "alien_offset" <primitive-type>
"char*" define-primitive-type "char*" define-primitive-type
"char*" "uchar*" typedef "char*" "uchar*" typedef
[ string>char-alien ] "char*" c-type set-c-type-prep [ string>char-alien ] "char*" c-type set-c-type-prep
[ alien-cell alien>u16-string ] [ alien-cell alien>u16-string ]
[ set-alien-cell ] [ set-alien-cell ]
4 4
"box_u16_string" "box_u16_string"
"alien_offset" <primitive-type> "alien_offset" <primitive-type>
"ushort*" define-primitive-type "ushort*" define-primitive-type
[ string>u16-alien ] "ushort*" c-type set-c-type-prep [ string>u16-alien ] "ushort*" c-type set-c-type-prep
] with-compilation-unit

4
core/assocs/assocs.factor
View File

@ -43,7 +43,7 @@ M: assoc assoc-find
inline inline
: assoc-push-if ( key value quot accum -- ) : assoc-push-if ( key value quot accum -- )
>r pick pick 2slip r> roll >r 2over 2slip r> roll
[ >r 2array r> push ] [ 3drop ] if ; inline [ >r 2array r> push ] [ 3drop ] if ; inline
: assoc-pusher ( quot -- quot' accum ) : assoc-pusher ( quot -- quot' accum )
@ -122,7 +122,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ; swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ;
: cache ( key assoc quot -- value ) : cache ( key assoc quot -- value )
pick pick at [ 2over at [
>r 3drop r> >r 3drop r>
] [ ] [
pick rot >r >r call dup r> r> set-at pick rot >r >r call dup r> r> set-at

16
core/bit-arrays/bit-arrays.factor
View File

@ -6,16 +6,14 @@ IN: bit-arrays
<PRIVATE <PRIVATE
: n>cell -5 shift 4 * ; inline : n>byte -3 shift ; inline
: cell/bit ( n alien -- byte bit ) : byte/bit ( n alien -- byte bit )
over n>cell alien-unsigned-4 swap 31 bitand ; inline over n>byte alien-unsigned-1 swap 7 bitand ; inline
: set-bit ( ? byte bit -- byte ) : set-bit ( ? byte bit -- byte )
2^ rot [ bitor ] [ bitnot bitand ] if ; inline 2^ rot [ bitor ] [ bitnot bitand ] if ; inline
: bits>bytes 7 + -3 shift ; inline
: bits>cells 31 + -5 shift ; inline : bits>cells 31 + -5 shift ; inline
: (set-bits) ( bit-array n -- ) : (set-bits) ( bit-array n -- )
@ -27,11 +25,13 @@ PRIVATE>
M: bit-array length array-capacity ; M: bit-array length array-capacity ;
M: bit-array nth-unsafe cell/bit bit? ; M: bit-array nth-unsafe
>r >fixnum r> byte/bit bit? ;
M: bit-array set-nth-unsafe M: bit-array set-nth-unsafe
[ cell/bit set-bit ] 2keep >r >fixnum r>
swap n>cell set-alien-unsigned-4 ; [ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ;
: clear-bits ( bit-array -- ) 0 (set-bits) ; : clear-bits ( bit-array -- ) 0 (set-bits) ;

2
core/bootstrap/compiler/compiler.factor
View File

@ -17,7 +17,7 @@ IN: bootstrap.compiler
"cpu." cpu append require "cpu." cpu append require
nl nl
"Compiling some words to speed up bootstrap..." write "Compiling some words to speed up bootstrap..." write flush
! Compile a set of words ahead of the full compile. ! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically ! This set of words was determined semi-empirically

1
core/bootstrap/primitives.factor
View File

@ -441,6 +441,7 @@ builtins get num-tags get tail f union-class define-class
{ "fixnum-bitxor" "math.private" } { "fixnum-bitxor" "math.private" }
{ "fixnum-bitnot" "math.private" } { "fixnum-bitnot" "math.private" }
{ "fixnum-shift" "math.private" } { "fixnum-shift" "math.private" }
{ "fixnum-shift-fast" "math.private" }
{ "fixnum<" "math.private" } { "fixnum<" "math.private" }
{ "fixnum<=" "math.private" } { "fixnum<=" "math.private" }
{ "fixnum>" "math.private" } { "fixnum>" "math.private" }

6
core/bootstrap/stage2.factor
View File

@ -4,7 +4,8 @@ USING: init command-line namespaces words debugger io
kernel.private math memory continuations kernel io.files kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units ; definitions assocs compiler.errors compiler.units
math.parser ;
IN: bootstrap.stage2 IN: bootstrap.stage2
! Wrap everything in a catch which starts a listener so ! Wrap everything in a catch which starts a listener so
@ -67,7 +68,8 @@ IN: bootstrap.stage2
] [ print-error 1 exit ] recover ] [ print-error 1 exit ] recover
] set-boot-quot ] set-boot-quot
: count-words all-words swap subset length pprint ; : count-words ( pred -- )
all-words swap subset length number>string write ;
[ compiled? ] count-words " compiled words" print [ compiled? ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print [ symbol? ] count-words " symbol words" print

2
core/command-line/command-line-docs.factor
View File

@ -4,7 +4,7 @@ IN: command-line
ARTICLE: "runtime-cli-args" "Command line switches for the VM" ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features." "A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table { $table
{ { $snippet "-i=" { $emphasis "image" } } "Specifies the image file to use" } { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" } { { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" } { { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" } { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" }

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

@ -3,6 +3,8 @@ assocs words.private sequences ;
IN: compiler IN: compiler
ARTICLE: "compiler-usage" "Calling the optimizing compiler" ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
$nl
"The main entry points to the optimizing compiler:" "The main entry points to the optimizing compiler:"
{ $subsection compile } { $subsection compile }
{ $subsection recompile } { $subsection recompile }

28
core/compiler/compiler.factor
View File

@ -13,33 +13,22 @@ compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- ) : compiled-xref ( word dependencies -- )
2dup "compiled-uses" set-word-prop 2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex ; compiled-crossref get add-vertex* ;
: compiled-unxref ( word -- ) : compiled-unxref ( word -- )
dup "compiled-uses" word-prop dup "compiled-uses" word-prop
compiled-crossref get remove-vertex ; compiled-crossref get remove-vertex* ;
: compiled-usage ( word -- seq ) : compiled-usage ( word -- assoc )
compiled-crossref get at keys ; compiled-crossref get at ;
: sensitive? ( word -- ? )
dup "inline" word-prop
over "infer" word-prop
pick "specializer" word-prop
roll generic?
or or or ;
: compiled-usages ( words -- seq ) : compiled-usages ( words -- seq )
compiled-crossref get [ [ [ dup ] H{ } map>assoc dup ] keep [
[ compiled-usage [ nip +inlined+ eq? ] assoc-subset update
over dup set ] with each keys ;
over sensitive?
[ at namespace swap update ] [ 2drop ] if
] curry each
] H{ } make-assoc keys ;
: ripple-up ( word -- ) : ripple-up ( word -- )
compiled-usage [ queue-compile ] each ; compiled-usage [ drop queue-compile ] assoc-each ;
: save-effect ( word effect -- ) : save-effect ( word effect -- )
over "compiled-uses" word-prop [ over "compiled-uses" word-prop [
@ -60,7 +49,6 @@ compiled-crossref global [ H{ } assoc-like ] change-at
] computing-dependencies ; ] computing-dependencies ;
: compile-failed ( word error -- ) : compile-failed ( word error -- )
! dup inference-error? [ rethrow ] unless
f pick compiled get set-at f pick compiled get set-at
swap compiler-error ; swap compiler-error ;

7
core/compiler/errors/errors.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs prettyprint io sequences USING: kernel namespaces assocs prettyprint io sequences
sorting continuations debugger math ; sorting continuations debugger math math.parser ;
IN: compiler.errors IN: compiler.errors
SYMBOL: compiler-errors SYMBOL: compiler-errors
@ -41,8 +41,9 @@ M: object compiler-warning? drop f ;
: (compiler-report) ( what assoc -- ) : (compiler-report) ( what assoc -- )
length dup zero? [ 2drop ] [ length dup zero? [ 2drop ] [
":" write over write " - print " write pprint [
" compiler " write write "." print ":" % over % " - print " % # " compiler " % % "." %
] "" make print
] if ; ] if ;
: compiler-report ( -- ) : compiler-report ( -- )

20
core/compiler/test/intrinsics.factor
View File

@ -441,3 +441,23 @@ cell 8 = [
] keep 2 fixnum+fast ] keep 2 fixnum+fast
] compile-call ] compile-call
] unit-test ] unit-test
[ 1 ] [
8 -3 [ fixnum-shift-fast ] compile-call
] unit-test
[ 2 ] [
16 -3 [ fixnum-shift-fast ] compile-call
] unit-test
[ 2 ] [
16 [ -3 fixnum-shift-fast ] compile-call
] unit-test
[ 8 ] [
1 3 [ fixnum-shift-fast ] compile-call
] unit-test
[ 8 ] [
1 [ 3 fixnum-shift-fast ] compile-call
] unit-test

26
core/compiler/test/redefine.factor
View File

@ -92,7 +92,7 @@ DEFER: x-4
[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test [ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
[ t ] [ \ x-3 "compiled-uses" word-prop [ interned? ] all? ] unit-test [ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test
DEFER: g-test-1 DEFER: g-test-1
@ -174,6 +174,7 @@ DEFER: hints-test-2
[ 10 ] [ hints-test-2 ] unit-test [ 10 ] [ hints-test-2 ] unit-test
DEFER: inline-then-not-inline-test-1
DEFER: inline-then-not-inline-test-2 DEFER: inline-then-not-inline-test-2
[ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test [ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test
@ -182,6 +183,25 @@ DEFER: inline-then-not-inline-test-2
[ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test [ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test
[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 9 ;" eval ] unit-test \ inline-then-not-inline-test-2 word-xt "a" set
[ 6 9 ] [ inline-then-not-inline-test-2 ] unit-test [ ] [ "IN: temporary : inline-then-not-inline-test-1 6 6 9 ;" eval ] unit-test
[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test
[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
DEFER: generic-then-not-generic-test-1
DEFER: generic-then-not-generic-test-2
[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test
[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test
[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test
[ 9 ] [ generic-then-not-generic-test-2 ] unit-test
[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
[ 4 ] [ generic-then-not-generic-test-2 ] unit-test

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

@ -3,7 +3,7 @@ continuations.private parser vectors arrays namespaces
threads assocs words quotations ; threads assocs words quotations ;
IN: continuations IN: continuations
ARTICLE: "errors-restartable" "Restartable error handling" ARTICLE: "errors-restartable" "Restartable errors"
"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:" "Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:"
{ $subsection throw-restarts } { $subsection throw-restarts }
{ $subsection rethrow-restarts } { $subsection rethrow-restarts }

2
core/continuations/continuations.factor
View File

@ -128,7 +128,7 @@ PRIVATE>
: cleanup ( try cleanup-always cleanup-error -- ) : cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry over >r compose [ dip rethrow ] curry
>r (catch) r> ifcc r> call ; inline recover r> call ; inline
: attempt-all ( seq quot -- obj ) : attempt-all ( seq quot -- obj )
[ [

4
core/cpu/ppc/assembler/assembler.factor
View File

@ -126,6 +126,10 @@ words math.bitfields io.binary ;
: (XOR) 316 x-form 31 insn ; : (XOR) 316 x-form 31 insn ;
: XOR 0 (XOR) ; : XOR. 1 (XOR) ; : XOR 0 (XOR) ; : XOR. 1 (XOR) ;
: (NEG) 0 -rot 104 xo-form 31 insn ;
: NEG 0 0 (NEG) ; : NEG. 0 1 (NEG) ;
: NEGO 1 0 (NEG) ; : NEGO. 1 1 (NEG) ;
: CMPI d-form 11 insn ; : CMPI d-form 11 insn ;
: CMPLI d-form 10 insn ; : CMPLI d-form 10 insn ;

71
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -166,15 +166,43 @@ IN: cpu.ppc.intrinsics
} }
} define-intrinsics } define-intrinsics
\ fixnum-shift [ : %untag-fixnums ( seq -- )
"out" operand "x" operand "y" get neg SRAWI [ dup %untag-fixnum ] unique-operands ;
! Mask off low bits
"out" operand dup %untag \ fixnum-shift-fast {
] H{ {
{ +input+ { { f "x" } { [ -31 0 between? ] "y" } } } [
{ +scratch+ { { f "out" } } } "out" operand "x" operand "y" get
{ +output+ { "out" } } dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
} define-intrinsic ! Mask off low bits
"out" operand dup %untag
] H{
{ +input+ { { f "x" } { [ ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
}
{
[
{ "positive" "end" } [ define-label ] each
"y" operand "out" operand swap %untag-fixnum
0 "y" operand 0 CMPI
"positive" get BGE
"y" operand dup NEG
"out" operand "x" operand "out" operand SRAW
"end" get B
"positive" resolve-label
"out" operand "x" operand "out" operand SLW
"end" resolve-label
! Mask off low bits
"out" operand dup %untag
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
}
}
} define-intrinsics
: generate-fixnum-mod : generate-fixnum-mod
#! PowerPC doesn't have a MOD instruction; so we compute #! PowerPC doesn't have a MOD instruction; so we compute
@ -222,9 +250,6 @@ IN: cpu.ppc.intrinsics
first2 define-fixnum-jump first2 define-fixnum-jump
] each ] each
: %untag-fixnums ( seq -- )
[ dup %untag-fixnum ] unique-operands ;
: overflow-check ( insn1 insn2 -- ) : overflow-check ( insn1 insn2 -- )
[ [
>r 0 0 LI >r 0 0 LI
@ -335,9 +360,10 @@ IN: cpu.ppc.intrinsics
} define-intrinsic } define-intrinsic
: define-float-op ( word op -- ) : define-float-op ( word op -- )
[ "x" operand "x" operand "y" operand ] swap add H{ [ "z" operand "x" operand "y" operand ] swap add H{
{ +input+ { { float "x" } { float "y" } } } { +input+ { { float "x" } { float "y" } } }
{ +output+ { "x" } } { +scratch+ { { float "z" } } }
{ +output+ { "z" } }
} define-intrinsic ; } define-intrinsic ;
{ {
@ -374,6 +400,23 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } } { +output+ { "out" } }
} define-intrinsic } define-intrinsic
\ fixnum>float [
HEX: 4330 "scratch" operand LIS
"scratch" operand 1 0 param@ STW
"scratch" operand "in" operand %untag-fixnum
"scratch" operand dup HEX: 8000 XORIS
"scratch" operand 1 cell param@ STW
"f1" operand 1 0 param@ LFD
4503601774854144.0 "scratch" operand load-indirect
"f2" operand "scratch" operand float-offset LFD
"f1" operand "f1" operand "f2" operand FSUB
] H{
{ +input+ { { f "in" } } }
{ +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } }
{ +output+ { "f1" } }
} define-intrinsic
\ tag [ \ tag [
"out" operand "in" operand tag-mask get ANDI "out" operand "in" operand tag-mask get ANDI
"out" operand dup %tag-fixnum "out" operand dup %tag-fixnum

2
core/cpu/x86/32/32.factor
View File

@ -46,7 +46,7 @@ M: float-regs push-return-reg
: FLD 4 = [ FLDS ] [ FLDL ] if ; : FLD 4 = [ FLDS ] [ FLDL ] if ;
: load/store-float-return reg-size >r stack-reg swap [+] r> ; : load/store-float-return reg-size >r stack@ r> ;
M: float-regs load-return-reg load/store-float-return FLD ; M: float-regs load-return-reg load/store-float-return FLD ;
M: float-regs store-return-reg load/store-float-return FSTP ; M: float-regs store-return-reg load/store-float-return FSTP ;

1
core/cpu/x86/32/bootstrap.factor
View File

@ -12,5 +12,6 @@ IN: bootstrap.x86
: stack-reg ESP ; : stack-reg ESP ;
: ds-reg ESI ; : ds-reg ESI ;
: fixnum>slot@ arg0 1 SAR ; : fixnum>slot@ arg0 1 SAR ;
: rex-length 0 ;
"resource:core/cpu/x86/bootstrap.factor" run-file "resource:core/cpu/x86/bootstrap.factor" run-file

10
core/cpu/x86/64/64.factor
View File

@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system namespaces sequences generator.registers generator.fixup system
alien alien.compiler alien.structs slots splitting ; alien alien.compiler alien.structs slots splitting assocs ;
IN: cpu.x86.64 IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend PREDICATE: x86-backend amd64-backend
@ -173,8 +173,8 @@ USE: cpu.x86.intrinsics
T{ x86-backend f 8 } compiler-backend set-global T{ x86-backend f 8 } compiler-backend set-global
! The ABI for passing structs by value is pretty messed up ! The ABI for passing structs by value is pretty messed up
"void*" c-type clone "__stack_value" define-primitive-type << "void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs ) : struct-types&offset ( struct-type -- pairs )
struct-type-fields [ struct-type-fields [
@ -183,7 +183,7 @@ T{ stack-params } "__stack_value" c-type set-c-type-reg-class
: split-struct ( pairs -- seq ) : split-struct ( pairs -- seq )
[ [
[ first2 8 mod zero? [ t , ] when , ] each [ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] subset ; ] { } make { t } split [ empty? not ] subset ;
: flatten-large-struct ( type -- ) : flatten-large-struct ( type -- )
@ -200,5 +200,3 @@ M: struct-type flatten-value-type ( type -- seq )
"void*" "double" ? c-type , "void*" "double" ? c-type ,
] each ] each
] if ; ] if ;
12 profiler-prologue set-global

4
core/cpu/x86/64/bootstrap.factor
View File

@ -8,10 +8,10 @@ IN: bootstrap.x86
: arg0 RDI ; : arg0 RDI ;
: arg1 RSI ; : arg1 RSI ;
: temp-reg RBX ;
: stack-reg RSP ; : stack-reg RSP ;
: ds-reg R14 ; : ds-reg R14 ;
: scan-reg RBX ;
: xt-reg RCX ;
: fixnum>slot@ ; : fixnum>slot@ ;
: rex-length 1 ;
"resource:core/cpu/x86/bootstrap.factor" run-file "resource:core/cpu/x86/bootstrap.factor" run-file

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

@ -81,7 +81,7 @@ SYMBOL: XMM15 \ XMM15 15 128 define-register
: n, >le % ; inline : n, >le % ; inline
: 4, 4 n, ; inline : 4, 4 n, ; inline
: 2, 2 n, ; inline : 2, 2 n, ; inline
: cell, cell n, ; inline : cell, bootstrap-cell n, ; inline
#! Extended AMD64 registers (R8-R15) return true. #! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? ) GENERIC: extended? ( op -- ? )
@ -232,14 +232,14 @@ UNION: operand register indirect ;
: rex-prefix ( reg r/m rex.w -- ) : rex-prefix ( reg r/m rex.w -- )
#! Compile an AMD64 REX prefix. #! Compile an AMD64 REX prefix.
pick pick rex.w? BIN: 01001000 BIN: 01000000 ? 2over rex.w? BIN: 01001000 BIN: 01000000 ?
swap rex.r swap rex.b swap rex.r swap rex.b
dup BIN: 01000000 = [ drop ] [ , ] if ; dup BIN: 01000000 = [ drop ] [ , ] if ;
: 16-prefix ( reg r/m -- ) : 16-prefix ( reg r/m -- )
[ register-16? ] either? [ HEX: 66 , ] when ; [ register-16? ] either? [ HEX: 66 , ] when ;
: prefix ( reg r/m rex.w -- ) pick pick 16-prefix rex-prefix ; : prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
: prefix-1 ( reg rex.w -- ) f swap prefix ; : prefix-1 ( reg rex.w -- ) f swap prefix ;
@ -290,7 +290,7 @@ UNION: operand register indirect ;
: 2-operand ( dst src op -- ) : 2-operand ( dst src op -- )
#! Sets the opcode's direction bit. It is set if the #! Sets the opcode's direction bit. It is set if the
#! destination is a direct register operand. #! destination is a direct register operand.
pick pick 16-prefix 2over 16-prefix
direction-bit direction-bit
operand-size-bit operand-size-bit
(2-operand) ; (2-operand) ;

27
core/cpu/x86/bootstrap.factor
View File

@ -13,7 +13,8 @@ big-endian off
[ [
! Load word ! Load word
temp-reg 0 [] MOV temp-reg 0 MOV
temp-reg dup [] MOV
! Bump profiling counter ! Bump profiling counter
temp-reg profile-count-offset [+] 1 tag-fixnum ADD temp-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code ! Load word->code
@ -22,24 +23,27 @@ big-endian off
temp-reg compiled-header-size ADD temp-reg compiled-header-size ADD
! Jump to XT ! Jump to XT
temp-reg JMP temp-reg JMP
] rc-absolute-cell rt-literal 2 jit-profiling jit-define ] rc-absolute-cell rt-literal 1 rex-length + jit-profiling jit-define
[ [
temp-reg 0 MOV ! load XT
stack-frame-size PUSH ! save stack frame size stack-frame-size PUSH ! save stack frame size
0 PUSH ! push XT temp-reg PUSH ! push XT
arg1 PUSH ! alignment arg1 PUSH ! alignment
] rc-absolute-cell rt-label 6 jit-prolog jit-define ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
[ [
arg0 0 [] MOV ! load literal arg0 0 MOV ! load literal
arg0 dup [] MOV
ds-reg bootstrap-cell ADD ! increment datastack pointer ds-reg bootstrap-cell ADD ! increment datastack pointer
ds-reg [] arg0 MOV ! store literal on datastack ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-literal 2 jit-push-literal jit-define ] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define
[ [
arg0 0 MOV ! load XT
arg1 stack-reg MOV ! pass callstack pointer as arg 2 arg1 stack-reg MOV ! pass callstack pointer as arg 2
(JMP) drop ! go arg0 JMP ! go
] rc-relative rt-primitive 3 jit-primitive jit-define ] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
[ [
(JMP) drop (JMP) drop
@ -57,17 +61,18 @@ big-endian off
arg0 arg1 [] CMOVNE ! load true branch if not equal arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
arg0 quot-xt@ [+] JMP ! jump to quotation-xt arg0 quot-xt@ [+] JMP ! jump to quotation-xt
] rc-absolute-cell rt-literal 1 jit-if-jump jit-define ] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
[ [
arg1 0 [] MOV ! load dispatch table arg1 0 MOV ! load dispatch table
arg1 dup [] MOV
arg0 ds-reg [] MOV ! load index arg0 ds-reg [] MOV ! load index
fixnum>slot@ ! turn it into an array offset fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location arg0 arg1 ADD ! compute quotation location
arg0 arg0 array-start [+] MOV ! load quotation arg0 arg0 array-start [+] MOV ! load quotation
arg0 quot-xt@ [+] JMP ! execute branch arg0 quot-xt@ [+] JMP ! execute branch
] rc-absolute-cell rt-literal 2 jit-dispatch jit-define ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[ [
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame

15
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2006 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.x86.assembler cpu.x86.allot USING: alien arrays cpu.x86.assembler cpu.x86.allot
cpu.x86.architecture cpu.architecture kernel kernel.private math cpu.x86.architecture cpu.architecture kernel kernel.private math
@ -240,18 +240,19 @@ IN: cpu.x86.intrinsics
} }
} define-intrinsics } define-intrinsics
\ fixnum-shift [ : %untag-fixnums ( seq -- )
"x" operand "y" get neg SAR [ %untag-fixnum ] unique-operands ;
\ fixnum-shift-fast [
"x" operand "y" get
dup 0 < [ neg SAR ] [ SHL ] if
! Mask off low bits ! Mask off low bits
"x" operand %untag "x" operand %untag
] H{ ] H{
{ +input+ { { f "x" } { [ -31 0 between? ] "y" } } } { +input+ { { f "x" } { [ ] "y" } } }
{ +output+ { "x" } } { +output+ { "x" } }
} define-intrinsic } define-intrinsic
: %untag-fixnums ( seq -- )
[ %untag-fixnum ] unique-operands ;
: overflow-check ( word -- ) : overflow-check ( word -- )
"end" define-label "end" define-label
"z" operand "x" operand MOV "z" operand "x" operand MOV

5
core/generic/generic.factor
View File

@ -85,7 +85,10 @@ M: method-spec definer drop \ M: \ ; ;
M: method-spec definition first2 method method-def ; M: method-spec definition first2 method method-def ;
M: method-spec forget* first2 [ delete-at ] with-methods ; : forget-method ( class generic -- )
check-method [ delete-at ] with-methods ;
M: method-spec forget* first2 forget-method ;
: implementors* ( classes -- words ) : implementors* ( classes -- words )
all-words [ all-words [

32
core/graphs/graphs-tests.factor
View File

@ -16,3 +16,35 @@ H{
[ { 2 3 4 5 } ] [ [ { 2 3 4 5 } ] [
2 [ "g" get at ] closure keys natural-sort 2 [ "g" get at ] closure keys natural-sort
] unit-test ] unit-test
H{ } "g" set
[ ] [
"mary"
H{ { "billy" "one" } { "joey" "two" } }
"g" get add-vertex*
] unit-test
[ H{ { "mary" "one" } } ] [
"billy" "g" get at
] unit-test
[ ] [
"liz"
H{ { "billy" "four" } { "fred" "three" } }
"g" get add-vertex*
] unit-test
[ H{ { "mary" "one" } { "liz" "four" } } ] [
"billy" "g" get at
] unit-test
[ ] [
"mary"
H{ { "billy" "one" } { "joey" "two" } }
"g" get remove-vertex*
] unit-test
[ H{ { "liz" "four" } } ] [
"billy" "g" get at
] unit-test

16
core/graphs/graphs.factor
View File

@ -16,9 +16,25 @@ SYMBOL: graph
: add-vertex ( vertex edges graph -- ) : add-vertex ( vertex edges graph -- )
[ [ dupd nest set-at ] with each ] if-graph ; inline [ [ dupd nest set-at ] with each ] if-graph ; inline
: (add-vertex) ( key value vertex -- )
rot nest set-at ;
: add-vertex* ( vertex edges graph -- )
[
swap [ (add-vertex) ] curry assoc-each
] if-graph ; inline
: remove-vertex ( vertex edges graph -- ) : remove-vertex ( vertex edges graph -- )
[ [ graph get at delete-at ] with each ] if-graph ; inline [ [ graph get at delete-at ] with each ] if-graph ; inline
: (remove-vertex) ( key value vertex -- )
rot graph get at delete-at drop ;
: remove-vertex* ( vertex edges graph -- )
[
swap [ (remove-vertex) ] curry assoc-each
] if-graph ; inline
SYMBOL: previous SYMBOL: previous
: (closure) ( obj quot -- ) : (closure) ( obj quot -- )

8
core/inference/backend/backend.factor
View File

@ -76,7 +76,8 @@ GENERIC: apply-object ( obj -- )
M: object apply-object apply-literal ; M: object apply-object apply-literal ;
M: wrapper apply-object wrapped dup depends-on apply-literal ; M: wrapper apply-object
wrapped dup +called+ depends-on apply-literal ;
: terminate ( -- ) : terminate ( -- )
terminated? on #terminate node, ; terminated? on #terminate node, ;
@ -372,6 +373,7 @@ TUPLE: effect-error word effect ;
: custom-infer ( word -- ) : custom-infer ( word -- )
#! Customized inference behavior #! Customized inference behavior
dup +inlined+ depends-on
"infer" word-prop call ; "infer" word-prop call ;
: cached-infer ( word -- ) : cached-infer ( word -- )
@ -449,10 +451,12 @@ M: #call-label collect-recursion*
] if ; ] if ;
M: word apply-object M: word apply-object
dup depends-on [ [
dup +inlined+ depends-on
dup inline-recursive-label dup inline-recursive-label
[ declared-infer ] [ inline-word ] if [ declared-infer ] [ inline-word ] if
] [ ] [
dup +called+ depends-on
dup recursive-label dup recursive-label
[ declared-infer ] [ apply-word ] if [ declared-infer ] [ apply-word ] if
] if-inline ; ] if-inline ;

31
core/inference/class/class-tests.factor
View File

@ -50,7 +50,7 @@ M: object xyz ;
] unit-test ] unit-test
: (fx-repeat) ( i n quot -- ) : (fx-repeat) ( i n quot -- )
pick pick fixnum>= [ 2over fixnum>= [
3drop 3drop
] [ ] [
[ swap >r call 1 fixnum+fast r> ] keep (fx-repeat) [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
@ -66,7 +66,7 @@ M: object xyz ;
] unit-test ] unit-test
: (i-repeat) ( i n quot -- ) : (i-repeat) ( i n quot -- )
pick pick dup xyz drop >= [ 2over dup xyz drop >= [
3drop 3drop
] [ ] [
[ swap >r call 1+ r> ] keep (i-repeat) [ swap >r call 1+ r> ] keep (i-repeat)
@ -214,7 +214,7 @@ GENERIC: annotate-entry-test-1 ( x -- )
M: fixnum annotate-entry-test-1 drop ; M: fixnum annotate-entry-test-1 drop ;
: (annotate-entry-test-2) ( from to quot -- ) : (annotate-entry-test-2) ( from to quot -- )
pick pick >= [ 2over >= [
3drop 3drop
] [ ] [
[ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2) [ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
@ -235,3 +235,28 @@ M: fixnum annotate-entry-test-1 drop ;
[ t ] [ [ t ] [
[ 3 + = ] \ equal? inlined? [ 3 + = ] \ equal? inlined?
] unit-test ] unit-test
[ t ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ shift inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ fixnum-shift inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
\ fixnum-shift inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test

3
core/inference/known-words/known-words.factor
View File

@ -254,6 +254,9 @@ t over set-effect-terminated?
\ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop \ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum-shift make-foldable \ fixnum-shift make-foldable
\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
\ fixnum-shift-fast make-foldable
\ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop \ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum= make-foldable \ bignum= make-foldable

25
core/inference/state/state-tests.factor Normal file
View File

@ -0,0 +1,25 @@
IN: temporary
USING: tools.test inference.state ;
SYMBOL: a
SYMBOL: b
[ ] [ a +called+ depends-on ] unit-test
[ H{ { a +called+ } } ] [
[ a +called+ depends-on ] computing-dependencies
] unit-test
[ H{ { a +called+ } { b +inlined+ } } ] [
[
a +called+ depends-on b +inlined+ depends-on
] computing-dependencies
] unit-test
[ H{ { a +inlined+ } { b +inlined+ } } ] [
[
a +inlined+ depends-on
a +called+ depends-on
b +inlined+ depends-on
] computing-dependencies
] unit-test

11
core/inference/state/state.factor
View File

@ -31,11 +31,16 @@ SYMBOL: current-node
! Words that the current dataflow IR depends on ! Words that the current dataflow IR depends on
SYMBOL: dependencies SYMBOL: dependencies
: depends-on ( word -- ) SYMBOL: +inlined+
dup dependencies get dup [ set-at ] [ 3drop ] if ; SYMBOL: +called+
: depends-on ( word how -- )
swap dependencies get dup [
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
] [ 3drop ] if ;
: computing-dependencies ( quot -- dependencies ) : computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep keys ; H{ } clone [ dependencies rot with-variable ] keep ;
inline inline
! Did the current control-flow path throw an error? ! Did the current control-flow path throw an error?

11
core/inference/transforms/transforms.factor
View File

@ -61,6 +61,11 @@ M: pair (bitfield-quot) ( spec -- quot )
\ set-slots [ <reversed> [get-slots] ] 1 define-transform \ set-slots [ <reversed> [get-slots] ] 1 define-transform
\ construct-boa [ : [construct] ( word quot -- newquot )
dup tuple-size [ <tuple-boa> ] 2curry >r dup +inlined+ depends-on dup tuple-size r> 2curry ;
] 1 define-transform
\ construct-boa
[ [ <tuple-boa> ] [construct] ] 1 define-transform
\ construct-empty
[ [ <tuple> ] [construct] ] 1 define-transform

10
core/io/files/files.factor
View File

@ -35,7 +35,11 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: stat ( path -- directory? permissions length modified ) : stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ; normalize-pathname (stat) ;
: exists? ( path -- ? ) stat >r 3drop r> >boolean ; : file-length ( path -- n ) stat 4array third ;
: file-modified ( path -- n ) stat >r 3drop r> ; inline
: exists? ( path -- ? ) file-modified >boolean ;
: directory? ( path -- ? ) stat 3drop ; : directory? ( path -- ? ) stat 3drop ;
@ -52,10 +56,6 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: directory ( path -- seq ) : directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ; normalize-directory dup (directory) fixup-directory ;
: file-length ( path -- n ) stat 4array third ;
: file-modified ( path -- n ) stat >r 3drop r> ;
: last-path-separator ( path -- n ? ) : last-path-separator ( path -- n ? )
[ length 2 [-] ] keep [ path-separator? ] find-last* ; [ length 2 [-] ] keep [ path-separator? ] find-last* ;

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

@ -19,6 +19,7 @@ $nl
{ $subsection 3dup } { $subsection 3dup }
{ $subsection dupd } { $subsection dupd }
{ $subsection over } { $subsection over }
{ $subsection 2over }
{ $subsection pick } { $subsection pick }
{ $subsection tuck } { $subsection tuck }
"Permuting stack elements:" "Permuting stack elements:"
@ -160,6 +161,7 @@ HELP: nip ( x y -- y ) $shuffle ;
HELP: 2nip ( x y z -- z ) $shuffle ; HELP: 2nip ( x y z -- z ) $shuffle ;
HELP: tuck ( x y -- y x y ) $shuffle ; HELP: tuck ( x y -- y x y ) $shuffle ;
HELP: over ( x y -- x y x ) $shuffle ; HELP: over ( x y -- x y x ) $shuffle ;
HELP: 2over $shuffle ;
HELP: pick ( x y z -- x y z x ) $shuffle ; HELP: pick ( x y z -- x y z x ) $shuffle ;
HELP: swap ( x y -- y x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ;
HELP: spin $shuffle ; HELP: spin $shuffle ;

4
core/kernel/kernel.factor
View File

@ -12,6 +12,8 @@ IN: kernel
: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline : -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline
: 2over ( x y z -- x y z x y ) pick pick ; inline
: clear ( -- ) { } set-datastack ; : clear ( -- ) { } set-datastack ;
! Combinators ! Combinators
@ -55,7 +57,7 @@ DEFER: if
: keep ( x quot -- x ) over slip ; inline : keep ( x quot -- x ) over slip ; inline
: 2keep ( x y quot -- x y ) pick pick 2slip ; inline : 2keep ( x y quot -- x y ) 2over 2slip ; inline
: 3keep ( x y z quot -- x y z ) : 3keep ( x y z quot -- x y z )
>r 3dup r> -roll 3slip ; inline >r 3dup r> -roll 3slip ; inline

5
core/math/integers/integers-docs.factor
View File

@ -120,6 +120,11 @@ HELP: fixnum-shift ( x y -- z )
{ $description "Primitive version of " { $link shift } ". The result may overflow to a bignum." } { $description "Primitive version of " { $link shift } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ; { $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
HELP: fixnum-shift-fast ( x y -- z )
{ $values { "x" fixnum } { "y" fixnum } { "z" fixnum } }
{ $description "Primitive version of " { $link shift } ". Unlike " { $link fixnum-shift } ", does not perform an overflow check, so the result may be incorrect." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
HELP: fixnum+fast ( x y -- z ) HELP: fixnum+fast ( x y -- z )
{ $values { "x" fixnum } { "y" fixnum } { "z" fixnum } } { $values { "x" fixnum } { "y" fixnum } { "z" fixnum } }
{ $description "Primitive version of " { $link + } ". Unlike " { $link fixnum+ } ", does not perform an overflow check, so the result may be incorrect." } { $description "Primitive version of " { $link + } ". Unlike " { $link fixnum+ } ", does not perform an overflow check, so the result may be incorrect." }

2
core/math/integers/integers.factor
View File

@ -32,7 +32,7 @@ M: fixnum shift >fixnum fixnum-shift ;
M: fixnum bitnot fixnum-bitnot ; M: fixnum bitnot fixnum-bitnot ;
M: fixnum bit? 2^ bitand 0 > ; M: fixnum bit? neg shift 1 bitand 0 > ;
: (fixnum-log2) ( accum n -- accum ) : (fixnum-log2) ( accum n -- accum )
dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ; dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;

8
core/math/intervals/intervals.factor
View File

@ -66,9 +66,9 @@ C: <interval> interval
[ endpoint-max ] reduce <interval> ; [ endpoint-max ] reduce <interval> ;
: (interval-op) ( p1 p2 quot -- p3 ) : (interval-op) ( p1 p2 quot -- p3 )
pick pick >r >r 2over >r >r
>r >r first r> first r> call >r [ first ] 2apply r> call
r> second r> second and 2array ; inline r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 ) : interval-op ( i1 i2 quot -- i3 )
pick interval-from pick interval-from pick (interval-op) >r pick interval-from pick interval-from pick (interval-op) >r
@ -85,7 +85,7 @@ C: <interval> interval
: interval-integer-op ( i1 i2 quot -- i3 ) : interval-integer-op ( i1 i2 quot -- i3 )
>r 2dup >r 2dup
[ interval>points [ first integer? ] 2apply and ] 2apply and [ interval>points [ first integer? ] both? ] both?
r> [ 2drop f ] if ; inline r> [ 2drop f ] if ; inline
: interval-shift ( i1 i2 -- i3 ) : interval-shift ( i1 i2 -- i3 )

2
core/math/math.factor
View File

@ -119,7 +119,7 @@ M: float fp-nan?
: iterate-prep 0 -rot ; inline : iterate-prep 0 -rot ; inline
: if-iterate? >r >r pick pick < r> r> if ; inline : if-iterate? >r >r 2over < r> r> if ; inline
: iterate-step ( i n quot -- i n quot ) : iterate-step ( i n quot -- i n quot )
#! Apply quot to i, keep i and quot, hide n. #! Apply quot to i, keep i and quot, hide n.

18
core/memory/memory-docs.factor
View File

@ -1,25 +1,15 @@
USING: help.markup help.syntax debugger sequences kernel ; USING: help.markup help.syntax debugger sequences kernel ;
IN: memory IN: memory
ARTICLE: "memory" "Object memory" ARTICLE: "images" "Images"
"You can query memory status:" "The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
{ $subsection data-room }
{ $subsection code-room }
"There are a pair of combinators, analogous to " { $link each } " and " { $link subset } ", which operate on the entire collection of objects in the object heap:"
{ $subsection each-object }
{ $subsection instances }
"You can check an object's the heap memory usage:"
{ $subsection size }
"The garbage collector can be invoked manually:"
{ $subsection data-gc }
{ $subsection code-gc }
"The current image can be saved:"
{ $subsection save } { $subsection save }
{ $subsection save-image } { $subsection save-image }
{ $subsection save-image-and-exit } { $subsection save-image-and-exit }
"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
{ $see-also "tools.memory" } ; { $see-also "tools.memory" } ;
ABOUT: "memory" ABOUT: "image"
HELP: begin-scan ( -- ) HELP: begin-scan ( -- )
{ $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects." { $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."

22
core/optimizer/backend/backend.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs inference inference.class USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend io kernel math namespaces inference.dataflow inference.backend inference.state io kernel
sequences vectors words quotations hashtables combinators math namespaces sequences vectors words quotations hashtables
classes generic.math continuations optimizer.def-use combinators classes generic.math continuations optimizer.def-use
optimizer.pattern-match generic.standard ; optimizer.pattern-match generic.standard ;
IN: optimizer.backend IN: optimizer.backend
@ -173,8 +173,8 @@ M: node remember-method*
2drop ; 2drop ;
: remember-method ( method-spec node -- ) : remember-method ( method-spec node -- )
swap dup swap dup second +inlined+ depends-on
[ [ swap remember-method* ] curry each-node ] [ 2drop ] if ; [ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node ) : (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise #! Must remember the method before splicing in, otherwise
@ -184,7 +184,10 @@ M: node remember-method*
[ swap infer-classes/node ] 2keep [ swap infer-classes/node ] 2keep
[ substitute-node ] keep ; [ substitute-node ] keep ;
: splice-quot ( #call quot -- node ) f swap (splice-method) ; : splice-quot ( #call quot -- node )
over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep
[ substitute-node ] keep ;
: drop-inputs ( node -- #shuffle ) : drop-inputs ( node -- #shuffle )
node-in-d clone \ #shuffle in-node ; node-in-d clone \ #shuffle in-node ;
@ -225,7 +228,7 @@ M: #dispatch optimize-node*
#! t indicates failure #! t indicates failure
{ {
{ [ dup t eq? ] [ 3drop t ] } { [ dup t eq? ] [ 3drop t ] }
{ [ pick pick swap node-history member? ] [ 3drop t ] } { [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] } { [ t ] [ (splice-method) ] }
} cond ; } cond ;
@ -358,7 +361,8 @@ M: #dispatch optimize-node*
] if ; ] if ;
: optimistic-inline ( #call -- node ) : optimistic-inline ( #call -- node )
dup node-param word-def splice-quot ; dup node-param dup +inlined+ depends-on
word-def splice-quot ;
M: #call optimize-node* M: #call optimize-node*
{ {

33
core/optimizer/math/math.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.math IN: optimizer.math
USING: alien arrays generic hashtables kernel assocs math USING: alien arrays generic hashtables kernel assocs math
@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io
namespaces assocs quotations math.intervals sequences.private namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes combinators splitting layouts math.parser classes
generic.math optimizer.pattern-match optimizer.backend generic.math optimizer.pattern-match optimizer.backend
optimizer.def-use generic.standard ; optimizer.def-use generic.standard system ;
{ + bignum+ float+ fixnum+fast } { { + bignum+ float+ fixnum+fast } {
{ { number 0 } [ drop ] } { { number 0 } [ drop ] }
@ -82,7 +82,7 @@ optimizer.def-use generic.standard ;
{ { @ @ } [ 2drop 0 ] } { { @ @ } [ 2drop 0 ] }
} define-identities } define-identities
{ shift fixnum-shift bignum-shift } { { shift fixnum-shift fixnum-shift-fast bignum-shift } {
{ { 0 number } [ drop ] } { { 0 number } [ drop ] }
{ { number 0 } [ drop ] } { { number 0 } [ drop ] }
} define-identities } define-identities
@ -196,7 +196,7 @@ optimizer.def-use generic.standard ;
] 2curry "output-classes" set-word-prop ] 2curry "output-classes" set-word-prop
] each ] each
{ fixnum-shift shift } [ { fixnum-shift fixnum-shift-fast shift } [
[ [
dup dup
node-in-d second value-interval* node-in-d second value-interval*
@ -439,3 +439,28 @@ most-negative-fixnum most-positive-fixnum [a,b]
[ splice-quot ] curry , [ splice-quot ] curry ,
] { } make 1array define-optimizers ] { } make 1array define-optimizers
] assoc-each ] assoc-each
: fixnum-shift-fast-pos? ( node -- ? )
#! Shifting 1 to the left won't overflow if the shift
#! count is small enough
dup dup node-in-d first node-literal 1 = [
dup node-in-d second node-interval
0 cell-bits tag-bits get - 2 - [a,b] interval-subset?
] [ drop f ] if ;
: fixnum-shift-fast-neg? ( node -- ? )
#! Shifting any number to the right won't overflow if the
#! shift count is small enough
dup node-in-d second node-interval
cell-bits 1- neg 0 [a,b] interval-subset? ;
: fixnum-shift-fast? ( node -- ? )
dup fixnum-shift-fast-pos?
[ drop t ] [ fixnum-shift-fast-neg? ] if ;
\ fixnum-shift {
{
[ dup fixnum-shift-fast? ]
[ [ fixnum-shift-fast ] splice-quot ]
}
} define-optimizers

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

@ -49,7 +49,7 @@ ARTICLE: "vocabulary-search-errors" "Word lookup errors"
} }
"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ; "When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ;
ARTICLE: "vocabulary-search" "Vocabulary search" ARTICLE: "vocabulary-search" "Vocabulary search path"
"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order." "When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
$nl $nl
"For a source file the vocabulary search path starts off with two vocabularies:" "For a source file the vocabulary search path starts off with two vocabularies:"

2
core/parser/parser-tests.factor
View File

@ -301,7 +301,7 @@ IN: temporary
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary GENERIC: killer?" "IN: temporary GENERIC: killer? ( a -- b )"
<string-reader> "removing-the-predicate" parse-stream drop <string-reader> "removing-the-predicate" parse-stream drop
] unit-test ] unit-test

5
core/parser/parser.factor
View File

@ -437,7 +437,7 @@ SYMBOL: bootstrap-syntax
smudged-usage forget-all smudged-usage forget-all
over empty? [ 2dup smudged-usage-warning ] unless 2drop ; over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
: finish-parsing ( contents quot -- ) : finish-parsing ( lines quot -- )
file get file get
[ record-form ] keep [ record-form ] keep
[ record-modified ] keep [ record-modified ] keep
@ -447,8 +447,7 @@ SYMBOL: bootstrap-syntax
: parse-stream ( stream name -- quot ) : parse-stream ( stream name -- quot )
[ [
[ [
contents lines dup parse-fresh
dup string-lines parse-fresh
tuck finish-parsing tuck finish-parsing
forget-smudged forget-smudged
] with-source-file ] with-source-file

12
core/sequences/sequences.factor
View File

@ -194,7 +194,7 @@ TUPLE: slice-error reason ;
: check-slice ( from to seq -- from to seq ) : check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when pick 0 < [ "start < 0" slice-error ] when
dup length pick < [ "end > sequence" slice-error ] when dup length pick < [ "end > sequence" slice-error ] when
pick pick > [ "start > end" slice-error ] when ; inline 2over > [ "start > end" slice-error ] when ; inline
: <slice> ( from to seq -- slice ) : <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when dup slice? [ collapse-slice ] when
@ -445,7 +445,7 @@ PRIVATE>
[ = not ] with subset ; [ = not ] with subset ;
: cache-nth ( i seq quot -- elt ) : cache-nth ( i seq quot -- elt )
pick pick ?nth dup [ 2over ?nth dup [
>r 3drop r> >r 3drop r>
] [ ] [
drop swap >r over >r call dup r> r> set-nth drop swap >r over >r call dup r> r> set-nth
@ -465,7 +465,7 @@ M: sequence <=>
[ mismatch not ] [ 2drop f ] if ; inline [ mismatch not ] [ 2drop f ] if ; inline
: move ( to from seq -- ) : move ( to from seq -- )
pick pick number= 2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
: (delete) ( elt store scan seq -- elt store scan seq ) : (delete) ( elt store scan seq -- elt store scan seq )
@ -499,15 +499,15 @@ M: sequence <=>
: pop* ( seq -- ) dup length 1- swap set-length ; : pop* ( seq -- ) dup length 1- swap set-length ;
: move-backward ( shift from to seq -- ) : move-backward ( shift from to seq -- )
pick pick number= [ 2over number= [
2drop 2drop 2drop 2drop
] [ ] [
[ >r pick pick + pick r> move >r 1+ r> ] keep [ >r 2over + pick r> move >r 1+ r> ] keep
move-backward move-backward
] if ; ] if ;
: move-forward ( shift from to seq -- ) : move-forward ( shift from to seq -- )
pick pick number= [ 2over number= [
2drop 2drop 2drop 2drop
] [ ] [
[ >r pick >r dup dup r> + swap r> move 1- ] keep [ >r pick >r dup dup r> + swap r> move 1- ] keep

4
core/slots/slots.factor
View File

@ -89,8 +89,8 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ;
: simple-slot ( class name # -- spec ) : simple-slot ( class name # -- spec )
>r object bootstrap-word over r> f f <slot-spec> >r object bootstrap-word over r> f f <slot-spec>
pick pick simple-reader-word over set-slot-spec-reader 2over simple-reader-word over set-slot-spec-reader
rot rot simple-writer-word over set-slot-spec-writer ; -rot simple-writer-word over set-slot-spec-writer ;
: simple-slots ( class slots base -- specs ) : simple-slots ( class slots base -- specs )
over length [ + ] with map over length [ + ] with map

4
core/tuples/tuples.factor
View File

@ -15,7 +15,7 @@ M: tuple class class-of-tuple ;
<PRIVATE <PRIVATE
: tuple= ( tuple1 tuple2 -- ? ) : tuple= ( tuple1 tuple2 -- ? )
over array-capacity over array-capacity dup -rot number= [ over array-capacity over array-capacity tuck number= [
-rot -rot
[ >r over r> array-nth >r array-nth r> = ] 2curry [ >r over r> array-nth >r array-nth r> = ] 2curry
all-integers? all-integers?
@ -59,7 +59,7 @@ M: tuple class class-of-tuple ;
] unless ] unless
] when 2drop ; ] when 2drop ;
GENERIC: tuple-size ( class -- size ) foldable GENERIC: tuple-size ( class -- size )
M: tuple-class tuple-size "slot-names" word-prop length 2 + ; M: tuple-class tuple-size "slot-names" word-prop length 2 + ;

4
extra/benchmark/nsieve-bits/nsieve-bits.factor
View File

@ -6,11 +6,11 @@ bit-arrays namespaces io ;
2dup length >= [ 2dup length >= [
3drop 3drop
] [ ] [
f pick pick set-nth-unsafe >r over + r> clear-flags f 2over set-nth-unsafe >r over + r> clear-flags
] if ; inline ] if ; inline
: (nsieve-bits) ( count i seq -- count ) : (nsieve-bits) ( count i seq -- count )
2dup length <= [ 2dup length < [
2dup nth-unsafe [ 2dup nth-unsafe [
over dup 2 * pick clear-flags over dup 2 * pick clear-flags
rot 1+ -rot ! increment count rot 1+ -rot ! increment count

2
extra/benchmark/nsieve/nsieve.factor
View File

@ -10,7 +10,7 @@ arrays namespaces io ;
] if ; inline ] if ; inline
: (nsieve) ( count i seq -- count ) : (nsieve) ( count i seq -- count )
2dup length <= [ 2dup length < [
2dup nth-unsafe [ 2dup nth-unsafe [
over dup 2 * pick clear-flags over dup 2 * pick clear-flags
rot 1+ -rot ! increment count rot 1+ -rot ! increment count

7
extra/calendar/calendar.factor
View File

@ -4,7 +4,7 @@
USING: arrays hashtables io io.streams.string kernel math USING: arrays hashtables io io.streams.string kernel math
math.vectors math.functions math.parser namespaces sequences math.vectors math.functions math.parser namespaces sequences
strings tuples system debugger combinators vocabs.loader strings tuples system debugger combinators vocabs.loader
calendar.backend structs alien.c-types ; calendar.backend structs alien.c-types math.vectors ;
IN: calendar IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ; TUPLE: timestamp year month day hour minute second gmt-offset ;
@ -186,7 +186,8 @@ M: number +second ( timestamp n -- timestamp )
#! data #! data
tuple-slots tuple-slots
{ 1 12 365.2425 8765.82 525949.2 31556952.0 } { 1 12 365.2425 8765.82 525949.2 31556952.0 }
[ / ] 2map sum ; v/ sum ;
: dt>months ( dt -- x ) dt>years 12 * ; : dt>months ( dt -- x ) dt>years 12 * ;
: dt>days ( dt -- x ) dt>years 365.2425 * ; : dt>days ( dt -- x ) dt>years 365.2425 * ;
: dt>hours ( dt -- x ) dt>years 8765.82 * ; : dt>hours ( dt -- x ) dt>years 8765.82 * ;
@ -235,7 +236,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
unix-1970 millis 1000 /f seconds +dt ; unix-1970 millis 1000 /f seconds +dt ;
: now ( -- timestamp ) gmt >local-time ; : now ( -- timestamp ) gmt >local-time ;
: before ( dt -- -dt ) tuple-slots [ neg ] map array>dt ; : before ( dt -- -dt ) tuple-slots vneg array>dt ;
: from-now ( dt -- timestamp ) now swap +dt ; : from-now ( dt -- timestamp ) now swap +dt ;
: ago ( dt -- timestamp ) before from-now ; : ago ( dt -- timestamp ) before from-now ;

4
extra/combinators/cleave/cleave.factor
View File

@ -7,7 +7,7 @@ IN: combinators.cleave
! The cleaver family ! The cleaver family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bi ( obj quot quot -- val val ) >r over slip r> call ; inline : bi ( obj quot quot -- val val ) >r keep r> call ; inline
: tri ( obj quot quot quot -- val val val ) : tri ( obj quot quot quot -- val val val )
>r pick >r bi r> r> call ; inline >r pick >r bi r> r> call ; inline
@ -23,7 +23,7 @@ IN: combinators.cleave
! The spread family ! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bi* ( obj obj quot quot -- val val ) >r swap >r call r> r> call ; inline : bi* ( obj obj quot quot -- val val ) >r swap slip r> call ; inline
: tri* ( obj obj obj quot quot quot -- val val val ) : tri* ( obj obj obj quot quot quot -- val val val )
>r rot >r bi* r> r> call ; inline >r rot >r bi* r> r> call ; inline

24
extra/combinators/lib/lib.factor
View File

@ -67,6 +67,28 @@ MACRO: napply ( n -- )
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
: 2with ( param1 param2 obj quot -- obj curry )
with with ; inline
: 3with ( param1 param2 param3 obj quot -- obj curry )
with with with ; inline
: with* ( obj assoc quot -- assoc curry )
swapd [ [ -rot ] dip call ] 2curry ; inline
: 2with* ( obj1 obj2 assoc quot -- assoc curry )
with* with* ; inline
: 3with* ( obj1 obj2 obj3 assoc quot -- assoc curry )
with* with* with* ; inline
: assoc-each-with ( obj assoc quot -- )
with* assoc-each ; inline
: assoc-map-with ( obj assoc quot -- assoc )
with* assoc-map ; inline
MACRO: nfirst ( n -- ) MACRO: nfirst ( n -- )
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ; [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
@ -168,4 +190,4 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
] { } assoc>map concat compose ; ] { } assoc>map concat compose ;
: either ( object first second -- ? ) : either ( object first second -- ? )
>r over slip swap [ r> drop ] [ r> call ] ?if ; inline >r keep swap [ r> drop ] [ r> call ] ?if ; inline

3
extra/crypto/common/common-docs.factor
View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax kernel math sequences quotations USING: help.markup help.syntax kernel math sequences quotations
crypto.common math.private ; math.private ;
IN: crypto.common
HELP: >32-bit HELP: >32-bit
{ $values { "x" "an integer" } { "y" "an integer" } } { $values { "x" "an integer" } { "y" "an integer" } }

15
extra/furnace/furnace.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2006 Slava Pestov, Doug Coleman ! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs calendar debugger furnace.sessions furnace.validator USING: arrays assocs calendar debugger furnace.sessions
hashtables heaps html.elements http http.server.responders furnace.validator hashtables heaps html.elements http
http.server.templating io.files kernel math namespaces http.server.responders http.server.templating io.files kernel
quotations sequences splitting words strings vectors math namespaces quotations sequences splitting words strings
webapps.callback ; vectors webapps.callback continuations tuples classes vocabs
USING: continuations io prettyprint ; html io ;
IN: furnace IN: furnace
: code>quotation ( word/quot -- quot ) : code>quotation ( word/quot -- quot )
@ -174,7 +174,6 @@ PREDICATE: word action "action" word-prop ;
[ service-post ] "post" set [ service-post ] "post" set
] make-responder ; ] make-responder ;
USING: classes html tuples vocabs ;
: explode-tuple ( tuple -- ) : explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ; [ set ] 2each ;

93
extra/help/cookbook/cookbook.factor
View File

@ -1,5 +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 inference ; prettyprint sequences vocabs.loader namespaces inference ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook" ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
"The following is a simple snippet of Factor code:" "The following is a simple snippet of Factor code:"
@ -176,16 +177,7 @@ $nl
"parser" "parser"
} ; } ;
ARTICLE: "cookbook-sources" "Source file cookbook" ARTICLE: "cookbook-io" "Input and output cookbook"
"By convention, code is stored in files with the " { $snippet ".factor" } " filename extension. You can load source files using " { $link run-file } ":"
{ $code "\"hello.factor\" run-file" }
{ $references
"Programs larger than one source file or programs which depend on other libraries should be loaded via the vocabulary system instead. Advanced functionality can be implemented by calling the parser and source reader at run time."
"parser-files"
"vocabs.loader"
} ;
ARTICLE: "cookbook-io" "I/O cookbook"
"Ask the user for their age, and print it back:" "Ask the user for their age, and print it back:"
{ $code { $code
": ask-age ( -- ) \"How old are you?\" print ;" ": ask-age ( -- ) \"How old are you?\" print ;"
@ -205,6 +197,12 @@ ARTICLE: "cookbook-io" "I/O cookbook"
{ $code { $code
"\"data.bin\" <file-reader> [ 1024 read ] with-stream" "\"data.bin\" <file-reader> [ 1024 read ] with-stream"
} }
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory:"
{ $code
"\"mydata.dat\" dup file-length ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}
"Send some bytes to a remote host:" "Send some bytes to a remote host:"
{ $code { $code
"\"myhost\" 1033 <inet> <client>" "\"myhost\" 1033 <inet> <client>"
@ -216,6 +214,58 @@ ARTICLE: "cookbook-io" "I/O cookbook"
"io" "io"
} ; } ;
ARTICLE: "cookbook-compiler" "Compiler cookbook"
"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is a fully transparent process. However, there are a few things worth knowing about the compilation process."
$nl
"The optimizing compiler trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
$nl
"After loading a vocabulary, you might see messages like:"
{ $code
":errors - print 2 compiler errors."
":warnings - print 50 compiler warnings."
}
"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erronous stack effect declarations."
{ $references
"To learn more about the compiler and static stack effect inference, read these articles:"
"compiler"
"compiler-errors"
"inference"
} ;
ARTICLE: "cookbook-application" "Application cookbook"
"Vocabularies can define a main entry point:"
{ $code "IN: game-of-life"
"..."
": play-life ... ;"
""
"MAIN: play-life"
}
"See " { $link POSTPONE: MAIN: } " for details. The " { $link run } " word loads a vocabulary if necessary, and calls its main entry point; try the following, it's fun:"
{ $code "\"tetris\" run" }
"On Mac OS X and Windows, stand-alone applications can also be deployed; these are genuine, 100% native code double-clickable executables:"
{ $code "\"tetris\" deploy-tool" }
{ $references
{ }
"vocabs.loader"
"tools.deploy"
"ui.tools.deploy"
"cookbook-scripts"
} ;
ARTICLE: "cookbook-scripts" "Scripting cookbook"
"Factor can be used for command-line scripting on Unix-like systems."
$nl
"A text file can begin with a comment like the following, and made executable:"
{ $code "#! /usr/bin/env factor -script" }
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
$nl
"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch supresses compiler messages, and exits Factor when the script finishes."
{ $references
{ }
"cli"
"cookbook-application"
} ;
ARTICLE: "cookbook-philosophy" "Factor philosophy" ARTICLE: "cookbook-philosophy" "Factor philosophy"
"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write." "Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write."
$nl $nl
@ -251,28 +301,17 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
} ; } ;
ARTICLE: "cookbook" "Factor cookbook" ARTICLE: "cookbook" "Factor cookbook"
{ $list "The Factor cookbook is a high-level overview of the most important concepts required to program in Factor."
{ "Factor is a dynamically-typed, stack-based language." }
{ { $link .s } " prints the contents of the stack." }
{ { $link . } " prints the object at the top of the stack." }
{ { "You can load vocabularies from " { $snippet "core/" } ", " { $snippet "extra/" } " or " { $snippet "work/" } " with " { $link require } ":" }
{ $code "\"http.server\" require" } }
{ { "Some vocabularies have a defined main entry point, and can be run just like applications in an operating system:" }
{ $code "\"tetris\" run" }
}
{ "Make sure to browse the " { $link "vocab-index" } "." }
{ "You can load source files with " { $link run-file } ":"
{ $code "\"my-program.factor\" run-file" }
"However, the vocabulary system should be used instead of loading source files directly; it provides automatic code organization and dependency management." }
{ "If you are reading this from the Factor UI, take a look at " { $link "ui-tools" } "." }
}
{ $subsection "cookbook-syntax" } { $subsection "cookbook-syntax" }
{ $subsection "cookbook-colon-defs" } { $subsection "cookbook-colon-defs" }
{ $subsection "cookbook-combinators" } { $subsection "cookbook-combinators" }
{ $subsection "cookbook-variables" } { $subsection "cookbook-variables" }
{ $subsection "cookbook-vocabs" } { $subsection "cookbook-vocabs" }
{ $subsection "cookbook-sources" }
{ $subsection "cookbook-io" } { $subsection "cookbook-io" }
{ $subsection "cookbook-application" }
{ $subsection "cookbook-scripts" }
{ $subsection "cookbook-compiler" }
{ $subsection "cookbook-philosophy" } { $subsection "cookbook-philosophy" }
{ $subsection "cookbook-pitfalls" } ; { $subsection "cookbook-pitfalls" } ;
ABOUT: "cookbook"

7
extra/help/handbook/handbook.factor
View File

@ -181,14 +181,15 @@ ARTICLE: "program-org" "Program organization"
{ $subsection "parser" } { $subsection "parser" }
{ $subsection "vocabs.loader" } ; { $subsection "vocabs.loader" } ;
USE: help.cookbook USING: help.cookbook help.tutorial ;
ARTICLE: "handbook" "Factor documentation" ARTICLE: "handbook" "Factor documentation"
"Welcome to Factor. Factor is dynamically-typed, stack-based, and very expressive. It is one of the most powerful and flexible programming languages ever invented. Have fun with Factor!"
{ $heading "Starting points" } { $heading "Starting points" }
{ $subsection "cookbook" } { $subsection "cookbook" }
{ $subsection "first-program" }
{ $subsection "vocab-index" } { $subsection "vocab-index" }
{ $subsection "changes" } { $subsection "changes" }
{ $subsection "cli" }
{ $heading "Language reference" } { $heading "Language reference" }
{ $subsection "conventions" } { $subsection "conventions" }
{ $subsection "syntax" } { $subsection "syntax" }
@ -202,6 +203,8 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "os" } { $subsection "os" }
{ $subsection "alien" } { $subsection "alien" }
{ $heading "Environment reference" } { $heading "Environment reference" }
{ $subsection "cli" }
{ $subsection "images" }
{ $subsection "prettyprint" } { $subsection "prettyprint" }
{ $subsection "tools" } { $subsection "tools" }
{ $subsection "help" } { $subsection "help" }

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

@ -44,7 +44,7 @@ M: f print-element drop ;
: with-default-style ( quot -- ) : with-default-style ( quot -- )
default-style get [ default-style get [
last-element off last-element off
H{ } swap with-nesting default-style get swap with-nesting
] with-style ; inline ] with-style ; inline
: print-content ( element -- ) : print-content ( element -- )

153
extra/help/tutorial/tutorial.factor Normal file
View File

@ -0,0 +1,153 @@
USING: help.markup help.syntax ui.commands ui.operations
ui.tools.search ui.tools.workspace editors vocabs.loader
kernel sequences prettyprint tools.test strings ;
IN: help.tutorial
ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
"Factor source code is organized into " { $link "vocabularies" } ". Before we can write our first program, we must create a vocabulary for it."
$nl
"Start by asking Factor for the path to your ``work'' directory, where you will place your own code:"
{ $code "\"work\" resource-path ." }
"Open the work directory in your file manager, and create a subdirectory named " { $snippet "palindrome" } ". Inside this directory, create a file named " { $snippet "palindrome.factor" } " using your favorite text editor. Leave the file empty for now."
$nl
"Inside the Factor listener, type"
{ $code "USE: palindrome" }
"The source file should now load. Since it is empty, it does nothing. If you get an error message, make sure you created the directory and the file in the right place and gave them the right names."
$nl
"Now, we will start filling out this source file. Go back to your editor, and type:"
{ $code
"! Copyright (C) 2008 <your name here>"
"! See http://factorcode.org/license.txt for BSD license."
}
"This is the standard header for Factor source files; it consists of two " { $link "syntax-comments" } "."
$nl
"Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
{ $code "IN: palindrome" }
"You are now ready to go onto the nex section." ;
ARTICLE: "first-program-logic" "Writing some logic in your first program"
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
{ $code
"! Copyright (C) 2008 <your name here>"
"! See http://factorcode.org/license.txt for BSD license."
"IN: palindrome"
}
"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
$nl
"Recall that a string is a palindrome if it is spelled the same forwards or backwards; that is, if the string is equal to its reverse. We can express this in Factor as follows:"
{ $code ": palindrome? ( string -- ? ) dup reverse = ;" }
"Place this definition at the end of your source file."
$nl
"Now we have changed the source file, we must reload it into Factor so that we can test the new definition. To do this, simply go to the Factor workspace and press " { $command workspace "workflow" refresh-all } ". This will find any previously-loaded source files which have changed on disk, and reload them."
$nl
"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
$nl
"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary by entering the following in the listener:"
{ $code "\\ dup see" }
"This shows the definition of " { $link dup } ", along with an " { $link POSTPONE: IN: } " form."
$nl
"Now, add the following at the start of the source file:"
{ $code "USING: kernel ;" }
"Next, find out what vocabulary " { $link reverse } " lives in:"
{ $code "\\ reverse see" }
"It lives in the " { $vocab-link "sequences" } " vocabulary, so we add that to the search path:"
{ $code "USING: kernel sequences ;" }
"Finally, check what vocabulary " { $link = } " lives in:"
{ $code "\\ = see" }
"It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors." ;
ARTICLE: "first-program-test" "Testing your first program"
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
{ $code
"! Copyright (C) 2008 <your name here>"
"! See http://factorcode.org/license.txt for BSD license."
"IN: palindrome"
"USING: kernel sequences ;"
""
": palindrome? ( str -- ? ) dup reverse = ;"
}
"We will now test our new word in the listener. First, push a string on the stack:"
{ $code "\"hello\"" }
"Note that the stack display at the top of the workspace now shows this string. Having supplied the input, we call our word:"
{ $code "palindrome?" }
"The stack display should now have a boolean false - " { $link f } " - which is the word's output. Since ``hello'' is not a palindrome, this is what we expect. We can get rid of this boolean by calling " { $link drop } ". The stack should be empty after this is done."
$nl
"Now, let's try it with a palindrome; we will push the string and call the word in the same line of code:"
{ $code "\"racecar\" palindrome?" }
"The stack should now contain a boolean true - " { $link t } ". We can print it and drop it using the " { $link . } " word:"
{ $code "." }
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
$nl
"Create a file named " { $snippet "palindrome-tests.factor" } " in the same directory as " { $snippet "palindrome.factor" } ". Now, we can run unit tests from the listener:"
{ $code "\"palindrome\" test" }
"We will add some unit tests corresponding to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
$nl
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code
"USING: palindrome tools.test ;"
"[ f ] [ \"hello\" palindrome? ] unit-test"
"[ t ] [ \"racecar\" palindrome? ] unit-test"
}
"Now, you can run unit tests:"
{ $code "\"palindrome\" test" }
"It should report that all tests have passed." ;
ARTICLE: "first-program-extend" "Extending your first program"
"Our palindrome program works well, however we'd like to extend it to ignore spaces and non-alphabetical characters in the input."
$nl
"For example, we'd like it to identify the following as a palindrome:"
{ $code "\"A man, a plan, a canal: Panama.\"" }
"However, right now, the simplistic algorithm we use says this is not a palindrome:"
{ $example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" }
"We would like it to output " { $link t } " there. We can encode this requirement with a unit test that we add to " { $snippet "palindrome-tests.factor" } ":"
{ $code "[ t ] [ \"A man, a plan, a canal: Panama.\" palindrome? ] unit-test" }
"If you now run unit tests, you will see a unit test failure:"
{ $code "\"palindrome\" test" }
"The next step is to, of course, fix our code so that the unit test can pass."
$nl
"We begin by writing a word called " { $snippet "normalize" } " which removes blanks and non-alphabetical characters from a string, and then converts the string to lower case. We call this word " { $snippet "normalize" } ". To figure out how to write this word, we begin with some interactive experimentation in the listener."
$nl
"Start by pushing a character on the stack; notice that characters are really just integers:"
{ $code "CHAR: a" }
"Now, use the " { $link Letter? } " word to test if it is an alphabetical character, upper or lower case:"
{ $example "Letter? ." "t" }
"This gives the expected result."
$nl
"Now try with a non-alphabetical character:"
{ $code "CHAR: #" }
{ $example "Letter? ." "f" }
"What we want to do is given a string, remove all characters which do not match the " { $link Letter? } " predicate. Let's push a string on the stack:"
{ $code "\"A man, a plan, a canal: Panama.\"" }
"Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:"
{ $code "[ Letter? ]" }
"Finally, pass the string and the quotation to the " { $link subset } " word:"
{ $code "subset" }
"Now the stack should contain the following string:"
{ "\"AmanaplanacanalPanama\"" }
"This is almost what we want; we just need to convert the string to lower case now. This can be done by calling " { $link >lower } "; the " { $snippet ">" } " prefix is a naming convention for conversion operations, and should be read as ``to'':"
{ $code ">lower" }
"Finally, let's print the top of the stack and discard it:"
{ $code "." }
"This will output " { $snippet "amanaplanacanalpanama" } ". This string is in the form that we want, and we evaluated the following code to get it into this form:"
{ $code "[ Letter? ] subset >lower" }
"This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":"
{ $code ": normalize ( str -- newstr ) [ Letter? ] subset >lower ;" }
"You will need to add " { $vocab-link "strings" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
$nl
"We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
{ $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" }
"Now if you press " { $command workspace "workflow" refresh-all } ", the source file should reload without any errors. You can run unit tests again, and this time, they will all pass:"
{ $code "\"palindrome\" test" } ;
ARTICLE: "first-program" "Your first program"
"In this tutorial, we will write a simple Factor program which prompts the user to enter a word, and tests if it is a palindrome (that is, the word is spelled the same backwards and forwards)."
$nl
"In this tutorial, you will learn about basic Factor development tools, as well as application deployment."
{ $subsection "first-program-start" }
{ $subsection "first-program-logic" }
{ $subsection "first-program-test" }
{ $subsection "first-program-extend" } ;
ABOUT: "first-program"

3
extra/hexdump/hexdump-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax hexdump kernel ; USING: help.markup help.syntax kernel ;
IN: hexdump
HELP: hexdump. HELP: hexdump.
{ $values { "seq" "a sequence" } } { $values { "seq" "a sequence" } }

8
extra/html/elements/elements-tests.factor Normal file
View File

@ -0,0 +1,8 @@
IN: temporary
USING: tools.test html html.elements io.streams.string ;
: make-html-string
[ with-html-stream ] string-out ;
[ "<a href='h&amp;o'>" ]
[ [ <a "h&o" =href a> ] make-html-string ] unit-test

89
extra/html/elements/elements.factor
View File

@ -4,17 +4,17 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations USING: io kernel namespaces prettyprint quotations
sequences strings words xml.writer ; sequences strings words xml.writer compiler.units effects ;
IN: html.elements IN: html.elements
! These words are used to provide a means of writing ! These words are used to provide a means of writing
! formatted HTML to standard output with a familiar 'html' look ! formatted HTML to standard output with a familiar 'html' look
! and feel in the code. ! and feel in the code.
! !
! HTML tags can be used in a number of different ways. The highest ! HTML tags can be used in a number of different ways. The highest
! level involves a similar syntax to HTML: ! level involves a similar syntax to HTML:
! !
! <p> "someoutput" write </p> ! <p> "someoutput" write </p>
! !
! <p> will output the opening tag and </p> will output the closing ! <p> will output the opening tag and </p> will output the closing
@ -28,7 +28,7 @@ IN: html.elements
! in that namespace. Before the attribute word should come the ! in that namespace. Before the attribute word should come the
! value of that attribute. ! value of that attribute.
! The finishing word will print out the operning tag including ! The finishing word will print out the operning tag including
! attributes. ! attributes.
! Any writes after this will appear after the opening tag. ! Any writes after this will appear after the opening tag.
! !
! Values for attributes can be used directly without any stack ! Values for attributes can be used directly without any stack
@ -57,54 +57,59 @@ SYMBOL: html
: print-html ( str -- ) : print-html ( str -- )
write-html "\n" write-html ; write-html "\n" write-html ;
: html-word ( name def -- ) : html-word ( name def effect -- )
#! Define 'word creating' word to allow #! Define 'word creating' word to allow
#! dynamically creating words. #! dynamically creating words.
>r elements-vocab create r> define-compound ; >r >r elements-vocab create r> r> define-declared ;
: <foo> "<" swap ">" 3append ; : <foo> "<" swap ">" 3append ;
: empty-effect T{ effect f 0 0 } ;
: def-for-html-word-<foo> ( name -- ) : def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned #! Return the name and code for the <foo> patterned
#! word. #! word.
dup <foo> swap [ <foo> write-html ] curry html-word ; dup <foo> swap [ <foo> write-html ] curry
empty-effect html-word ;
: <foo "<" swap append ; : <foo "<" swap append ;
: def-for-html-word-<foo ( name -- ) : def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned #! Return the name and code for the <foo patterned
#! word. #! word.
<foo dup [ write-html ] curry html-word ; <foo dup [ write-html ] curry
empty-effect html-word ;
: foo> ">" append ; : foo> ">" append ;
: def-for-html-word-foo> ( name -- ) : def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned #! Return the name and code for the foo> patterned
#! word. #! word.
foo> [ ">" write-html ] html-word ; foo> [ ">" write-html ] empty-effect html-word ;
: </foo> [ "</" % % ">" % ] "" make ; : </foo> [ "</" % % ">" % ] "" make ;
: def-for-html-word-</foo> ( name -- ) : def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned #! Return the name and code for the </foo> patterned
#! word. #! word.
</foo> dup [ write-html ] curry html-word ; </foo> dup [ write-html ] curry empty-effect html-word ;
: <foo/> [ "<" % % "/>" % ] "" make ; : <foo/> [ "<" % % "/>" % ] "" make ;
: def-for-html-word-<foo/> ( name -- ) : def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned #! Return the name and code for the <foo/> patterned
#! word. #! word.
dup <foo/> swap [ <foo/> write-html ] curry html-word ; dup <foo/> swap [ <foo/> write-html ] curry
empty-effect html-word ;
: foo/> "/>" append ; : foo/> "/>" append ;
: def-for-html-word-foo/> ( name -- ) : def-for-html-word-foo/> ( name -- )
#! Return the name and code for the foo/> patterned #! Return the name and code for the foo/> patterned
#! word. #! word.
foo/> [ "/>" write-html ] html-word ; foo/> [ "/>" write-html ] empty-effect html-word ;
: define-closed-html-word ( name -- ) : define-closed-html-word ( name -- )
#! Given an HTML tag name, define the words for #! Given an HTML tag name, define the words for
#! that closable HTML tag. #! that closable HTML tag.
dup def-for-html-word-<foo> dup def-for-html-word-<foo>
@ -112,7 +117,7 @@ SYMBOL: html
dup def-for-html-word-foo> dup def-for-html-word-foo>
def-for-html-word-</foo> ; def-for-html-word-</foo> ;
: define-open-html-word ( name -- ) : define-open-html-word ( name -- )
#! Given an HTML tag name, define the words for #! Given an HTML tag name, define the words for
#! that open HTML tag. #! that open HTML tag.
dup def-for-html-word-<foo/> dup def-for-html-word-<foo/>
@ -123,34 +128,38 @@ SYMBOL: html
" " write-html " " write-html
write-html write-html
"='" write-html "='" write-html
escape-quoted-string write escape-quoted-string write-html
"'" write-html ; "'" write-html ;
: attribute-effect T{ effect f { "string" } 0 } ;
: define-attribute-word ( name -- ) : define-attribute-word ( name -- )
dup "=" swap append swap dup "=" swap append swap
[ write-attr ] curry html-word ; [ write-attr ] curry attribute-effect html-word ;
! Define some closed HTML tags
[ [
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" ! Define some closed HTML tags
"ol" "li" "form" "a" "p" "html" "head" "body" "title" [
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"script" "div" "span" "select" "option" "style" "ol" "li" "form" "a" "p" "html" "head" "body" "title"
] [ define-closed-html-word ] each "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style"
] [ define-closed-html-word ] each
! Define some open HTML tags ! Define some open HTML tags
[ [
"input" "input"
"br" "br"
"link" "link"
"img" "img"
] [ define-open-html-word ] each ] [ define-open-html-word ] each
! Define some attributes ! Define some attributes
[ [
"method" "action" "type" "value" "name" "method" "action" "type" "value" "name"
"size" "href" "class" "border" "rows" "cols" "size" "href" "class" "border" "rows" "cols"
"id" "onclick" "style" "valign" "accesskey" "id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel" "src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
] [ define-attribute-word ] each ] [ define-attribute-word ] each
] with-compilation-unit

8
extra/html/html-tests.factor
View File

@ -54,10 +54,16 @@ M: funky browser-link-href
] make-html-string ] make-html-string
] unit-test ] unit-test
[ "<div style='background-color: #ff00ff; '>cdr</div>" ] [ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
[ [
[ [
H{ { page-color { 1 0 1 1 } } } H{ { page-color { 1 0 1 1 } } }
[ "cdr" write ] with-nesting [ "cdr" write ] with-nesting
] make-html-string ] make-html-string
] unit-test ] unit-test
[
"<div style='white-space: pre; font-family: monospace; '></div>"
] [
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test

26
extra/html/html.factor
View File

@ -10,7 +10,19 @@ GENERIC: browser-link-href ( presented -- href )
M: object browser-link-href drop f ; M: object browser-link-href drop f ;
TUPLE: html-stream ; TUPLE: html-stream last-div? ;
! A hack: stream-nl after with-nesting or tabular-output is
! ignored, so that HTML stream output looks like UI pane output
: test-last-div? ( stream -- ? )
dup html-stream-last-div?
f rot set-html-stream-last-div? ;
: not-a-div ( stream -- stream )
dup test-last-div? drop ; inline
: a-div ( stream -- straem )
t over set-html-stream-last-div? ; inline
: <html-stream> ( stream -- stream ) : <html-stream> ( stream -- stream )
html-stream construct-delegate ; html-stream construct-delegate ;
@ -94,7 +106,7 @@ TUPLE: html-sub-stream style stream ;
TUPLE: html-span-stream ; TUPLE: html-span-stream ;
M: html-span-stream stream-close M: html-span-stream stream-close
end-sub-stream format-html-span ; end-sub-stream not-a-div format-html-span ;
: border-css, ( border -- ) : border-css, ( border -- )
"border: 1px solid #" % hex-color, "; " % ; "border: 1px solid #" % hex-color, "; " % ;
@ -109,7 +121,7 @@ M: html-span-stream stream-close
page-color [ bg-css, ] apply-style page-color [ bg-css, ] apply-style
border-color [ border-css, ] apply-style border-color [ border-css, ] apply-style
border-width [ padding-css, ] apply-style border-width [ padding-css, ] apply-style
wrap-margin [ pre-css, ] apply-style wrap-margin over at pre-css,
] make-css ; ] make-css ;
: div-tag ( style quot -- ) : div-tag ( style quot -- )
@ -127,7 +139,7 @@ M: html-span-stream stream-close
TUPLE: html-block-stream ; TUPLE: html-block-stream ;
M: html-block-stream stream-close ( quot style stream -- ) M: html-block-stream stream-close ( quot style stream -- )
end-sub-stream format-html-div ; end-sub-stream a-div format-html-div ;
: border-spacing-css, : border-spacing-css,
"padding: " % first2 max 2 /i # "px; " % ; "padding: " % first2 max 2 /i # "px; " % ;
@ -151,7 +163,7 @@ M: html-stream stream-write1 ( char stream -- )
>r 1string r> stream-write ; >r 1string r> stream-write ;
M: html-stream stream-write ( str stream -- ) M: html-stream stream-write ( str stream -- )
>r escape-string r> delegate stream-write ; not-a-div >r escape-string r> delegate stream-write ;
M: html-stream make-span-stream ( style stream -- stream' ) M: html-stream make-span-stream ( style stream -- stream' )
html-span-stream <html-sub-stream> ; html-span-stream <html-sub-stream> ;
@ -164,7 +176,7 @@ M: html-stream make-block-stream ( style stream -- stream' )
html-block-stream <html-sub-stream> ; html-block-stream <html-sub-stream> ;
M: html-stream stream-write-table ( grid style stream -- ) M: html-stream stream-write-table ( grid style stream -- )
[ a-div [
<table dup table-attrs table> swap [ <table dup table-attrs table> swap [
<tr> [ <tr> [
<td "top" =valign swap table-style =style td> <td "top" =valign swap table-style =style td>
@ -178,7 +190,7 @@ M: html-stream make-cell-stream ( style stream -- stream' )
(html-sub-stream) ; (html-sub-stream) ;
M: html-stream stream-nl ( stream -- ) M: html-stream stream-nl ( stream -- )
[ <br/> ] with-stream* ; dup test-last-div? [ drop ] [ [ <br/> ] with-stream* ] if ;
! Utilities ! Utilities
: with-html-stream ( quot -- ) : with-html-stream ( quot -- )

4
extra/http/server/responders/responders.factor
View File

@ -124,6 +124,10 @@ SYMBOL: max-post-request
: header-param ( key -- value ) "header" get at ; : header-param ( key -- value ) "header" get at ;
: host ( -- string )
#! The host the current responder was called from.
"Host" header-param ":" split1 drop ;
: add-responder ( responder -- ) : add-responder ( responder -- )
#! Add a responder object to the list. #! Add a responder object to the list.
"responder" over at responders get set-at ; "responder" over at responders get set-at ;

4
extra/http/server/server.factor
View File

@ -28,10 +28,6 @@ IN: http.server
{ "HEAD" "head" } { "HEAD" "head" }
} at "bad" or ; } at "bad" or ;
: host ( -- string )
#! The host the current responder was called from.
"Host" header-param ":" split1 drop ;
: (handle-request) ( arg cmd -- method path host ) : (handle-request) ( arg cmd -- method path host )
request-method dup "method" set swap request-method dup "method" set swap
prepare-url prepare-header host ; prepare-url prepare-header host ;

3
extra/http/server/templating/templating.factor
View File

@ -77,7 +77,6 @@ DEFER: <% delimiter
[ [
[ [
"quiet" on "quiet" on
file-vocabs
parser-notes off parser-notes off
templating-vocab use+ templating-vocab use+
dup source-file file set ! so that reload works properly dup source-file file set ! so that reload works properly
@ -85,7 +84,7 @@ DEFER: <% delimiter
?resource-path file-contents ?resource-path file-contents
[ eval-template ] [ html-error. drop ] recover [ eval-template ] [ html-error. drop ] recover
] keep ] keep
] with-scope ] with-file-vocabs
] assert-depth drop ; ] assert-depth drop ;
: run-relative-template-file ( filename -- ) : run-relative-template-file ( filename -- )

2
extra/inverse/inverse.factor
View File

@ -69,7 +69,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
} cond ; } cond ;
: math-exp? ( n n word -- ? ) : math-exp? ( n n word -- ? )
{ + - * / ^ } member? -rot [ number? ] 2apply and and ; { + - * / ^ } member? -rot [ number? ] both? and ;
: (fold-constants) ( quot -- ) : (fold-constants) ( quot -- )
dup length 3 < [ % ] [ dup length 3 < [ % ] [

2
extra/io/nonblocking/nonblocking.factor
View File

@ -113,7 +113,7 @@ M: input-port stream-read
] if ; ] if ;
: read-until-loop ( seps port sbuf -- separator/f ) : read-until-loop ( seps port sbuf -- separator/f )
pick pick read-until-step over [ 2over read-until-step over [
>r over push-all r> dup [ >r over push-all r> dup [
>r 3drop r> >r 3drop r>
] [ ] [

2
extra/lazy-lists/lazy-lists.factor
View File

@ -319,7 +319,7 @@ TUPLE: lazy-from-by n quot ;
C: lfrom-by lazy-from-by ( n quot -- list ) C: lfrom-by lazy-from-by ( n quot -- list )
: lfrom ( n -- list ) : lfrom ( n -- list )
[ 1 + ] lfrom-by ; [ 1+ ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car ) M: lazy-from-by car ( lazy-from-by -- car )
lazy-from-by-n ; lazy-from-by-n ;

43
extra/lint/lint.factor
View File

@ -83,7 +83,8 @@ def-hash get-global [
! Remove n m shift defs ! Remove n m shift defs
[ [
drop dup length 3 = [ drop dup length 3 = [
dup first2 [ number? ] 2apply and swap third \ shift = and not dup first2 [ number? ] both?
swap third \ shift = and not
] [ drop t ] if ] [ drop t ] if
] assoc-subset ] assoc-subset
@ -120,7 +121,7 @@ M: word lint ( word -- seq )
: word-path. ( word -- ) : word-path. ( word -- )
[ word-vocabulary ":" ] keep unparse 3append write nl ; [ word-vocabulary ":" ] keep unparse 3append write nl ;
: lint. ( array -- ) : (lint.) ( pair -- )
first2 >r word-path. r> [ first2 >r word-path. r> [
bl bl bl bl bl bl bl bl
dup . dup .
@ -128,32 +129,46 @@ M: word lint ( word -- seq )
def-hash get at [ bl bl bl bl word-path. ] each def-hash get at [ bl bl bl bl word-path. ] each
nl nl
] each nl nl ; ] each nl nl ;
: lint. ( alist -- )
[ (lint.) ] each ;
GENERIC: run-lint ( obj -- obj ) GENERIC: run-lint ( obj -- obj )
: (trim-self)
def-hash get-global at* [
dupd remove empty? not
] [
drop f
] if ;
: trim-self ( seq -- newseq ) : trim-self ( seq -- newseq )
[ [ (trim-self) ] subset ] assoc-map ;
: filter-symbols ( alist -- alist )
[ [
first2 [ nip first dup def-hash get at
def-hash get-global at* [ [ first ] 2apply literalize = not
dupd remove empty? not ] assoc-subset ;
] [
drop f
] if
] subset 2array
] map ;
M: sequence run-lint ( seq -- seq ) M: sequence run-lint ( seq -- seq )
[ [
global [ dup . flush ] bind global [ dup . flush ] bind
dup lint 2array dup lint
] map ] { } map>assoc
trim-self trim-self
[ second empty? not ] subset ; [ second empty? not ] subset
filter-symbols ;
M: word run-lint ( word -- seq ) M: word run-lint ( word -- seq )
1array run-lint ; 1array run-lint ;
: lint-all ( -- seq ) : lint-all ( -- seq )
all-words run-lint dup [ lint. ] each ; all-words run-lint dup lint. ;
: lint-vocab ( vocab -- seq )
words run-lint dup lint. ;
: lint-word ( word -- seq )
1array run-lint dup lint. ;

5
extra/math/functions/functions.factor
View File

@ -30,6 +30,11 @@ M: real sqrt
2dup >r >r >r odd? r> call r> 2/ r> each-bit 2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline ] if ; inline
: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
: set-bit ( x n -- y ) 2^ bitor ; foldable
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
: bit-set? ( x n -- ? ) bit-clear? not ; foldable
GENERIC: (^) ( x y -- z ) foldable GENERIC: (^) ( x y -- z ) foldable
: ^n ( z w -- z^w ) : ^n ( z w -- z^w )

54
extra/math/miller-rabin/miller-rabin.factor
View File

@ -18,43 +18,31 @@ SYMBOL: trials
: next-odd ( m -- n ) : next-odd ( m -- n )
dup even? [ 1+ ] [ 2 + ] if ; dup even? [ 1+ ] [ 2 + ] if ;
: random-bits ( m -- n ) : random-bits ( m -- n ) 2^ random ; foldable
#! Top bit is always set
2^ [ random ] keep -1 shift bitor ; foldable
: (factor-2s) ( s n -- s n ) : factor-2s ( zero n -- r s )
dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
: factor-2s ( n -- r s )
#! factor an even number into 2 ^ s * m #! factor an even number into 2 ^ s * m
dup even? over 0 > and [ dup even? [ -1 shift >r 1+ r> factor-2s ] when ;
"input must be positive and even" throw
] unless 0 swap (factor-2s) ;
:: (miller-rabin) | n prime?! | :: (miller-rabin) | n prime?! |
n dup 1 = over even? or [ 0 n 1- factor-2s s set r set
drop f trials get [
] [ n 1- [1,b] random a set
1- factor-2s s set r set a get s get n ^mod 1 = [
trials get [ 0 count set
n 1- [1,b] random a set r get [
a get s get n ^mod 1 = [ 2^ s get * a get swap n ^mod n - -1 = [
0 count set count [ 1+ ] change
r get [ r get +
2^ s get * a get swap n ^mod n - -1 = [
count [ 1+ ] change
r get +
] when
] each
count get zero? [
f prime?!
trials get +
] when ] when
] unless ] each
drop count get zero? [
] each f prime?!
prime? trials get +
] if ; ] when
] unless
drop
] each prime? ;
TUPLE: miller-rabin-bounds ; TUPLE: miller-rabin-bounds ;
@ -62,6 +50,7 @@ TUPLE: miller-rabin-bounds ;
over { over {
{ [ dup 1 <= ] [ 3drop f ] } { [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] } { [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
{ [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] } { [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] }
} cond ; } cond ;
@ -87,4 +76,3 @@ TUPLE: miller-rabin-bounds ;
#! generate two primes #! generate two primes
over 5 < [ "not enough primes below 5 bits" throw ] when over 5 < [ "not enough primes below 5 bits" throw ] when
[ [ drop random-prime ] with map ] [ all-unique? ] generate ; [ [ drop random-prime ] with map ] [ all-unique? ] generate ;

2
extra/opengl/opengl.factor
View File

@ -27,7 +27,7 @@ IN: opengl
swap glBegin call glEnd ; inline swap glBegin call glEnd ; inline
: do-enabled ( what quot -- ) : do-enabled ( what quot -- )
over glEnable swap slip glDisable ; inline over glEnable dip glDisable ; inline
: do-matrix ( mode quot -- ) : do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep swap [ glMatrixMode glPushMatrix call ] keep

7
extra/pack/pack.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types arrays assocs byte-arrays inference
inference.transforms io io.binary io.streams.string kernel inference.transforms io io.binary io.streams.string kernel
math math.parser namespaces parser prettyprint math math.parser namespaces parser prettyprint
quotations sequences strings threads vectors quotations sequences strings threads vectors
words macros ; words macros math.functions ;
IN: pack IN: pack
SYMBOL: big-endian SYMBOL: big-endian
@ -10,9 +10,6 @@ SYMBOL: big-endian
: big-endian? ( -- ? ) : big-endian? ( -- ? )
1 <int> *char zero? ; 1 <int> *char zero? ;
: clear-bit ( m n -- o )
2^ bitnot bitand ;
: >endian ( obj n -- str ) : >endian ( obj n -- str )
big-endian get [ >be ] [ >le ] if ; inline big-endian get [ >be ] [ >le ] if ; inline
@ -88,7 +85,7 @@ M: string b, ( n string -- ) heap-size b, ;
"\0" read-until [ drop f ] unless ; "\0" read-until [ drop f ] unless ;
: read-c-string* ( n -- str/f ) : read-c-string* ( n -- str/f )
read [ 0 = ] right-trim dup empty? [ drop f ] when ; read [ zero? ] right-trim dup empty? [ drop f ] when ;
: (read-128-ber) ( n -- n ) : (read-128-ber) ( n -- n )
1 read first 1 read first

366
extra/peg/ebnf/ebnf.factor
View File

@ -1,184 +1,184 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg ; quotations vectors namespaces math assocs continuations peg ;
IN: peg.ebnf IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ; TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ; TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-choice options ; TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ; TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ; TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-optional elements ; TUPLE: ebnf-optional elements ;
TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action word ; TUPLE: ebnf-action word ;
TUPLE: ebnf rules ; TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal C: <ebnf-terminal> ebnf-terminal
C: <ebnf-choice> ebnf-choice C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence C: <ebnf-sequence> ebnf-sequence
C: <ebnf-repeat0> ebnf-repeat0 C: <ebnf-repeat0> ebnf-repeat0
C: <ebnf-optional> ebnf-optional C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action C: <ebnf-action> ebnf-action
C: <ebnf> ebnf C: <ebnf> ebnf
SYMBOL: parsers SYMBOL: parsers
SYMBOL: non-terminals SYMBOL: non-terminals
SYMBOL: last-parser SYMBOL: last-parser
: reset-parser-generation ( -- ) : reset-parser-generation ( -- )
V{ } clone parsers set V{ } clone parsers set
H{ } clone non-terminals set H{ } clone non-terminals set
f last-parser set ; f last-parser set ;
: store-parser ( parser -- number ) : store-parser ( parser -- number )
parsers get [ push ] keep length 1- ; parsers get [ push ] keep length 1- ;
: get-parser ( index -- parser ) : get-parser ( index -- parser )
parsers get nth ; parsers get nth ;
: non-terminal-index ( name -- number ) : non-terminal-index ( name -- number )
dup non-terminals get at [ dup non-terminals get at [
nip nip
] [ ] [
f store-parser [ swap non-terminals get set-at ] keep f store-parser [ swap non-terminals get set-at ] keep
] if* ; ] if* ;
GENERIC: (generate-parser) ( ast -- id ) GENERIC: (generate-parser) ( ast -- id )
: generate-parser ( ast -- id ) : generate-parser ( ast -- id )
(generate-parser) dup last-parser set ; (generate-parser) dup last-parser set ;
M: ebnf-terminal (generate-parser) ( ast -- id ) M: ebnf-terminal (generate-parser) ( ast -- id )
ebnf-terminal-symbol token sp store-parser ; ebnf-terminal-symbol token sp store-parser ;
M: ebnf-non-terminal (generate-parser) ( ast -- id ) M: ebnf-non-terminal (generate-parser) ( ast -- id )
[ [
ebnf-non-terminal-symbol dup non-terminal-index , ebnf-non-terminal-symbol dup non-terminal-index ,
parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or , parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
] [ ] make delay sp store-parser ; ] [ ] make delay sp store-parser ;
M: ebnf-choice (generate-parser) ( ast -- id ) M: ebnf-choice (generate-parser) ( ast -- id )
ebnf-choice-options [ ebnf-choice-options [
generate-parser get-parser generate-parser get-parser
] map choice store-parser ; ] map choice store-parser ;
M: ebnf-sequence (generate-parser) ( ast -- id ) M: ebnf-sequence (generate-parser) ( ast -- id )
ebnf-sequence-elements [ ebnf-sequence-elements [
generate-parser get-parser generate-parser get-parser
] map seq store-parser ; ] map seq store-parser ;
M: ebnf-repeat0 (generate-parser) ( ast -- id ) M: ebnf-repeat0 (generate-parser) ( ast -- id )
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ; ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
M: ebnf-optional (generate-parser) ( ast -- id ) M: ebnf-optional (generate-parser) ( ast -- id )
ebnf-optional-elements generate-parser get-parser optional store-parser ; ebnf-optional-elements generate-parser get-parser optional store-parser ;
M: ebnf-rule (generate-parser) ( ast -- id ) M: ebnf-rule (generate-parser) ( ast -- id )
dup ebnf-rule-symbol non-terminal-index swap dup ebnf-rule-symbol non-terminal-index swap
ebnf-rule-elements generate-parser get-parser ! nt-id body ebnf-rule-elements generate-parser get-parser ! nt-id body
swap [ parsers get set-nth ] keep ; swap [ parsers get set-nth ] keep ;
M: ebnf-action (generate-parser) ( ast -- id ) M: ebnf-action (generate-parser) ( ast -- id )
ebnf-action-word search 1quotation ebnf-action-word search 1quotation
last-parser get get-parser swap action store-parser ; last-parser get get-parser swap action store-parser ;
M: vector (generate-parser) ( ast -- id ) M: vector (generate-parser) ( ast -- id )
[ generate-parser ] map peek ; [ generate-parser ] map peek ;
M: f (generate-parser) ( ast -- id ) M: f (generate-parser) ( ast -- id )
drop last-parser get ; drop last-parser get ;
M: ebnf (generate-parser) ( ast -- id ) M: ebnf (generate-parser) ( ast -- id )
ebnf-rules [ ebnf-rules [
generate-parser generate-parser
] map peek ; ] map peek ;
DEFER: 'rhs' DEFER: 'rhs'
: 'non-terminal' ( -- parser ) : 'non-terminal' ( -- parser )
CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ; CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser ) : 'terminal' ( -- parser )
"'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ; "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
: 'element' ( -- parser ) : 'element' ( -- parser )
'non-terminal' 'terminal' 2array choice ; 'non-terminal' 'terminal' 2array choice ;
DEFER: 'choice' DEFER: 'choice'
: 'group' ( -- parser ) : 'group' ( -- parser )
"(" token sp hide "(" token sp hide
[ 'choice' sp ] delay [ 'choice' sp ] delay
")" token sp hide ")" token sp hide
3array seq [ first ] action ; 3array seq [ first ] action ;
: 'repeat0' ( -- parser ) : 'repeat0' ( -- parser )
"{" token sp hide "{" token sp hide
[ 'choice' sp ] delay [ 'choice' sp ] delay
"}" token sp hide "}" token sp hide
3array seq [ first <ebnf-repeat0> ] action ; 3array seq [ first <ebnf-repeat0> ] action ;
: 'optional' ( -- parser ) : 'optional' ( -- parser )
"[" token sp hide "[" token sp hide
[ 'choice' sp ] delay [ 'choice' sp ] delay
"]" token sp hide "]" token sp hide
3array seq [ first <ebnf-optional> ] action ; 3array seq [ first <ebnf-optional> ] action ;
: 'sequence' ( -- parser ) : 'sequence' ( -- parser )
[ [
'element' sp , 'element' sp ,
'group' sp , 'group' sp ,
'repeat0' sp , 'repeat0' sp ,
'optional' sp , 'optional' sp ,
] { } make choice ] { } make choice
repeat1 [ repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if dup length 1 = [ first ] [ <ebnf-sequence> ] if
] action ; ] action ;
: 'choice' ( -- parser ) : 'choice' ( -- parser )
'sequence' sp "|" token sp list-of [ 'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ; ] action ;
: 'action' ( -- parser ) : 'action' ( -- parser )
"=>" token hide "=>" token hide
[ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
2array seq [ first <ebnf-action> ] action ; 2array seq [ first <ebnf-action> ] action ;
: 'rhs' ( -- parser ) : 'rhs' ( -- parser )
'choice' 'action' sp optional 2array seq ; 'choice' 'action' sp optional 2array seq ;
: 'rule' ( -- parser ) : 'rule' ( -- parser )
'non-terminal' [ ebnf-non-terminal-symbol ] action 'non-terminal' [ ebnf-non-terminal-symbol ] action
"=" token sp hide "=" token sp hide
'rhs' 'rhs'
3array seq [ first2 <ebnf-rule> ] action ; 3array seq [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser ) : 'ebnf' ( -- parser )
'rule' sp "." token sp hide list-of [ <ebnf> ] action ; 'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
: ebnf>quot ( string -- quot ) : ebnf>quot ( string -- quot )
'ebnf' parse [ 'ebnf' parse [
parse-result-ast [ parse-result-ast [
reset-parser-generation reset-parser-generation
generate-parser drop generate-parser drop
[ [
non-terminals get non-terminals get
[ [
get-parser [ get-parser [
swap , \ in , \ get , \ create , swap , \ in , \ get , \ create ,
1quotation , \ define-compound , 1quotation , \ define ,
] [ ] [
drop drop
] if* ] if*
] assoc-each ] assoc-each
] [ ] make ] [ ] make
] with-scope ] with-scope
] [ ] [
f f
] if* ; ] if* ;
: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing : <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing

283
extra/peg/peg-docs.factor
View File

@ -1,142 +1,143 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax peg ; USING: help.markup help.syntax ;
IN: peg
HELP: parse
{ $values HELP: parse
{ "input" "a string" } { $values
{ "parser" "a parser" } { "input" "a string" }
{ "result" "a parse-result or f" } { "parser" "a parser" }
} { "result" "a parse-result or f" }
{ $description }
"Given the input string, parse it using the given parser. The result is a <parse-result> object if " { $description
"the parse was successful, otherwise it is f." } ; "Given the input string, parse it using the given parser. The result is a <parse-result> object if "
"the parse was successful, otherwise it is f." } ;
HELP: token
{ $values HELP: token
{ "string" "a string" } { $values
{ "parser" "a parser" } { "string" "a string" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that matches the given string." } ; { $description
"Returns a parser that matches the given string." } ;
HELP: satisfy
{ $values HELP: satisfy
{ "quot" "a quotation" } { $values
{ "parser" "a parser" } { "quot" "a quotation" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that calls the quotation on the first character of the input string, " { $description
"succeeding if that quotation returns true. The AST is the character from the string." } ; "Returns a parser that calls the quotation on the first character of the input string, "
"succeeding if that quotation returns true. The AST is the character from the string." } ;
HELP: range
{ $values HELP: range
{ "min" "a character" } { $values
{ "max" "a character" } { "min" "a character" }
{ "parser" "a parser" } { "max" "a character" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that matches a single character that lies within the range of characters given, inclusive." } { $description
{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ; "Returns a parser that matches a single character that lies within the range of characters given, inclusive." }
{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ;
HELP: seq
{ $values HELP: seq
{ "seq" "a sequence of parsers" } { $values
{ "parser" "a parser" } { "seq" "a sequence of parsers" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if " { $description
"all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by " "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if "
"the individual parsers." } ; "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
"the individual parsers." } ;
HELP: choice
{ $values HELP: choice
{ "seq" "a sequence of parsers" } { $values
{ "parser" "a parser" } { "seq" "a sequence of parsers" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. " { $description
"The resulting AST is that produced by the successful parser." } ; "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. "
"The resulting AST is that produced by the successful parser." } ;
HELP: repeat0
{ $values HELP: repeat0
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is " { $description
"an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were " "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
"parsed." } ; "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
"parsed." } ;
HELP: repeat1
{ $values HELP: repeat1
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is " { $description
"an array of the AST produced by the 'p1' parser." } ; "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is "
"an array of the AST produced by the 'p1' parser." } ;
HELP: optional
{ $values HELP: optional
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is " { $description
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ; "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
HELP: ensure
{ $values HELP: ensure
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the " { $description
"AST and does not move the location in the input string. This can be used for lookahead and " "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
"disambiguation, along with the " { $link ensure-not } " word." } "AST and does not move the location in the input string. This can be used for lookahead and "
{ $examples { $code "\"0\" token ensure octal-parser" } } ; "disambiguation, along with the " { $link ensure-not } " word." }
{ $examples { $code "\"0\" token ensure octal-parser" } } ;
HELP: ensure-not
{ $values HELP: ensure-not
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the " { $description
"AST and does not move the location in the input string. This can be used for lookahead and " "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
"disambiguation, along with the " { $link ensure } " word." } "AST and does not move the location in the input string. This can be used for lookahead and "
{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ; "disambiguation, along with the " { $link ensure } " word." }
{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
HELP: action
{ $values HELP: action
{ "parser" "a parser" } { $values
{ "quot" "a quotation with stack effect ( ast -- ast )" } { "parser" "a parser" }
} { "quot" "a quotation with stack effect ( ast -- ast )" }
{ $description }
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting " { $description
"from that parse. The result of the quotation is then used as the final AST. This can be used " "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than " "from that parse. The result of the quotation is then used as the final AST. This can be used "
"the default AST." } "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ; "the default AST." }
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
HELP: sp
{ $values HELP: sp
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that calls the original parser 'p1' after stripping any whitespace " { $description
" from the left of the input string." } ; "Returns a parser that calls the original parser 'p1' after stripping any whitespace "
" from the left of the input string." } ;
HELP: hide
{ $values HELP: hide
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that succeeds if the original parser succeeds, but does not " { $description
"put any result in the AST. Useful for ignoring 'syntax' in the AST." } "Returns a parser that succeeds if the original parser succeeds, but does not "
{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ; "put any result in the AST. Useful for ignoring 'syntax' in the AST." }
{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;
HELP: delay
{ $values HELP: delay
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Delays the construction of a parser until it is actually required to parse. This " { $description
"allows for calling a parser that results in a recursive call to itself. The quotation " "Delays the construction of a parser until it is actually required to parse. This "
"allows for calling a parser that results in a recursive call to itself. The quotation "
"should return the constructed parser." } ; "should return the constructed parser." } ;

2
extra/random-tester/random-tester.factor
View File

@ -22,7 +22,7 @@ TUPLE: random-tester-error ;
datastack clone after set datastack clone after set
clear clear
before get [ ] each before get [ ] each
quot get [ compile-1 ] [ errored on ] recover ; quot get [ compile-call ] [ errored on ] recover ;
: do-test ! ( data... quot -- ) : do-test ! ( data... quot -- )
.s flush test-compiler .s flush test-compiler

2
extra/random-weighted/random-weighted.factor
View File

@ -4,7 +4,7 @@ USING: kernel namespaces arrays quotations sequences assocs combinators
IN: random-weighted IN: random-weighted
: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ; : probabilities ( weights -- probabilities ) dup sum v/n ;
: layers ( probabilities -- layers ) : layers ( probabilities -- layers )
dup length 1+ [ head ] with map 1 tail [ sum ] map ; dup length 1+ [ head ] with map 1 tail [ sum ] map ;

2
extra/random/random.factor
View File

@ -36,7 +36,7 @@ SYMBOL: mt
: set-mt-ith ( y i-get i-set -- ) : set-mt-ith ( y i-get i-set -- )
>r mt-nth >r >r mt-nth >r
[ -1 shift ] keep odd? mt-a 0 ? r> bitxor bitxor r> [ 2/ ] keep odd? mt-a 0 ? r> bitxor bitxor r>
mt-seq set-nth ; inline mt-seq set-nth ; inline
: mt-y ( y1 y2 -- y ) : mt-y ( y1 y2 -- y )

2
extra/shuffle/shuffle.factor
View File

@ -21,8 +21,6 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
: 2over ( a b c -- a b c a b ) pick pick ; inline
: nipd ( a b c -- b c ) rot drop ; inline : nipd ( a b c -- b c ) rot drop ; inline
: 3nip ( a b c d -- d ) 3 nnip ; inline : 3nip ( a b c d -- d ) 3 nnip ; inline

2
extra/slides/slides.factor
View File

@ -85,7 +85,7 @@ TUPLE: slides ;
>r first3 r> head 3array ; >r first3 r> head 3array ;
: strip-tease ( data -- seq ) : strip-tease ( data -- seq )
dup third length 1 - [ dup third length 1- [
2 + (strip-tease) 2 + (strip-tease)
] with map ; ] with map ;

6
extra/tar/tar.factor
View File

@ -35,7 +35,7 @@ linkname magic version uname gname devmajor devminor prefix ;
: header-checksum ( seq -- x ) : header-checksum ( seq -- x )
148 cut-slice 8 tail-slice 148 cut-slice 8 tail-slice
[ 0 [ + ] reduce ] 2apply + 256 + ; [ sum ] 2apply + 256 + ;
TUPLE: checksum-error ; TUPLE: checksum-error ;
TUPLE: malformed-block-error ; TUPLE: malformed-block-error ;
@ -164,7 +164,7 @@ TUPLE: unimplemented-typeflag header ;
! Long file name ! Long file name
: typeflag-L ( header -- ) : typeflag-L ( header -- )
<string-writer> [ read-data-blocks ] keep <string-writer> [ read-data-blocks ] keep
>string [ CHAR: \0 = ] right-trim filename set >string [ zero? ] right-trim filename set
global [ "long filename: " write filename get . flush ] bind global [ "long filename: " write filename get . flush ] bind
filename get tar-path+ make-directories ; filename get tar-path+ make-directories ;
@ -196,7 +196,7 @@ TUPLE: unimplemented-typeflag header ;
! global [ dup tar-header-name [ print flush ] when* ] bind ! global [ dup tar-header-name [ print flush ] when* ] bind
dup tar-header-typeflag dup tar-header-typeflag
{ {
{ CHAR: \0 [ typeflag-0 ] } { 0 [ typeflag-0 ] }
{ CHAR: 0 [ typeflag-0 ] } { CHAR: 0 [ typeflag-0 ] }
{ CHAR: 1 [ typeflag-1 ] } { CHAR: 1 [ typeflag-1 ] }
{ CHAR: 2 [ typeflag-2 ] } { CHAR: 2 [ typeflag-2 ] }

15
extra/tools/memory/memory-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax memory ; USING: help.markup help.syntax memory sequences ;
IN: tools.memory IN: tools.memory
ARTICLE: "tools.memory" "Object memory tools" ARTICLE: "tools.memory" "Object memory tools"
@ -6,7 +6,18 @@ ARTICLE: "tools.memory" "Object memory tools"
{ $subsection room. } { $subsection room. }
{ $subsection heap-stats. } { $subsection heap-stats. }
{ $subsection heap-stats } { $subsection heap-stats }
{ $see-also "memory" } ; "You can query memory status:"
{ $subsection data-room }
{ $subsection code-room }
"There are a pair of combinators, analogous to " { $link each } " and " { $link subset } ", which operate on the entire collection of objects in the object heap:"
{ $subsection each-object }
{ $subsection instances }
"You can check an object's the heap memory usage:"
{ $subsection size }
"The garbage collector can be invoked manually:"
{ $subsection data-gc }
{ $subsection code-gc }
{ $see-also "image" } ;
ABOUT: "tools.memory" ABOUT: "tools.memory"

6
extra/tools/test/test-docs.factor
View File

@ -1,12 +1,14 @@
USING: help.markup help.syntax kernel ; USING: help.markup help.syntax kernel ;
IN: tools.test IN: tools.test
ARTICLE: "tools.test" "Unit testing modules" ARTICLE: "tools.test" "Unit testing"
"A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract."
$nl $nl
"For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know." "For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know."
$nl $nl
"Unit tests for a vocabulary are placed in test harness files ( "{ $link "vocabs.loader" } "). If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" "Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } " -tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
$nl
"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:"
{ $subsection unit-test } { $subsection unit-test }
{ $subsection unit-test-fails } { $subsection unit-test-fails }
"The following words run test harness files; any test failures are collected and printed at the end:" "The following words run test harness files; any test failures are collected and printed at the end:"

15
extra/tools/test/test.factor
View File

@ -55,12 +55,17 @@ TUPLE: expected-error ;
[ nl failure. nl ] each ; [ nl failure. nl ] each ;
: run-tests ( seq -- ) : run-tests ( seq -- )
[ dup run-test ] { } map>assoc dup empty? [ drop "==== NOTHING TO TEST" print ] [
[ second empty? not ] subset [ dup run-test ] { } map>assoc
dup empty? [ drop ] [ [ second empty? not ] subset
nl nl
"==== FAILING TESTS:" print dup empty? [
[ nl failures. ] assoc-each drop
"==== ALL TESTS PASSED" print
] [
"==== FAILING TESTS:" print
[ nl failures. ] assoc-each
] if
] if ; ] if ;
: run-vocab-tests ( vocabs -- ) : run-vocab-tests ( vocabs -- )

3
extra/tuple-arrays/tuple-arrays-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.syntax help.markup tuple-arrays splitting kernel ; USING: help.syntax help.markup splitting kernel ;
IN: tuple-arrays
HELP: tuple-array HELP: tuple-array
{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. Packed follows the sequence protocol and is implemented using the " { $link groups } " class." } ; { $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. Packed follows the sequence protocol and is implemented using the " { $link groups } " class." } ;

4
extra/ui/gadgets/panes/panes.factor
View File

@ -105,7 +105,7 @@ C: <pane-stream> pane-stream
: pane-format ( style pane seq -- ) : pane-format ( style pane seq -- )
[ dup pane-nl ] [ dup pane-nl ]
[ pick pick pane-current stream-format ] [ 2over pane-current stream-format ]
interleave 2drop ; interleave 2drop ;
GENERIC: write-gadget ( gadget stream -- ) GENERIC: write-gadget ( gadget stream -- )
@ -327,7 +327,7 @@ M: paragraph stream-format
] [ ] [
rot " " split rot " " split
[ 2dup gadget-bl ] [ 2dup gadget-bl ]
[ pick pick gadget-format ] interleave [ 2over gadget-format ] interleave
2drop 2drop
] if ; ] if ;

2
extra/ui/tools/deploy/deploy-docs.factor
View File

@ -13,3 +13,5 @@ $nl
{ $subsection deploy-tool } { $subsection deploy-tool }
"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu." "Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu."
{ $see-also "tools.deploy" } ; { $see-also "tools.deploy" } ;
ABOUT: "ui.tools.deploy"

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

@ -81,7 +81,7 @@ TUPLE: deploy-gadget vocab settings ;
close-window ; close-window ;
: com-help ( -- ) : com-help ( -- )
"ui-deploy" help-window ; "ui.tools.deploy" help-window ;
\ com-help H{ \ com-help H{
{ +nullary+ t } { +nullary+ t }

1
extra/visitor/authors.txt
View File

@ -1 +0,0 @@
Daniel Ehrenberg

1
extra/visitor/summary.txt
View File

@ -1 +0,0 @@
Double-dispatch generic words

1
extra/visitor/tags.txt
View File

@ -1 +0,0 @@
extensions

18
extra/visitor/visitor-tests.factor
View File

@ -1,18 +0,0 @@
USING: visitor math sequences math.parser strings tools.test kernel ;
VISITOR: ++ ( object object -- object )
! acts like +, coercing string arguments to a number, unless both arguments are strings, in which case it appends them
V: number string ++
string>number + ;
V: string number ++
>r string>number r> + ;
V: number number ++
+ ;
V: string string ++
append ;
[ 3 ] [ 1 2 ++ ] unit-test
[ 3 ] [ "1" 2 ++ ] unit-test
[ 3 ] [ 1 "2" ++ ] unit-test
[ "12" ] [ "1" "2" ++ ] unit-test

63
extra/visitor/visitor.factor
View File

@ -1,63 +0,0 @@
USING: kernel generic.standard syntax words parser assocs
generic quotations sequences effects arrays classes definitions
prettyprint sorting prettyprint.backend shuffle ;
IN: visitor
: define-visitor ( word -- )
dup dup reset-word define-simple-generic
dup H{ } clone "visitor-methods" set-word-prop
H{ } clone "visitors" set-word-prop ;
: VISITOR:
CREATE define-visitor ; parsing
: record-visitor ( top-class generic method-word -- )
swap "visitors" word-prop swapd set-at ;
: define-1generic ( word -- )
1 <standard-combination> define-generic ;
: copy-effect ( from to -- )
swap stack-effect "declared-effect" set-word-prop ;
: new-vmethod ( method bottom-class top-class generic -- )
gensym dup define-1generic
2dup copy-effect
3dup 1quotation -rot define-method
[ record-visitor ] keep
define-method ;
: define-visitor-method ( method bottom-class top-class generic -- )
4dup >r 2array r> "visitor-methods" word-prop set-at
2dup "visitors" word-prop at
[ nip define-method ] [ new-vmethod ] ?if ;
: V:
! syntax: V: bottom-class top-class generic body... ;
f set-word scan-word scan-word scan-word
parse-definition -roll define-visitor-method ; parsing
! see instance:
! see must be redone because "methods" doesn't show methods
PREDICATE: standard-generic visitor "visitors" word-prop ;
PREDICATE: array triple length 3 = ;
PREDICATE: triple visitor-spec
first3 visitor? >r [ class? ] 2apply and r> and ;
M: visitor-spec definer drop \ V: \ ; ;
M: visitor definer drop \ VISITOR: f ;
M: visitor-spec synopsis*
! same as method-spec#synopsis*
dup definer drop pprint-word
[ pprint-word ] each ;
M: visitor-spec definition
first3 >r 2array r> "visitor-methods" word-prop at ;
M: visitor see
dup (see)
dup see-class
dup "visitor-methods" word-prop keys natural-sort swap
[ >r first2 r> 3array ] curry map see-all ;

4
extra/webapps/cgi/cgi.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators USING: namespaces kernel assocs io.files combinators
arrays io.launcher io http.server http.server.responders arrays io.launcher io http.server.responders webapps.file
webapps.file sequences strings ; sequences strings ;
IN: webapps.cgi IN: webapps.cgi
SYMBOL: cgi-root SYMBOL: cgi-root

6
vm/math.c
View File

@ -166,6 +166,12 @@ DEFINE_PRIMITIVE(fixnum_shift)
fixnum_to_bignum(x),y))); fixnum_to_bignum(x),y)));
} }
DEFINE_PRIMITIVE(fixnum_shift_fast)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
}
DEFINE_PRIMITIVE(fixnum_less) DEFINE_PRIMITIVE(fixnum_less)
{ {
POP_FIXNUMS(x,y) POP_FIXNUMS(x,y)

1
vm/math.h
View File

@ -22,6 +22,7 @@ DECLARE_PRIMITIVE(fixnum_and);
DECLARE_PRIMITIVE(fixnum_or); DECLARE_PRIMITIVE(fixnum_or);
DECLARE_PRIMITIVE(fixnum_xor); DECLARE_PRIMITIVE(fixnum_xor);
DECLARE_PRIMITIVE(fixnum_shift); DECLARE_PRIMITIVE(fixnum_shift);
DECLARE_PRIMITIVE(fixnum_shift_fast);
DECLARE_PRIMITIVE(fixnum_less); DECLARE_PRIMITIVE(fixnum_less);
DECLARE_PRIMITIVE(fixnum_lesseq); DECLARE_PRIMITIVE(fixnum_lesseq);
DECLARE_PRIMITIVE(fixnum_greater); DECLARE_PRIMITIVE(fixnum_greater);

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