diff --git a/README.txt b/README.txt index c5bae96b9c..f92bfe25c7 100644 --- a/README.txt +++ b/README.txt @@ -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 diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 3dc1fbfb86..1c8163e2fa 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -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 ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 91a2e6efaa..b665300bee 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -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" -"void*" define-primitive-type +[ + [ alien-cell ] + [ set-alien-cell ] + bootstrap-cell + "box_alien" + "alien_offset" + "void*" define-primitive-type -[ alien-signed-8 ] -[ set-alien-signed-8 ] -8 -"box_signed_8" -"to_signed_8" -"longlong" define-primitive-type + [ alien-signed-8 ] + [ set-alien-signed-8 ] + 8 + "box_signed_8" + "to_signed_8" + "longlong" define-primitive-type -[ alien-unsigned-8 ] -[ set-alien-unsigned-8 ] -8 -"box_unsigned_8" -"to_unsigned_8" -"ulonglong" define-primitive-type + [ alien-unsigned-8 ] + [ set-alien-unsigned-8 ] + 8 + "box_unsigned_8" + "to_unsigned_8" + "ulonglong" define-primitive-type -[ alien-signed-cell ] -[ set-alien-signed-cell ] -bootstrap-cell -"box_signed_cell" -"to_fixnum" -"long" define-primitive-type + [ alien-signed-cell ] + [ set-alien-signed-cell ] + bootstrap-cell + "box_signed_cell" + "to_fixnum" + "long" define-primitive-type -[ alien-unsigned-cell ] -[ set-alien-unsigned-cell ] -bootstrap-cell -"box_unsigned_cell" -"to_cell" -"ulong" define-primitive-type + [ alien-unsigned-cell ] + [ set-alien-unsigned-cell ] + bootstrap-cell + "box_unsigned_cell" + "to_cell" + "ulong" define-primitive-type -[ alien-signed-4 ] -[ set-alien-signed-4 ] -4 -"box_signed_4" -"to_fixnum" -"int" define-primitive-type + [ alien-signed-4 ] + [ set-alien-signed-4 ] + 4 + "box_signed_4" + "to_fixnum" + "int" define-primitive-type -[ alien-unsigned-4 ] -[ set-alien-unsigned-4 ] -4 -"box_unsigned_4" -"to_cell" -"uint" define-primitive-type + [ alien-unsigned-4 ] + [ set-alien-unsigned-4 ] + 4 + "box_unsigned_4" + "to_cell" + "uint" define-primitive-type -[ alien-signed-2 ] -[ set-alien-signed-2 ] -2 -"box_signed_2" -"to_fixnum" -"short" define-primitive-type + [ alien-signed-2 ] + [ set-alien-signed-2 ] + 2 + "box_signed_2" + "to_fixnum" + "short" define-primitive-type -[ alien-unsigned-2 ] -[ set-alien-unsigned-2 ] -2 -"box_unsigned_2" -"to_cell" -"ushort" define-primitive-type + [ alien-unsigned-2 ] + [ set-alien-unsigned-2 ] + 2 + "box_unsigned_2" + "to_cell" + "ushort" define-primitive-type -[ alien-signed-1 ] -[ set-alien-signed-1 ] -1 -"box_signed_1" -"to_fixnum" -"char" define-primitive-type + [ alien-signed-1 ] + [ set-alien-signed-1 ] + 1 + "box_signed_1" + "to_fixnum" + "char" define-primitive-type -[ alien-unsigned-1 ] -[ set-alien-unsigned-1 ] -1 -"box_unsigned_1" -"to_cell" -"uchar" define-primitive-type + [ alien-unsigned-1 ] + [ set-alien-unsigned-1 ] + 1 + "box_unsigned_1" + "to_cell" + "uchar" define-primitive-type -[ alien-unsigned-4 zero? not ] -[ 1 0 ? set-alien-unsigned-4 ] -4 -"box_boolean" -"to_boolean" -"bool" define-primitive-type + [ alien-unsigned-4 zero? not ] + [ 1 0 ? set-alien-unsigned-4 ] + 4 + "box_boolean" + "to_boolean" + "bool" define-primitive-type -[ alien-float ] -[ >r >r >float r> r> set-alien-float ] -4 -"box_float" -"to_float" -"float" define-primitive-type + [ alien-float ] + [ >r >r >float r> r> set-alien-float ] + 4 + "box_float" + "to_float" + "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" -"double" define-primitive-type + [ alien-double ] + [ >r >r >float r> r> set-alien-double ] + 8 + "box_double" + "to_double" + "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" -"char*" define-primitive-type + [ alien-cell alien>char-string ] + [ set-alien-cell ] + bootstrap-cell + "box_char_string" + "alien_offset" + "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" -"ushort*" define-primitive-type + [ alien-cell alien>u16-string ] + [ set-alien-cell ] + 4 + "box_u16_string" + "alien_offset" + "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 diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index a940248198..5079420b54 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -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 diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index d5257e8493..3b847a0060 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -6,16 +6,14 @@ IN: bit-arrays 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) ; diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 9da231ac96..ff9d5c5e1e 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 9858ccb5ec..3e93a868ca 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 2bcd4ce82f..f9c738a8d0 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -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 diff --git a/core/command-line/command-line-docs.factor b/core/command-line/command-line-docs.factor index 0c9bbd131a..e41d316792 100644 --- a/core/command-line/command-line-docs.factor +++ b/core/command-line/command-line-docs.factor @@ -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" } diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index ccddf97244..17e6938a0c 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -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 } diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index af0ac8ac89..784104d57f 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -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 ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index 65de89524a..363c13c478 100755 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -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 ( -- ) diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index b6c283ed4d..954e45cb66 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -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 diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index ed7a0399fb..821daef203 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -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 diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 87616d8833..2918f3340b 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -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 } diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 27ed277c6c..278264c17d 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -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 ) [ diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor index 9bd9e615c5..628022698f 100755 --- a/core/cpu/ppc/assembler/assembler.factor +++ b/core/cpu/ppc/assembler/assembler.factor @@ -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 ; diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 86db66a61f..34197fdef3 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -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 diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 1104915a9e..d3e33c46bd 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -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 ; diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor index 423597eb01..4ce4b1684d 100755 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -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 diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 4f1bbcb833..745b6efd2d 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -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 diff --git a/core/cpu/x86/64/bootstrap.factor b/core/cpu/x86/64/bootstrap.factor index 9d3fa8849f..1227369ae8 100644 --- a/core/cpu/x86/64/bootstrap.factor +++ b/core/cpu/x86/64/bootstrap.factor @@ -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 diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 3163ce1b41..17aa6bbb54 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -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) ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 8fe5127ab0..ea4cadd51b 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -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 diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 9f6fb5d3b0..0e9d66498d 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -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 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 961c962e42..5ee6b9c87c 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -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 [ diff --git a/core/graphs/graphs-tests.factor b/core/graphs/graphs-tests.factor index c68ecca3d9..90b0e93b7c 100644 --- a/core/graphs/graphs-tests.factor +++ b/core/graphs/graphs-tests.factor @@ -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 diff --git a/core/graphs/graphs.factor b/core/graphs/graphs.factor index 853589532d..973d49f1fa 100644 --- a/core/graphs/graphs.factor +++ b/core/graphs/graphs.factor @@ -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 -- ) diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 3afbe3bc8e..cf2d021430 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -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 ; diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 63c117ba6b..16d9fae36a 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -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 diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 747eeed673..2223dd56b6 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -254,6 +254,9 @@ t over set-effect-terminated? \ fixnum-shift { fixnum fixnum } { integer } "inferred-effect" set-word-prop \ fixnum-shift make-foldable +\ fixnum-shift-fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-shift-fast make-foldable + \ bignum= { bignum bignum } { object } "inferred-effect" set-word-prop \ bignum= make-foldable diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor new file mode 100644 index 0000000000..e9c31171ed --- /dev/null +++ b/core/inference/state/state-tests.factor @@ -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 diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor index f1b2bff316..cf11ffc88a 100755 --- a/core/inference/state/state.factor +++ b/core/inference/state/state.factor @@ -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? diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index e36d703be8..62c3129f3a 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -61,6 +61,11 @@ M: pair (bitfield-quot) ( spec -- quot ) \ set-slots [ [get-slots] ] 1 define-transform -\ construct-boa [ - dup tuple-size [ ] 2curry -] 1 define-transform +: [construct] ( word quot -- newquot ) + >r dup +inlined+ depends-on dup tuple-size r> 2curry ; + +\ construct-boa +[ [ ] [construct] ] 1 define-transform + +\ construct-empty +[ [ ] [construct] ] 1 define-transform diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 7bd9599e4d..6e4648b590 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -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* ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index aec42d1bde..8f0e4efbd9 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -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 ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 8ac1fc5fa0..7c4930f5a8 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -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 diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index b319e028fb..aa716c3197 100755 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -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." } diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 4f03201c02..59a4dff8de 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -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 ; diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 26efbef0df..b7eb5be8c9 100644 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -66,9 +66,9 @@ C: interval [ endpoint-max ] reduce ; : (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-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 ) diff --git a/core/math/math.factor b/core/math/math.factor index 54651f51d8..8b48e49f97 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -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. diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index 80670a6db5..7d99e6311e 100644 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -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." diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 9da5679ea9..1122d83129 100644 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -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* { diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 31ced167a6..ec3c9c15da 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -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 diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index a896deb4d5..de56dc55db 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -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:" diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 8b308da57f..55d43ce8e0 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -301,7 +301,7 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary GENERIC: killer?" + "IN: temporary GENERIC: killer? ( a -- b )" "removing-the-predicate" parse-stream drop ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 8dcca00e3a..31a3ceac03 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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 diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index d4b5633210..a0c909bf56 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 : ( 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 diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 743929ebdb..4517ee4363 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -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 - 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 diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 6eff703cbd..9c7b5c960a 100644 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -15,7 +15,7 @@ M: tuple class class-of-tuple ; 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 + ; diff --git a/extra/benchmark/nsieve-bits/nsieve-bits.factor b/extra/benchmark/nsieve-bits/nsieve-bits.factor index c2f8e02996..46ebc6595e 100644 --- a/extra/benchmark/nsieve-bits/nsieve-bits.factor +++ b/extra/benchmark/nsieve-bits/nsieve-bits.factor @@ -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 diff --git a/extra/benchmark/nsieve/nsieve.factor b/extra/benchmark/nsieve/nsieve.factor index b9200fb2bb..c567aa8a8f 100644 --- a/extra/benchmark/nsieve/nsieve.factor +++ b/extra/benchmark/nsieve/nsieve.factor @@ -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 diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 9a54608126..4e473279fa 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -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 ; diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 85381ec499..e1e3585813 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -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 diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 1c786a2559..9356d6c9b5 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -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 diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor index 1292e04777..032e174eb1 100644 --- a/extra/crypto/common/common-docs.factor +++ b/extra/crypto/common/common-docs.factor @@ -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" } } diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 09c175f94c..80419e9c8d 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -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 ; diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 5cb168b1fd..654f863fd6 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -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\" [ 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 [ reverse-here ] change-each" + "] with-mapped-file" +} "Send some bytes to a remote host:" { $code "\"myhost\" 1033 " @@ -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" diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index bb2d633545..fdfc6b6604 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -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" } diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 5d90fd367c..5f1b027823 100644 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -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 -- ) diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor new file mode 100644 index 0000000000..a4d5e36b06 --- /dev/null +++ b/extra/help/tutorial/tutorial.factor @@ -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 " + "! 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 " + "! 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 " + "! 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" diff --git a/extra/hexdump/hexdump-docs.factor b/extra/hexdump/hexdump-docs.factor index 3fe9bd9594..adf31d3787 100644 --- a/extra/hexdump/hexdump-docs.factor +++ b/extra/hexdump/hexdump-docs.factor @@ -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" } } diff --git a/extra/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor new file mode 100644 index 0000000000..786fe0e68c --- /dev/null +++ b/extra/html/elements/elements-tests.factor @@ -0,0 +1,8 @@ +IN: temporary +USING: tools.test html html.elements io.streams.string ; + +: make-html-string + [ with-html-stream ] string-out ; + +[ "" ] +[ [ ] make-html-string ] unit-test diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index d737c113a8..ff3e7b1283 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -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: -! +! !

"someoutput" write

! !

will output the opening tag and

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 ; + : "<" swap ">" 3append ; +: empty-effect T{ effect f 0 0 } ; + : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry html-word ; + dup swap [ write-html ] curry + empty-effect html-word ; : ">" 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 ; : [ "" % ] "" make ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned - #! word. - dup [ write-html ] curry html-word ; + #! word. + dup [ write-html ] curry empty-effect html-word ; : [ "<" % % "/>" % ] "" make ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry html-word ; + dup swap [ 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- @@ -112,7 +117,7 @@ SYMBOL: html dup def-for-html-word-foo> def-for-html-word- ; -: 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- @@ -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 diff --git a/extra/html/html-tests.factor b/extra/html/html-tests.factor index 798d5563fe..5c33df18b3 100644 --- a/extra/html/html-tests.factor +++ b/extra/html/html-tests.factor @@ -54,10 +54,16 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ "
cdr
" ] +[ "
cdr
" ] [ [ H{ { page-color { 1 0 1 1 } } } [ "cdr" write ] with-nesting ] make-html-string ] unit-test + +[ + "
" +] [ + [ H{ } [ ] with-nesting nl ] make-html-string +] unit-test diff --git a/extra/html/html.factor b/extra/html/html.factor index 391737ca61..f9d5bde5e6 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -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 : ( 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 ; @@ -164,7 +176,7 @@ M: html-stream make-block-stream ( style stream -- stream' ) html-block-stream ; M: html-stream stream-write-table ( grid style stream -- ) - [ + a-div [ swap [ [
@@ -178,7 +190,7 @@ M: html-stream make-cell-stream ( style stream -- stream' ) (html-sub-stream) ; M: html-stream stream-nl ( stream -- ) - [
] with-stream* ; + dup test-last-div? [ drop ] [ [
] with-stream* ] if ; ! Utilities : with-html-stream ( quot -- ) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 2dfbf73004..8dcaa7223d 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -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 ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 58ef587150..99ed41afa3 100644 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -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 ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 680f7b73d5..69f8b4e7fd 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -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 -- ) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 583ae610c0..cade645dde 100644 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -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 < [ % ] [ diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 8af2702c69..9ff21aa011 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -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> ] [ diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index a76e0e5f81..1979819dd1 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -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 ; diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index 9299e6075e..44b234b254 100644 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -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. ; diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index 2c1a69a3d5..59ade44365 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -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 ) diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index cd20216ff9..66d5793f93 100644 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -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 ; - diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index aabdccd1fb..f611c97209 100644 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -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 diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index c9d05c19d7..b9b1f6f314 100644 --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -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 *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 diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e55ee9d852..5343bb513b 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -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 -C: ebnf-terminal -C: ebnf-choice -C: ebnf-sequence -C: ebnf-repeat0 -C: ebnf-optional -C: ebnf-rule -C: ebnf-action -C: 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 ] action ; - -: 'terminal' ( -- parser ) - "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string ] 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 ] action ; - -: 'optional' ( -- parser ) - "[" token sp hide - [ 'choice' sp ] delay - "]" token sp hide - 3array seq [ first ] action ; - -: 'sequence' ( -- parser ) - [ - 'element' sp , - 'group' sp , - 'repeat0' sp , - 'optional' sp , - ] { } make choice - repeat1 [ - dup length 1 = [ first ] [ ] if - ] action ; - -: 'choice' ( -- parser ) - 'sequence' sp "|" token sp list-of [ - dup length 1 = [ first ] [ ] if - ] action ; - -: 'action' ( -- parser ) - "=>" token hide - [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp - 2array seq [ first ] 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 ] action ; - -: 'ebnf' ( -- parser ) - 'rule' sp "." token sp hide list-of [ ] 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 +C: ebnf-terminal +C: ebnf-choice +C: ebnf-sequence +C: ebnf-repeat0 +C: ebnf-optional +C: ebnf-rule +C: ebnf-action +C: 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 ] action ; + +: 'terminal' ( -- parser ) + "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string ] 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 ] action ; + +: 'optional' ( -- parser ) + "[" token sp hide + [ 'choice' sp ] delay + "]" token sp hide + 3array seq [ first ] action ; + +: 'sequence' ( -- parser ) + [ + 'element' sp , + 'group' sp , + 'repeat0' sp , + 'optional' sp , + ] { } make choice + repeat1 [ + dup length 1 = [ first ] [ ] if + ] action ; + +: 'choice' ( -- parser ) + 'sequence' sp "|" token sp list-of [ + dup length 1 = [ first ] [ ] if + ] action ; + +: 'action' ( -- parser ) + "=>" token hide + [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp + 2array seq [ first ] 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 ] action ; + +: 'ebnf' ( -- parser ) + 'rule' sp "." token sp hide list-of [ ] 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* ; + : " parse-tokens " " join ebnf>quot call ; parsing \ No newline at end of file diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 41463d85a0..6dff95c829 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -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 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 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." } ; \ No newline at end of file diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor index f8aa0f29b5..c3a1ecbec4 100644 --- a/extra/random-tester/random-tester.factor +++ b/extra/random-tester/random-tester.factor @@ -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 diff --git a/extra/random-weighted/random-weighted.factor b/extra/random-weighted/random-weighted.factor index e3c71ec807..1e9e35d0bf 100644 --- a/extra/random-weighted/random-weighted.factor +++ b/extra/random-weighted/random-weighted.factor @@ -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 ; diff --git a/extra/random/random.factor b/extra/random/random.factor index 6045da72d8..db2aacd2b0 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -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 ) diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor index b0fdd952d5..f9f8b030a8 100644 --- a/extra/shuffle/shuffle.factor +++ b/extra/shuffle/shuffle.factor @@ -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 diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index 70a08cdced..ba423699c3 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -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 ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 01a50566b4..4a737f06c2 100644 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -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 -- ) [ 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 ] } diff --git a/extra/tools/memory/memory-docs.factor b/extra/tools/memory/memory-docs.factor index 3d746bbf9d..939dda0cfc 100644 --- a/extra/tools/memory/memory-docs.factor +++ b/extra/tools/memory/memory-docs.factor @@ -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" diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index 3fc5057c4c..48a1192282 100644 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -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:" diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 87ab7abf71..2a26c8639e 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -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 -- ) diff --git a/extra/tuple-arrays/tuple-arrays-docs.factor b/extra/tuple-arrays/tuple-arrays-docs.factor index a90068ed57..d6949eaeac 100644 --- a/extra/tuple-arrays/tuple-arrays-docs.factor +++ b/extra/tuple-arrays/tuple-arrays-docs.factor @@ -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 } ". 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." } ; diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 15547ce8db..016d02e527 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -105,7 +105,7 @@ C: 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 ; diff --git a/extra/ui/tools/deploy/deploy-docs.factor b/extra/ui/tools/deploy/deploy-docs.factor index 293a391279..e625d26c60 100755 --- a/extra/ui/tools/deploy/deploy-docs.factor +++ b/extra/ui/tools/deploy/deploy-docs.factor @@ -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" diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index 7b20c4591f..df87d57873 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -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 } diff --git a/extra/visitor/authors.txt b/extra/visitor/authors.txt deleted file mode 100644 index f990dd0ed2..0000000000 --- a/extra/visitor/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/visitor/summary.txt b/extra/visitor/summary.txt deleted file mode 100644 index 3093ae9a9c..0000000000 --- a/extra/visitor/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Double-dispatch generic words diff --git a/extra/visitor/tags.txt b/extra/visitor/tags.txt deleted file mode 100644 index f4274299b1..0000000000 --- a/extra/visitor/tags.txt +++ /dev/null @@ -1 +0,0 @@ -extensions diff --git a/extra/visitor/visitor-tests.factor b/extra/visitor/visitor-tests.factor deleted file mode 100644 index 8248affaf7..0000000000 --- a/extra/visitor/visitor-tests.factor +++ /dev/null @@ -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 diff --git a/extra/visitor/visitor.factor b/extra/visitor/visitor.factor deleted file mode 100644 index dd6bad7d97..0000000000 --- a/extra/visitor/visitor.factor +++ /dev/null @@ -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 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 ; diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor index 3588b21bda..26b8f31eae 100644 --- a/extra/webapps/cgi/cgi.factor +++ b/extra/webapps/cgi/cgi.factor @@ -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 diff --git a/vm/math.c b/vm/math.c index a8bc76c2b1..8c4e7d537a 100644 --- a/vm/math.c +++ b/vm/math.c @@ -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) diff --git a/vm/math.h b/vm/math.h index 7e427b4833..d82a373571 100644 --- a/vm/math.h +++ b/vm/math.h @@ -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); diff --git a/vm/primitives.c b/vm/primitives.c index 9bc1323eae..dd96ee1495 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -33,6 +33,7 @@ void *primitives[] = { primitive_fixnum_xor, primitive_fixnum_not, primitive_fixnum_shift, + primitive_fixnum_shift_fast, primitive_fixnum_less, primitive_fixnum_lesseq, primitive_fixnum_greater,