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
- Compiling the Factor VM
- Libraries needed for compilation
- Bootstrapping the Factor image
- Running Factor on Unix with X11
- Running Factor on Mac OS X - Cocoa UI
- Running Factor on Mac OS X - X11 UI
- Running Factor on Windows
- Command line usage
- The Factor FAQ
- Source organization
- Community
@ -59,6 +61,17 @@ for your platform.
Compilation will yield an executable named 'factor' on Unix,
'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
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
* The Factor FAQ
The Factor FAQ lives online at http://factorcode.org/faq.fhtml
* Command line usage
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 ;
: 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
kernel kernel.private libc math namespaces parser sequences
strings words assocs splitting math.parser cpu.architecture
alien quotations system ;
alien quotations system compiler.units ;
IN: alien.c-types
TUPLE: c-type
@ -227,130 +227,135 @@ M: long-long-type box-return ( type -- )
define-out ;
: expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around
#! staging violations
dup array? [
unclip >r [ dup word? [ execute ] when ] map r> add*
unclip >r [ dup word? [ word-def call ] when ] map
r> add*
] when ;
[ alien-cell ]
[ set-alien-cell ]
bootstrap-cell
"box_alien"
"alien_offset" <primitive-type>
"void*" define-primitive-type
[
[ alien-cell ]
[ set-alien-cell ]
bootstrap-cell
"box_alien"
"alien_offset" <primitive-type>
"void*" define-primitive-type
[ alien-signed-8 ]
[ set-alien-signed-8 ]
8
"box_signed_8"
"to_signed_8" <primitive-type> <long-long-type>
"longlong" define-primitive-type
[ alien-signed-8 ]
[ set-alien-signed-8 ]
8
"box_signed_8"
"to_signed_8" <primitive-type> <long-long-type>
"longlong" define-primitive-type
[ alien-unsigned-8 ]
[ set-alien-unsigned-8 ]
8
"box_unsigned_8"
"to_unsigned_8" <primitive-type> <long-long-type>
"ulonglong" define-primitive-type
[ alien-unsigned-8 ]
[ set-alien-unsigned-8 ]
8
"box_unsigned_8"
"to_unsigned_8" <primitive-type> <long-long-type>
"ulonglong" define-primitive-type
[ alien-signed-cell ]
[ set-alien-signed-cell ]
bootstrap-cell
"box_signed_cell"
"to_fixnum" <primitive-type>
"long" define-primitive-type
[ alien-signed-cell ]
[ set-alien-signed-cell ]
bootstrap-cell
"box_signed_cell"
"to_fixnum" <primitive-type>
"long" define-primitive-type
[ alien-unsigned-cell ]
[ set-alien-unsigned-cell ]
bootstrap-cell
"box_unsigned_cell"
"to_cell" <primitive-type>
"ulong" define-primitive-type
[ alien-unsigned-cell ]
[ set-alien-unsigned-cell ]
bootstrap-cell
"box_unsigned_cell"
"to_cell" <primitive-type>
"ulong" define-primitive-type
[ alien-signed-4 ]
[ set-alien-signed-4 ]
4
"box_signed_4"
"to_fixnum" <primitive-type>
"int" define-primitive-type
[ alien-signed-4 ]
[ set-alien-signed-4 ]
4
"box_signed_4"
"to_fixnum" <primitive-type>
"int" define-primitive-type
[ alien-unsigned-4 ]
[ set-alien-unsigned-4 ]
4
"box_unsigned_4"
"to_cell" <primitive-type>
"uint" define-primitive-type
[ alien-unsigned-4 ]
[ set-alien-unsigned-4 ]
4
"box_unsigned_4"
"to_cell" <primitive-type>
"uint" define-primitive-type
[ alien-signed-2 ]
[ set-alien-signed-2 ]
2
"box_signed_2"
"to_fixnum" <primitive-type>
"short" define-primitive-type
[ alien-signed-2 ]
[ set-alien-signed-2 ]
2
"box_signed_2"
"to_fixnum" <primitive-type>
"short" define-primitive-type
[ alien-unsigned-2 ]
[ set-alien-unsigned-2 ]
2
"box_unsigned_2"
"to_cell" <primitive-type>
"ushort" define-primitive-type
[ alien-unsigned-2 ]
[ set-alien-unsigned-2 ]
2
"box_unsigned_2"
"to_cell" <primitive-type>
"ushort" define-primitive-type
[ alien-signed-1 ]
[ set-alien-signed-1 ]
1
"box_signed_1"
"to_fixnum" <primitive-type>
"char" define-primitive-type
[ alien-signed-1 ]
[ set-alien-signed-1 ]
1
"box_signed_1"
"to_fixnum" <primitive-type>
"char" define-primitive-type
[ alien-unsigned-1 ]
[ set-alien-unsigned-1 ]
1
"box_unsigned_1"
"to_cell" <primitive-type>
"uchar" define-primitive-type
[ alien-unsigned-1 ]
[ set-alien-unsigned-1 ]
1
"box_unsigned_1"
"to_cell" <primitive-type>
"uchar" define-primitive-type
[ alien-unsigned-4 zero? not ]
[ 1 0 ? set-alien-unsigned-4 ]
4
"box_boolean"
"to_boolean" <primitive-type>
"bool" define-primitive-type
[ alien-unsigned-4 zero? not ]
[ 1 0 ? set-alien-unsigned-4 ]
4
"box_boolean"
"to_boolean" <primitive-type>
"bool" define-primitive-type
[ alien-float ]
[ >r >r >float r> r> set-alien-float ]
4
"box_float"
"to_float" <primitive-type>
"float" define-primitive-type
[ alien-float ]
[ >r >r >float r> r> set-alien-float ]
4
"box_float"
"to_float" <primitive-type>
"float" define-primitive-type
T{ float-regs f 4 } "float" c-type set-c-type-reg-class
[ >float ] "float" c-type set-c-type-prep
T{ float-regs f 4 } "float" c-type set-c-type-reg-class
[ >float ] "float" c-type set-c-type-prep
[ alien-double ]
[ >r >r >float r> r> set-alien-double ]
8
"box_double"
"to_double" <primitive-type>
"double" define-primitive-type
[ alien-double ]
[ >r >r >float r> r> set-alien-double ]
8
"box_double"
"to_double" <primitive-type>
"double" define-primitive-type
T{ float-regs f 8 } "double" c-type set-c-type-reg-class
[ >float ] "double" c-type set-c-type-prep
T{ float-regs f 8 } "double" c-type set-c-type-reg-class
[ >float ] "double" c-type set-c-type-prep
[ alien-cell alien>char-string ]
[ set-alien-cell ]
bootstrap-cell
"box_char_string"
"alien_offset" <primitive-type>
"char*" define-primitive-type
[ alien-cell alien>char-string ]
[ set-alien-cell ]
bootstrap-cell
"box_char_string"
"alien_offset" <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 ]
[ set-alien-cell ]
4
"box_u16_string"
"alien_offset" <primitive-type>
"ushort*" define-primitive-type
[ alien-cell alien>u16-string ]
[ set-alien-cell ]
4
"box_u16_string"
"alien_offset" <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
: 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
: 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 ;
: cache ( key assoc quot -- value )
pick pick at [
2over at [
>r 3drop r>
] [
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
: n>cell -5 shift 4 * ; inline
: n>byte -3 shift ; inline
: cell/bit ( n alien -- byte bit )
over n>cell alien-unsigned-4 swap 31 bitand ; inline
: byte/bit ( n alien -- byte bit )
over n>byte alien-unsigned-1 swap 7 bitand ; inline
: set-bit ( ? byte bit -- byte )
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
: bits>bytes 7 + -3 shift ; inline
: bits>cells 31 + -5 shift ; inline
: (set-bits) ( bit-array n -- )
@ -27,11 +25,13 @@ PRIVATE>
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
[ cell/bit set-bit ] 2keep
swap n>cell set-alien-unsigned-4 ;
>r >fixnum r>
[ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ;
: 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
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.
! 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-bitnot" "math.private" }
{ "fixnum-shift" "math.private" }
{ "fixnum-shift-fast" "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
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units ;
definitions assocs compiler.errors compiler.units
math.parser ;
IN: bootstrap.stage2
! Wrap everything in a catch which starts a listener so
@ -67,7 +68,8 @@ IN: bootstrap.stage2
] [ print-error 1 exit ] recover
] 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
[ 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"
"A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $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 "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $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
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:"
{ $subsection compile }
{ $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 -- )
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex ;
compiled-crossref get add-vertex* ;
: compiled-unxref ( word -- )
dup "compiled-uses" word-prop
compiled-crossref get remove-vertex ;
compiled-crossref get remove-vertex* ;
: compiled-usage ( word -- seq )
compiled-crossref get at keys ;
: sensitive? ( word -- ? )
dup "inline" word-prop
over "infer" word-prop
pick "specializer" word-prop
roll generic?
or or or ;
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
: compiled-usages ( words -- seq )
compiled-crossref get [
[
over dup set
over sensitive?
[ at namespace swap update ] [ 2drop ] if
] curry each
] H{ } make-assoc keys ;
[ [ dup ] H{ } map>assoc dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
] with each keys ;
: ripple-up ( word -- )
compiled-usage [ queue-compile ] each ;
compiled-usage [ drop queue-compile ] assoc-each ;
: save-effect ( word effect -- )
over "compiled-uses" word-prop [
@ -60,7 +49,6 @@ compiled-crossref global [ H{ } assoc-like ] change-at
] computing-dependencies ;
: compile-failed ( word error -- )
! dup inference-error? [ rethrow ] unless
f pick compiled get set-at
swap compiler-error ;

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

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

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

@ -441,3 +441,23 @@ cell 8 = [
] keep 2 fixnum+fast
] compile-call
] 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 [ interned? ] all? ] unit-test
[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test
DEFER: g-test-1
@ -174,6 +174,7 @@ DEFER: hints-test-2
[ 10 ] [ hints-test-2 ] unit-test
DEFER: inline-then-not-inline-test-1
DEFER: inline-then-not-inline-test-2
[ ] [ "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
[ ] [ "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 ;
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:"
{ $subsection throw-restarts }
{ $subsection rethrow-restarts }

2
core/continuations/continuations.factor
View File

@ -128,7 +128,7 @@ PRIVATE>
: cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry
>r (catch) r> ifcc r> call ; inline
recover r> call ; inline
: 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 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 ;
: CMPLI d-form 10 insn ;

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

@ -166,15 +166,43 @@ IN: cpu.ppc.intrinsics
}
} define-intrinsics
\ fixnum-shift [
"out" operand "x" operand "y" get neg SRAWI
! Mask off low bits
"out" operand dup %untag
] H{
{ +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
: %untag-fixnums ( seq -- )
[ dup %untag-fixnum ] unique-operands ;
\ fixnum-shift-fast {
{
[
"out" operand "x" operand "y" get
dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
! 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
#! PowerPC doesn't have a MOD instruction; so we compute
@ -222,9 +250,6 @@ IN: cpu.ppc.intrinsics
first2 define-fixnum-jump
] each
: %untag-fixnums ( seq -- )
[ dup %untag-fixnum ] unique-operands ;
: overflow-check ( insn1 insn2 -- )
[
>r 0 0 LI
@ -335,9 +360,10 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: 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" } } }
{ +output+ { "x" } }
{ +scratch+ { { float "z" } } }
{ +output+ { "z" } }
} define-intrinsic ;
{
@ -374,6 +400,23 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } }
} 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 [
"out" operand "in" operand tag-mask get ANDI
"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 ;
: 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 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 ;
: ds-reg ESI ;
: fixnum>slot@ arg0 1 SAR ;
: rex-length 0 ;
"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.allot cpu.architecture kernel kernel.private math
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
PREDICATE: x86-backend amd64-backend
@ -173,8 +173,8 @@ USE: cpu.x86.intrinsics
T{ x86-backend f 8 } compiler-backend set-global
! The ABI for passing structs by value is pretty messed up
"void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class
<< "void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
@ -183,7 +183,7 @@ T{ stack-params } "__stack_value" c-type set-c-type-reg-class
: split-struct ( pairs -- seq )
[
[ first2 8 mod zero? [ t , ] when , ] each
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] subset ;
: flatten-large-struct ( type -- )
@ -200,5 +200,3 @@ M: struct-type flatten-value-type ( type -- seq )
"void*" "double" ? c-type ,
] each
] if ;
12 profiler-prologue set-global

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

@ -8,10 +8,10 @@ IN: bootstrap.x86
: arg0 RDI ;
: arg1 RSI ;
: temp-reg RBX ;
: stack-reg RSP ;
: ds-reg R14 ;
: scan-reg RBX ;
: xt-reg RCX ;
: fixnum>slot@ ;
: rex-length 1 ;
"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
: 4, 4 n, ; inline
: 2, 2 n, ; inline
: cell, cell n, ; inline
: cell, bootstrap-cell n, ; inline
#! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? )
@ -232,14 +232,14 @@ UNION: operand register indirect ;
: rex-prefix ( reg r/m rex.w -- )
#! 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
dup BIN: 01000000 = [ drop ] [ , ] if ;
: 16-prefix ( reg r/m -- )
[ 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 ;
@ -290,7 +290,7 @@ UNION: operand register indirect ;
: 2-operand ( dst src op -- )
#! Sets the opcode's direction bit. It is set if the
#! destination is a direct register operand.
pick pick 16-prefix
2over 16-prefix
direction-bit
operand-size-bit
(2-operand) ;

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

@ -13,7 +13,8 @@ big-endian off
[
! Load word
temp-reg 0 [] MOV
temp-reg 0 MOV
temp-reg dup [] MOV
! Bump profiling counter
temp-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
@ -22,24 +23,27 @@ big-endian off
temp-reg compiled-header-size ADD
! Jump to XT
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
0 PUSH ! push XT
temp-reg PUSH ! push XT
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 [] 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
(JMP) drop ! go
] rc-relative rt-primitive 3 jit-primitive jit-define
arg0 JMP ! go
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
[
(JMP) drop
@ -57,17 +61,18 @@ big-endian off
arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
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
fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location
arg0 arg0 array-start [+] MOV ! load quotation
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

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.
USING: alien arrays cpu.x86.assembler cpu.x86.allot
cpu.x86.architecture cpu.architecture kernel kernel.private math
@ -240,18 +240,19 @@ IN: cpu.x86.intrinsics
}
} define-intrinsics
\ fixnum-shift [
"x" operand "y" get neg SAR
: %untag-fixnums ( seq -- )
[ %untag-fixnum ] unique-operands ;
\ fixnum-shift-fast [
"x" operand "y" get
dup 0 < [ neg SAR ] [ SHL ] if
! Mask off low bits
"x" operand %untag
] H{
{ +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
{ +input+ { { f "x" } { [ ] "y" } } }
{ +output+ { "x" } }
} define-intrinsic
: %untag-fixnums ( seq -- )
[ %untag-fixnum ] unique-operands ;
: overflow-check ( word -- )
"end" define-label
"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 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 )
all-words [

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

@ -16,3 +16,35 @@ H{
[ { 2 3 4 5 } ] [
2 [ "g" get at ] closure keys natural-sort
] 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 -- )
[ [ 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 -- )
[ [ 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
: (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: wrapper apply-object wrapped dup depends-on apply-literal ;
M: wrapper apply-object
wrapped dup +called+ depends-on apply-literal ;
: terminate ( -- )
terminated? on #terminate node, ;
@ -372,6 +373,7 @@ TUPLE: effect-error word effect ;
: custom-infer ( word -- )
#! Customized inference behavior
dup +inlined+ depends-on
"infer" word-prop call ;
: cached-infer ( word -- )
@ -449,10 +451,12 @@ M: #call-label collect-recursion*
] if ;
M: word apply-object
dup depends-on [
[
dup +inlined+ depends-on
dup inline-recursive-label
[ declared-infer ] [ inline-word ] if
] [
dup +called+ depends-on
dup recursive-label
[ declared-infer ] [ apply-word ] if
] if-inline ;

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

@ -50,7 +50,7 @@ M: object xyz ;
] unit-test
: (fx-repeat) ( i n quot -- )
pick pick fixnum>= [
2over fixnum>= [
3drop
] [
[ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
@ -66,7 +66,7 @@ M: object xyz ;
] unit-test
: (i-repeat) ( i n quot -- )
pick pick dup xyz drop >= [
2over dup xyz drop >= [
3drop
] [
[ 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 ;
: (annotate-entry-test-2) ( from to quot -- )
pick pick >= [
2over >= [
3drop
] [
[ 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 ] [
[ 3 + = ] \ equal? inlined?
] 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 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= 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
SYMBOL: dependencies
: depends-on ( word -- )
dup dependencies get dup [ set-at ] [ 3drop ] if ;
SYMBOL: +inlined+
SYMBOL: +called+
: depends-on ( word how -- )
swap dependencies get dup [
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
] [ 3drop ] if ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep keys ;
H{ } clone [ dependencies rot with-variable ] keep ;
inline
! 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
\ construct-boa [
dup tuple-size [ <tuple-boa> ] 2curry
] 1 define-transform
: [construct] ( word quot -- newquot )
>r dup +inlined+ depends-on dup tuple-size r> 2curry ;
\ 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 )
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 ;
@ -52,10 +56,6 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: directory ( path -- seq )
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 ? )
[ length 2 [-] ] keep [ path-separator? ] find-last* ;

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

@ -19,6 +19,7 @@ $nl
{ $subsection 3dup }
{ $subsection dupd }
{ $subsection over }
{ $subsection 2over }
{ $subsection pick }
{ $subsection tuck }
"Permuting stack elements:"
@ -160,6 +161,7 @@ HELP: nip ( x y -- y ) $shuffle ;
HELP: 2nip ( x y z -- z ) $shuffle ;
HELP: tuck ( x y -- y x y ) $shuffle ;
HELP: over ( x y -- x y x ) $shuffle ;
HELP: 2over $shuffle ;
HELP: pick ( x y z -- x y z x ) $shuffle ;
HELP: swap ( x y -- y x ) $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
: 2over ( x y z -- x y z x y ) pick pick ; inline
: clear ( -- ) { } set-datastack ;
! Combinators
@ -55,7 +57,7 @@ DEFER: if
: 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 )
>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." }
{ $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 )
{ $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." }

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 bit? 2^ bitand 0 > ;
M: fixnum bit? neg shift 1 bitand 0 > ;
: (fixnum-log2) ( accum n -- accum )
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> ;
: (interval-op) ( p1 p2 quot -- p3 )
pick pick >r >r
>r >r first r> first r> call
r> second r> second and 2array ; inline
2over >r >r
>r [ first ] 2apply r> call
r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 )
pick interval-from pick interval-from pick (interval-op) >r
@ -85,7 +85,7 @@ C: <interval> interval
: interval-integer-op ( i1 i2 quot -- i3 )
>r 2dup
[ interval>points [ first integer? ] 2apply and ] 2apply and
[ interval>points [ first integer? ] both? ] both?
r> [ 2drop f ] if ; inline
: 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
: 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 )
#! 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 ;
IN: memory
ARTICLE: "memory" "Object 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 }
"The current image can be saved:"
ARTICLE: "images" "Images"
"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
{ $subsection save }
{ $subsection save-image }
{ $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" } ;
ABOUT: "memory"
ABOUT: "image"
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."

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.
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend io kernel math namespaces
sequences vectors words quotations hashtables combinators
classes generic.math continuations optimizer.def-use
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.pattern-match generic.standard ;
IN: optimizer.backend
@ -173,8 +173,8 @@ M: node remember-method*
2drop ;
: remember-method ( method-spec node -- )
swap dup
[ [ swap remember-method* ] curry each-node ] [ 2drop ] if ;
swap dup second +inlined+ depends-on
[ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise
@ -184,7 +184,10 @@ M: node remember-method*
[ swap infer-classes/node ] 2keep
[ 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 )
node-in-d clone \ #shuffle in-node ;
@ -225,7 +228,7 @@ M: #dispatch optimize-node*
#! t indicates failure
{
{ [ dup t eq? ] [ 3drop t ] }
{ [ pick pick swap node-history member? ] [ 3drop t ] }
{ [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] }
} cond ;
@ -358,7 +361,8 @@ M: #dispatch optimize-node*
] if ;
: 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*
{

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.
IN: optimizer.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
combinators splitting layouts math.parser classes
generic.math optimizer.pattern-match optimizer.backend
optimizer.def-use generic.standard ;
optimizer.def-use generic.standard system ;
{ + bignum+ float+ fixnum+fast } {
{ { number 0 } [ drop ] }
@ -82,7 +82,7 @@ optimizer.def-use generic.standard ;
{ { @ @ } [ 2drop 0 ] }
} define-identities
{ shift fixnum-shift bignum-shift } {
{ shift fixnum-shift fixnum-shift-fast bignum-shift } {
{ { 0 number } [ drop ] }
{ { number 0 } [ drop ] }
} define-identities
@ -196,7 +196,7 @@ optimizer.def-use generic.standard ;
] 2curry "output-classes" set-word-prop
] each
{ fixnum-shift shift } [
{ fixnum-shift fixnum-shift-fast shift } [
[
dup
node-in-d second value-interval*
@ -439,3 +439,28 @@ most-negative-fixnum most-positive-fixnum [a,b]
[ splice-quot ] curry ,
] { } make 1array define-optimizers
] 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." ;
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."
$nl
"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
[ ] [
"IN: temporary GENERIC: killer?"
"IN: temporary GENERIC: killer? ( a -- b )"
<string-reader> "removing-the-predicate" parse-stream drop
] unit-test

5
core/parser/parser.factor
View File

@ -437,7 +437,7 @@ SYMBOL: bootstrap-syntax
smudged-usage forget-all
over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
: finish-parsing ( contents quot -- )
: finish-parsing ( lines quot -- )
file get
[ record-form ] keep
[ record-modified ] keep
@ -447,8 +447,7 @@ SYMBOL: bootstrap-syntax
: parse-stream ( stream name -- quot )
[
[
contents
dup string-lines parse-fresh
lines dup parse-fresh
tuck finish-parsing
forget-smudged
] 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 )
pick 0 < [ "start < 0" 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 )
dup slice? [ collapse-slice ] when
@ -445,7 +445,7 @@ PRIVATE>
[ = not ] with subset ;
: cache-nth ( i seq quot -- elt )
pick pick ?nth dup [
2over ?nth dup [
>r 3drop r>
] [
drop swap >r over >r call dup r> r> set-nth
@ -465,7 +465,7 @@ M: sequence <=>
[ mismatch not ] [ 2drop f ] if ; inline
: move ( to from seq -- )
pick pick number=
2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
: (delete) ( elt store scan seq -- elt store scan seq )
@ -499,15 +499,15 @@ M: sequence <=>
: pop* ( seq -- ) dup length 1- swap set-length ;
: move-backward ( shift from to seq -- )
pick pick number= [
2over number= [
2drop 2drop
] [
[ >r pick pick + pick r> move >r 1+ r> ] keep
[ >r 2over + pick r> move >r 1+ r> ] keep
move-backward
] if ;
: move-forward ( shift from to seq -- )
pick pick number= [
2over number= [
2drop 2drop
] [
[ >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 )
>r object bootstrap-word over r> f f <slot-spec>
pick pick simple-reader-word over set-slot-spec-reader
rot rot simple-writer-word over set-slot-spec-writer ;
2over simple-reader-word over set-slot-spec-reader
-rot simple-writer-word over set-slot-spec-writer ;
: simple-slots ( class slots base -- specs )
over length [ + ] with map

4
core/tuples/tuples.factor
View File

@ -15,7 +15,7 @@ M: tuple class class-of-tuple ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
over array-capacity over array-capacity dup -rot number= [
over array-capacity over array-capacity tuck number= [
-rot
[ >r over r> array-nth >r array-nth r> = ] 2curry
all-integers?
@ -59,7 +59,7 @@ M: tuple class class-of-tuple ;
] unless
] when 2drop ;
GENERIC: tuple-size ( class -- size ) foldable
GENERIC: tuple-size ( class -- size )
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 >= [
3drop
] [
f pick pick set-nth-unsafe >r over + r> clear-flags
f 2over set-nth-unsafe >r over + r> clear-flags
] if ; inline
: (nsieve-bits) ( count i seq -- count )
2dup length <= [
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
rot 1+ -rot ! increment count

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

@ -10,7 +10,7 @@ arrays namespaces io ;
] if ; inline
: (nsieve) ( count i seq -- count )
2dup length <= [
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
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
math.vectors math.functions math.parser namespaces sequences
strings tuples system debugger combinators vocabs.loader
calendar.backend structs alien.c-types ;
calendar.backend structs alien.c-types math.vectors ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
@ -186,7 +186,8 @@ M: number +second ( timestamp n -- timestamp )
#! data
tuple-slots
{ 1 12 365.2425 8765.82 525949.2 31556952.0 }
[ / ] 2map sum ;
v/ sum ;
: dt>months ( dt -- x ) dt>years 12 * ;
: dt>days ( dt -- x ) dt>years 365.2425 * ;
: dt>hours ( dt -- x ) dt>years 8765.82 * ;
@ -235,7 +236,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
unix-1970 millis 1000 /f seconds +dt ;
: 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 ;
: ago ( dt -- timestamp ) before from-now ;

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

@ -7,7 +7,7 @@ IN: combinators.cleave
! 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 )
>r pick >r bi r> r> call ; inline
@ -23,7 +23,7 @@ IN: combinators.cleave
! 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 )
>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
: 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 -- )
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
@ -168,4 +190,4 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
] { } assoc>map concat compose ;
: 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
crypto.common math.private ;
math.private ;
IN: crypto.common
HELP: >32-bit
{ $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.
USING: arrays assocs calendar debugger furnace.sessions furnace.validator
hashtables heaps html.elements http http.server.responders
http.server.templating io.files kernel math namespaces
quotations sequences splitting words strings vectors
webapps.callback ;
USING: continuations io prettyprint ;
USING: arrays assocs calendar debugger furnace.sessions
furnace.validator hashtables heaps html.elements http
http.server.responders http.server.templating io.files kernel
math namespaces quotations sequences splitting words strings
vectors webapps.callback continuations tuples classes vocabs
html io ;
IN: furnace
: code>quotation ( word/quot -- quot )
@ -174,7 +174,6 @@ PREDICATE: word action "action" word-prop ;
[ service-post ] "post" set
] make-responder ;
USING: classes html tuples vocabs ;
: explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ;

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

@ -1,5 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces inference ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
"The following is a simple snippet of Factor code:"
@ -176,16 +177,7 @@ $nl
"parser"
} ;
ARTICLE: "cookbook-sources" "Source file 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"
ARTICLE: "cookbook-io" "Input and output cookbook"
"Ask the user for their age, and print it back:"
{ $code
": ask-age ( -- ) \"How old are you?\" print ;"
@ -205,6 +197,12 @@ ARTICLE: "cookbook-io" "I/O cookbook"
{ $code
"\"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:"
{ $code
"\"myhost\" 1033 <inet> <client>"
@ -216,6 +214,58 @@ ARTICLE: "cookbook-io" "I/O cookbook"
"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"
"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
@ -251,28 +301,17 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
} ;
ARTICLE: "cookbook" "Factor cookbook"
{ $list
{ "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" } "." }
}
"The Factor cookbook is a high-level overview of the most important concepts required to program in Factor."
{ $subsection "cookbook-syntax" }
{ $subsection "cookbook-colon-defs" }
{ $subsection "cookbook-combinators" }
{ $subsection "cookbook-variables" }
{ $subsection "cookbook-vocabs" }
{ $subsection "cookbook-sources" }
{ $subsection "cookbook-io" }
{ $subsection "cookbook-application" }
{ $subsection "cookbook-scripts" }
{ $subsection "cookbook-compiler" }
{ $subsection "cookbook-philosophy" }
{ $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 "vocabs.loader" } ;
USE: help.cookbook
USING: help.cookbook help.tutorial ;
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" }
{ $subsection "cookbook" }
{ $subsection "first-program" }
{ $subsection "vocab-index" }
{ $subsection "changes" }
{ $subsection "cli" }
{ $heading "Language reference" }
{ $subsection "conventions" }
{ $subsection "syntax" }
@ -202,6 +203,8 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "os" }
{ $subsection "alien" }
{ $heading "Environment reference" }
{ $subsection "cli" }
{ $subsection "images" }
{ $subsection "prettyprint" }
{ $subsection "tools" }
{ $subsection "help" }

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

@ -44,7 +44,7 @@ M: f print-element drop ;
: with-default-style ( quot -- )
default-style get [
last-element off
H{ } swap with-nesting
default-style get swap with-nesting
] with-style ; inline
: 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.
{ $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.
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.writer ;
sequences strings words xml.writer compiler.units effects ;
IN: html.elements
! These words are used to provide a means of writing
! 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
! level involves a similar syntax to HTML:
!
!
! <p> "someoutput" write </p>
!
! <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
! value of that attribute.
! The finishing word will print out the operning tag including
! attributes.
! attributes.
! Any writes after this will appear after the opening tag.
!
! Values for attributes can be used directly without any stack
@ -57,54 +57,59 @@ SYMBOL: html
: print-html ( str -- )
write-html "\n" write-html ;
: html-word ( name def -- )
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
>r elements-vocab create r> define-compound ;
>r >r elements-vocab create r> r> define-declared ;
: <foo> "<" swap ">" 3append ;
: empty-effect T{ effect f 0 0 } ;
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
dup <foo> swap [ <foo> write-html ] curry html-word ;
dup <foo> swap [ <foo> write-html ] curry
empty-effect html-word ;
: <foo "<" swap append ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
<foo dup [ write-html ] curry html-word ;
<foo dup [ write-html ] curry
empty-effect html-word ;
: foo> ">" append ;
: def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned
#! word.
foo> [ ">" write-html ] html-word ;
foo> [ ">" write-html ] empty-effect html-word ;
: </foo> [ "</" % % ">" % ] "" make ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
</foo> dup [ write-html ] curry html-word ;
#! word.
</foo> dup [ write-html ] curry empty-effect html-word ;
: <foo/> [ "<" % % "/>" % ] "" make ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
dup <foo/> swap [ <foo/> write-html ] curry html-word ;
dup <foo/> swap [ <foo/> write-html ] curry
empty-effect html-word ;
: foo/> "/>" append ;
: def-for-html-word-foo/> ( name -- )
#! Return the name and code for the foo/> patterned
#! word.
foo/> [ "/>" write-html ] html-word ;
#! 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
#! that closable HTML tag.
dup def-for-html-word-<foo>
@ -112,7 +117,7 @@ SYMBOL: html
dup 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
#! that open HTML tag.
dup def-for-html-word-<foo/>
@ -123,34 +128,38 @@ SYMBOL: html
" " write-html
write-html
"='" write-html
escape-quoted-string write
escape-quoted-string write-html
"'" write-html ;
: attribute-effect T{ effect f { "string" } 0 } ;
: define-attribute-word ( name -- )
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"
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style"
] [ define-closed-html-word ] each
! Define some closed HTML tags
[
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"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
[
"input"
"br"
"link"
"img"
] [ define-open-html-word ] each
! Define some open HTML tags
[
"input"
"br"
"link"
"img"
] [ define-open-html-word ] each
! Define some attributes
[
"method" "action" "type" "value" "name"
"size" "href" "class" "border" "rows" "cols"
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
] [ define-attribute-word ] each
! Define some attributes
[
"method" "action" "type" "value" "name"
"size" "href" "class" "border" "rows" "cols"
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
] [ 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
] 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 } } }
[ "cdr" write ] with-nesting
] make-html-string
] 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 ;
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 construct-delegate ;
@ -94,7 +106,7 @@ TUPLE: html-sub-stream style stream ;
TUPLE: html-span-stream ;
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: 1px solid #" % hex-color, "; " % ;
@ -109,7 +121,7 @@ M: html-span-stream stream-close
page-color [ bg-css, ] apply-style
border-color [ border-css, ] apply-style
border-width [ padding-css, ] apply-style
wrap-margin [ pre-css, ] apply-style
wrap-margin over at pre-css,
] make-css ;
: div-tag ( style quot -- )
@ -127,7 +139,7 @@ M: html-span-stream stream-close
TUPLE: html-block-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,
"padding: " % first2 max 2 /i # "px; " % ;
@ -151,7 +163,7 @@ M: html-stream stream-write1 ( char stream -- )
>r 1string r> stream-write ;
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' )
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> ;
M: html-stream stream-write-table ( grid style stream -- )
[
a-div [
<table dup table-attrs table> swap [
<tr> [
<td "top" =valign swap table-style =style td>
@ -178,7 +190,7 @@ M: html-stream make-cell-stream ( style stream -- stream' )
(html-sub-stream) ;
M: html-stream stream-nl ( stream -- )
[ <br/> ] with-stream* ;
dup test-last-div? [ drop ] [ [ <br/> ] with-stream* ] if ;
! Utilities
: 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 ;
: host ( -- string )
#! The host the current responder was called from.
"Host" header-param ":" split1 drop ;
: add-responder ( responder -- )
#! Add a responder object to the list.
"responder" over at responders get set-at ;

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

@ -28,10 +28,6 @@ IN: http.server
{ "HEAD" "head" }
} 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 )
request-method dup "method" set swap
prepare-url prepare-header host ;

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

@ -77,7 +77,6 @@ DEFER: <% delimiter
[
[
"quiet" on
file-vocabs
parser-notes off
templating-vocab use+
dup source-file file set ! so that reload works properly
@ -85,7 +84,7 @@ DEFER: <% delimiter
?resource-path file-contents
[ eval-template ] [ html-error. drop ] recover
] keep
] with-scope
] with-file-vocabs
] assert-depth drop ;
: 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 ;
: math-exp? ( n n word -- ? )
{ + - * / ^ } member? -rot [ number? ] 2apply and and ;
{ + - * / ^ } member? -rot [ number? ] both? and ;
: (fold-constants) ( quot -- )
dup length 3 < [ % ] [

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

@ -113,7 +113,7 @@ M: input-port stream-read
] if ;
: 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 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 )
: lfrom ( n -- list )
[ 1 + ] lfrom-by ;
[ 1+ ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car )
lazy-from-by-n ;

43
extra/lint/lint.factor
View File

@ -83,7 +83,8 @@ def-hash get-global [
! Remove n m shift defs
[
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
] assoc-subset
@ -120,7 +121,7 @@ M: word lint ( word -- seq )
: word-path. ( word -- )
[ word-vocabulary ":" ] keep unparse 3append write nl ;
: lint. ( array -- )
: (lint.) ( pair -- )
first2 >r word-path. r> [
bl bl bl bl
dup .
@ -128,32 +129,46 @@ M: word lint ( word -- seq )
def-hash get at [ bl bl bl bl word-path. ] each
nl
] each nl nl ;
: lint. ( alist -- )
[ (lint.) ] each ;
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) ] subset ] assoc-map ;
: filter-symbols ( alist -- alist )
[
first2 [
def-hash get-global at* [
dupd remove empty? not
] [
drop f
] if
] subset 2array
] map ;
nip first dup def-hash get at
[ first ] 2apply literalize = not
] assoc-subset ;
M: sequence run-lint ( seq -- seq )
[
global [ dup . flush ] bind
dup lint 2array
] map
dup lint
] { } map>assoc
trim-self
[ second empty? not ] subset ;
[ second empty? not ] subset
filter-symbols ;
M: word run-lint ( word -- seq )
1array run-lint ;
: 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
] 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
: ^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 )
dup even? [ 1+ ] [ 2 + ] if ;
: random-bits ( m -- n )
#! Top bit is always set
2^ [ random ] keep -1 shift bitor ; foldable
: random-bits ( m -- n ) 2^ random ; foldable
: (factor-2s) ( s n -- s n )
dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
: factor-2s ( n -- r s )
: factor-2s ( zero n -- r s )
#! factor an even number into 2 ^ s * m
dup even? over 0 > and [
"input must be positive and even" throw
] unless 0 swap (factor-2s) ;
dup even? [ -1 shift >r 1+ r> factor-2s ] when ;
:: (miller-rabin) | n prime?! |
n dup 1 = over even? or [
drop f
] [
1- factor-2s s set r set
trials get [
n 1- [1,b] random a set
a get s get n ^mod 1 = [
0 count set
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 +
0 n 1- factor-2s s set r set
trials get [
n 1- [1,b] random a set
a get s get n ^mod 1 = [
0 count set
r get [
2^ s get * a get swap n ^mod n - -1 = [
count [ 1+ ] change
r get +
] when
] unless
drop
] each
prime?
] if ;
] each
count get zero? [
f prime?!
trials get +
] when
] unless
drop
] each prime? ;
TUPLE: miller-rabin-bounds ;
@ -62,6 +50,7 @@ TUPLE: miller-rabin-bounds ;
over {
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
{ [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] }
} cond ;
@ -87,4 +76,3 @@ TUPLE: miller-rabin-bounds ;
#! generate two primes
over 5 < [ "not enough primes below 5 bits" throw ] when
[ [ 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
: do-enabled ( what quot -- )
over glEnable swap slip glDisable ; inline
over glEnable dip glDisable ; inline
: do-matrix ( mode quot -- )
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
math math.parser namespaces parser prettyprint
quotations sequences strings threads vectors
words macros ;
words macros math.functions ;
IN: pack
SYMBOL: big-endian
@ -10,9 +10,6 @@ SYMBOL: big-endian
: big-endian? ( -- ? )
1 <int> *char zero? ;
: clear-bit ( m n -- o )
2^ bitnot bitand ;
: >endian ( obj n -- str )
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 ;
: 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 )
1 read first

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

@ -1,184 +1,184 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-optional elements ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action word ;
TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal
C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence
C: <ebnf-repeat0> ebnf-repeat0
C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf> ebnf
SYMBOL: parsers
SYMBOL: non-terminals
SYMBOL: last-parser
: reset-parser-generation ( -- )
V{ } clone parsers set
H{ } clone non-terminals set
f last-parser set ;
: store-parser ( parser -- number )
parsers get [ push ] keep length 1- ;
: get-parser ( index -- parser )
parsers get nth ;
: non-terminal-index ( name -- number )
dup non-terminals get at [
nip
] [
f store-parser [ swap non-terminals get set-at ] keep
] if* ;
GENERIC: (generate-parser) ( ast -- id )
: generate-parser ( ast -- id )
(generate-parser) dup last-parser set ;
M: ebnf-terminal (generate-parser) ( ast -- id )
ebnf-terminal-symbol token sp store-parser ;
M: ebnf-non-terminal (generate-parser) ( ast -- id )
[
ebnf-non-terminal-symbol dup non-terminal-index ,
parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
] [ ] make delay sp store-parser ;
M: ebnf-choice (generate-parser) ( ast -- id )
ebnf-choice-options [
generate-parser get-parser
] map choice store-parser ;
M: ebnf-sequence (generate-parser) ( ast -- id )
ebnf-sequence-elements [
generate-parser get-parser
] map seq store-parser ;
M: ebnf-repeat0 (generate-parser) ( ast -- id )
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
M: ebnf-optional (generate-parser) ( ast -- id )
ebnf-optional-elements generate-parser get-parser optional store-parser ;
M: ebnf-rule (generate-parser) ( ast -- id )
dup ebnf-rule-symbol non-terminal-index swap
ebnf-rule-elements generate-parser get-parser ! nt-id body
swap [ parsers get set-nth ] keep ;
M: ebnf-action (generate-parser) ( ast -- id )
ebnf-action-word search 1quotation
last-parser get get-parser swap action store-parser ;
M: vector (generate-parser) ( ast -- id )
[ generate-parser ] map peek ;
M: f (generate-parser) ( ast -- id )
drop last-parser get ;
M: ebnf (generate-parser) ( ast -- id )
ebnf-rules [
generate-parser
] map peek ;
DEFER: 'rhs'
: 'non-terminal' ( -- parser )
CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
"'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
: 'element' ( -- parser )
'non-terminal' 'terminal' 2array choice ;
DEFER: 'choice'
: 'group' ( -- parser )
"(" token sp hide
[ 'choice' sp ] delay
")" token sp hide
3array seq [ first ] action ;
: 'repeat0' ( -- parser )
"{" token sp hide
[ 'choice' sp ] delay
"}" token sp hide
3array seq [ first <ebnf-repeat0> ] action ;
: 'optional' ( -- parser )
"[" token sp hide
[ 'choice' sp ] delay
"]" token sp hide
3array seq [ first <ebnf-optional> ] action ;
: 'sequence' ( -- parser )
[
'element' sp ,
'group' sp ,
'repeat0' sp ,
'optional' sp ,
] { } make choice
repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
] action ;
: 'choice' ( -- parser )
'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ;
: 'action' ( -- parser )
"=>" token hide
[ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
2array seq [ first <ebnf-action> ] action ;
: 'rhs' ( -- parser )
'choice' 'action' sp optional 2array seq ;
: 'rule' ( -- parser )
'non-terminal' [ ebnf-non-terminal-symbol ] action
"=" token sp hide
'rhs'
3array seq [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser )
'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
: ebnf>quot ( string -- quot )
'ebnf' parse [
parse-result-ast [
reset-parser-generation
generate-parser drop
[
non-terminals get
[
get-parser [
swap , \ in , \ get , \ create ,
1quotation , \ define-compound ,
] [
drop
] if*
] assoc-each
] [ ] make
] with-scope
] [
f
] if* ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-optional elements ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action word ;
TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal
C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence
C: <ebnf-repeat0> ebnf-repeat0
C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf> ebnf
SYMBOL: parsers
SYMBOL: non-terminals
SYMBOL: last-parser
: reset-parser-generation ( -- )
V{ } clone parsers set
H{ } clone non-terminals set
f last-parser set ;
: store-parser ( parser -- number )
parsers get [ push ] keep length 1- ;
: get-parser ( index -- parser )
parsers get nth ;
: non-terminal-index ( name -- number )
dup non-terminals get at [
nip
] [
f store-parser [ swap non-terminals get set-at ] keep
] if* ;
GENERIC: (generate-parser) ( ast -- id )
: generate-parser ( ast -- id )
(generate-parser) dup last-parser set ;
M: ebnf-terminal (generate-parser) ( ast -- id )
ebnf-terminal-symbol token sp store-parser ;
M: ebnf-non-terminal (generate-parser) ( ast -- id )
[
ebnf-non-terminal-symbol dup non-terminal-index ,
parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
] [ ] make delay sp store-parser ;
M: ebnf-choice (generate-parser) ( ast -- id )
ebnf-choice-options [
generate-parser get-parser
] map choice store-parser ;
M: ebnf-sequence (generate-parser) ( ast -- id )
ebnf-sequence-elements [
generate-parser get-parser
] map seq store-parser ;
M: ebnf-repeat0 (generate-parser) ( ast -- id )
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
M: ebnf-optional (generate-parser) ( ast -- id )
ebnf-optional-elements generate-parser get-parser optional store-parser ;
M: ebnf-rule (generate-parser) ( ast -- id )
dup ebnf-rule-symbol non-terminal-index swap
ebnf-rule-elements generate-parser get-parser ! nt-id body
swap [ parsers get set-nth ] keep ;
M: ebnf-action (generate-parser) ( ast -- id )
ebnf-action-word search 1quotation
last-parser get get-parser swap action store-parser ;
M: vector (generate-parser) ( ast -- id )
[ generate-parser ] map peek ;
M: f (generate-parser) ( ast -- id )
drop last-parser get ;
M: ebnf (generate-parser) ( ast -- id )
ebnf-rules [
generate-parser
] map peek ;
DEFER: 'rhs'
: 'non-terminal' ( -- parser )
CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
"'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
: 'element' ( -- parser )
'non-terminal' 'terminal' 2array choice ;
DEFER: 'choice'
: 'group' ( -- parser )
"(" token sp hide
[ 'choice' sp ] delay
")" token sp hide
3array seq [ first ] action ;
: 'repeat0' ( -- parser )
"{" token sp hide
[ 'choice' sp ] delay
"}" token sp hide
3array seq [ first <ebnf-repeat0> ] action ;
: 'optional' ( -- parser )
"[" token sp hide
[ 'choice' sp ] delay
"]" token sp hide
3array seq [ first <ebnf-optional> ] action ;
: 'sequence' ( -- parser )
[
'element' sp ,
'group' sp ,
'repeat0' sp ,
'optional' sp ,
] { } make choice
repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
] action ;
: 'choice' ( -- parser )
'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ;
: 'action' ( -- parser )
"=>" token hide
[ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
2array seq [ first <ebnf-action> ] action ;
: 'rhs' ( -- parser )
'choice' 'action' sp optional 2array seq ;
: 'rule' ( -- parser )
'non-terminal' [ ebnf-non-terminal-symbol ] action
"=" token sp hide
'rhs'
3array seq [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser )
'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
: ebnf>quot ( string -- quot )
'ebnf' parse [
parse-result-ast [
reset-parser-generation
generate-parser drop
[
non-terminals get
[
get-parser [
swap , \ in , \ get , \ create ,
1quotation , \ define ,
] [
drop
] if*
] assoc-each
] [ ] make
] with-scope
] [
f
] if* ;
: <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.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax peg ;
HELP: parse
{ $values
{ "input" "a string" }
{ "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 "
"the parse was successful, otherwise it is f." } ;
HELP: token
{ $values
{ "string" "a string" }
{ "parser" "a parser" }
}
{ $description
"Returns a parser that matches the given string." } ;
HELP: satisfy
{ $values
{ "quot" "a quotation" }
{ "parser" "a parser" }
}
{ $description
"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
{ "min" "a character" }
{ "max" "a character" }
{ "parser" "a parser" }
}
{ $description
"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
{ "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 "
"all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
"the individual parsers." } ;
HELP: choice
{ $values
{ "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. "
"The resulting AST is that produced by the successful parser." } ;
HELP: repeat0
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
"an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
"parsed." } ;
HELP: repeat1
{ $values
{ "parser" "a parser" }
}
{ $description
"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
{ "parser" "a parser" }
}
{ $description
"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
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure-not } " word." }
{ $examples { $code "\"0\" token ensure octal-parser" } } ;
HELP: ensure-not
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure } " word." }
{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
HELP: action
{ $values
{ "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 "
"from that parse. The result of the quotation is then used as the final AST. This can be used "
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
"the default AST." }
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
HELP: sp
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that calls the original parser 'p1' after stripping any whitespace "
" from the left of the input string." } ;
HELP: hide
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the original parser succeeds, but does not "
"put any result in the AST. Useful for ignoring 'syntax' in the AST." }
{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;
HELP: delay
{ $values
{ "parser" "a parser" }
}
{ $description
"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 "
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: peg
HELP: parse
{ $values
{ "input" "a string" }
{ "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 "
"the parse was successful, otherwise it is f." } ;
HELP: token
{ $values
{ "string" "a string" }
{ "parser" "a parser" }
}
{ $description
"Returns a parser that matches the given string." } ;
HELP: satisfy
{ $values
{ "quot" "a quotation" }
{ "parser" "a parser" }
}
{ $description
"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
{ "min" "a character" }
{ "max" "a character" }
{ "parser" "a parser" }
}
{ $description
"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
{ "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 "
"all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
"the individual parsers." } ;
HELP: choice
{ $values
{ "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. "
"The resulting AST is that produced by the successful parser." } ;
HELP: repeat0
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
"an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
"parsed." } ;
HELP: repeat1
{ $values
{ "parser" "a parser" }
}
{ $description
"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
{ "parser" "a parser" }
}
{ $description
"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
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure-not } " word." }
{ $examples { $code "\"0\" token ensure octal-parser" } } ;
HELP: ensure-not
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure } " word." }
{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
HELP: action
{ $values
{ "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 "
"from that parse. The result of the quotation is then used as the final AST. This can be used "
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
"the default AST." }
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
HELP: sp
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that calls the original parser 'p1' after stripping any whitespace "
" from the left of the input string." } ;
HELP: hide
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the original parser succeeds, but does not "
"put any result in the AST. Useful for ignoring 'syntax' in the AST." }
{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;
HELP: delay
{ $values
{ "parser" "a parser" }
}
{ $description
"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." } ;

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

@ -22,7 +22,7 @@ TUPLE: random-tester-error ;
datastack clone after set
clear
before get [ ] each
quot get [ compile-1 ] [ errored on ] recover ;
quot get [ compile-call ] [ errored on ] recover ;
: do-test ! ( data... quot -- )
.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
: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ;
: probabilities ( weights -- probabilities ) dup sum v/n ;
: layers ( probabilities -- layers )
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 -- )
>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-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
: 2over ( a b c -- a b c a b ) pick pick ; inline
: nipd ( a b c -- b c ) rot drop ; 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 ;
: strip-tease ( data -- seq )
dup third length 1 - [
dup third length 1- [
2 + (strip-tease)
] 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 )
148 cut-slice 8 tail-slice
[ 0 [ + ] reduce ] 2apply + 256 + ;
[ sum ] 2apply + 256 + ;
TUPLE: checksum-error ;
TUPLE: malformed-block-error ;
@ -164,7 +164,7 @@ TUPLE: unimplemented-typeflag header ;
! Long file name
: typeflag-L ( header -- )
<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
filename get tar-path+ make-directories ;
@ -196,7 +196,7 @@ TUPLE: unimplemented-typeflag header ;
! global [ dup tar-header-name [ print flush ] when* ] bind
dup tar-header-typeflag
{
{ CHAR: \0 [ typeflag-0 ] }
{ 0 [ typeflag-0 ] }
{ CHAR: 0 [ typeflag-0 ] }
{ CHAR: 1 [ typeflag-1 ] }
{ 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
ARTICLE: "tools.memory" "Object memory tools"
@ -6,7 +6,18 @@ ARTICLE: "tools.memory" "Object memory tools"
{ $subsection room. }
{ $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"

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

@ -1,12 +1,14 @@
USING: help.markup help.syntax kernel ;
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."
$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."
$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-fails }
"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 ;
: run-tests ( seq -- )
[ dup run-test ] { } map>assoc
[ second empty? not ] subset
dup empty? [ drop ] [
dup empty? [ drop "==== NOTHING TO TEST" print ] [
[ dup run-test ] { } map>assoc
[ second empty? not ] subset
nl
"==== FAILING TESTS:" print
[ nl failures. ] assoc-each
dup empty? [
drop
"==== ALL TESTS PASSED" print
] [
"==== FAILING TESTS:" print
[ nl failures. ] assoc-each
] if
] if ;
: 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
{ $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 -- )
[ dup pane-nl ]
[ pick pick pane-current stream-format ]
[ 2over pane-current stream-format ]
interleave 2drop ;
GENERIC: write-gadget ( gadget stream -- )
@ -327,7 +327,7 @@ M: paragraph stream-format
] [
rot " " split
[ 2dup gadget-bl ]
[ pick pick gadget-format ] interleave
[ 2over gadget-format ] interleave
2drop
] if ;

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

@ -13,3 +13,5 @@ $nl
{ $subsection deploy-tool }
"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu."
{ $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 ;
: com-help ( -- )
"ui-deploy" help-window ;
"ui.tools.deploy" help-window ;
\ com-help H{
{ +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.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators
arrays io.launcher io http.server http.server.responders
webapps.file sequences strings ;
arrays io.launcher io http.server.responders webapps.file
sequences strings ;
IN: webapps.cgi
SYMBOL: cgi-root

6
vm/math.c
View File

@ -166,6 +166,12 @@ DEFINE_PRIMITIVE(fixnum_shift)
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)
{
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_xor);
DECLARE_PRIMITIVE(fixnum_shift);
DECLARE_PRIMITIVE(fixnum_shift_fast);
DECLARE_PRIMITIVE(fixnum_less);
DECLARE_PRIMITIVE(fixnum_lesseq);
DECLARE_PRIMITIVE(fixnum_greater);

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