diff --git a/README.txt b/README.txt index 12dade5ba1..dd7c3e7ad3 100755 --- a/README.txt +++ b/README.txt @@ -6,7 +6,6 @@ implementation. It is not an introduction to the language itself. * Contents -- Platform support - Compiling the Factor VM - Libraries needed for compilation - Bootstrapping the Factor image @@ -19,80 +18,50 @@ implementation. It is not an introduction to the language itself. - Source organization - Community -* Platform support - -Factor supports the following platforms: - - Linux/x86 - Linux/AMD64 - Linux/PowerPC - Linux/ARM - Mac OS X/x86 - Mac OS X/PowerPC - FreeBSD/x86 - FreeBSD/AMD64 - OpenBSD/x86 - OpenBSD/AMD64 - Solaris/x86 - Solaris/AMD64 - MS Windows/x86 (XP and above) - MS Windows CE/ARM - -Please donate time or hardware if you wish to see Factor running on -other platforms. In particular, we are interested in: - - Windows/AMD64 - Mac OS X/AMD64 - Solaris/UltraSPARC - Linux/MIPS - * Compiling the Factor VM The Factor runtime is written in GNU C99, and is built with GNU make and gcc. -Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc -3.3 or earlier. If you are using gcc 4.3, you might get an unusable -Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the -command-line arguments for make. +Factor supports various platforms. For an up-to-date list, see +. -Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of -targets and build options. Then run 'make' with the appropriate target -for your platform. +Factor requires gcc 3.4 or later. + +On x86, Factor /will not/ build using gcc 3.3 or earlier. + +If you are using gcc 4.3, you might get an unusable Factor binary unless +you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line +arguments for make. + +Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. Compilation will yield an executable named 'factor' on Unix, -'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE. +'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE. * Libraries needed for compilation -For X11 support, you need recent development libraries for libc, Freetype, -X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu), -you can use the line +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 + 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 :) +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 -due to size concerns. Instead, download a boot image from: - - http://factorcode.org/images/ - Once you have compiled the Factor runtime, you must bootstrap the Factor system using the image that corresponds to your CPU architecture. -Once you download the right image, bootstrap the system with the +Boot images can be obtained from . + +Once you download the right image, bootstrap Factor with the following command line: ./factor -i=boot..image -Or this command for Mac OS X systems: - -./Factor.app/Contents/MacOS/factor -i=boot..image - Bootstrap can take a while, depending on your system. When the process completes, a 'factor.image' file will be generated. Note that this image is both CPU and OS-specific, so in general cannot be shared between @@ -122,9 +91,8 @@ The latter keeps the terminal listener running. * Running Factor on Mac OS X - Cocoa UI -On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the -terminal listener. If you are using Mac OS X 10.3, you can only run the -X11 UI, as documented in the next section. +On Mac OS X, a Cocoa UI is available in addition to the terminal +listener. The 'factor' executable runs the terminal listener: @@ -136,17 +104,16 @@ contains factor.image and the library sources. * Running Factor on Mac OS X - X11 UI -The X11 UI is available on Mac OS X, however its use is not recommended -since it does not integrate with the host OS. However, if you are -running Mac OS X 10.3, it is your only choice. +The X11 UI is also available on Mac OS X, however its use is not +recommended since it does not integrate with the host OS. When compiling Factor, pass the X11=1 parameter: - make macosx-ppc X11=1 + make X11=1 Then bootstrap with the following switches: - ./factor -i=boot.ppc.image -ui-backend=x11 + ./factor -i=boot..image -ui-backend=x11 Now if $DISPLAY is set, running ./factor will start the UI. @@ -155,40 +122,36 @@ Now if $DISPLAY is set, running ./factor will start the UI. If you did not download the binary package, you can bootstrap Factor in the command prompt: - factor-nt.exe -i=boot.x86.32.image + factor.exe -i=boot..image Once bootstrapped, double-clicking factor.exe starts the Factor UI. To run the listener in the command prompt: - factor-nt.exe -run=listener + factor.exe -run=listener * The Factor FAQ -The Factor FAQ lives online at http://factorcode.org/faq.fhtml +The Factor FAQ is available at . * Command line usage -The Factor VM supports a number of command line switches. To read -command line usage documentation, either enter the following in the UI -listener: +Factor supports a number of command line switches. To read command line +usage documentation, enter the following in the UI listener: "command-line" about * Source organization -The following two directories are managed by the module system; consult -the documentation for details: +The Factor source tree is organized as follows: + build-support/ - scripts used for compiling Factor core/ - Factor core library and compiler extra/ - more libraries - -The following directories contain additional files: - - misc/ - editor modes, icons, etc - vm/ - sources for the Factor runtime, written in C fonts/ - TrueType fonts used by UI + misc/ - editor modes, icons, etc unmaintained/ - unmaintained contributions, please help! + vm/ - sources for the Factor VM, written in C * Community diff --git a/build-support/factor.sh b/build-support/factor.sh index 476e885257..4bcd9e3086 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -190,6 +190,7 @@ find_architecture() { i386) ARCH=x86;; i686) ARCH=x86;; amd64) ARCH=x86;; + ppc64) ARCH=ppc;; *86) ARCH=x86;; *86_64) ARCH=x86;; "Power Macintosh") ARCH=ppc;; diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index fcafe3441c..7d13080e3c 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -78,7 +78,7 @@ $nl "<< \"freetype\" {" " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" - " { [ t ] [ drop ] }" + " [ drop ]" "} cond >>" } "Note the parse time evaluation with " { $link POSTPONE: << } "." } ; @@ -204,7 +204,7 @@ ARTICLE: "alien-callback-gc" "Callbacks and code GC" "A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body." $nl "This is the safest approach, however it can lead to code heap leaks when repeatedly reloading code which defines callbacks. If you are " { $emphasis "completely sure" } " that no running C code is holding a reference to any callbacks, you can blow them all away:" -{ $code "USE: alien callbacks get clear-hash code-gc" } +{ $code "USE: alien callbacks get clear-hash gc" } "This will reclaim all callback bodies which are otherwise unreachable from the dictionary (that is, their associated callback words have since been redefined, recompiled or forgotten)." ; ARTICLE: "alien-callback" "Calling Factor from C" diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 56be3e66a5..f664e1175a 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -54,7 +54,7 @@ TUPLE: library path abi dll ; : library ( name -- library ) libraries get at ; : ( path abi -- library ) - over dup [ dlopen ] when \ library construct-boa ; + over dup [ dlopen ] when \ library boa ; : load-library ( name -- dll ) library dup [ library-dll ] when ; @@ -62,22 +62,16 @@ TUPLE: library path abi dll ; : add-library ( name path abi -- ) swap libraries get set-at ; -TUPLE: alien-callback return parameters abi quot xt ; - ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) alien-callback-error ; -TUPLE: alien-indirect return parameters abi ; - ERROR: alien-indirect-error ; : alien-indirect ( ... funcptr return parameters abi -- ) alien-indirect-error ; -TUPLE: alien-invoke library function return parameters abi ; - ERROR: alien-invoke-error library symbol ; : alien-invoke ( ... return library function parameters -- ... ) diff --git a/core/alien/arrays/arrays.factor b/core/alien/arrays/arrays.factor index c9b9d838dd..402b01550b 100644 --- a/core/alien/arrays/arrays.factor +++ b/core/alien/arrays/arrays.factor @@ -25,7 +25,7 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; -M: value-type c-type-reg-class drop T{ int-regs } ; +M: value-type c-type-reg-class drop int-regs ; M: value-type c-type-prep drop f ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index ca1a89b4ae..c97c760695 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -4,7 +4,8 @@ USING: bit-arrays byte-arrays float-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations -layouts system compiler.units io.files io.encodings.binary ; +layouts system compiler.units io.files io.encodings.binary +accessors combinators ; IN: alien.c-types DEFER: @@ -17,8 +18,12 @@ boxer prep unboxer getter setter reg-class size align stack-align? ; +: new-c-type ( class -- type ) + new + int-regs >>reg-class ; + : ( -- type ) - T{ int-regs } { set-c-type-reg-class } \ c-type construct ; + \ c-type new-c-type ; SYMBOL: c-types @@ -181,10 +186,10 @@ DEFER: >c-ushort-array : define-c-type ( type name vocab -- ) >r tuck typedef r> [ define-nth ] 2keep define-set-nth ; -TUPLE: long-long-type ; +TUPLE: long-long-type < c-type ; -: ( type -- type ) - long-long-type construct-delegate ; +: ( -- type ) + long-long-type new-c-type ; M: long-long-type unbox-parameter ( n type -- ) c-type-unboxer %unbox-long-long ; @@ -235,22 +240,15 @@ M: long-long-type box-return ( type -- ) : define-from-array ( type vocab -- ) [ from-array-word ] 2keep c-array>quot define ; -: ( getter setter width boxer unboxer -- type ) - - [ set-c-type-unboxer ] keep - [ set-c-type-boxer ] keep - [ set-c-type-size ] 2keep - [ set-c-type-align ] keep - [ set-c-type-setter ] keep - [ set-c-type-getter ] keep ; - : define-primitive-type ( type name -- ) "alien.c-types" - [ define-c-type ] 2keep - [ define-deref ] 2keep - [ define-to-array ] 2keep - [ define-from-array ] 2keep - define-out ; + { + [ define-c-type ] + [ define-deref ] + [ define-to-array ] + [ define-from-array ] + [ define-out ] + } 2cleave ; : expand-constants ( c-type -- c-type' ) #! We use word-def call instead of execute to get around @@ -264,130 +262,157 @@ M: long-long-type box-return ( type -- ) binary file-contents dup malloc-byte-array swap length ; [ - [ alien-cell ] - [ set-alien-cell ] - bootstrap-cell - "box_alien" - "alien_offset" + + [ alien-cell ] >>getter + [ set-alien-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + "box_alien" >>boxer + "alien_offset" >>unboxer "void*" define-primitive-type - [ alien-signed-8 ] - [ set-alien-signed-8 ] - 8 - "box_signed_8" - "to_signed_8" + + [ alien-signed-8 ] >>getter + [ set-alien-signed-8 ] >>setter + 8 >>size + 8 >>align + "box_signed_8" >>boxer + "to_signed_8" >>unboxer "longlong" define-primitive-type - [ alien-unsigned-8 ] - [ set-alien-unsigned-8 ] - 8 - "box_unsigned_8" - "to_unsigned_8" + + [ alien-unsigned-8 ] >>getter + [ set-alien-unsigned-8 ] >>setter + 8 >>size + 8 >>align + "box_unsigned_8" >>boxer + "to_unsigned_8" >>unboxer "ulonglong" define-primitive-type - [ alien-signed-cell ] - [ set-alien-signed-cell ] - bootstrap-cell - "box_signed_cell" - "to_fixnum" + + [ alien-signed-cell ] >>getter + [ set-alien-signed-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + "box_signed_cell" >>boxer + "to_fixnum" >>unboxer "long" define-primitive-type - [ alien-unsigned-cell ] - [ set-alien-unsigned-cell ] - bootstrap-cell - "box_unsigned_cell" - "to_cell" + + [ alien-unsigned-cell ] >>getter + [ set-alien-unsigned-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + "box_unsigned_cell" >>boxer + "to_cell" >>unboxer "ulong" define-primitive-type - [ alien-signed-4 ] - [ set-alien-signed-4 ] - 4 - "box_signed_4" - "to_fixnum" + + [ alien-signed-4 ] >>getter + [ set-alien-signed-4 ] >>setter + 4 >>size + 4 >>align + "box_signed_4" >>boxer + "to_fixnum" >>unboxer "int" define-primitive-type - [ alien-unsigned-4 ] - [ set-alien-unsigned-4 ] - 4 - "box_unsigned_4" - "to_cell" + + [ alien-unsigned-4 ] >>getter + [ set-alien-unsigned-4 ] >>setter + 4 >>size + 4 >>align + "box_unsigned_4" >>boxer + "to_cell" >>unboxer "uint" define-primitive-type - [ alien-signed-2 ] - [ set-alien-signed-2 ] - 2 - "box_signed_2" - "to_fixnum" + + [ alien-signed-2 ] >>getter + [ set-alien-signed-2 ] >>setter + 2 >>size + 2 >>align + "box_signed_2" >>boxer + "to_fixnum" >>unboxer "short" define-primitive-type - [ alien-unsigned-2 ] - [ set-alien-unsigned-2 ] - 2 - "box_unsigned_2" - "to_cell" + + [ alien-unsigned-2 ] >>getter + [ set-alien-unsigned-2 ] >>setter + 2 >>size + 2 >>align + "box_unsigned_2" >>boxer + "to_cell" >>unboxer "ushort" define-primitive-type - [ alien-signed-1 ] - [ set-alien-signed-1 ] - 1 - "box_signed_1" - "to_fixnum" + + [ alien-signed-1 ] >>getter + [ set-alien-signed-1 ] >>setter + 1 >>size + 1 >>align + "box_signed_1" >>boxer + "to_fixnum" >>unboxer "char" define-primitive-type - [ alien-unsigned-1 ] - [ set-alien-unsigned-1 ] - 1 - "box_unsigned_1" - "to_cell" + + [ alien-unsigned-1 ] >>getter + [ set-alien-unsigned-1 ] >>setter + 1 >>size + 1 >>align + "box_unsigned_1" >>boxer + "to_cell" >>unboxer "uchar" define-primitive-type - [ alien-unsigned-4 zero? not ] - [ 1 0 ? set-alien-unsigned-4 ] - 4 - "box_boolean" - "to_boolean" + + [ alien-unsigned-4 zero? not ] >>getter + [ 1 0 ? set-alien-unsigned-4 ] >>setter + 4 >>size + 4 >>align + "box_boolean" >>boxer + "to_boolean" >>unboxer "bool" define-primitive-type - [ alien-float ] - [ >r >r >float r> r> set-alien-float ] - 4 - "box_float" - "to_float" + + [ alien-float ] >>getter + [ >r >r >float r> r> set-alien-float ] >>setter + 4 >>size + 4 >>align + "box_float" >>boxer + "to_float" >>unboxer + single-float-regs >>reg-class + [ >float ] >>prep "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 - - [ alien-double ] - [ >r >r >float r> r> set-alien-double ] - 8 - "box_double" - "to_double" + + [ alien-double ] >>getter + [ >r >r >float r> r> set-alien-double ] >>setter + 8 >>size + 8 >>align + "box_double" >>boxer + "to_double" >>unboxer + double-float-regs >>reg-class + [ >float ] >>prep "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 - - [ alien-cell alien>char-string ] - [ set-alien-cell ] - bootstrap-cell - "box_char_string" - "alien_offset" + + [ alien-cell alien>char-string ] >>getter + [ set-alien-cell ] >>setter + bootstrap-cell >>size + bootstrap-cell >>align + "box_char_string" >>boxer + "alien_offset" >>unboxer + [ string>char-alien ] >>prep "char*" define-primitive-type "char*" "uchar*" typedef - [ string>char-alien ] "char*" c-type set-c-type-prep - - [ alien-cell alien>u16-string ] - [ set-alien-cell ] - 4 - "box_u16_string" - "alien_offset" + + [ alien-cell alien>u16-string ] >>getter + [ set-alien-cell ] >>setter + 4 >>size + 4 >>align + "box_u16_string" >>boxer + "alien_offset" >>unboxer + [ string>u16-alien ] >>prep "ushort*" define-primitive-type - [ string>u16-alien ] "ushort*" c-type set-c-type-prep - os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef - ] with-compilation-unit diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index f9dc426de1..f0c0706a3c 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences inference words arrays parser quotations continuations inference.backend effects namespaces.private io io.streams.string memory system threads -tools.test ; +tools.test math ; FUNCTION: void ffi_test_0 ; [ ] [ ffi_test_0 ] unit-test @@ -87,7 +87,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ -1 indirect-test-1 ] must-fail : indirect-test-2 - "int" { "int" "int" } "cdecl" alien-indirect data-gc ; + "int" { "int" "int" } "cdecl" alien-indirect gc ; { 3 1 } [ indirect-test-2 ] must-infer-as @@ -97,7 +97,7 @@ unit-test : indirect-test-3 "int" { "int" "int" "int" "int" } "stdcall" alien-indirect - data-gc ; + gc ; << "f-stdcall" f "stdcall" add-library >> @@ -106,13 +106,13 @@ unit-test : ffi_test_18 ( w x y z -- int ) "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } - alien-invoke data-gc ; + alien-invoke gc ; [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test : ffi_test_19 ( x y z -- bar ) "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } - alien-invoke data-gc ; + alien-invoke gc ; [ 11 6 -7 ] [ 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z @@ -143,7 +143,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, "void" f "ffi_test_31" { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } - alien-invoke code-gc 3 ; + alien-invoke gc 3 ; [ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test @@ -312,14 +312,14 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; : callback-4 "void" { } "cdecl" [ "Hello world" write ] alien-callback - data-gc ; + gc ; [ "Hello world" ] [ [ callback-4 callback_test_1 ] with-string-writer ] unit-test : callback-5 - "void" { } "cdecl" [ data-gc ] alien-callback ; + "void" { } "cdecl" [ gc ] alien-callback ; [ "testing" ] [ "testing" callback-5 callback_test_1 @@ -354,3 +354,14 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; ] alien-callback ; [ ] [ callback-8 callback_test_1 ] unit-test + +: callback-9 + "int" { "int" "int" "int" } "cdecl" [ + + + 1+ + ] alien-callback ; + +FUNCTION: int ffi_test_37 ( void* func ) ; + +[ 1 ] [ callback-9 ffi_test_37 ] unit-test + +[ 7 ] [ callback-9 ffi_test_37 ] unit-test diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 1a9d5b5392..9bd65aa0bc 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -9,6 +9,14 @@ kernel.private threads continuations.private libc combinators compiler.errors continuations layouts accessors ; IN: alien.compiler +TUPLE: #alien-node < node return parameters abi ; + +TUPLE: #alien-callback < #alien-node quot xt ; + +TUPLE: #alien-indirect < #alien-node ; + +TUPLE: #alien-invoke < #alien-node library function ; + : large-struct? ( ctype -- ? ) dup c-struct? [ heap-size struct-small-enough? not @@ -62,29 +70,36 @@ GENERIC: reg-size ( register-class -- n ) M: int-regs reg-size drop cell ; -M: float-regs reg-size float-regs-size ; +M: single-float-regs reg-size drop 4 ; + +M: double-float-regs reg-size drop 8 ; + +GENERIC: reg-class-variable ( register-class -- symbol ) + +M: reg-class reg-class-variable ; + +M: float-regs reg-class-variable drop float-regs ; GENERIC: inc-reg-class ( register-class -- ) -: (inc-reg-class) - dup class inc +M: reg-class inc-reg-class + dup reg-class-variable inc fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; -M: int-regs inc-reg-class - (inc-reg-class) ; - M: float-regs inc-reg-class - dup (inc-reg-class) + dup call-next-method fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ; : reg-class-full? ( class -- ? ) - dup class get swap param-regs length >= ; + [ reg-class-variable get ] [ param-regs length ] bi >= ; : spill-param ( reg-class -- n reg-class ) - reg-size stack-params dup get -rot +@ T{ stack-params } ; + stack-params get + >r reg-size stack-params +@ r> + stack-params ; : fastcall-param ( reg-class -- n reg-class ) - [ dup class get swap inc-reg-class ] keep ; + [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ; : alloc-parameter ( parameter -- reg reg-class ) c-type-reg-class dup reg-class-full? @@ -205,7 +220,7 @@ M: no-such-library compiler-error-type drop +linkage+ ; : no-such-library ( name -- ) - \ no-such-library construct-boa + \ no-such-library boa compiling-word get compiler-error ; TUPLE: no-such-symbol name ; @@ -217,7 +232,7 @@ M: no-such-symbol compiler-error-type drop +linkage+ ; : no-such-symbol ( name -- ) - \ no-such-symbol construct-boa + \ no-such-symbol boa compiling-word get compiler-error ; : check-dlsym ( symbols dll -- ) @@ -229,32 +244,32 @@ M: no-such-symbol compiler-error-type ] if ; : alien-invoke-dlsym ( node -- symbols dll ) - dup alien-invoke-function dup pick stdcall-mangle 2array - swap alien-invoke-library library dup [ library-dll ] when + dup function>> dup pick stdcall-mangle 2array + swap library>> library dup [ dll>> ] when 2dup check-dlsym ; \ alien-invoke [ ! Four literals 4 ensure-values - \ alien-invoke empty-node + #alien-invoke new ! Compile-time parameters - pop-parameters over set-alien-invoke-parameters - pop-literal nip over set-alien-invoke-function - pop-literal nip over set-alien-invoke-library - pop-literal nip over set-alien-invoke-return + pop-parameters >>parameters + pop-literal nip >>function + pop-literal nip >>library + pop-literal nip >>return ! Quotation which coerces parameters to required types dup make-prep-quot recursive-state get infer-quot ! Set ABI - dup alien-invoke-library - library [ library-abi ] [ "cdecl" ] if* - over set-alien-invoke-abi + dup library>> + library [ abi>> ] [ "cdecl" ] if* + >>abi ! Add node to IR dup node, ! Magic #: consume exactly the number of inputs 0 alien-invoke-stack ] "infer" set-word-prop -M: alien-invoke generate-node +M: #alien-invoke generate-node dup alien-invoke-frame [ end-basic-block %prepare-alien-invoke @@ -273,11 +288,11 @@ M: alien-indirect-error summary ! Three literals and function pointer 4 ensure-values 4 reify-curries - \ alien-indirect empty-node + #alien-indirect new ! Compile-time parameters - pop-literal nip over set-alien-indirect-abi - pop-parameters over set-alien-indirect-parameters - pop-literal nip over set-alien-indirect-return + pop-literal nip >>abi + pop-parameters >>parameters + pop-literal nip >>return ! Quotation which coerces parameters to required types dup make-prep-quot [ dip ] curry recursive-state get infer-quot ! Add node to IR @@ -286,7 +301,7 @@ M: alien-indirect-error summary 1 alien-invoke-stack ] "infer" set-word-prop -M: alien-indirect generate-node +M: #alien-indirect generate-node dup alien-invoke-frame [ ! Flush registers end-basic-block @@ -315,17 +330,17 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; : callback-bottom ( node -- ) - alien-callback-xt [ word-xt drop ] curry + xt>> [ word-xt drop ] curry recursive-state get infer-quot ; \ alien-callback [ 4 ensure-values - \ alien-callback empty-node dup node, - pop-literal nip over set-alien-callback-quot - pop-literal nip over set-alien-callback-abi - pop-parameters over set-alien-callback-parameters - pop-literal nip over set-alien-callback-return - gensym dup register-callback over set-alien-callback-xt + #alien-callback new dup node, + pop-literal nip >>quot + pop-literal nip >>abi + pop-parameters >>parameters + pop-literal nip >>return + gensym dup register-callback >>xt callback-bottom ] "infer" set-word-prop @@ -360,14 +375,13 @@ TUPLE: callback-context ; return>> { { [ dup "void" = ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } - { [ t ] [ c-type c-type-prep ] } + [ c-type c-type-prep ] } cond ; : wrap-callback-quot ( node -- quot ) [ - dup alien-callback-quot - swap prepare-callback-return append , - [ callback-context construct-empty do-callback ] % + [ quot>> ] [ prepare-callback-return ] bi append , + [ callback-context new do-callback ] % ] [ ] make ; : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ; @@ -376,7 +390,7 @@ TUPLE: callback-context ; { { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } { [ dup return>> large-struct? ] [ drop 4 ] } - { [ t ] [ drop 0 ] } + [ drop 0 ] } cond ; : %callback-return ( node -- ) @@ -387,9 +401,8 @@ TUPLE: callback-context ; callback-unwind %unwind ; : generate-callback ( node -- ) - dup alien-callback-xt dup [ + dup xt>> dup [ init-templates - %save-word-xt %prologue-later dup alien-stack-frame [ dup registers>objects @@ -398,5 +411,5 @@ TUPLE: callback-context ; ] with-stack-frame ] with-generator ; -M: alien-callback generate-node +M: #alien-callback generate-node end-basic-block generate-callback iterate-next ; diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index 491f4351a3..6d98d31790 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -68,7 +68,7 @@ M: struct-type stack-size : (define-struct) ( name vocab size align fields -- ) >r [ align ] keep r> - struct-type construct-boa + struct-type boa -rot define-c-type ; : make-field ( struct-name vocab type field-name -- spec ) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 6e4b8b4e21..67ea30f379 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -68,7 +68,7 @@ M: alien pprint* { { [ dup expired? ] [ drop "( alien expired )" text ] } { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } - { [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } + [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } cond ; M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ; diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 414c64581e..9c5f40d883 100755 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -12,9 +12,9 @@ M: array resize resize-array ; : >array ( seq -- array ) { } clone-like ; -M: object new drop f ; +M: object new-sequence drop f ; -M: f new drop dup zero? [ drop f ] [ f ] if ; +M: f new-sequence drop dup zero? [ drop f ] [ f ] if ; M: array like drop dup array? [ >array ] unless ; diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index e85789a4f2..863fdaecb3 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -69,14 +69,14 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs" ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)." { $subsection subassoc? } -{ $subsection intersect } +{ $subsection assoc-intersect } { $subsection update } -{ $subsection union } -{ $subsection diff } +{ $subsection assoc-union } +{ $subsection assoc-diff } { $subsection remove-all } { $subsection substitute } { $subsection substitute-here } -{ $see-also key? } ; +{ $see-also key? assoc-contains? assoc-all? "sets" } ; ARTICLE: "assocs-mutation" "Storing keys and values in assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" @@ -97,6 +97,7 @@ $nl { $subsection assoc-map } { $subsection assoc-push-if } { $subsection assoc-subset } +{ $subsection assoc-contains? } { $subsection assoc-all? } "Three additional combinators:" { $subsection cache } @@ -206,9 +207,13 @@ HELP: assoc-subset { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } } { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ; +HELP: assoc-contains? +{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } } +{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ; + HELP: assoc-all? { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } } -{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ; +{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ; HELP: subassoc? { $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } } @@ -260,7 +265,7 @@ HELP: values { keys values } related-words -HELP: intersect +HELP: assoc-intersect { $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } } { $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." } { $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ; @@ -270,11 +275,11 @@ HELP: update { $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." } { $side-effects "assoc1" } ; -HELP: union +HELP: assoc-union { $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } } { $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ; -HELP: diff +HELP: assoc-diff { $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } } { $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." } ; diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index c4db604784..76f484006d 100755 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -58,24 +58,24 @@ H{ } clone "cache-test" set ] [ H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } } H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } } - intersect + assoc-intersect ] unit-test [ H{ { 1 2 } { 2 3 } { 6 5 } } ] [ H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } } - union + assoc-union ] unit-test [ H{ { 1 2 } { 2 3 } } t ] [ - f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd = + f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd = ] unit-test [ H{ { 1 f } } ] [ - H{ { 1 f } } H{ { 1 f } } intersect + H{ { 1 f } } H{ { 1 f } } assoc-intersect ] unit-test [ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 6b6bd3d51a..4a6ecae4fe 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -109,17 +109,17 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) >r over r> hashcode* 2/ >r dupd hashcode* r> bitxor ] { } assoc>map hashcode* ; -: intersect ( assoc1 assoc2 -- intersection ) +: assoc-intersect ( assoc1 assoc2 -- intersection ) swap [ nip key? ] curry assoc-subset ; : update ( assoc1 assoc2 -- ) swap [ swapd set-at ] curry assoc-each ; -: union ( assoc1 assoc2 -- union ) +: assoc-union ( assoc1 assoc2 -- union ) 2dup [ assoc-size ] bi@ + pick new-assoc [ rot update ] keep [ swap update ] keep ; -: diff ( assoc1 assoc2 -- diff ) +: assoc-diff ( assoc1 assoc2 -- diff ) swap [ nip key? not ] curry assoc-subset ; : remove-all ( assoc seq -- subseq ) @@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ; : value-at ( value assoc -- key/f ) swap [ = nip ] curry assoc-find 2drop ; +: zip ( keys values -- alist ) + 2array flip ; inline + : search-alist ( key alist -- pair i ) [ first = ] with find swap ; inline @@ -204,7 +207,7 @@ M: enum set-at seq>> set-nth ; M: enum delete-at enum-seq delete-nth ; M: enum >alist ( enum -- alist ) - seq>> [ length ] keep 2array flip ; + seq>> [ length ] keep zip ; M: enum assoc-size seq>> length ; diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index ee485d399e..ffb9f5d195 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -43,7 +43,7 @@ M: bit-array clone (clone) ; M: bit-array like drop dup bit-array? [ >bit-array ] unless ; -M: bit-array new drop ; +M: bit-array new-sequence drop ; M: bit-array equal? over bit-array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor index c418a24813..db941ac6f7 100755 --- a/core/bit-vectors/bit-vectors.factor +++ b/core/bit-vectors/bit-vectors.factor @@ -7,7 +7,7 @@ IN: bit-vectors vector ( bit-array length -- bit-vector ) - bit-vector construct-boa ; inline + bit-vector boa ; inline PRIVATE> @@ -22,7 +22,7 @@ M: bit-vector like [ dup length bit-array>vector ] [ >bit-vector ] if ] unless ; -M: bit-vector new +M: bit-vector new-sequence drop [ ] keep >fixnum bit-array>vector ; M: bit-vector equal? diff --git a/core/bit-vectors/summary.txt b/core/bit-vectors/summary.txt new file mode 100644 index 0000000000..76a7d0f1cc --- /dev/null +++ b/core/bit-vectors/summary.txt @@ -0,0 +1 @@ +Growable bit arrays diff --git a/core/bit-vectors/tags.txt b/core/bit-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/bit-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 6b467caa5a..da3c634ebd 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -19,7 +19,7 @@ IN: bootstrap.compiler enable-compiler nl -"Compiling some words to speed up bootstrap..." write flush +"Compiling..." write flush ! Compile a set of words ahead of the full compile. ! This set of words was determined semi-empirically @@ -37,8 +37,6 @@ nl wrap probe - delegate - underlying find-pair-next namestack* @@ -55,7 +53,7 @@ nl "." write flush { - new nth push pop peek + new-sequence nth push pop peek } compile "." write flush @@ -76,4 +74,6 @@ nl malloc calloc free memcpy } compile +vocabs [ words [ compiled? not ] subset compile "." write flush ] each + " done" print flush diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 6e0f8e2970..05d48af2e8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -4,9 +4,9 @@ USING: alien arrays bit-arrays byte-arrays generic assocs hashtables assocs hashtables.private io kernel kernel.private math namespaces parser prettyprint sequences sequences.private strings sbufs vectors words quotations assocs system layouts -splitting growable classes classes.tuple classes.tuple.private -words.private io.binary io.files vocabs vocabs.loader -source-files definitions debugger float-arrays +splitting growable classes classes.builtin classes.tuple +classes.tuple.private words.private io.binary io.files vocabs +vocabs.loader source-files definitions debugger float-arrays quotations.private sequences.private combinators io.encodings.binary ; IN: bootstrap.image diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index ceb011d52b..e839576bc9 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -36,4 +36,4 @@ tag-numbers get H{ { word 17 } { byte-array 18 } { tuple-layout 19 } -} union type-numbers set +} assoc-union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6c87730278..f1e41ac2b6 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -3,10 +3,10 @@ USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes -classes.tuple classes.tuple.private kernel.private vocabs -vocabs.loader source-files definitions slots.deprecated -classes.union compiler.units bootstrap.image.private io.files -accessors combinators ; +classes.builtin classes.tuple classes.tuple.private +kernel.private vocabs vocabs.loader source-files definitions +slots.deprecated classes.union compiler.units +bootstrap.image.private io.files accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -30,7 +30,7 @@ crossref off ! Bring up a bare cross-compiling vocabulary. "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set -H{ } clone changed-words set +H{ } clone changed-definitions set H{ } clone forgotten-definitions set H{ } clone root-cache set H{ } clone source-files set @@ -390,7 +390,7 @@ define-builtin ! Create special tombstone values "tombstone" "hashtables.private" create -"tuple" "kernel" lookup +tuple { } define-tuple-class "((empty))" "hashtables.private" create @@ -403,7 +403,7 @@ define-builtin ! Some tuple classes "hashtable" "hashtables" create -"tuple" "kernel" lookup +tuple { { { "array-capacity" "sequences.private" } @@ -424,7 +424,7 @@ define-builtin } define-tuple-class "sbuf" "sbufs" create -"tuple" "kernel" lookup +tuple { { { "string" "strings" } @@ -440,7 +440,7 @@ define-builtin } define-tuple-class "vector" "vectors" create -"tuple" "kernel" lookup +tuple { { { "array" "arrays" } @@ -456,7 +456,7 @@ define-builtin } define-tuple-class "byte-vector" "byte-vectors" create -"tuple" "kernel" lookup +tuple { { { "byte-array" "byte-arrays" } @@ -472,7 +472,7 @@ define-builtin } define-tuple-class "bit-vector" "bit-vectors" create -"tuple" "kernel" lookup +tuple { { { "bit-array" "bit-arrays" } @@ -488,7 +488,7 @@ define-builtin } define-tuple-class "float-vector" "float-vectors" create -"tuple" "kernel" lookup +tuple { { { "float-array" "float-arrays" } @@ -504,7 +504,7 @@ define-builtin } define-tuple-class "curry" "kernel" create -"tuple" "kernel" lookup +tuple { { { "object" "kernel" } @@ -525,7 +525,7 @@ define-builtin [ tuple-layout [ ] curry ] tri define "compose" "kernel" create -"tuple" "kernel" lookup +tuple { { { "object" "kernel" } @@ -640,8 +640,7 @@ define-builtin { "setenv" "kernel.private" } { "(exists?)" "io.files.private" } { "(directory)" "io.files.private" } - { "data-gc" "memory" } - { "code-gc" "memory" } + { "gc" "memory" } { "gc-time" "memory" } { "save-image" "memory" } { "save-image-and-exit" "memory" } @@ -733,11 +732,14 @@ define-builtin { "set-innermost-frame-quot" "kernel.private" } { "call-clear" "kernel" } { "(os-envs)" "system.private" } + { "set-os-env" "system" } + { "unset-os-env" "system" } { "(set-os-envs)" "system.private" } { "resize-byte-array" "byte-arrays" } { "resize-bit-array" "bit-arrays" } { "resize-float-array" "float-arrays" } { "dll-valid?" "alien" } + { "unimplemented" "kernel.private" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index c82ebbe9f8..dfd2e4be6f 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -5,7 +5,7 @@ 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 -math.parser generic ; +math.parser generic sets ; IN: bootstrap.stage2 SYMBOL: bootstrap-time @@ -24,13 +24,9 @@ SYMBOL: bootstrap-time : load-components ( -- ) "exclude" "include" [ get-global " " split [ empty? not ] subset ] bi@ - seq-diff + diff [ "bootstrap." prepend require ] each ; -: compile-remaining ( -- ) - "Compiling remaining words..." print flush - vocabs [ words [ compiled? not ] subset compile ] each ; - : count-words ( pred -- ) all-words swap subset length number>string write ; @@ -57,7 +53,7 @@ millis >r default-image-name "output-image" set-global -"math help handbook compiler random tools ui ui.tools io" "include" set-global +"math compiler help random tools ui ui.tools io handbook" "include" set-global "" "exclude" set-global parse-command-line @@ -79,10 +75,6 @@ os winnt? [ "windows.nt" require ] when load-components run-bootstrap-init - - "bootstrap.compiler" vocab [ - compile-remaining - ] when ] with-compiler-errors :errors diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index a989e091bb..b56a46b6b3 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -5,7 +5,7 @@ IN: boxes TUPLE: box value full? ; -: ( -- box ) box construct-empty ; +: ( -- box ) box new ; : >box ( value box -- ) dup box-full? [ "Box already has a value" throw ] when diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 548c293e7c..d603470810 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -10,7 +10,7 @@ M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline M: byte-array like drop dup byte-array? [ >byte-array ] unless ; -M: byte-array new drop ; +M: byte-array new-sequence drop ; M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index 6a08f657a2..206a23f43b 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -7,7 +7,7 @@ IN: byte-vectors vector ( byte-array length -- byte-vector ) - byte-vector construct-boa ; inline + byte-vector boa ; inline PRIVATE> @@ -22,7 +22,7 @@ M: byte-vector like [ dup length byte-array>vector ] [ >byte-vector ] if ] unless ; -M: byte-vector new +M: byte-vector new-sequence drop [ ] keep >fixnum byte-array>vector ; M: byte-vector equal? diff --git a/core/byte-vectors/summary.txt b/core/byte-vectors/summary.txt new file mode 100644 index 0000000000..e914ebb319 --- /dev/null +++ b/core/byte-vectors/summary.txt @@ -0,0 +1 @@ +Growable byte arrays diff --git a/core/byte-vectors/tags.txt b/core/byte-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/byte-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 0f468908a9..d61b62af3b 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -68,13 +68,13 @@ UNION: c a b ; [ t ] [ \ tuple-class \ class class< ] unit-test [ f ] [ \ class \ tuple-class class< ] unit-test -TUPLE: delegate-clone ; +TUPLE: tuple-example ; -[ t ] [ \ null \ delegate-clone class< ] unit-test -[ f ] [ \ object \ delegate-clone class< ] unit-test -[ f ] [ \ object \ delegate-clone class< ] unit-test -[ t ] [ \ delegate-clone \ tuple class< ] unit-test -[ f ] [ \ tuple \ delegate-clone class< ] unit-test +[ t ] [ \ null \ tuple-example class< ] unit-test +[ f ] [ \ object \ tuple-example class< ] unit-test +[ f ] [ \ object \ tuple-example class< ] unit-test +[ t ] [ \ tuple-example \ tuple class< ] unit-test +[ f ] [ \ tuple \ tuple-example class< ] unit-test TUPLE: a1 ; TUPLE: b1 ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 97309dbea2..b7a3e074e5 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes combinators accessors sequences arrays -vectors assocs namespaces words sorting layouts math hashtables -kernel.private ; +USING: kernel classes classes.builtin combinators accessors +sequences arrays vectors assocs namespaces words sorting layouts +math hashtables kernel.private sets ; IN: classes.algebra : 2cache ( key1 key2 assoc quot -- value ) @@ -84,7 +84,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup members ] [ right-union-class< ] } { [ over superclass ] [ superclass< ] } - { [ t ] [ 2drop f ] } + [ 2drop f ] } cond ; : anonymous-union-intersect? ( first second -- ? ) @@ -103,15 +103,15 @@ C: anonymous-complement { { [ over tuple eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } - { [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] } - { [ t ] [ swap classes-intersect? ] } + { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] } + [ swap classes-intersect? ] } cond ; : builtin-class-intersect? ( first second -- ? ) { { [ 2dup eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } - { [ t ] [ swap classes-intersect? ] } + [ swap classes-intersect? ] } cond ; : (classes-intersect?) ( first second -- ? ) @@ -154,7 +154,7 @@ C: anonymous-complement { [ over members ] [ left-union-and ] } { [ over anonymous-union? ] [ left-anonymous-union-and ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : left-anonymous-union-or ( first second -- class ) @@ -169,7 +169,7 @@ C: anonymous-complement { [ 2dup swap class< ] [ drop ] } { [ dup anonymous-union? ] [ right-anonymous-union-or ] } { [ over anonymous-union? ] [ left-anonymous-union-or ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : (class-not) ( class -- complement ) @@ -177,7 +177,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> ] } { [ dup object eq? ] [ drop null ] } { [ dup null eq? ] [ drop object ] } - { [ t ] [ ] } + [ ] } cond ; : largest-class ( seq -- n elt ) @@ -205,7 +205,7 @@ C: anonymous-complement { [ dup builtin-class? ] [ dup set ] } { [ dup members ] [ members [ (flatten-class) ] each ] } { [ dup superclass ] [ superclass (flatten-class) ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : flatten-class ( class -- assoc ) diff --git a/core/classes/builtin/builtin-docs.factor b/core/classes/builtin/builtin-docs.factor new file mode 100644 index 0000000000..054587ff14 --- /dev/null +++ b/core/classes/builtin/builtin-docs.factor @@ -0,0 +1,28 @@ +USING: help.syntax help.markup classes layouts ; +IN: classes.builtin + +ARTICLE: "builtin-classes" "Built-in classes" +"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior." +$nl +"The set of built-in classes is a class:" +{ $subsection builtin-class } +{ $subsection builtin-class? } +"See " { $link "type-index" } " for a list of built-in classes." ; + +HELP: builtin-class +{ $class-description "The class of built-in classes." } +{ $examples + "The class of arrays is a built-in class:" + { $example "USING: arrays classes.builtin prettyprint ;" "array builtin-class? ." "t" } + "However, an instance of the array class is not a built-in class; it is not even a class:" + { $example "USING: classes.builtin prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" } +} ; + +HELP: builtins +{ $var-description "Vector mapping type numbers to builtin class words." } ; + +HELP: type>class +{ $values { "n" "a non-negative integer" } { "class" class } } +{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." } +{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ; + diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor new file mode 100644 index 0000000000..1c2871b031 --- /dev/null +++ b/core/classes/builtin/builtin.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: classes words kernel kernel.private namespaces +sequences ; +IN: classes.builtin + +SYMBOL: builtins + +PREDICATE: builtin-class < class + "metaclass" word-prop builtin-class eq? ; + +: type>class ( n -- class ) builtins get-global nth ; + +: bootstrap-type>class ( n -- class ) builtins get nth ; + +M: hi-tag class hi-tag type>class ; + +M: object class tag type>class ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 3f30b71457..dd3782e877 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -4,14 +4,6 @@ layouts classes.private classes.union classes.mixin classes.predicate quotations ; IN: classes -ARTICLE: "builtin-classes" "Built-in classes" -"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior." -$nl -"The set of built-in classes is a class:" -{ $subsection builtin-class } -{ $subsection builtin-class? } -"See " { $link "type-index" } " for a list of built-in classes." ; - ARTICLE: "class-predicates" "Class predicate words" "With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property." $nl @@ -38,17 +30,21 @@ $nl { $subsection class? } "You can ask an object for its class:" { $subsection class } +"Testing if an object is an instance of a class:" +{ $subsection instance? } "There is a universal class which all objects are an instance of, and an empty class with no instances:" { $subsection object } { $subsection null } "Obtaining a list of all defined classes:" { $subsection classes } -"Other sorts of classes:" +"There are several sorts of classes:" { $subsection "builtin-classes" } { $subsection "unions" } -{ $subsection "singletons" } { $subsection "mixins" } { $subsection "predicates" } +{ $subsection "singletons" } +{ $link "tuples" } " are documented in their own section." +$nl "Classes can be inspected and operated upon:" { $subsection "class-operations" } { $see-also "class-index" } ; @@ -58,37 +54,20 @@ ABOUT: "classes" HELP: class { $values { "object" object } { "class" class } } { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." } -{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." } +{ $class-description "The class of all class words." } { $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ; HELP: classes { $values { "seq" "a sequence of class words" } } { $description "Finds all class words in the dictionary." } ; -HELP: builtin-class -{ $class-description "The class of built-in classes." } -{ $examples - "The class of arrays is a built-in class:" - { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" } - "However, an instance of the array class is not a built-in class; it is not even a class:" - { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" } -} ; - HELP: tuple-class { $class-description "The class of tuple class words." } { $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; -HELP: builtins -{ $var-description "Vector mapping type numbers to builtin class words." } ; - HELP: update-map { $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; -HELP: type>class -{ $values { "n" "a non-negative integer" } { "class" class } } -{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." } -{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ; - HELP: predicate-word { $values { "word" "a word" } { "predicate" "a predicate word" } } { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index c45fd7360b..4f43b86f64 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -30,20 +30,11 @@ SYMBOL: update-map PREDICATE: class < word "class" word-prop ; -SYMBOL: builtins - -PREDICATE: builtin-class < class - "metaclass" word-prop builtin-class eq? ; - PREDICATE: tuple-class < class "metaclass" word-prop tuple-class eq? ; : classes ( -- seq ) all-words [ class? ] subset ; -: type>class ( n -- class ) builtins get-global nth ; - -: bootstrap-type>class ( n -- class ) builtins get nth ; - : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; @@ -98,7 +89,7 @@ M: word reset-class drop ; dup reset-class dup deferred? [ dup define-symbol ] when dup word-props - r> union over set-word-props + r> assoc-union over set-word-props dup predicate-word [ 1quotation "predicate" set-word-prop ] [ swap "predicating" set-word-prop ] @@ -130,9 +121,5 @@ GENERIC: update-methods ( assoc -- ) GENERIC: class ( object -- class ) -M: hi-tag class hi-tag type>class ; - -M: object class tag type>class ; - : instance? ( obj class -- ? ) "predicate" word-prop call ; diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor index 1fa6f7bd83..82dec5cec0 100755 --- a/core/classes/mixin/mixin-docs.factor +++ b/core/classes/mixin/mixin-docs.factor @@ -1,16 +1,18 @@ USING: help.markup help.syntax help words compiler.units -classes ; +classes sequences ; IN: classes.mixin ARTICLE: "mixins" "Mixin classes" -"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, new classes can be made into instances of a mixin class after the original definition of the mixin." +"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, mixin classes have the additional property that they are " { $emphasis "open" } "; new classes can be added to the mixin after the original definition of the mixin." { $subsection POSTPONE: MIXIN: } { $subsection POSTPONE: INSTANCE: } { $subsection define-mixin-class } { $subsection add-mixin-instance } "The set of mixin classes is a class:" { $subsection mixin-class } -{ $subsection mixin-class? } ; +{ $subsection mixin-class? } +"Mixins are used to defines suites of behavior which are generally useful and can be applied to user-defined classes. For example, the " { $link immutable-sequence } " mixin can be used with user-defined sequences to make them immutable." +{ $see-also "unions" "tuple-subclassing" } ; HELP: mixin-class { $class-description "The class of mixin classes." } ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index aefd522269..33b0fc32fa 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -24,7 +24,7 @@ TUPLE: check-mixin-class mixin ; : check-mixin-class ( mixin -- mixin ) dup mixin-class? [ - \ check-mixin-class construct-boa throw + \ check-mixin-class boa throw ] unless ; : if-mixin-member? ( class mixin true false -- ) @@ -49,7 +49,7 @@ M: mixin-instance equal? { [ over mixin-instance? not ] [ f ] } { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; M: mixin-instance hashcode* diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor index 8548f84a3a..a8dae809ec 100644 --- a/core/classes/singleton/singleton-docs.factor +++ b/core/classes/singleton/singleton-docs.factor @@ -2,27 +2,33 @@ USING: help.markup help.syntax kernel words ; IN: classes.singleton ARTICLE: "singletons" "Singleton classes" -"A singleton is a class with only one instance and with no state. Methods may dispatch off of singleton classes." +"A singleton is a class with only one instance and with no state." { $subsection POSTPONE: SINGLETON: } -{ $subsection define-singleton-class } ; +{ $subsection define-singleton-class } +"The set of all singleton classes is itself a class:" +{ $subsection singleton-class? } +{ $subsection singleton-class } ; HELP: SINGLETON: -{ $syntax "SINGLETON: class" -} { $values +{ $syntax "SINGLETON: class" } +{ $values { "class" "a new singleton to define" } -} { $description - "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton." -} { $examples +} +{ $description + "Defines a new singleton class. The class word itself is the sole instance of the singleton class." +} +{ $examples { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } -} { $see-also - POSTPONE: PREDICATE: } ; HELP: define-singleton-class { $values { "word" "a new word" } } { $description - "Defines a newly created word to be a singleton class." } ; + "Defines a singleton class. This is the run-time equivalent of " { $link POSTPONE: SINGLETON: } "." } ; { POSTPONE: SINGLETON: define-singleton-class } related-words +HELP: singleton-class +{ $class-description "The class of singleton classes." } ; + ABOUT: "singletons" diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 664f0545fa..cdfdee9717 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -3,48 +3,148 @@ classes.tuple.private classes slots quotations words arrays generic.standard sequences definitions compiler.units ; IN: classes.tuple -ARTICLE: "tuple-constructors" "Constructors" -"Tuples are created by calling one of two words:" -{ $subsection construct-empty } -{ $subsection construct-boa } -"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "" } "." +ARTICLE: "parametrized-constructors" "Parameterized constructors" +"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack." $nl +"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:" +{ $code + "TUPLE: vehicle max-speed occupants ;" + "" + ": add-occupant ( person vehicle -- ) occupants>> push ;" + "" + "TUPLE: car < vehicle engine ;" + ": ( max-speed engine -- car )" + " car new" + " V{ } clone >>occupants" + " swap >>engine" + " swap >>max-speed ;" + "" + "TUPLE: aeroplane < vehicle max-altitude ;" + ": ( max-speed max-altitude -- aeroplane )" + " aeroplane new" + " V{ } clone >>occupants" + " swap >>max-altitude" + " swap >>max-speed ;" +} +"The two constructors depend on the implementation of " { $snippet "vehicle" } " because they are responsible for initializing the " { $snippet "occupants" } " slot to an empty vector. If this slot is changed to contain a hashtable instead, there will be two places instead of one. A better approach is to use a parametrized constructor for vehicles:" +{ $code + "TUPLE: vehicle max-speed occupants ;" + "" + ": add-occupant ( person vehicle -- ) occupants>> push ;" + "" + ": new-vehicle ( class -- vehicle )" + " new" + " V{ } clone >>occupants ;" + "" + "TUPLE: car < vehicle engine ;" + ": ( max-speed engine -- car )" + " car new-vehicle" + " swap >>engine" + " swap >>max-speed ;" + "" + "TUPLE: aeroplane < vehicle max-altitude ;" + ": ( max-speed max-altitude -- aeroplane )" + " aeroplane new-vehicle" + " swap >>max-altitude" + " swap >>max-speed ;" +} +"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ; + +ARTICLE: "tuple-constructors" "Tuple constructors" +"Tuples are created by calling one of two constructor primitives:" +{ $subsection new } +{ $subsection boa } "A shortcut for defining BOA constructors:" { $subsection POSTPONE: C: } +"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "" } "." +$nl +"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers." +$nl "Examples of constructors:" { $code "TUPLE: color red green blue alpha ;" "" + "! The following two are equivalent" "C: rgba" - ": color construct-boa ; ! identical to above" + ": color boa ;" "" + "! We can define constructors which call other constructors" ": f ;" "" - ": construct-empty ;" - ": f f f f ; ! identical to above" + "! The following two are equivalent" + ": color new ;" + ": f f f f ;" +} +{ $subsection "parametrized-constructors" } ; + +ARTICLE: "tuple-inheritance-example" "Tuple subclassing example" +"Rectangles, parallelograms and circles are all shapes. We support two operations on shapes:" +{ $list + "Computing the area" + "Computing the perimiter" +} +"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimiter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:" +{ $code + "GENERIC: area ( shape -- n )" + "GENERIC: perimiter ( shape -- n )" + "" + "TUPLE: shape ;" + "" + "TUPLE: circle < shape radius ;" + "M: area circle radius>> sq pi * ;" + "M: perimiter circle radius>> 2 * pi * ;" + "" + "TUPLE: quad < shape width height" + "M: area quad [ width>> ] [ height>> ] bi * ;" + "" + "TUPLE: rectangle < quad ;" + "M: rectangle perimiter [ width>> 2 * ] [ height>> 2 * ] bi + ;" + "" + ": hypot ( a b -- c ) [ sq ] bi@ + sqrt ;" + "" + "TUPLE: parallelogram < quad skew ;" + "M: parallelogram perimiter" + " [ width>> 2 * ] [ [ height>> ] [ skew>> ] bi hypot 2 * ] bi + ;" } ; -ARTICLE: "tuple-delegation" "Tuple delegation" -"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown." -{ $subsection delegate } -{ $subsection set-delegate } -"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution." +ARTICLE: "tuple-inheritance-anti-example" "When not to use tuple subclassing" +"Tuple subclassing should only be used for " { $emphasis "is-a" } " relationships; for example, a car " { $emphasis "is a" } " vehicle, and a circle " { $emphasis "is a" } " shape." +{ $heading "Anti-pattern #1: subclassing for has-a" } +"Subclassing should not be used for " { $emphasis "has-a" } " relationships. For example, if a shape " { $emphasis "has a" } " color, then " { $snippet "shape" } " should not subclass " { $snippet "color" } ". Using tuple subclassing in inappropriate situations leads to code which is more brittle and less flexible than it should be." $nl -"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object." +"For example, suppose that " { $snippet "shape" } " inherits from " { $snippet "color" } ":" +{ $code + "TUPLE: color r g b ;" + "TUPLE: shape < color ... ;" +} +"Now, the implementation of " { $snippet "shape" } " depends on a specific representation of colors as RGB colors. If a new generic color protocol is devised which also allows HSB and YUV colors to be used, the shape class will not be able to take advantage of them without changes. A better approach is to store the color in a slot:" +{ $code + "TUPLE: rgb-color r g b ;" + "TUPLE: hsv-color h s v ;" + "..." + "TUPLE: shape color ... ;" +} +"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships." +{ $heading "Anti-pattern #2: subclassing for implementation sharing only" } +"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used." $nl -"A pair of words examine delegation chains:" -{ $subsection delegates } -{ $subsection is? } -"An example:" -{ $example - "TUPLE: ellipse center radius ;" - "TUPLE: colored color ;" - "{ 0 0 } 10 \"my-ellipse\" set" - "{ 1 0 0 } \"my-shape\" set" - "\"my-ellipse\" get \"my-shape\" get set-delegate" - "\"my-shape\" get dup color>> swap center>> .s" - "{ 0 0 }\n{ 1 0 0 }" -} ; +"There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "." +$nl +"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes." +{ $heading "Anti-pattern #3: subclassing to override a method definition" } +"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor." +{ $see-also "parametrized-constructors" } ; + +ARTICLE: "tuple-subclassing" "Tuple subclassing" +"Tuple subclassing can be used to express natural relationships between classes at the language level. For example, every car " { $emphasis "is a" } " vehicle, so if the " { $snippet "car" } " class subclasses the " { $snippet "vehicle" } " class, it can " { $emphasis "inherit" } " the slots and methods of " { $snippet "vehicle" } "." +$nl +"To define one tuple class as a subclass of another, use the optional superclass parameter to " { $link POSTPONE: TUPLE: } ":" +{ $code + "TUPLE: subclass < superclass ... ;" +} +{ $subsection "tuple-inheritance-example" } +{ $subsection "tuple-inheritance-anti-example" } +{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ; ARTICLE: "tuple-introspection" "Tuple introspection" "In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way." @@ -67,11 +167,11 @@ ARTICLE: "tuple-examples" "Tuple examples" } "We can define a constructor which makes an empty employee:" { $code ": ( -- employee )" - " employee construct-empty ;" } + " employee new ;" } "Or we may wish the default constructor to always give employees a starting salary:" { $code ": ( -- employee )" - " employee construct-empty" + " employee new" " 40000 >>salary ;" } "We can define more refined constructors:" @@ -81,7 +181,7 @@ ARTICLE: "tuple-examples" "Tuple examples" "An alternative strategy is to define the most general BOA constructor first:" { $code ": ( name position -- person )" - " 40000 employee construct-boa ;" + " 40000 employee boa ;" } "Now we can define more specific constructors:" { $code @@ -94,7 +194,7 @@ ARTICLE: "tuple-examples" "Tuple examples" "SYMBOL: checks" "" ": ( to amount -- check )" - " checks counter check construct-boa ;" + " checks counter check boa ;" "" ": biweekly-paycheck ( employee -- check )" " dup name>> swap salary>> 26 / ;" @@ -119,7 +219,28 @@ ARTICLE: "tuple-examples" "Tuple examples" ": promote ( person -- person )" " [ 1.2 * ] change-salary" " [ next-position ] change-position ;" -} ; +} +"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ; + +ARTICLE: "tuple-redefinition" "Tuple redefinition" +"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses." +$nl +"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "." +$nl +"There are three ways to change the list of effective slots of a class:" +{ $list + "Adding or removing direct slots of the class" + "Adding or removing direct slots of a superclass of the class" + "Changing the inheritance hierarchy by redefining a class to have a different superclass" +} +"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:" +{ $list + "If any slots were removed, the values are removed from the instance and are lost forever." + { "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." } + "If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory." + "If the number or order of effective slots changes, any BOA constructors are recompiled." +} +"Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ; ARTICLE: "tuples" "Tuples" "Tuples are user-defined classes composed of named slots." @@ -132,22 +253,16 @@ $nl { $subsection "accessors" } "Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:" { $subsection "tuple-constructors" } -"Further topics:" -{ $subsection "tuple-delegation" } +"Expressing relationships through the object system:" +{ $subsection "tuple-subclassing" } +"Introspection:" { $subsection "tuple-introspection" } +"Tuple classes can be redefined; this updates existing instances:" +{ $subsection "tuple-redefinition" } "Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ; ABOUT: "tuples" -HELP: delegate -{ $values { "obj" object } { "delegate" object } } -{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." } -{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ; - -HELP: set-delegate -{ $values { "delegate" object } { "tuple" tuple } } -{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ; - HELP: tuple= { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } } { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } @@ -179,12 +294,12 @@ $low-level-note ; HELP: tuple-slots { $values { "tuple" tuple } { "seq" sequence } } -{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ; +{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ; { tuple-slots tuple>array } related-words HELP: define-tuple-slots -{ $values { "class" tuple-class } { "slots" "a sequence of strings" } } +{ $values { "class" tuple-class } } { $description "Defines slot accessor and mutator words for the tuple." } $low-level-note ; @@ -201,43 +316,33 @@ HELP: define-tuple-class { tuple-class define-tuple-class POSTPONE: TUPLE: } related-words -HELP: delegates -{ $values { "obj" object } { "seq" sequence } } -{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ; - -HELP: is? -{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } } -{ $description "Tests if the object or one of its delegates satisfies the predicate quotation." -$nl -"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ; - HELP: >tuple { $values { "seq" sequence } { "tuple" tuple } } -{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots." +{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots." $nl "If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." } { $errors "Throws an error if the first element of the sequence is not a tuple class word." } ; HELP: tuple>array ( tuple -- array ) { $values { "tuple" tuple } { "array" array } } -{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ; +{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ; HELP: ( layout -- tuple ) { $values { "layout" tuple-layout } { "tuple" tuple } } -{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ; +{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ; HELP: ( ... layout -- tuple ) { $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } } -{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ; +{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ; -HELP: construct-empty +HELP: new { $values { "class" tuple-class } { "tuple" tuple } } { $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." } { $examples { $example "USING: kernel prettyprint ;" "TUPLE: employee number name department ;" - "employee construct-empty ." + "employee new ." "T{ employee f f f f }" } } ; @@ -259,12 +364,12 @@ HELP: construct " color construct ;" } "The last definition is actually equivalent to the following:" - { $code ": ( r g b a -- color ) rgba construct-boa ;" } + { $code ": ( r g b a -- color ) rgba boa ;" } "Which can be abbreviated further:" { $code "C: color" } } ; -HELP: construct-boa +HELP: boa { $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } } { $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." } -{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ; +{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index a8e9066f56..ce6fd9367c 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -7,7 +7,7 @@ calendar prettyprint io.streams.string splitting inspector ; IN: classes.tuple.tests TUPLE: rect x y w h ; -: rect construct-boa ; +: rect boa ; : move ( x rect -- rect ) [ + ] change-x ; @@ -16,25 +16,6 @@ TUPLE: rect x y w h ; [ t ] [ 10 20 30 40 dup clone 0 swap move = ] unit-test -GENERIC: delegation-test -M: object delegation-test drop 3 ; -TUPLE: quux-tuple ; -: quux-tuple construct-empty ; -M: quux-tuple delegation-test drop 4 ; -TUPLE: quuux-tuple ; -: { set-delegate } quuux-tuple construct ; - -[ 3 ] [ delegation-test ] unit-test - -GENERIC: delegation-test-2 -TUPLE: quux-tuple-2 ; -: quux-tuple-2 construct-empty ; -M: quux-tuple-2 delegation-test-2 drop 4 ; -TUPLE: quuux-tuple-2 ; -: { set-delegate } quuux-tuple-2 construct ; - -[ 4 ] [ delegation-test-2 ] unit-test - ! Make sure we handle tuple class redefinition TUPLE: redefinition-test ; @@ -102,11 +83,6 @@ C: empty [ t ] [ hashcode fixnum? ] unit-test -TUPLE: delegate-clone ; - -[ T{ delegate-clone T{ empty f } } ] -[ T{ delegate-clone T{ empty f } } clone ] unit-test - ! Compiler regression [ t length ] [ object>> t eq? ] must-fail-with @@ -222,8 +198,8 @@ SYMBOL: not-a-tuple-class ] unit-test ! Missing check -[ not-a-tuple-class construct-boa ] must-fail -[ not-a-tuple-class construct-empty ] must-fail +[ not-a-tuple-class boa ] must-fail +[ not-a-tuple-class new ] must-fail TUPLE: erg's-reshape-problem a b c d ; @@ -231,8 +207,8 @@ C: erg's-reshape-problem ! We want to make sure constructors are recompiled when ! tuples are reshaped -: cons-test-1 \ erg's-reshape-problem construct-empty ; -: cons-test-2 \ erg's-reshape-problem construct-boa ; +: cons-test-1 \ erg's-reshape-problem new ; +: cons-test-2 \ erg's-reshape-problem boa ; "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval @@ -242,7 +218,7 @@ C: erg's-reshape-problem [ "IN: classes.tuple.tests SYMBOL: not-a-class C: not-a-class" eval -] [ [ no-tuple-class? ] is? ] must-fail-with +] [ error>> no-tuple-class? ] must-fail-with ! Inheritance TUPLE: computer cpu ram ; @@ -512,7 +488,7 @@ USE: vocabs ] with-compilation-unit ] unit-test -[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with +[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with ! Accessors not being forgotten... [ [ ] ] [ @@ -553,3 +529,15 @@ TUPLE: another-forget-accessors-test ; ] unit-test [ t ] [ \ another-forget-accessors-test class? ] unit-test + +! Shadowing test +[ f ] [ + t parser-notes? [ + [ + "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval + ] with-string-writer empty? + ] with-variable +] unit-test + +! Missing error check +[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index b1cb3f8a66..c14205e1d9 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -7,10 +7,6 @@ classes classes.private slots.deprecated slots.private slots compiler.units math.private accessors assocs ; IN: classes.tuple -M: tuple delegate 2 slot ; - -M: tuple set-delegate 2 set-slot ; - M: tuple class 1 slot 2 slot { word } declare ; ERROR: no-tuple-class class ; @@ -44,7 +40,7 @@ PRIVATE> >r copy-tuple-slots r> layout-class prefix ; -: tuple-slots ( tuple -- array ) +: tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; : slots>tuple ( tuple class -- array ) @@ -52,11 +48,17 @@ PRIVATE> [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each ] keep ; -: >tuple ( tuple -- array ) +: >tuple ( tuple -- seq ) unclip slots>tuple ; : slot-names ( class -- seq ) - "slot-names" word-prop ; + "slot-names" word-prop + [ dup array? [ second ] when ] map ; + +: all-slot-names ( class -- slots ) + superclasses [ slot-names ] map concat \ class prefix ; + +ERROR: bad-superclass class ; over superclass-size 2 + simple-slots ; : define-tuple-slots ( class -- ) - dup dup slot-names generate-tuple-slots + dup dup "slot-names" word-prop generate-tuple-slots [ "slots" set-word-prop ] [ define-accessors ] ! new [ define-slots ] ! old @@ -122,9 +124,6 @@ PRIVATE> : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: all-slot-names ( class -- slots ) - superclasses [ slot-names ] map concat \ class prefix ; - : compute-slot-permutation ( class old-slot-names -- permutation ) >r all-slot-names r> [ index ] curry map ; @@ -177,7 +176,7 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ changed-word ] + [ changed-definition ] [ redefined ] tri ] each-subclass @@ -188,21 +187,28 @@ M: tuple-class update-class : tuple-class-unchanged? ( class superclass slots -- ? ) rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; +: valid-superclass? ( class -- ? ) + [ tuple-class? ] [ tuple eq? ] bi or ; + +: check-superclass ( superclass -- ) + dup valid-superclass? [ bad-superclass ] unless drop ; + PRIVATE> GENERIC# define-tuple-class 2 ( class superclass slots -- ) M: word define-tuple-class + over check-superclass define-new-tuple-class ; M: tuple-class define-tuple-class 3dup tuple-class-unchanged? - [ 3dup redefine-tuple-class ] unless + [ over check-superclass 3dup redefine-tuple-class ] unless 3drop ; : define-error-class ( class superclass slots -- ) [ define-tuple-class ] [ 2drop ] 3bi - dup [ construct-boa throw ] curry define ; + dup [ boa throw ] curry define ; M: tuple-class reset-class [ @@ -228,9 +234,10 @@ M: tuple equal? M: tuple hashcode* [ - dup tuple-size -rot 0 -rot [ - swapd array-nth hashcode* bitxor - ] 2curry reduce + [ class hashcode ] [ tuple-size ] [ ] tri + >r rot r> [ + swapd array-nth hashcode* sequence-hashcode-step + ] 2curry each ] recursive-hashcode ; ! Deprecated diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor index 237f32c3e0..91726b6697 100755 --- a/core/classes/union/union-docs.factor +++ b/core/classes/union/union-docs.factor @@ -11,7 +11,9 @@ ARTICLE: "unions" "Union classes" { $subsection members } "The set of union classes is a class:" { $subsection union-class } -{ $subsection union-class? } ; +{ $subsection union-class? } +"Unions are used to define behavior shared between a fixed set of classes." +{ $see-also "mixins" "tuple-subclassing" } ; ABOUT: "unions" diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index f497fd20e5..54c62c44fa 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -64,9 +64,9 @@ HELP: alist>quot { $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ; HELP: cond -{ $values { "assoc" "a sequence of quotation pairs" } } +{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } } { $description - "Calls the second quotation in the first pair whose first quotation yields a true value." + "Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value." $nl "The following two phrases are equivalent:" { $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" } @@ -78,7 +78,7 @@ HELP: cond "{" " { [ dup 0 > ] [ \"positive\" ] }" " { [ dup 0 < ] [ \"negative\" ] }" - " { [ dup zero? ] [ \"zero\" ] }" + " [ \"zero\" ]" "} cond" } } ; @@ -88,9 +88,9 @@ HELP: no-cond { $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ; HELP: case -{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } } +{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } } { $description - "Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation." + "Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation." $nl "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied." $nl diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 8abc53e43f..b612669b71 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,7 +1,54 @@ -IN: combinators.tests USING: alien strings kernel math tools.test io prettyprint -namespaces combinators words ; +namespaces combinators words classes sequences ; +IN: combinators.tests +! Compiled +: cond-test-1 ( obj -- str ) + { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond ; + +\ cond-test-1 must-infer + +[ "even" ] [ 2 cond-test-1 ] unit-test +[ "odd" ] [ 3 cond-test-1 ] unit-test + +: cond-test-2 ( obj -- str ) + { + { [ dup t = ] [ drop "true" ] } + { [ dup f = ] [ drop "false" ] } + [ drop "something else" ] + } cond ; + +\ cond-test-2 must-infer + +[ "true" ] [ t cond-test-2 ] unit-test +[ "false" ] [ f cond-test-2 ] unit-test +[ "something else" ] [ "ohio" cond-test-2 ] unit-test + +: cond-test-3 ( obj -- str ) + { + [ drop "something else" ] + { [ dup t = ] [ drop "true" ] } + { [ dup f = ] [ drop "false" ] } + } cond ; + +\ cond-test-3 must-infer + +[ "something else" ] [ t cond-test-3 ] unit-test +[ "something else" ] [ f cond-test-3 ] unit-test +[ "something else" ] [ "ohio" cond-test-3 ] unit-test + +: cond-test-4 ( -- ) + { + } cond ; + +\ cond-test-4 must-infer + +[ cond-test-4 ] [ class \ no-cond = ] must-fail-with + +! Interpreted [ "even" ] [ 2 { { [ dup 2 mod 0 = ] [ drop "even" ] } @@ -21,11 +68,66 @@ namespaces combinators words ; { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] unit-test -: case-test-1 +[ "neither" ] [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + [ drop "neither" ] + } cond +] unit-test + +[ "neither" ] [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + [ drop "neither" ] + } cond +] unit-test + +[ "early" ] [ + 2 { + { [ dup 2 mod 1 = ] [ drop "odd" ] } + [ drop "early" ] + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ "really early" ] [ + 2 { + [ drop "really early" ] + { [ dup 2 mod 1 = ] [ drop "odd" ] } + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ { } cond ] [ class \ no-cond = ] must-fail-with + +[ "early" ] [ + 2 { + { [ dup 2 mod 1 = ] [ drop "odd" ] } + [ drop "early" ] + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ "really early" ] [ + 2 { + [ drop "really early" ] + { [ dup 2 mod 1 = ] [ drop "odd" ] } + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ { } cond ] [ class \ no-cond = ] must-fail-with + +! Compiled +: case-test-1 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -33,6 +135,8 @@ namespaces combinators words ; { 4 [ "four" ] } } case ; +\ case-test-1 must-infer + [ "two" ] [ 2 case-test-1 ] unit-test ! Interpreted @@ -40,7 +144,7 @@ namespaces combinators words ; [ "x" case-test-1 ] must-fail -: case-test-2 +: case-test-2 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -49,12 +153,14 @@ namespaces combinators words ; [ sq ] } case ; +\ case-test-2 must-infer + [ 25 ] [ 5 case-test-2 ] unit-test ! Interpreted [ 25 ] [ 5 \ case-test-2 word-def call ] unit-test -: case-test-3 +: case-test-3 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -65,8 +171,122 @@ namespaces combinators words ; [ sq ] } case ; +\ case-test-3 must-infer + [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test +: case-const-1 1 ; +: case-const-2 2 ; inline + +! Compiled +: case-test-4 ( obj -- str ) + { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case ; + +\ case-test-4 must-infer + +[ "uno" ] [ 1 case-test-4 ] unit-test +[ "dos" ] [ 2 case-test-4 ] unit-test +[ "tres" ] [ 3 case-test-4 ] unit-test +[ "demasiado" ] [ 100 case-test-4 ] unit-test + +: case-test-5 ( obj -- ) + { + { case-const-1 [ "uno" print ] } + { case-const-2 [ "dos" print ] } + { 3 [ "tres" print ] } + { 4 [ "cuatro" print ] } + { 5 [ "cinco" print ] } + [ drop "demasiado" print ] + } case ; + +\ case-test-5 must-infer + +[ ] [ 1 case-test-5 ] unit-test + +! Interpreted +[ "uno" ] [ + 1 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "dos" ] [ + 2 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "tres" ] [ + 3 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "demasiado" ] [ + 100 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +: do-not-call "do not call" throw ; + +: test-case-6 + { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case ; + +[ "three" ] [ 3 test-case-6 ] unit-test +[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test + +[ "three" ] [ + 3 { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + +[ "do-not-call" ] [ + [ do-not-call ] first { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + +[ "do-not-call" ] [ + \ do-not-call { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + ! Interpreted [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 139c6d8fdf..e3d0f88680 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -3,7 +3,7 @@ IN: combinators USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors -hashtables sorting ; +hashtables sorting words sets ; : cleave ( x seq -- ) [ call ] with each ; @@ -34,13 +34,24 @@ hashtables sorting ; ERROR: no-cond ; : cond ( assoc -- ) - [ first call ] find nip dup [ second call ] [ no-cond ] if ; + [ dup callable? [ drop t ] [ first call ] if ] find nip + [ dup callable? [ call ] [ second call ] if ] + [ no-cond ] if* ; ERROR: no-case ; +: case-find ( obj assoc -- obj' ) + [ + dup array? [ + dupd first dup word? [ + execute + ] [ + dup wrapper? [ wrapped ] when + ] if = + ] [ quotation? ] if + ] find nip ; : case ( obj assoc -- ) - [ dup array? [ dupd first = ] [ quotation? ] if ] find nip - { + case-find { { [ dup array? ] [ nip second call ] } { [ dup quotation? ] [ call ] } { [ dup not ] [ no-case ] } @@ -59,6 +70,10 @@ ERROR: no-case ; M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ; +M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ; + +M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ; + M: hashtable hashcode* [ dup assoc-size 1 number= @@ -69,11 +84,14 @@ M: hashtable hashcode* [ rot \ if 3array append [ ] like ] assoc-each ; : cond>quot ( assoc -- quot ) + [ dup callable? [ [ t ] swap 2array ] when ] map reverse [ no-cond ] swap alist>quot ; : linear-case-quot ( default assoc -- quot ) - [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map - alist>quot ; + [ + [ 1quotation \ dup prefix \ = suffix ] + [ \ drop prefix ] bi* + ] assoc-map alist>quot ; : (distribute-buckets) ( buckets pair keys -- ) dup t eq? [ @@ -131,7 +149,9 @@ M: hashtable hashcode* dup empty? [ drop ] [ - dup length 4 <= [ + dup length 4 <= + over keys [ word? ] contains? or + [ linear-case-quot ] [ dup keys contiguous-range? [ diff --git a/core/command-line/command-line-docs.factor b/core/command-line/command-line-docs.factor index e41d316792..88ea43be20 100644 --- a/core/command-line/command-line-docs.factor +++ b/core/command-line/command-line-docs.factor @@ -7,9 +7,10 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM" { { $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" } - { { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } } - { { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" } + { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" } + { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } } + { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" } + { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" } { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" } { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" } } diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index a0599f79a1..806ea914bb 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces arrays sequences io inference.backend -inference.state generator debugger math.parser prettyprint words -compiler.units continuations vocabs assocs alien.compiler dlists -optimizer definitions math compiler.errors threads graphs -generic inference ; +inference.state generator debugger words compiler.units +continuations vocabs assocs alien.compiler dlists optimizer +definitions math compiler.errors threads graphs generic +inference ; IN: compiler : ripple-up ( word -- ) @@ -20,7 +20,7 @@ IN: compiler : finish-compile ( word effect dependencies -- ) >r dupd save-effect r> over compiled-unxref - over crossref? [ compiled-xref ] [ 2drop ] if ; + over compiled-crossref? [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor index 0d457a8310..81ab750305 100755 --- a/core/compiler/tests/float.factor +++ b/core/compiler/tests/float.factor @@ -2,7 +2,7 @@ IN: compiler.tests USING: compiler.units kernel kernel.private memory math math.private tools.test math.floats.private ; -[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test +[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test [ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 13b7de6987..dce2ec562a 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -48,7 +48,7 @@ IN: compiler.tests [ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test -[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test +[ 2 3 ] [ 1 [ { [ gc 1 ] [ gc 2 ] } dispatch 3 ] compile-call ] unit-test ! Labels @@ -187,7 +187,7 @@ DEFER: countdown-b { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] compile-call ] unit-test @@ -196,7 +196,7 @@ DEFER: countdown-b [ 3 { { [ dup fixnum? ] [ ] } - { [ t ] [ drop t ] } + [ drop t ] } cond ] compile-call ] unit-test diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index bdbc985078..004d088343 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -2,9 +2,9 @@ IN: compiler.tests USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences -words kernel math effects definitions compiler.units ; +words kernel math effects definitions compiler.units accessors ; -: ( n -- vreg ) T{ int-regs } ; +: ( n -- vreg ) int-regs ; [ [ ] [ init-templates ] unit-test @@ -15,18 +15,18 @@ words kernel math effects definitions compiler.units ; [ ] [ compute-free-vregs ] unit-test - [ f ] [ 0 T{ int-regs } free-vregs member? ] unit-test + [ f ] [ 0 int-regs free-vregs member? ] unit-test [ f ] [ [ copy-templates 1 phantom-push compute-free-vregs - 1 T{ int-regs } free-vregs member? + 1 int-regs free-vregs member? ] with-scope ] unit-test - [ t ] [ 1 T{ int-regs } free-vregs member? ] unit-test + [ t ] [ 1 int-regs free-vregs member? ] unit-test ] with-scope [ @@ -173,12 +173,12 @@ SYMBOL: template-chosen ] unit-test [ ] [ - 2 phantom-d get phantom-input + 2 phantom-datastack get phantom-input [ { { f "a" } { f "b" } } lazy-load ] { } make drop ] unit-test [ t ] [ - phantom-d get [ cached? ] all? + phantom-datastack get stack>> [ cached? ] all? ] unit-test ! >r diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 565c045e2a..14d75cdc03 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts -words definitions compiler.units io combinators ; +words definitions compiler.units io combinators vectors ; IN: compiler.tests ! Oops! @@ -202,3 +202,56 @@ TUPLE: my-tuple ; ] [ 2drop no-case ] if ] compile-call ] unit-test + +: float-spill-bug + { + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + [ dup float+ ] + } cleave ; + +[ t ] [ \ float-spill-bug compiled? ] unit-test + +! Regression +: dispatch-alignment-regression ( -- c ) + { tuple vector } 3 slot { word } declare + dup 1 slot 0 fixnum-bitand { [ ] } dispatch ; + +[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test + +[ vector ] [ dispatch-alignment-regression ] unit-test diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index 5843575eeb..2b43ac6f56 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -4,16 +4,16 @@ USING: kernel tools.test compiler.units ; TUPLE: color red green blue ; [ T{ color f 1 2 3 } ] -[ 1 2 3 [ color construct-boa ] compile-call ] unit-test +[ 1 2 3 [ color boa ] compile-call ] unit-test [ 1 3 ] [ - 1 2 3 color construct-boa + 1 2 3 color boa [ { color-red color-blue } get-slots ] compile-call ] unit-test [ T{ color f 10 2 20 } ] [ 10 20 - 1 2 3 color construct-boa [ + 1 2 3 color boa [ [ { set-color-red set-color-blue } set-slots ] compile-call @@ -21,12 +21,4 @@ TUPLE: color red green blue ; ] unit-test [ T{ color f f f f } ] -[ [ color construct-empty ] compile-call ] unit-test - -[ T{ color "a" f "b" f } ] [ - "a" "b" - [ { set-delegate set-color-green } color construct ] - compile-call -] unit-test - -[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test +[ [ color new ] compile-call ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index f87c1ec985..65e57a8912 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -10,7 +10,7 @@ SYMBOL: new-definitions TUPLE: redefine-error def ; : redefine-error ( definition -- ) - \ redefine-error construct-boa + \ redefine-error boa { { "Continue" t } } throw-restarts drop ; : add-once ( key assoc -- ) @@ -56,24 +56,24 @@ GENERIC: definitions-changed ( assoc obj -- ) [ drop word? ] assoc-subset [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ; -: changed-definitions ( -- assoc ) +: updated-definitions ( -- assoc ) H{ } clone dup forgotten-definitions get update dup new-definitions get first update dup new-definitions get second update - dup changed-words get update + dup changed-definitions get update dup dup changed-vocabs update ; : compile ( words -- ) recompile-hook get call - dup [ drop crossref? ] assoc-contains? + dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap ; SYMBOL: outdated-tuples SYMBOL: update-tuples-hook : call-recompile-hook ( -- ) - changed-words get keys + changed-definitions get keys [ word? ] subset compiled-usages recompile-hook get call ; : call-update-tuples-hook ( -- ) @@ -82,12 +82,12 @@ SYMBOL: update-tuples-hook : finish-compilation-unit ( -- ) call-recompile-hook call-update-tuples-hook - dup [ drop crossref? ] assoc-contains? modify-code-heap - changed-definitions notify-definition-observers ; + dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap + updated-definitions notify-definition-observers ; : with-compilation-unit ( quot -- ) [ - H{ } clone changed-words set + H{ } clone changed-definitions set H{ } clone forgotten-definitions set H{ } clone outdated-tuples set new-definitions set diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index ca7af930f2..b1db09b6bc 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private continuations.private parser vectors arrays namespaces -assocs words quotations ; +assocs words quotations io ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -17,6 +17,25 @@ ARTICLE: "errors-post-mortem" "Post-mortem error inspection" { $subsection error-continuation } "Developer tools for inspecting these values are found in " { $link "debugger" } "." ; +ARTICLE: "errors-anti-examples" "Common error handling pitfalls" +"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind." +{ $heading "Anti-pattern #1: Ignoring errors" } +"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user." +{ $heading "Anti-pattern #2: Catching errors too early" } +"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible." +$nl +"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically." +{ $heading "Anti-pattern #3: Dropping and rethrowing" } +"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught." +{ $heading "Anti-pattern #4: Logging and rethrowing" } +"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." +{ $heading "Anti-pattern #5: Leaking external resources" } +"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:" +{ $code + " ... do stuff ... dispose" +} +"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ; + ARTICLE: "errors" "Error handling" "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." $nl @@ -27,10 +46,13 @@ $nl { $subsection cleanup } { $subsection recover } { $subsection ignore-errors } +"Syntax sugar for defining errors:" +{ $subsection POSTPONE: ERROR: } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "debugger" } { $subsection "errors-post-mortem" } +{ $subsection "errors-anti-examples" } "When Factor encouters a critical error, it calls the following word:" { $subsection die } ; @@ -61,15 +83,18 @@ $nl "Another two words resume continuations:" { $subsection continue } { $subsection continue-with } -"Continuations serve as the building block for a number of higher-level abstractions." -{ $subsection "errors" } +"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; ABOUT: "continuations" HELP: dispose { $values { "object" "a disposable object" } } -{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." } +{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." +$nl +"No further operations can be performed on a disposable object after this call." +$nl +"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." } { $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ; HELP: with-disposal diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index d5ede60086..8b396763e1 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -46,8 +46,8 @@ IN: continuations.tests ! Weird PowerPC bug. [ ] [ [ "4" throw ] ignore-errors - data-gc - data-gc + gc + gc ] unit-test [ f ] [ { } kernel-error? ] unit-test diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index a2c296e8ce..cf67280cca 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -141,14 +141,9 @@ GENERIC: dispose ( object -- ) : with-disposal ( object quot -- ) over [ dispose ] curry [ ] cleanup ; inline -TUPLE: condition restarts continuation ; +TUPLE: condition error restarts continuation ; -: ( error restarts cc -- condition ) - { - set-delegate - set-condition-restarts - set-condition-continuation - } condition construct ; +C: condition ( error restarts cc -- condition ) : throw-restarts ( error restarts -- restart ) [ throw ] callcc1 2nip ; @@ -161,15 +156,14 @@ TUPLE: restart name obj continuation ; C: restart : restart ( restart -- ) - dup restart-obj swap restart-continuation continue-with ; + [ obj>> ] [ continuation>> ] bi continue-with ; M: object compute-restarts drop { } ; -M: tuple compute-restarts delegate compute-restarts ; - M: condition compute-restarts - [ delegate compute-restarts ] keep - [ condition-restarts ] keep - condition-continuation - [ ] curry { } assoc>map - append ; + [ error>> compute-restarts ] + [ + [ restarts>> ] + [ condition-continuation [ ] curry ] bi + { } assoc>map + ] bi append ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4670cf86d2..8c9db6c7e8 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -2,11 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel kernel.private math memory namespaces sequences layouts system hashtables classes alien -byte-arrays bit-arrays float-arrays combinators words ; +byte-arrays bit-arrays float-arrays combinators words sets ; IN: cpu.architecture ! A pseudo-register class for parameters spilled on the stack -TUPLE: stack-params ; +SINGLETON: stack-params ! Return values of this class go here GENERIC: return-reg ( register-class -- reg ) @@ -56,7 +56,7 @@ HOOK: %call cpu ( word -- ) HOOK: %jump-label cpu ( label -- ) ! Test if vreg is 'f' or not -HOOK: %jump-t cpu ( label -- ) +HOOK: %jump-f cpu ( label -- ) HOOK: %dispatch cpu ( -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index a1a4bd3809..1799411021 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -106,8 +106,8 @@ M: ppc %call ( label -- ) BL ; M: ppc %jump-label ( label -- ) B ; -M: ppc %jump-t ( label -- ) - 0 "flag" operand f v>operand CMPI BNE ; +M: ppc %jump-f ( label -- ) + 0 "flag" operand f v>operand CMPI BEQ ; M: ppc %dispatch ( -- ) [ @@ -146,11 +146,19 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ; M: int-regs %load-param-reg drop 1 rot local@ LWZ ; -: STF float-regs-size 4 = [ STFS ] [ STFD ] if ; +GENERIC: STF ( src dst off reg-class -- ) + +M: single-float-regs STF drop STFS ; + +M: double-float-regs STF drop STFD ; M: float-regs %save-param-reg >r 1 rot local@ r> STF ; -: LF float-regs-size 4 = [ LFS ] [ LFD ] if ; +GENERIC: LF ( dst src off reg-class -- ) + +M: single-float-regs LF drop LFS ; + +M: double-float-regs LF drop LFD ; M: float-regs %load-param-reg >r 1 rot local@ r> LF ; diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index d092473960..34e9900893 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -217,11 +217,11 @@ IN: cpu.ppc.intrinsics 2array define-if-intrinsics ; { - { fixnum< BLT } - { fixnum<= BLE } - { fixnum> BGT } - { fixnum>= BGE } - { eq? BEQ } + { fixnum< BGE } + { fixnum<= BGT } + { fixnum> BLE } + { fixnum>= BLT } + { eq? BNE } } [ first2 define-fixnum-jump ] each @@ -356,11 +356,11 @@ IN: cpu.ppc.intrinsics { { float "x" } { float "y" } } define-if-intrinsic ; { - { float< BLT } - { float<= BLE } - { float> BGT } - { float>= BGE } - { float= BEQ } + { float< BGE } + { float<= BGT } + { float> BLE } + { float>= BLT } + { float= BNE } } [ first2 define-float-jump ] each diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 4d447b38fc..985f717035 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -16,7 +16,6 @@ IN: cpu.x86.32 M: x86.32 ds-reg ESI ; M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; -M: x86.32 xt-reg ECX ; M: x86.32 stack-save-reg EDX ; M: temp-reg v>operand drop EBX ; @@ -155,7 +154,7 @@ M: x86.32 %box ( n reg-class func -- ) #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are #! boxing a parameter being passed to a callback from C. [ - T{ int-regs } box@ + int-regs box@ EDX over stack@ MOV EAX swap cell - stack@ MOV ] when* @@ -246,9 +245,8 @@ M: x86.32 %cleanup ( alien-node -- ) } { [ dup return>> large-struct? ] [ drop EAX PUSH ] - } { - [ t ] [ drop ] } + [ drop ] } cond ; M: x86.32 %unwind ( n -- ) %epilogue-later RET ; @@ -268,7 +266,7 @@ os windows? [ EDX 26 SHR EDX 1 AND { EAX EBX ECX EDX } [ POP ] each - JNE + JE ] { } define-if-intrinsic "-no-sse2" cli-args member? [ diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index d3ccffe00e..99f567f448 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -11,7 +11,6 @@ IN: cpu.x86.64 M: x86.64 ds-reg R14 ; M: x86.64 rs-reg R15 ; M: x86.64 stack-reg RSP ; -M: x86.64 xt-reg RCX ; M: x86.64 stack-save-reg RSI ; M: temp-reg v>operand drop RBX ; @@ -65,7 +64,7 @@ M: x86.64 %unbox ( n reg-class func -- ) over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; M: x86.64 %unbox-long-long ( n func -- ) - T{ int-regs } swap %unbox ; + int-regs swap %unbox ; M: x86.64 %unbox-struct-1 ( -- ) #! Alien must be in RDI. @@ -103,7 +102,7 @@ M: x86.64 %box ( n reg-class func -- ) f %alien-invoke ; M: x86.64 %box-long-long ( n func -- ) - T{ int-regs } swap %box ; + int-regs swap %box ; M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ; @@ -170,7 +169,7 @@ USE: cpu.x86.intrinsics ! 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 >> +stack-params "__stack_value" c-type set-c-type-reg-class >> : struct-types&offset ( struct-type -- pairs ) struct-type-fields [ @@ -192,7 +191,7 @@ M: struct-type flatten-value-type ( type -- seq ) ] [ struct-types&offset split-struct [ [ c-type c-type-reg-class ] map - T{ int-regs } swap member? + int-regs swap member? "void*" "double" ? c-type , ] each ] if ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 6c9a4dc05f..fa1c9c8768 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.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. USING: alien alien.c-types alien.compiler arrays cpu.x86.assembler cpu.architecture kernel kernel.private math @@ -9,7 +9,6 @@ IN: cpu.x86.architecture HOOK: ds-reg cpu HOOK: rs-reg cpu HOOK: stack-reg cpu -HOOK: xt-reg cpu HOOK: stack-save-reg cpu : stack@ stack-reg swap [+] ; @@ -22,7 +21,11 @@ M: rs-loc v>operand rs-loc-n rs-reg reg-stack ; M: int-regs %save-param-reg drop >r stack@ r> MOV ; M: int-regs %load-param-reg drop swap stack@ MOV ; -: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ; +GENERIC: MOVSS/D ( dst src reg-class -- ) + +M: single-float-regs MOVSS/D drop MOVSS ; + +M: double-float-regs MOVSS/D drop MOVSD ; M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ; @@ -43,13 +46,13 @@ M: x86 stack-frame ( n -- i ) 3 cells + 16 align cell - ; M: x86 %save-word-xt ( -- ) - xt-reg 0 MOV rc-absolute-cell rel-this ; + temp-reg v>operand 0 MOV rc-absolute-cell rel-this ; : factor-area-size 4 cells ; M: x86 %prologue ( n -- ) dup cell + PUSH - xt-reg PUSH + temp-reg v>operand PUSH stack-reg swap 2 cells - SUB ; M: x86 %epilogue ( n -- ) @@ -72,8 +75,8 @@ M: x86 %call ( label -- ) CALL ; M: x86 %jump-label ( label -- ) JMP ; -M: x86 %jump-t ( label -- ) - "flag" operand f v>operand CMP JNE ; +M: x86 %jump-f ( label -- ) + "flag" operand f v>operand CMP JE ; : code-alignment ( -- n ) building get length dup cell align swap - ; diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index a3ab256ea1..3ad7d4f7b5 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -104,7 +104,7 @@ M: indirect extended? indirect-base extended? ; canonicalize-ESP ; : ( base index scale displacement -- indirect ) - indirect construct-boa dup canonicalize ; + indirect boa dup canonicalize ; : reg-code "register" word-prop 7 bitand ; @@ -189,7 +189,7 @@ UNION: operand register indirect ; { { [ dup register-128? ] [ drop operand-64? ] } { [ dup not ] [ drop operand-64? ] } - { [ t ] [ nip operand-64? ] } + [ nip operand-64? ] } cond and ; : rex.r diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 80a786c9fa..c48f33b765 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -212,11 +212,11 @@ IN: cpu.x86.intrinsics 2array define-if-intrinsics ; { - { fixnum< JL } - { fixnum<= JLE } - { fixnum> JG } - { fixnum>= JGE } - { eq? JE } + { fixnum< JGE } + { fixnum<= JG } + { fixnum> JLE } + { fixnum>= JL } + { eq? JNE } } [ first2 define-fixnum-jump ] each diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor index 9c477b4132..fb96649753 100755 --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -27,11 +27,11 @@ IN: cpu.x86.sse2 { { float "x" } { float "y" } } define-if-intrinsic ; { - { float< JB } - { float<= JBE } - { float> JA } - { float>= JAE } - { float= JE } + { float< JAE } + { float<= JA } + { float> JBE } + { float>= JB } + { float= JNE } } [ first2 define-float-jump ] each diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 033ae0680c..827a5c4e8d 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -4,9 +4,9 @@ USING: arrays definitions generic hashtables inspector io kernel math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser classes.tuple continuations continuations.private combinators -generic.math io.streams.duplex classes compiler.units -generic.standard vocabs threads threads.private init -kernel.private libc io.encodings ; +generic.math io.streams.duplex classes.builtin classes +compiler.units generic.standard vocabs threads threads.private +init kernel.private libc io.encodings accessors ; IN: debugger GENERIC: error. ( error -- ) @@ -160,7 +160,7 @@ PREDICATE: kernel-error < array { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } - { [ t ] [ second 0 15 between? ] } + [ second 0 15 between? ] } cond ; : kernel-errors @@ -202,6 +202,12 @@ M: no-method error. M: no-math-method summary drop "No suitable arithmetic method" ; +M: no-next-method summary + drop "Executing call-next-method from least-specific method" ; + +M: inconsistent-next-method summary + drop "Executing call-next-method with inconsistent parameters" ; + M: stream-closed-twice summary drop "Attempt to perform I/O on closed stream" ; @@ -209,7 +215,10 @@ M: check-method summary drop "Invalid parameters for create-method" ; M: no-tuple-class summary - drop "Invalid class for define-constructor" ; + drop "BOA constructors can only be defined for tuple classes" ; + +M: bad-superclass summary + drop "Tuple classes can only inherit from other tuple classes" ; M: no-cond summary drop "Fall-through in cond" ; @@ -223,9 +232,11 @@ M: slice-error error. M: bounds-error summary drop "Sequence index out of bounds" ; -M: condition error. delegate error. ; +M: condition error. error>> error. ; -M: condition error-help drop f ; +M: condition summary error>> summary ; + +M: condition error-help error>> error-help ; M: assert summary drop "Assertion failed" ; diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index d855a14be9..d43c61ff70 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -12,8 +12,6 @@ $nl { $subsection forget } "Definitions can answer a sequence of definitions they directly depend on:" { $subsection uses } -"When a definition is changed, all definitions which depend on it are notified via a hook:" -{ $subsection redefined* } "Definitions must implement a few operations used for printing them in source form:" { $subsection synopsis* } { $subsection definer } @@ -108,11 +106,6 @@ HELP: usage { $description "Outputs a sequence of definitions that directly call the given definition." } { $notes "The sequence might include the definition itself, if it is a recursive word." } ; -HELP: redefined* -{ $values { "defspec" "a definition specifier" } } -{ $contract "Updates the definition to cope with a callee being redefined." } -$low-level-note ; - HELP: unxref { $values { "defspec" "a definition specifier" } } { $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." } diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 3dc28139ea..b20d81ec7c 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -2,26 +2,6 @@ IN: definitions.tests USING: tools.test generic kernel definitions sequences compiler.units words ; -TUPLE: combination-1 ; - -M: combination-1 perform-combination drop [ ] define ; - -M: combination-1 make-default-method 2drop [ "No method" throw ] ; - -SYMBOL: generic-1 - -[ - generic-1 T{ combination-1 } define-generic - - object \ generic-1 create-method [ ] define -] with-compilation-unit - -[ ] [ - [ - { combination-1 { object generic-1 } } forget-all - ] with-compilation-unit -] unit-test - GENERIC: some-generic ( a -- b ) USE: arrays diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index cec5109909..459512b83a 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -5,6 +5,13 @@ USING: kernel sequences namespaces assocs graphs ; ERROR: no-compilation-unit definition ; +SYMBOL: changed-definitions + +: changed-definition ( defspec -- ) + dup changed-definitions get + [ no-compilation-unit ] unless* + set-at ; + GENERIC: where ( defspec -- loc ) M: object where drop f ; @@ -42,13 +49,6 @@ M: object uses drop f ; : usage ( defspec -- seq ) \ f or crossref get at keys ; -GENERIC: redefined* ( defspec -- ) - -M: object redefined* drop ; - -: redefined ( defspec -- ) - [ crossref get at ] closure [ drop redefined* ] assoc-each ; - : unxref ( defspec -- ) dup uses crossref get remove-vertex ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index 28db6e1cbd..b0fe2a1157 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -1,5 +1,5 @@ USING: dlists dlists.private kernel tools.test random assocs -hashtables sequences namespaces sorting debugger io prettyprint +sets sequences namespaces sorting debugger io prettyprint math ; IN: dlists.tests @@ -79,7 +79,7 @@ IN: dlists.tests [ dlist-push-all ] keep [ dlist-delete-all ] keep dlist>array - ] 2keep seq-diff assert-same-elements + ] 2keep diff assert-same-elements ] unit-test [ ] [ diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 56134f3b54..e79907f11f 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -7,7 +7,7 @@ IN: dlists TUPLE: dlist front back length ; : ( -- obj ) - dlist construct-empty + dlist new 0 >>length ; : dlist-empty? ( dlist -- ? ) front>> not ; @@ -126,7 +126,7 @@ PRIVATE> { { [ over front>> over eq? ] [ drop pop-front* ] } { [ over back>> over eq? ] [ drop pop-back* ] } - { [ t ] [ unlink-node dec-length ] } + [ unlink-node dec-length ] } cond ; : delete-node-if* ( dlist quot -- obj/f ? ) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index aed4a64c6c..80a4f679c0 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -8,7 +8,7 @@ TUPLE: effect in out terminated? ; : ( in out -- effect ) dup { "*" } sequence= [ drop { } t ] [ f ] if - effect construct-boa ; + effect boa ; : effect-height ( effect -- n ) dup effect-out length swap effect-in length - ; @@ -20,7 +20,7 @@ TUPLE: effect in out terminated? ; { [ dup effect-terminated? ] [ f ] } { [ 2dup [ effect-in length ] bi@ > ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; GENERIC: (stack-picture) ( obj -- str ) diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index 33302572de..d25d447a46 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -24,7 +24,7 @@ M: float-array set-nth-unsafe M: float-array like drop dup float-array? [ >float-array ] unless ; -M: float-array new drop 0.0 ; +M: float-array new-sequence drop 0.0 ; M: float-array equal? over float-array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor index 2b023985a4..7f62f6f95c 100755 --- a/core/float-vectors/float-vectors.factor +++ b/core/float-vectors/float-vectors.factor @@ -7,7 +7,7 @@ IN: float-vectors vector ( float-array length -- float-vector ) - float-vector construct-boa ; inline + float-vector boa ; inline PRIVATE> @@ -22,7 +22,7 @@ M: float-vector like [ dup length float-array>vector ] [ >float-vector ] if ] unless ; -M: float-vector new +M: float-vector new-sequence drop [ 0.0 ] keep >fixnum float-array>vector ; M: float-vector equal? diff --git a/core/float-vectors/summary.txt b/core/float-vectors/summary.txt new file mode 100644 index 0000000000..c476f41a6e --- /dev/null +++ b/core/float-vectors/summary.txt @@ -0,0 +1 @@ +Growable float arrays diff --git a/core/float-vectors/tags.txt b/core/float-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/float-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 5cc0442464..920690e9d8 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -10,7 +10,7 @@ IN: generator.fixup TUPLE: frame-required n ; -: frame-required ( n -- ) \ frame-required construct-boa , ; +: frame-required ( n -- ) \ frame-required boa , ; : stack-frame-size ( code -- n ) no-stack-frame [ @@ -25,7 +25,7 @@ GENERIC: fixup* ( frame-size obj -- frame-size ) TUPLE: label offset ; -: