diff --git a/.gitignore b/.gitignore index 19ace1f500..7e1e52d866 100644 --- a/.gitignore +++ b/.gitignore @@ -18,4 +18,4 @@ factor temp logs work -misc/wordsize \ No newline at end of file +buildsupport/wordsize diff --git a/Makefile b/Makefile index 054d57b641..ecb333a0b2 100755 --- a/Makefile +++ b/Makefile @@ -45,8 +45,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ EXE_OBJS = $(PLAF_EXE_OBJS) -default: misc/wordsize - $(MAKE) `./misc/target` +default: build-support/wordsize + $(MAKE) `./build-support/target` help: @echo "Run '$(MAKE)' with one of the following parameters:" @@ -162,8 +162,8 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) -misc/wordsize: misc/wordsize.c - gcc misc/wordsize.c -o misc/wordsize +build-support/wordsize: build-support/wordsize.c + gcc build-support/wordsize.c -o build-support/wordsize clean: rm -f vm/*.o diff --git a/build-support/grovel.c b/build-support/grovel.c new file mode 100644 index 0000000000..600865cf39 --- /dev/null +++ b/build-support/grovel.c @@ -0,0 +1,157 @@ +#include + +#if defined(__FreeBSD__) + #define BSD + #define FREEBSD + #define UNIX +#endif + +#if defined(__NetBSD__) + #define BSD + #define NETBSD + #define UNIX +#endif + +#if (__OpenBSD__) + #define BSD + #define OPENBSD + #define UNIX +#endif + +#if defined(linux) + #define LINUX + #define UNIX +#endif + +#if defined(__amd64__) || defined(__x86_64__) + #define BIT64 +#else + #define BIT32 +#endif + +#if defined(UNIX) + #include + #include + #include + #include + #include + #include +#endif + +#define BL printf(" "); +#define QUOT printf("\""); +#define NL printf("\n"); +#define LB printf("{"); BL +#define RB BL printf("}"); +#define SEMI printf(";"); +#define grovel(t) printf("TYPEDEF: "); printf("%d", sizeof(t)); BL printf(#t); NL +#define grovel2impl(t,n) BL BL BL BL LB QUOT printf(#t); QUOT BL QUOT printf((n)); QUOT RB +#define grovel2(t,n) grovel2impl(t,n) NL +#define grovel2end(t,n) grovel2impl(t,n) BL SEMI NL +#define header(os) printf("vvv %s vvv", (os)); NL +#define footer(os) printf("^^^ %s ^^^", (os)); NL +#define header2(os,struct) printf("vvv %s %s vvv", (os), (struct)); NL +#define footer2(os,struct) printf("^^^ %s %s ^^^", (os), (struct)); NL +#define struct(n) printf("C-STRUCT: %s\n", (n)); +#define constant(n) printf("#define "); printf(#n); printf(" %d (HEX: %04x)", (n), (n)); NL + +void openbsd_types() +{ + header2("openbsd", "types"); + grovel(dev_t); + grovel(gid_t); + grovel(ino_t); + grovel(int32_t); + grovel(int64_t); + grovel(mode_t); + grovel(nlink_t); + grovel(off_t); + grovel(struct timespec); + grovel(uid_t); + footer2("openbsd", "types"); +} + +void openbsd_stat() +{ + header2("openbsd", "stat"); + struct("stat"); + grovel2(dev_t, "st_dev"); + grovel2(ino_t, "st_ino"); + grovel2(mode_t, "st_mode"); + grovel2(nlink_t, "st_nlink"); + grovel2(uid_t, "st_uid"); + grovel2(gid_t, "st_gid"); + grovel2(dev_t, "st_rdev"); + grovel2(int32_t, "st_lspare0"); + grovel2(struct timespec, "st_atim"); + grovel2(struct timespec, "st_mtim"); + grovel2(struct timespec, "st_ctim"); + grovel2(off_t, "st_size"); + grovel2(int64_t, "st_blocks"); + grovel2(u_int32_t, "st_blksize"); + grovel2(u_int32_t, "st_flags"); + grovel2(u_int32_t, "st_gen"); + grovel2(int32_t, "st_lspare1"); + grovel2(struct timespec, "st_birthtimespec"); + grovel2(int64_t, "st_qspare1"); + grovel2end(int64_t, "st_qspare2"); + footer2("openbsd", "stat"); +} + +void unix_types() +{ + grovel(dev_t); + grovel(gid_t); + grovel(ino_t); + grovel(int32_t); + grovel(int64_t); + grovel(mode_t); + grovel(nlink_t); + grovel(off_t); + grovel(struct timespec); + grovel(struct stat); + grovel(time_t); + grovel(uid_t); +} + +void unix_constants() +{ + constant(O_RDONLY); + constant(O_WRONLY); + constant(O_RDWR); + constant(O_APPEND); + constant(O_CREAT); + constant(O_TRUNC); + constant(O_EXCL); + constant(FD_SETSIZE); + constant(SOL_SOCKET); + constant(SO_REUSEADDR); + constant(SO_OOBINLINE); + constant(SO_SNDTIMEO); + constant(SO_RCVTIMEO); + constant(F_SETFL); + constant(O_NONBLOCK); + constant(EINTR); + constant(EAGAIN); + constant(EINPROGRESS); +} + +int main() { +#ifdef FREEBSD + grovel(blkcnt_t); + grovel(blksize_t); + grovel(fflags_t); +#endif + +#ifdef OPENBSD + openbsd_stat(); + openbsd_types(); +#endif + +#ifdef UNIX + unix_types(); + unix_constants(); +#endif + + return 0; +} diff --git a/build-support/target b/build-support/target new file mode 100755 index 0000000000..1903a6da64 --- /dev/null +++ b/build-support/target @@ -0,0 +1,38 @@ +#!/bin/sh + +if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ] +then + echo freebsd-x86-32 +elif [ \( `uname -s` = FreeBSD \) -a \( `uname -m` = amd64 \) ] +then + echo freebsd-x86-64 +elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ] +then + echo openbsd-x86-32 +elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ] +then + echo openbsd-x86-64 +elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ] +then + echo netbsd-x86-32 +elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = x86_64 \) ] +then + echo netbsd-x86-64 +elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] +then + echo macosx-ppc +elif [ `uname -s` = Darwin ] +then + echo macosx-x86-`./build-support/wordsize` +elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ] +then + echo linux-x86-32 +elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ] +then + echo linux-x86-64 +elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ] +then + echo winnt-x86-`./build-support/wordsize` +else + echo help +fi diff --git a/misc/wordsize.c b/build-support/wordsize.c similarity index 100% rename from misc/wordsize.c rename to build-support/wordsize.c diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 95b29ee50b..7bba9d7332 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -210,8 +210,9 @@ $nl ARTICLE: "alien-callback" "Calling Factor from C" "Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:" { $subsection alien-callback } -"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." -{ $subsection "alien-callback-gc" } ; +"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." +{ $subsection "alien-callback-gc" } +{ $see-also "byte-arrays-gc" } ; ARTICLE: "dll.private" "DLL handles" "DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "." @@ -290,7 +291,7 @@ $nl "The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library." $nl "C library interface words are found in the " { $vocab-link "alien" } " vocabulary." -{ $warning "Since C does not retain runtime type information or do any kind of runtime type checking, any C library interface is not pointer safe. Improper use of C functions can crash the runtime or corrupt memory in unpredictible ways." } +{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." } { $subsection "loading-libs" } { $subsection "alien-invoke" } { $subsection "alien-callback" } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index ca35cb3696..436d73e874 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math namespaces sequences system kernel.private tuples bit-arrays byte-arrays float-arrays -shuffle arrays macros ; +arrays ; IN: alien ! Some predicate classes used by the compiler for optimization @@ -65,21 +65,21 @@ TUPLE: library path abi dll ; TUPLE: alien-callback return parameters abi quot xt ; -TUPLE: alien-callback-error ; +ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) - \ alien-callback-error construct-empty throw ; + alien-callback-error ; TUPLE: alien-indirect return parameters abi ; -TUPLE: alien-indirect-error ; +ERROR: alien-indirect-error ; : alien-indirect ( ... funcptr return parameters abi -- ) - \ alien-indirect-error construct-empty throw ; + alien-indirect-error ; -TUPLE: alien-invoke library function return parameters ; +TUPLE: alien-invoke library function return parameters abi ; -TUPLE: alien-invoke-error library symbol ; +ERROR: alien-invoke-error library symbol ; : alien-invoke ( ... return library function parameters -- ... ) - 2over \ alien-invoke-error construct-boa throw ; + 2over alien-invoke-error ; diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index fe6873ac3a..8d2b03467b 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -158,6 +158,19 @@ HELP: define-out { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." } { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; +ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector" +"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data." +$nl +"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:" +{ $list + "the C function returns" + "the C function calls Factor code via a callback" +} +"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid." +$nl +"If this condition is not satisfied, " { $link "malloc" } " must be used instead." +{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ; + ARTICLE: "c-out-params" "Output parameters in C" "A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations." $nl @@ -229,13 +242,11 @@ $nl { $subsection } { $subsection } { $warning -"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning." -$nl -"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." } +"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." } { $see-also "c-arrays" } ; ARTICLE: "malloc" "Manual memory management" -"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case." +"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case." $nl "Allocating a C datum with a fixed address:" { $subsection malloc-object } @@ -245,8 +256,6 @@ $nl { $subsection malloc } { $subsection calloc } { $subsection realloc } -"The return value of the above three words must always be checked for a memory allocation failure:" -{ $subsection check-ptr } "You must always free pointers returned by any of the above words when the block of memory is no longer in use:" { $subsection free } "You can unsafely copy a range of bytes from one memory location to another:" @@ -271,20 +280,25 @@ ARTICLE: "c-strings" "C strings" { $subsection string>u16-alien } { $subsection malloc-char-string } { $subsection malloc-u16-string } -"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } "." +"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." $nl "Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:" { $subsection alien>char-string } -{ $subsection alien>u16-string } ; +{ $subsection alien>u16-string } +"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; ARTICLE: "c-data" "Passing data between Factor and C" -"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code." +"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers." +$nl +"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "." { $subsection "c-types-specs" } { $subsection "c-byte-arrays" } { $subsection "malloc" } { $subsection "c-strings" } { $subsection "c-arrays" } { $subsection "c-out-params" } +"Important guidelines for passing data in byte arrays:" +{ $subsection "byte-arrays-gc" } "C-style enumerated types are supported:" { $subsection POSTPONE: C-ENUM: } "C types can be aliased for convenience and consitency with native library documentation:" diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index f1d8abdc1e..d874243d71 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -26,9 +26,7 @@ global [ c-types [ H{ } assoc-like ] change ] bind -TUPLE: no-c-type name ; - -: no-c-type ( type -- * ) \ no-c-type construct-boa throw ; +ERROR: no-c-type name ; : (c-type) ( name -- type/f ) c-types get-global at dup [ diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 7e2e23726b..f9dc426de1 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -330,11 +330,11 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; ! Hack; if we're on ARM, we probably don't have much RAM, so ! skip this test. -cpu "arm" = [ - [ "testing" ] [ - "testing" callback-5a callback_test_1 - ] unit-test -] unless +! cpu "arm" = [ +! [ "testing" ] [ +! "testing" callback-5a callback_test_1 +! ] unit-test +! ] unless : callback-6 "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index fb7d50e882..3e0062c85a 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -6,14 +6,9 @@ inference.state inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs alien.syntax cpu.architecture alien inspector quotations assocs kernel.private threads continuations.private libc combinators -compiler.errors continuations layouts ; +compiler.errors continuations layouts accessors ; IN: alien.compiler -! Common protocol for alien-invoke/alien-callback/alien-indirect -GENERIC: alien-node-parameters ( node -- seq ) -GENERIC: alien-node-return ( node -- ctype ) -GENERIC: alien-node-abi ( node -- str ) - : large-struct? ( ctype -- ? ) dup c-struct? [ heap-size struct-small-enough? not @@ -22,11 +17,11 @@ GENERIC: alien-node-abi ( node -- str ) ] if ; : alien-node-parameters* ( node -- seq ) - dup alien-node-parameters - swap alien-node-return large-struct? [ "void*" add* ] when ; + dup parameters>> + swap return>> large-struct? [ "void*" add* ] when ; : alien-node-return* ( node -- ctype ) - alien-node-return dup large-struct? [ drop "void" ] when ; + return>> dup large-struct? [ drop "void" ] when ; : c-type-stack-align ( type -- align ) dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ; @@ -51,7 +46,7 @@ GENERIC: alien-node-abi ( node -- str ) : alien-invoke-frame ( node -- n ) #! One cell is temporary storage, temp@ - dup alien-node-return return-size + dup return>> return-size swap alien-stack-frame + cell + ; @@ -147,9 +142,9 @@ M: long-long-type flatten-value-type ( type -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline : alien-invoke-stack ( node extra -- ) - over alien-node-parameters length + dup reify-curries + over parameters>> length + dup reify-curries over consume-values - dup alien-node-return "void" = 0 1 ? + dup return>> "void" = 0 1 ? swap produce-values ; : (make-prep-quot) ( parameters -- ) @@ -161,11 +156,11 @@ M: long-long-type flatten-value-type ( type -- ) ] if ; : make-prep-quot ( node -- quot ) - alien-node-parameters + parameters>> [ (make-prep-quot) ] [ ] make ; : unbox-parameters ( offset node -- ) - alien-node-parameters [ + parameters>> [ %prepare-unbox >r over + r> unbox-parameter ] reverse-each-parameter drop ; @@ -174,7 +169,7 @@ M: long-long-type flatten-value-type ( type -- ) #! parameters. If the C function is returning a structure, #! the first parameter is an implicit target area pointer, #! so we need to use a different offset. - alien-node-return dup large-struct? + return>> dup large-struct? [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ; : objects>registers ( node -- ) @@ -188,14 +183,7 @@ M: long-long-type flatten-value-type ( type -- ) ] with-param-regs ; : box-return* ( node -- ) - alien-node-return [ ] [ box-return ] if-void ; - -M: alien-invoke alien-node-parameters alien-invoke-parameters ; -M: alien-invoke alien-node-return alien-invoke-return ; - -M: alien-invoke alien-node-abi - alien-invoke-library library - [ library-abi ] [ "cdecl" ] if* ; + return>> [ ] [ box-return ] if-void ; M: alien-invoke-error summary drop @@ -205,7 +193,7 @@ M: alien-invoke-error summary : stdcall-mangle ( symbol node -- symbol ) "@" - swap alien-node-parameters parameter-sizes drop + swap parameters>> parameter-sizes drop number>string 3append ; TUPLE: no-such-library name ; @@ -256,6 +244,10 @@ M: no-such-symbol compiler-error-type pop-literal nip over set-alien-invoke-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 ! Add node to IR dup node, ! Magic #: consume exactly the number of inputs @@ -274,10 +266,6 @@ M: alien-invoke generate-node iterate-next ] with-stack-frame ; -M: alien-indirect alien-node-parameters alien-indirect-parameters ; -M: alien-indirect alien-node-return alien-indirect-return ; -M: alien-indirect alien-node-abi alien-indirect-abi ; - M: alien-indirect-error summary drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ; @@ -323,10 +311,6 @@ callbacks global [ H{ } assoc-like ] change-at : register-callback ( word -- ) dup callbacks get set-at ; -M: alien-callback alien-node-parameters alien-callback-parameters ; -M: alien-callback alien-node-return alien-callback-return ; -M: alien-callback alien-node-abi alien-callback-abi ; - M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; @@ -373,7 +357,7 @@ TUPLE: callback-context ; wait-to-return ; inline : prepare-callback-return ( ctype -- quot ) - alien-node-return { + return>> { { [ dup "void" = ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } { [ t ] [ c-type c-type-prep ] } @@ -390,8 +374,8 @@ TUPLE: callback-context ; : callback-unwind ( node -- n ) { - { [ dup alien-node-abi "stdcall" = ] [ alien-stack-frame ] } - { [ dup alien-node-return large-struct? ] [ drop 4 ] } + { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } + { [ dup return>> large-struct? ] [ drop 4 ] } { [ t ] [ drop 0 ] } } cond ; diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index fe19f29766..6c7775de2b 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -1,6 +1,65 @@ IN: alien.structs USING: alien.c-types strings help.markup help.syntax -alien.syntax sequences io arrays ; +alien.syntax sequences io arrays slots.deprecated +kernel words slots assocs namespaces ; + +! Deprecated code +: ($spec-reader-values) ( slot-spec class -- element ) + dup ?word-name swap 2array + over slot-spec-name + rot slot-spec-type 2array 2array + [ { $instance } swap add ] assoc-map ; + +: $spec-reader-values ( slot-spec class -- ) + ($spec-reader-values) $values ; + +: $spec-reader-description ( slot-spec class -- ) + [ + "Outputs the value stored in the " , + { $snippet } rot slot-spec-name add , + " slot of " , + { $instance } swap add , + " instance." , + ] { } make $description ; + +: $spec-reader ( reader slot-specs class -- ) + >r slot-of-reader r> + over [ + 2dup $spec-reader-values + 2dup $spec-reader-description + ] when 2drop ; + +GENERIC: slot-specs ( help-type -- specs ) + +M: word slot-specs "slots" word-prop ; + +: $slot-reader ( reader -- ) + first dup "reading" word-prop [ slot-specs ] keep + $spec-reader ; + +: $spec-writer-values ( slot-spec class -- ) + ($spec-reader-values) reverse $values ; + +: $spec-writer-description ( slot-spec class -- ) + [ + "Stores a new value to the " , + { $snippet } rot slot-spec-name add , + " slot of " , + { $instance } swap add , + " instance." , + ] { } make $description ; + +: $spec-writer ( writer slot-specs class -- ) + >r slot-of-writer r> + over [ + 2dup $spec-writer-values + 2dup $spec-writer-description + dup ?word-name 1array $side-effects + ] when 2drop ; + +: $slot-writer ( reader -- ) + first dup "writing" word-prop [ slot-specs ] keep + $spec-writer ; M: string slot-specs c-type struct-type-fields ; diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index aec09621cb..e5de8ab83e 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math namespaces parser sequences strings words libc slots -alien.c-types cpu.architecture ; +slots.deprecated alien.c-types cpu.architecture ; IN: alien.structs : align-offset ( offset type -- offset ) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 3bd68bfde7..6e4b8b4e21 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman. +! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays alien alien.c-types alien.structs alien.arrays kernel math namespaces parser sequences words quotations @@ -9,7 +9,7 @@ IN: alien.syntax ; : function-quot ( type lib func types -- quot ) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 5ccde88e28..04d57dff16 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -79,7 +79,7 @@ nl "." write flush { - malloc free memcpy + malloc calloc free memcpy } compile " done" print flush diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f5f4d70d14..52a2496755 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -349,7 +349,7 @@ M: curry ' [ { dictionary source-files - typemap builtins classr default-image-name "output-image" set-global -"math help handbook compiler tools ui ui.tools io" "include" set-global +"math help handbook compiler random tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line @@ -106,5 +106,5 @@ f error-continuation set-global millis r> - dup bootstrap-time set-global print-report - "output-image" get resource-path save-image-and-exit + "output-image" get save-image-and-exit ] if diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index a4e87f28d8..e7e90d8dd0 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -21,6 +21,7 @@ IN: bootstrap.syntax "C:" "CHAR:" "DEFER:" + "ERROR:" "F{" "FV{" "FORGET:" diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 7d43ee905a..3322c3b043 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -1,6 +1,6 @@ USING: alien arrays definitions generic assocs hashtables io kernel math namespaces parser prettyprint sequences strings -tools.test vectors words quotations classes io.streams.string +tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units ; IN: classes.tests @@ -22,6 +22,8 @@ H{ } "s" set [ number ] [ number object class-and ] unit-test [ number ] [ object number class-and ] unit-test [ null ] [ slice reversed class-and ] unit-test +[ null ] [ general-t \ f class-and ] unit-test +[ object ] [ general-t \ f class-or ] unit-test TUPLE: first-one ; TUPLE: second-one ; @@ -63,10 +65,6 @@ UNION: c a b ; UNION: bah fixnum alien ; [ bah ] [ \ bah? "predicating" word-prop ] unit-test -! Test generic see and parsing -[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] -[ [ \ bah see ] with-string-writer ] unit-test - ! Test redefinition of classes UNION: union-1 fixnum float ; @@ -180,6 +178,8 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ; [ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test +USE: io.streams.string + 2 [ [ "mixin-forget-test" forget-source ] with-compilation-unit @@ -224,3 +224,7 @@ MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1 TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 [ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test + +! Test generic see and parsing +[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] +[ [ \ bah see ] with-string-writer ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index e60d3ba223..e47dbd20e5 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -8,11 +8,12 @@ vectors math quotations combinators sorting effects graphs ; PREDICATE: word class ( obj -- ? ) "class" word-prop ; SYMBOL: typemap +SYMBOL: class-map SYMBOL: classboolean ; { [ dup builtin-class? ] [ dup set ] } { [ dup members ] [ members [ (flatten-class) ] each ] } { [ dup superclass ] [ superclass (flatten-class) ] } + { [ t ] [ drop ] } } cond ; : flatten-class ( class -- assoc ) @@ -108,11 +110,31 @@ DEFER: (class<) : lookup-union ( classes -- class ) typemap get at dup empty? [ drop object ] [ first ] if ; +: lookup-tuple-union ( classes -- class ) + class-map get at dup empty? [ drop object ] [ first ] if ; + +! : (class-or) ( class class -- class ) +! [ flatten-builtin-class ] 2apply union lookup-union ; +! +! : (class-and) ( class class -- class ) +! [ flatten-builtin-class ] 2apply intersect lookup-union ; + +: class-or-fixup ( set set -- set ) + union + tuple over key? + [ [ drop tuple-class? not ] assoc-subset ] when ; + : (class-or) ( class class -- class ) - [ flatten-builtin-class ] 2apply union lookup-union ; + [ flatten-class ] 2apply class-or-fixup lookup-tuple-union ; : (class-and) ( class class -- class ) - [ flatten-builtin-class ] 2apply intersect lookup-union ; + 2dup [ tuple swap class< ] either? [ + [ flatten-builtin-class ] 2apply + intersect lookup-union + ] [ + [ flatten-class ] 2apply + intersect lookup-tuple-union + ] if ; : tuple-class-and ( class1 class2 -- class ) dupd eq? [ drop null ] unless ; @@ -219,9 +241,16 @@ M: word reset-class drop ; : typemap- ( class -- ) dup flatten-builtin-class typemap get pop-at ; +! class-map +: class-map+ ( class -- ) + dup flatten-class class-map get push-at ; + +: class-map- ( class -- ) + dup flatten-class class-map get pop-at ; + ! Class definition : cache-class ( class -- ) - dup typemap+ dup classr "predicate" word-prop [ dup ] swap append r> ] + [ >r "predicate" word-prop [ dup ] prepend r> ] assoc-map alist>quot ] if ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index ffd1576e6e..807b372e1d 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting ; -TUPLE: no-cond ; - -: no-cond ( -- * ) \ no-cond construct-empty throw ; +ERROR: no-cond ; : cond ( assoc -- ) [ first call ] find nip dup [ second call ] [ no-cond ] if ; -TUPLE: no-case ; - -: no-case ( -- * ) \ no-case construct-empty throw ; +ERROR: no-case ; : case ( obj assoc -- ) [ dup array? [ dupd first = ] [ quotation? ] if ] find nip @@ -80,7 +76,7 @@ M: hashtable hashcode* : hash-case-quot ( default assoc -- quot ) hash-case-table hash-dispatch-quot - [ dup hashcode >fixnum ] swap append ; + [ dup hashcode >fixnum ] prepend ; : contiguous-range? ( keys -- from to ? ) dup [ fixnum? ] all? [ diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor index ed4fb9f606..72c1e063e0 100644 --- a/core/command-line/command-line.factor +++ b/core/command-line/command-line.factor @@ -7,12 +7,12 @@ splitting io.files ; : run-bootstrap-init ( -- ) "user-init" get [ - home ".factor-boot-rc" path+ ?run-file + home ".factor-boot-rc" append-path ?run-file ] when ; : run-user-init ( -- ) "user-init" get [ - home ".factor-rc" path+ ?run-file + home ".factor-rc" append-path ?run-file ] when ; : cli-var-param ( name value -- ) swap set-global ; diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 7196a4b4fb..3520104e1f 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -8,7 +8,8 @@ $nl "The main entry point to the optimizing compiler:" { $subsection optimized-recompile-hook } "Removing a word's optimized definition:" -{ $subsection decompile } ; +{ $subsection decompile } +"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index dd9a453cfc..7a8fe5d735 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -261,7 +261,7 @@ cell 8 = [ : compiled-fixnum* fixnum* ; : test-fixnum* - (random) >fixnum (random) >fixnum + 32 random-bits >fixnum 32 random-bits >fixnum 2dup [ fixnum* ] 2keep compiled-fixnum* = [ 2drop ] [ "Oops" throw ] if ; @@ -271,7 +271,7 @@ cell 8 = [ : compiled-fixnum>bignum fixnum>bignum ; : test-fixnum>bignum - (random) >fixnum + 32 random-bits >fixnum dup [ fixnum>bignum ] keep compiled-fixnum>bignum = [ drop ] [ "Oops" throw ] if ; @@ -280,7 +280,7 @@ cell 8 = [ : compiled-bignum>fixnum bignum>fixnum ; : test-bignum>fixnum - 5 random [ drop (random) ] map product >bignum + 5 random [ drop 32 random-bits ] map product >bignum dup [ bignum>fixnum ] keep compiled-bignum>fixnum = [ drop ] [ "Oops" throw ] if ; @@ -385,7 +385,7 @@ cell 8 = [ [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test -: xword-def word-def [ { fixnum } declare ] swap append ; +: xword-def word-def [ { fixnum } declare ] prepend ; [ -100 ] [ -100 [ { byte-array } declare *char ] compile-call ] unit-test [ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index 74dac17be8..09baf91018 100755 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -9,7 +9,9 @@ $nl $nl "The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run time, a compilation unit must be created explicitly:" { $subsection with-compilation-unit } -"Words called to associate a definition with a source file location:" +"Compiling a set of words:" +{ $subsection compile } +"Words called to associate a definition with a compilation unit and a source file location:" { $subsection remember-definition } { $subsection remember-class } "Forward reference checking (see " { $link "definition-checking" } "):" diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 19b913541c..81a7d7cd02 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -5,7 +5,7 @@ cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup generator system layouts alien.compiler combinators command-line -compiler compiler.units io vocabs.loader ; +compiler compiler.units io vocabs.loader accessors ; IN: cpu.x86.32 PREDICATE: x86-backend x86-32-backend @@ -244,10 +244,10 @@ M: x86-32-backend %cleanup ( alien-node -- ) #! have to fix ESP. { { - [ dup alien-node-abi "stdcall" = ] + [ dup abi>> "stdcall" = ] [ alien-stack-frame ESP swap SUB ] } { - [ dup alien-node-return large-struct? ] + [ dup return>> large-struct? ] [ drop EAX PUSH ] } { [ t ] [ drop ] diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index ad2fa14954..4775093ba7 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser tuples continuations continuations.private combinators generic.math io.streams.duplex classes compiler.units generic.standard vocabs threads threads.private init -kernel.private libc ; +kernel.private libc io.encodings ; IN: debugger GENERIC: error. ( error -- ) @@ -75,9 +75,7 @@ SYMBOL: error-hook : try ( quot -- ) [ error-hook get call ] recover ; -TUPLE: assert got expect ; - -: assert ( got expect -- * ) \ assert construct-boa throw ; +ERROR: assert got expect ; : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ; @@ -86,28 +84,22 @@ TUPLE: assert got expect ; : trim-datastacks ( seq1 seq2 -- seq1' seq2' ) 2dup [ length ] 2apply min tuck tail >r tail r> ; -TUPLE: relative-underflow stack ; - -: relative-underflow ( before after -- * ) - trim-datastacks nip \ relative-underflow construct-boa throw ; +ERROR: relative-underflow stack ; M: relative-underflow summary drop "Too many items removed from data stack" ; -TUPLE: relative-overflow stack ; +ERROR: relative-overflow stack ; M: relative-overflow summary drop "Superfluous items pushed to data stack" ; -: relative-overflow ( before after -- * ) - trim-datastacks drop \ relative-overflow construct-boa throw ; - : assert-depth ( quot -- ) >r datastack r> swap slip >r datastack r> 2dup [ length ] compare sgn { - { -1 [ relative-underflow ] } + { -1 [ trim-datastacks nip relative-underflow ] } { 0 [ 2drop ] } - { 1 [ relative-overflow ] } + { 1 [ trim-datastacks drop relative-overflow ] } } case ; inline : expired-error. ( obj -- ) @@ -210,13 +202,13 @@ M: no-method error. M: no-math-method summary drop "No suitable arithmetic method" ; -M: check-closed summary +M: stream-closed-twice summary drop "Attempt to perform I/O on closed stream" ; M: check-method summary drop "Invalid parameters for create-method" ; -M: check-tuple summary +M: no-tuple-class summary drop "Invalid class for define-constructor" ; M: no-cond summary @@ -254,7 +246,7 @@ M: no-compilation-unit error. M: no-vocab summary drop "Vocabulary does not exist" ; -M: check-ptr summary +M: bad-ptr summary drop "Memory allocation failed" ; M: double-free summary @@ -282,6 +274,10 @@ M: thread error-in-thread ( error thread -- ) ] bind ] if ; +M: encode-error summary drop "Character encoding error" ; + +M: decode-error summary drop "Character decoding error" ; + [ 1 = ] swap dlist-find ] unit-test -[ 1 t ] [ 1 over push-back [ 1 = ] swap dlist-find ] unit-test -[ f f ] [ 1 over push-back [ 2 = ] swap dlist-find ] unit-test -[ f ] [ 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test +[ f f ] [ [ 1 = ] dlist-find ] unit-test +[ 1 t ] [ 1 over push-back [ 1 = ] dlist-find ] unit-test +[ f f ] [ 1 over push-back [ 2 = ] dlist-find ] unit-test +[ f ] [ 1 over push-back [ 2 = ] dlist-contains? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] dlist-contains? ] unit-test -[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node-if ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test -[ 0 ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test -[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back [ 1 = ] delete-node-if ] unit-test +[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test +[ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test +[ 0 ] [ 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test [ 0 ] [ dlist-length ] unit-test [ 1 ] [ 1 over push-front dlist-length ] unit-test diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 38c4ee233e..56134f3b54 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -1,71 +1,67 @@ -! Copyright (C) 2007 Mackenzie Straight, Doug Coleman. +! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman, +! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math sequences ; +USING: combinators kernel math sequences accessors ; IN: dlists TUPLE: dlist front back length ; : ( -- obj ) dlist construct-empty - 0 over set-dlist-length ; + 0 >>length ; -: dlist-empty? ( dlist -- ? ) dlist-front not ; +: dlist-empty? ( dlist -- ? ) front>> not ; dlist-node : inc-length ( dlist -- ) - [ dlist-length 1+ ] keep set-dlist-length ; inline + [ 1+ ] change-length drop ; inline : dec-length ( dlist -- ) - [ dlist-length 1- ] keep set-dlist-length ; inline + [ 1- ] change-length drop ; inline : set-prev-when ( dlist-node dlist-node/f -- ) - [ set-dlist-node-prev ] [ drop ] if* ; + [ (>>prev) ] [ drop ] if* ; : set-next-when ( dlist-node dlist-node/f -- ) - [ set-dlist-node-next ] [ drop ] if* ; + [ (>>next) ] [ drop ] if* ; : set-next-prev ( dlist-node -- ) - dup dlist-node-next set-prev-when ; + dup next>> set-prev-when ; : normalize-front ( dlist -- ) - dup dlist-back [ drop ] [ f swap set-dlist-front ] if ; + dup back>> [ f >>front ] unless drop ; : normalize-back ( dlist -- ) - dup dlist-front [ drop ] [ f swap set-dlist-back ] if ; + dup front>> [ f >>back ] unless drop ; : set-back-to-front ( dlist -- ) - dup dlist-back - [ drop ] [ dup dlist-front swap set-dlist-back ] if ; + dup back>> [ dup front>> >>back ] unless drop ; : set-front-to-back ( dlist -- ) - dup dlist-front - [ drop ] [ dup dlist-back swap set-dlist-front ] if ; + dup front>> [ dup back>> >>front ] unless drop ; -: (dlist-find-node) ( quot dlist-node -- node/f ? ) - dup dlist-node-obj pick dupd call [ - drop nip t - ] [ - drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if* - ] if ; inline +: (dlist-find-node) ( dlist-node quot -- node/f ? ) + over [ + [ >r obj>> r> call ] 2keep rot + [ drop t ] [ >r next>> r> (dlist-find-node) ] if + ] [ 2drop f f ] if ; inline -: dlist-find-node ( quot dlist -- node/f ? ) - dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline +: dlist-find-node ( dlist quot -- node/f ? ) + >r front>> r> (dlist-find-node) ; inline -: (dlist-each-node) ( quot dlist -- ) - over - [ 2dup call >r dlist-node-next r> (dlist-each-node) ] - [ 2drop ] if ; inline +: dlist-each-node ( dlist quot -- ) + [ t ] compose dlist-find-node 2drop ; inline -: dlist-each-node ( quot dlist -- ) - >r dlist-front r> (dlist-each-node) ; inline PRIVATE> : push-front* ( obj dlist -- dlist-node ) - [ dlist-front f swap dup dup set-next-prev ] keep - [ set-dlist-front ] keep + [ front>> f swap dup dup set-next-prev ] keep + [ (>>front) ] keep [ set-back-to-front ] keep inc-length ; @@ -76,9 +72,9 @@ PRIVATE> [ push-front ] curry each ; : push-back* ( obj dlist -- dlist-node ) - [ dlist-back f ] keep - [ dlist-back set-next-when ] 2keep - [ set-dlist-back ] 2keep + [ back>> f ] keep + [ back>> set-next-when ] 2keep + [ (>>back) ] 2keep [ set-front-to-back ] keep inc-length ; @@ -89,70 +85,75 @@ PRIVATE> [ push-back ] curry each ; : peek-front ( dlist -- obj ) - dlist-front dlist-node-obj ; + front>> obj>> ; : pop-front ( dlist -- obj ) - dup dlist-front [ - dup dlist-node-next - f rot set-dlist-node-next + dup front>> [ + dup next>> + f rot (>>next) f over set-prev-when - swap set-dlist-front - ] 2keep dlist-node-obj + swap (>>front) + ] 2keep obj>> swap [ normalize-back ] keep dec-length ; : pop-front* ( dlist -- ) pop-front drop ; : peek-back ( dlist -- obj ) - dlist-back dlist-node-obj ; + back>> obj>> ; : pop-back ( dlist -- obj ) - dup dlist-back [ - dup dlist-node-prev - f rot set-dlist-node-prev + dup back>> [ + dup prev>> + f rot (>>prev) f over set-next-when - swap set-dlist-back - ] 2keep dlist-node-obj + swap (>>back) + ] 2keep obj>> swap [ normalize-front ] keep dec-length ; : pop-back* ( dlist -- ) pop-back drop ; -: dlist-find ( quot dlist -- obj/f ? ) - dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline +: dlist-find ( dlist quot -- obj/f ? ) + dlist-find-node [ obj>> t ] [ drop f f ] if ; inline -: dlist-contains? ( quot dlist -- ? ) +: dlist-contains? ( dlist quot -- ? ) dlist-find nip ; inline : unlink-node ( dlist-node -- ) - dup dlist-node-prev over dlist-node-next set-prev-when - dup dlist-node-next swap dlist-node-prev set-next-when ; + dup prev>> over next>> set-prev-when + dup next>> swap prev>> set-next-when ; : delete-node ( dlist dlist-node -- ) { - { [ over dlist-front over eq? ] [ drop pop-front* ] } - { [ over dlist-back over eq? ] [ drop pop-back* ] } + { [ over front>> over eq? ] [ drop pop-front* ] } + { [ over back>> over eq? ] [ drop pop-back* ] } { [ t ] [ unlink-node dec-length ] } } cond ; -: delete-node-if* ( quot dlist -- obj/f ? ) - tuck dlist-find-node [ - [ delete-node ] keep [ dlist-node-obj t ] [ f f ] if* +: delete-node-if* ( dlist quot -- obj/f ? ) + dupd dlist-find-node [ + dup [ + [ delete-node ] keep obj>> t + ] [ + 2drop f f + ] if ] [ 2drop f f ] if ; inline -: delete-node-if ( quot dlist -- obj/f ) +: delete-node-if ( dlist quot -- obj/f ) delete-node-if* drop ; inline : dlist-delete ( obj dlist -- obj/f ) - >r [ eq? ] curry r> delete-node-if ; + swap [ eq? ] curry delete-node-if ; : dlist-delete-all ( dlist -- ) - f over set-dlist-front - f over set-dlist-back - 0 swap set-dlist-length ; + f >>front + f >>back + 0 >>length + drop ; : dlist-each ( dlist quot -- ) - [ dlist-node-obj ] swap compose dlist-each-node ; inline + [ obj>> ] swap compose dlist-each-node ; inline : dlist-slurp ( dlist quot -- ) over dlist-empty? @@ -160,4 +161,3 @@ PRIVATE> inline : 1dlist ( obj -- dlist ) [ push-front ] keep ; - diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 62b85dde3a..b59c92c798 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -126,7 +126,7 @@ HELP: method { method create-method POSTPONE: M: } related-words HELP: -{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } } +{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } } { $description "Creates a new method." } ; HELP: methods @@ -143,7 +143,7 @@ HELP: check-method { $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ; HELP: with-methods -{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } } +{ $values { "generic" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } } { $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." } $low-level-note ; diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor old mode 100644 new mode 100755 index cbbf070398..5c15e43eb5 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -15,7 +15,7 @@ HELP: no-math-method HELP: math-method { $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } } { $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." } -{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ; +{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip +/float ]" } } ; HELP: math-class { $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 9fd5481a39..46f57a1629 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? ) dup empty? [ [ dip ] curry [ ] like ] unless r> append ; -TUPLE: no-math-method left right generic ; - -: no-math-method ( left right generic -- * ) - \ no-math-method construct-boa throw ; +ERROR: no-math-method left right generic ; : default-math-method ( generic -- quot ) [ no-math-method ] curry [ ] like ; @@ -53,7 +50,7 @@ TUPLE: no-math-method left right generic ; 2dup and [ 2dup math-upgrade >r math-class-max over order min-class applicable-method - r> swap append + r> prepend ] [ 2drop object-method ] if ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index c634e02e75..37f72e7d95 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -26,10 +26,7 @@ SYMBOL: (dispatch#) : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ; -TUPLE: no-method object generic ; - -: no-method ( object generic -- * ) - \ no-method construct-boa throw ; +ERROR: no-method object generic ; : error-method ( word -- quot ) picker swap [ no-method ] curry append ; @@ -161,7 +158,7 @@ C: hook-combination 0 (dispatch#) [ swap slip hook-combination-var [ get ] curry - swap append + prepend ] with-variable ; inline M: hook-combination make-default-method @@ -170,7 +167,7 @@ M: hook-combination make-default-method M: hook-combination perform-combination [ standard-methods - [ [ drop ] swap append ] assoc-map + [ [ drop ] prepend ] assoc-map single-combination ] with-hook ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 61e09d894e..0b3123c87b 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -33,7 +33,7 @@ IN: heaps.tests : random-alist ( n -- alist ) [ [ - (random) dup number>string swap set + 32 random-bits dup number>string swap set ] times ] H{ } make-assoc ; diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 3c12e388c4..4f5d199264 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -514,10 +514,10 @@ DEFER: an-inline-word { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as -TUPLE: custom-error ; +ERROR: custom-error ; [ T{ effect f 0 0 t } ] [ - [ custom-error construct-boa throw ] infer + [ custom-error ] infer ] unit-test : funny-throw throw ; inline diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 235c2924bb..08fb56ced7 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -354,7 +354,7 @@ M: object infer-call \ setenv { object fixnum } { } set-primitive-effect -\ (stat) { string } { object object object object } set-primitive-effect +\ exists? { string } { object } set-primitive-effect \ (directory) { string } { array } set-primitive-effect diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 240f39218b..a829bad47e 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot ) \ get-slots [ [get-slots] ] 1 define-transform -TUPLE: duplicated-slots-error names ; +ERROR: duplicated-slots-error names ; M: duplicated-slots-error summary drop "Calling set-slots with duplicate slot setters" ; -: duplicated-slots-error ( names -- * ) - \ duplicated-slots-error construct-boa throw ; - \ set-slots [ dup all-unique? [ [get-slots] ] [ duplicated-slots-error ] if diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor index b8bcc0f87a..5038628ed9 100644 --- a/core/io/encodings/binary/binary.factor +++ b/core/io/encodings/binary/binary.factor @@ -1,3 +1,8 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -IN: io.encodings.binary SYMBOL: binary +USING: io.encodings kernel ; +IN: io.encodings.binary + +TUPLE: binary ; +M: binary drop ; +M: binary drop ; diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index e5e71b05f0..fd5ddaa82d 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -14,19 +14,19 @@ ARTICLE: "encodings-constructors" "Constructing an encoded stream" { $subsection } { $subsection } ; -HELP: ( stream encoding -- newstream ) +HELP: { $values { "stream" "an output stream" } { "encoding" "an encoding descriptor" } { "newstream" "an encoded output stream" } } { $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ; -HELP: ( stream encoding -- newstream ) +HELP: { $values { "stream" "an input stream" } { "encoding" "an encoding descriptor" } { "newstream" "an encoded output stream" } } { $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ; -HELP: ( stream-in stream-out encoding -- duplex ) +HELP: { $values { "stream-in" "an input stream" } { "stream-out" "an output stream" } { "encoding" "an encoding descriptor" } @@ -44,25 +44,21 @@ $nl { $vocab-link "io.encodings.utf16" } ; ARTICLE: "encodings-protocol" "Encoding protocol" "An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again." -{ $subsection decode-step } -{ $subsection init-decoder } -{ $subsection stream-write-encoded } ; +{ $subsection decode-char } +{ $subsection encode-char } +"The following methods are optional:" +{ $subsection } +{ $subsection } ; -HELP: decode-step ( buf char encoding -- ) -{ $values { "buf" "A string buffer which characters can be pushed to" } - { "char" "An octet which is read from a stream" } - { "encoding" "An encoding descriptor tuple" } } -{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ; +HELP: decode-char +{ $values { "stream" "an underlying input stream" } + { "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } } +{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ; -HELP: stream-write-encoded ( string stream encoding -- ) -{ $values { "string" "a string" } - { "stream" "an output stream" } +HELP: encode-char +{ $values { "char" "a character" } + { "stream" "an underlying output stream" } { "encoding" "an encoding descriptor" } } -{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ; +{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ; -HELP: init-decoder ( stream encoding -- encoding ) -{ $values { "stream" "an input stream" } - { "encoding" "an encoding descriptor" } } -{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ; - -{ init-decoder decode-step stream-write-encoded } related-words +{ encode-char decode-char } related-words diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 2f68334bde..a781b63ad5 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -2,62 +2,39 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces growable strings io classes continuations combinators -io.styles io.streams.plain io.encodings.binary splitting -io.streams.duplex byte-arrays ; +io.styles io.streams.plain splitting +io.streams.duplex byte-arrays sequences.private ; IN: io.encodings ! The encoding descriptor protocol -GENERIC: decode-step ( buf char encoding -- ) -M: object decode-step drop swap push ; +GENERIC: decode-char ( stream encoding -- char/f ) -GENERIC: init-decoder ( stream encoding -- encoding ) -M: tuple-class init-decoder construct-empty init-decoder ; -M: object init-decoder nip ; +GENERIC: encode-char ( char stream encoding -- ) -GENERIC: stream-write-encoded ( string stream encoding -- byte-array ) -M: object stream-write-encoded drop stream-write ; +GENERIC: ( stream encoding -- newstream ) + +: replacement-char HEX: fffd ; + +TUPLE: decoder stream code cr ; + +ERROR: decode-error ; + +GENERIC: ( stream encoding -- newstream ) + +TUPLE: encoder stream code ; + +ERROR: encode-error ; ! Decoding -TUPLE: decode-error ; + construct-empty ; +M: tuple f decoder construct-boa ; -SYMBOL: begin - -: push-decoded ( buf ch -- buf ch state ) - over push 0 begin ; - -: push-replacement ( buf -- buf ch state ) - ! This is the replacement character - HEX: fffd push-decoded ; - -: space ( resizable -- room-left ) - dup underlying swap [ length ] 2apply - ; - -: full? ( resizable -- ? ) space zero? ; - -: end-read-loop ( buf ch state stream quot -- string/f ) - 2drop 2drop >string f like ; - -: decode-read-loop ( buf stream encoding -- string/f ) - pick full? [ 2drop >string ] [ - over stream-read1 [ - -rot tuck >r >r >r dupd r> decode-step r> r> - decode-read-loop - ] [ 2drop >string f like ] if* - ] if ; - -: decode-read ( length stream encoding -- string ) - rot -rot decode-read-loop ; - -TUPLE: decoder code cr ; -: ( stream encoding -- newstream ) - dup binary eq? [ drop ] [ - dupd init-decoder { set-delegate set-decoder-code } - decoder construct - ] if ; +: >decoder< ( decoder -- stream encoding ) + { decoder-stream decoder-code } get-slots ; : cr+ t swap set-decoder-cr ; inline @@ -82,72 +59,78 @@ TUPLE: decoder code cr ; over decoder-cr [ over cr- "\n" ?head [ - swap stream-read1 [ add ] when* - ] [ nip ] if - ] [ nip ] if ; + over stream-read1 [ add ] when* + ] when + ] when nip ; + +: read-loop ( n stream -- string ) + SBUF" " clone [ + [ + >r nip stream-read1 dup + [ r> push f ] [ r> 2drop t ] if + ] 2curry find-integer drop + ] keep "" like f like ; M: decoder stream-read - tuck { delegate decoder-code } get-slots decode-read fix-read ; + tuck read-loop fix-read ; M: decoder stream-read-partial stream-read ; -: decoder-read-until ( stream delim -- ch ) - ! Copied from { c-reader stream-read-until }!!! - over stream-read1 dup [ - dup pick memq? [ 2nip ] [ , decoder-read-until ] if - ] [ - 2nip - ] if ; +: (read-until) ( buf quot -- string/f sep/f ) + ! quot: -- char stop? + dup call + [ >r drop "" like r> ] + [ pick push (read-until) ] if ; inline M: decoder stream-read-until - ! Copied from { c-reader stream-read-until }!!! - [ swap decoder-read-until ] "" make - swap over empty? over not and [ 2drop f f ] when ; + SBUF" " clone -rot >decoder< + [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry + (read-until) ; : fix-read1 ( stream char -- char ) over decoder-cr [ over cr- dup CHAR: \n = [ - drop stream-read1 - ] [ nip ] if - ] [ nip ] if ; + drop dup stream-read1 + ] when + ] when nip ; M: decoder stream-read1 - 1 swap stream-read f like [ first ] [ f ] if* ; + dup >decoder< decode-char fix-read1 ; M: decoder stream-readln ( stream -- str ) "\r\n" over stream-read-until handle-readln ; +M: decoder dispose decoder-stream dispose ; + ! Encoding +M: tuple-class construct-empty ; +M: tuple encoder construct-boa ; -TUPLE: encode-error ; - -: encode-error ( -- * ) \ encode-error construct-empty throw ; - -TUPLE: encoder code ; -: ( stream encoding -- newstream ) - dup binary eq? [ drop ] [ - construct-empty { set-delegate set-encoder-code } - encoder construct - ] if ; +: >encoder< ( encoder -- stream encoding ) + { encoder-stream encoder-code } get-slots ; M: encoder stream-write1 - >r 1string r> stream-write ; + >encoder< encode-char ; M: encoder stream-write - { delegate encoder-code } get-slots stream-write-encoded ; + >encoder< [ encode-char ] 2curry each ; -M: encoder dispose delegate dispose ; +M: encoder dispose encoder-stream dispose ; + +M: encoder stream-flush encoder-stream stream-flush ; INSTANCE: encoder plain-writer ! Rebinding duplex streams which have not read anything yet : reencode ( stream encoding -- newstream ) - over encoder? [ >r delegate r> ] when ; + over encoder? [ >r encoder-stream r> ] when ; : redecode ( stream encoding -- newstream ) - over decoder? [ >r delegate r> ] when ; + over decoder? [ >r decoder-stream r> ] when ; + +PRIVATE> : ( stream-in stream-out encoding -- duplex ) tuck reencode >r redecode r> ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 5887a8375e..e98860f25d 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -6,82 +6,68 @@ IN: io.encodings.utf8 ! Decoding UTF-8 -TUPLE: utf8 ch state ; +TUPLE: utf8 ; -SYMBOL: double -SYMBOL: triple -SYMBOL: triple2 -SYMBOL: quad -SYMBOL: quad2 -SYMBOL: quad3 +r over starts-2? - [ 6 shift swap BIN: 111111 bitand bitor r> ] - [ r> 3drop push-replacement ] if ; +: append-nums ( stream byte -- stream char ) + over stream-read1 dup starts-2? + [ swap 6 shift swap BIN: 111111 bitand bitor ] + [ 2drop replacement-char ] if ; -: begin-utf8 ( buf byte -- buf ch state ) +: double ( stream byte -- stream char ) + BIN: 11111 bitand append-nums ; + +: triple ( stream byte -- stream char ) + BIN: 1111 bitand append-nums append-nums ; + +: quad ( stream byte -- stream char ) + BIN: 111 bitand append-nums append-nums append-nums ; + +: begin-utf8 ( stream byte -- stream char ) { - { [ dup -7 shift zero? ] [ push-decoded ] } - { [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] } - { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] } - { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] } - { [ t ] [ drop push-replacement ] } + { [ dup -7 shift zero? ] [ ] } + { [ dup -5 shift BIN: 110 number= ] [ double ] } + { [ dup -4 shift BIN: 1110 number= ] [ triple ] } + { [ dup -3 shift BIN: 11110 number= ] [ quad ] } + { [ t ] [ drop replacement-char ] } } cond ; -: end-multibyte ( buf byte ch -- buf ch state ) - f append-nums [ push-decoded ] unless* ; +: decode-utf8 ( stream -- char/f ) + dup stream-read1 dup [ begin-utf8 ] when nip ; -: decode-utf8-step ( buf byte ch state -- buf ch state ) - { - { begin [ drop begin-utf8 ] } - { double [ end-multibyte ] } - { triple [ triple2 append-nums ] } - { triple2 [ end-multibyte ] } - { quad [ quad2 append-nums ] } - { quad2 [ quad3 append-nums ] } - { quad3 [ end-multibyte ] } - } case ; - -: unpack-state ( encoding -- ch state ) - { utf8-ch utf8-state } get-slots ; - -: pack-state ( ch state encoding -- ) - { set-utf8-ch set-utf8-state } set-slots ; - -M: utf8 decode-step ( buf char encoding -- ) - [ unpack-state decode-utf8-step ] keep pack-state drop ; - -M: utf8 init-decoder nip begin over set-utf8-state ; +M: utf8 decode-char + drop decode-utf8 ; ! Encoding UTF-8 -: encoded ( char -- ) - BIN: 111111 bitand BIN: 10000000 bitor write1 ; +: encoded ( stream char -- ) + BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ; -: char>utf8 ( char -- ) +: char>utf8 ( stream char -- ) { - { [ dup -7 shift zero? ] [ write1 ] } + { [ dup -7 shift zero? ] [ swap stream-write1 ] } { [ dup -11 shift zero? ] [ - dup -6 shift BIN: 11000000 bitor write1 + 2dup -6 shift BIN: 11000000 bitor swap stream-write1 encoded ] } { [ dup -16 shift zero? ] [ - dup -12 shift BIN: 11100000 bitor write1 - dup -6 shift encoded + 2dup -12 shift BIN: 11100000 bitor swap stream-write1 + 2dup -6 shift encoded encoded ] } { [ t ] [ - dup -18 shift BIN: 11110000 bitor write1 - dup -12 shift encoded - dup -6 shift encoded + 2dup -18 shift BIN: 11110000 bitor swap stream-write1 + 2dup -12 shift encoded + 2dup -6 shift encoded encoded ] } } cond ; -M: utf8 stream-write-encoded - ! For efficiency, this should be modified to avoid variable reads - drop [ [ char>utf8 ] each ] with-stream* ; +M: utf8 encode-char + drop swap char>utf8 ; + +PRIVATE> diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index df9c78fe47..1a3bde0e5c 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -19,7 +19,7 @@ ARTICLE: "pathnames" "Pathname manipulation" { $subsection parent-directory } { $subsection file-name } { $subsection last-path-separator } -{ $subsection path+ } +{ $subsection append-path } "Pathnames relative to Factor's install directory:" { $subsection resource-path } { $subsection ?resource-path } @@ -54,9 +54,7 @@ ARTICLE: "fs-meta" "File meta-data" { $subsection file-info } { $subsection link-info } { $subsection exists? } -{ $subsection directory? } -! { $subsection file-modified } -{ $subsection stat } ; +{ $subsection directory? } ; ARTICLE: "delete-move-copy" "Deleting, moving, copying files" "Operations for deleting and copying files come in two forms:" @@ -216,15 +214,7 @@ HELP: with-directory { $description "Changes the current working directory for the duration of a quotation's execution." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; -HELP: stat ( path -- directory? permissions length modified ) -{ $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } } -{ $description - "Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values." -} ; - -{ stat exists? directory? } related-words - -HELP: path+ +HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Concatenates two pathnames." } ; @@ -273,7 +263,7 @@ HELP: normalize-directory HELP: normalize-pathname { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } -{ $description "Called by the " { $link stat } " word, and possibly " { $link } " and " { $link } ", to prepare a pathname before passing it to underlying code." } ; +{ $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; HELP: ( str -- pathname ) { $values { "str" "a pathname string" } { "pathname" pathname } } diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index e347e3e3d6..4cda463983 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,5 +1,6 @@ IN: io.files.tests -USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; +USING: tools.test io.files io threads kernel continuations io.encodings.ascii +io.files.unique sequences strings accessors ; [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test @@ -130,4 +131,16 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test -[ ] [ "append-test" ascii dispose ] unit-test +[ ] [ "append-test" temp-file ascii dispose ] unit-test + + + +[ 123 ] [ + "core" ".test" [ + [ + ascii [ + 123 CHAR: a >string write + ] with-file-writer + ] keep file-info size>> + ] with-unique-file +] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index a6320a7507..21cc7c8f0a 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -32,10 +32,13 @@ HOOK: rename-file io-backend ( from to -- ) : left-trim-separators ( str -- newstr ) [ path-separator? ] left-trim ; -: path+ ( str1 str2 -- str ) +: append-path ( str1 str2 -- str ) >r right-trim-separators "/" r> left-trim-separators 3append ; +: prepend-path ( str1 str2 -- str ) + swap append-path ; inline + : last-path-separator ( path -- n ? ) [ length 1- ] keep [ path-separator? ] find-last* ; @@ -45,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ; : special-directory? ( name -- ? ) { "." ".." } member? ; -TUPLE: no-parent-directory path ; - -: no-parent-directory ( path -- * ) - \ no-parent-directory construct-boa throw ; +ERROR: no-parent-directory path ; : parent-directory ( path -- parent ) right-trim-separators { @@ -83,14 +83,11 @@ SYMBOL: +socket+ SYMBOL: +unknown+ ! File metadata -: stat ( path -- directory? permissions length modified ) - normalize-pathname (stat) ; +: exists? ( path -- ? ) + normalize-pathname (exists?) ; -: file-modified ( path -- n ) stat >r 3drop r> ; - -: exists? ( path -- ? ) file-modified >boolean ; - -: directory? ( path -- ? ) file-info file-info-type +directory+ = ; +: directory? ( path -- ? ) + file-info file-info-type +directory+ = ; ! Current working directory HOOK: cd io-backend ( path -- ) @@ -119,7 +116,7 @@ HOOK: make-directory io-backend ( path -- ) : fixup-directory ( path seq -- newseq ) [ dup string? - [ tuck path+ directory? 2array ] [ nip ] if + [ tuck append-path directory? 2array ] [ nip ] if ] with map [ first special-directory? not ] subset ; @@ -127,7 +124,7 @@ HOOK: make-directory io-backend ( path -- ) normalize-directory dup (directory) fixup-directory ; : directory* ( path -- seq ) - dup directory [ first2 >r path+ r> 2array ] with map ; + dup directory [ first2 >r append-path r> 2array ] with map ; ! Touching files HOOK: touch-file io-backend ( path -- ) @@ -146,7 +143,7 @@ HOOK: delete-directory io-backend ( path -- ) : delete-tree ( path -- ) dup directory? (delete-tree) ; -: to-directory over file-name path+ ; +: to-directory over file-name append-path ; ! Moving and renaming files HOOK: move-file io-backend ( from to -- ) @@ -179,7 +176,7 @@ DEFER: copy-tree-into : copy-tree ( from to -- ) over directory? [ >r dup directory swap r> [ - >r swap first path+ r> copy-tree-into + >r swap first append-path r> copy-tree-into ] 2curry each ] [ copy-file @@ -193,8 +190,8 @@ DEFER: copy-tree-into ! Special paths : resource-path ( path -- newpath ) - \ resource-path get [ image parent-directory ] unless* - swap path+ ; + "resource-path" get [ image parent-directory ] unless* + prepend-path ; : ?resource-path ( path -- newpath ) "resource:" ?head [ resource-path ] when ; @@ -236,7 +233,7 @@ M: pathname <=> [ pathname-string ] compare ; [ dup make-directory ] when ; -: temp-file ( name -- path ) temp-directory swap path+ ; +: temp-file ( name -- path ) temp-directory prepend-path ; ! Home directory : home ( -- dir ) diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 22c942d2d9..8a9089a564 100755 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -28,15 +28,6 @@ IN: io.tests ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test -[ "" ] [ 0 read ] unit-test - -! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test - -[ - "/core/io/test/binary.txt" - [ 0.2 read ] with-stream -] must-fail - [ { { "It seems " CHAR: J } @@ -58,3 +49,12 @@ IN: io.tests 10 [ 65536 read drop ] times ] with-file-reader ] unit-test + +! [ "" ] [ 0 read ] unit-test + +! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test + +! [ +! "/core/io/test/binary.txt" +! [ 0.2 read ] with-stream +! ] must-fail diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor index d5ca8eac68..2a8441ff23 100644 --- a/core/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -1,5 +1,5 @@ USING: byte-arrays byte-vectors kernel io.encodings io.streams.string -sequences io namespaces ; +sequences io namespaces io.encodings.private ; IN: io.streams.byte-array : ( encoding -- stream ) @@ -7,7 +7,7 @@ IN: io.streams.byte-array : with-byte-writer ( encoding quot -- byte-array ) >r r> [ stdio get ] compose with-stream* - >byte-array ; inline + dup encoder? [ encoder-stream ] when >byte-array ; inline : ( byte-array encoding -- stream ) >r >byte-vector dup reverse-here r> ; diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor index 97e60b4a60..83e991b713 100755 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ; : ( in out -- stream ) f duplex-stream construct-boa ; -TUPLE: check-closed ; +ERROR: stream-closed-twice ; : check-closed ( stream -- ) - duplex-stream-closed? - [ \ check-closed construct-boa throw ] when ; + duplex-stream-closed? [ stream-closed-twice ] when ; : duplex-stream-in+ ( duplex -- stream ) dup check-closed duplex-stream-in ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 7833e0aa47..b7ff37a971 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: io.streams.string USING: io kernel math namespaces sequences sbufs strings generic splitting growable continuations io.streams.plain -io.encodings ; +io.encodings io.encodings.private ; +IN: io.streams.string M: growable dispose drop ; @@ -49,8 +49,11 @@ M: growable stream-read M: growable stream-read-partial stream-read ; +TUPLE: null ; +M: null decode-char drop stream-read1 ; + : ( str -- stream ) - >sbuf dup reverse-here f ; + >sbuf dup reverse-here null ; : with-string-reader ( str quot -- ) >r r> with-stream ; inline diff --git a/core/libc/libc.factor b/core/libc/libc.factor index e82b244d6d..756d29e551 100755 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -23,20 +23,14 @@ SYMBOL: mallocs PRIVATE> -TUPLE: check-ptr ; +ERROR: bad-ptr ; : check-ptr ( c-ptr -- c-ptr ) - [ \ check-ptr construct-boa throw ] unless* ; + [ bad-ptr ] unless* ; -TUPLE: double-free ; +ERROR: double-free ; -: double-free ( -- * ) - \ double-free construct-empty throw ; - -TUPLE: realloc-error ptr size ; - -: realloc-error ( alien size -- * ) - \ realloc-error construct-boa throw ; +ERROR: realloc-error ptr size ; } -"A view of a sequence as an associative structure:" +"An enum provides such a view of a sequence:" { $subsection enum } { $subsection } "Utility word used by developer tools which inspect objects:" -{ $subsection make-mirror } ; +{ $subsection make-mirror } +{ $see-also "slots" } ; ABOUT: "mirrors" diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 5153d84c7f..560a174289 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -35,7 +35,7 @@ IN: optimizer.specializers swap "method-class" word-prop add* ; : specialize-method ( quot method -- quot' ) - method-declaration [ declare ] curry swap append ; + method-declaration [ declare ] curry prepend ; : specialize-quot ( quot specializer -- quot' ) dup { number } = [ diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 48f929b836..4d200c17d2 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -224,7 +224,7 @@ HELP: skip { $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } { $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; -HELP: change-column +HELP: change-lexer-column { $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } } { $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index e46f179424..f024eda54c 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -1,7 +1,7 @@ USING: arrays math parser tools.test kernel generic words io.streams.string namespaces classes effects source-files assocs sequences strings io.files definitions continuations -sorting tuples compiler.units debugger vocabs.loader ; +sorting tuples compiler.units debugger vocabs vocabs.loader ; IN: parser.tests [ @@ -461,3 +461,11 @@ must-fail-with ] times [ ] [ "parser" reload ] unit-test + +[ ] [ + [ "this-better-not-exist" forget-vocab ] with-compilation-unit +] unit-test + +[ + "USE: this-better-not-exist" eval +] must-fail diff --git a/core/parser/parser.factor b/core/parser/parser.factor index fd93479283..28822db708 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -60,7 +60,7 @@ t parser-notes set-global [ swap CHAR: \s eq? xor ] curry find* drop [ r> drop ] [ r> length ] if* ; -: change-column ( lexer quot -- ) +: change-lexer-column ( lexer quot -- ) swap [ dup lexer-column swap lexer-line-text rot call ] keep set-lexer-column ; inline @@ -68,14 +68,14 @@ t parser-notes set-global GENERIC: skip-blank ( lexer -- ) M: lexer skip-blank ( lexer -- ) - [ t skip ] change-column ; + [ t skip ] change-lexer-column ; GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if - ] change-column ; + ] change-lexer-column ; : still-parsing? ( lexer -- ? ) dup lexer-line swap lexer-text length <= ; @@ -98,10 +98,7 @@ M: lexer skip-word ( lexer -- ) : scan ( -- str/f ) lexer get parse-token ; -TUPLE: bad-escape ; - -: bad-escape ( -- * ) - \ bad-escape construct-empty throw ; +ERROR: bad-escape ; M: bad-escape summary drop "Bad escape code" ; @@ -156,7 +153,7 @@ name>char-hook global [ : parse-string ( -- str ) lexer get [ [ swap tail-slice (parse-string) ] "" make swap - ] change-column ; + ] change-lexer-column ; TUPLE: parse-error file line col text ; @@ -215,10 +212,7 @@ SYMBOL: in : set-in ( name -- ) check-vocab-string dup in set create-vocab (use+) ; -TUPLE: unexpected want got ; - -: unexpected ( want got -- * ) - \ unexpected construct-boa throw ; +ERROR: unexpected want got ; PREDICATE: unexpected unexpected-eof unexpected-got not ; @@ -294,10 +288,7 @@ M: no-word summary : CREATE-METHOD ( -- method ) scan-word bootstrap-word scan-word create-method-in ; -TUPLE: staging-violation word ; - -: staging-violation ( word -- * ) - \ staging-violation construct-boa throw ; +ERROR: staging-violation word ; M: staging-violation summary drop @@ -352,9 +343,7 @@ SYMBOL: lexer-factory ] if ] if ; -TUPLE: bad-number ; - -: bad-number ( -- * ) \ bad-number construct-boa throw ; +ERROR: bad-number ; : parse-base ( parsed base -- parsed ) scan swap base> [ bad-number ] unless* parsed ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9fc5264440..14674ba2f2 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; : bounds-check? ( n seq -- ? ) length 1- 0 swap between? ; inline -TUPLE: bounds-error index seq ; - -: bounds-error ( n seq -- * ) - \ bounds-error construct-boa throw ; +ERROR: bounds-error index seq ; : bounds-check ( n seq -- n seq ) 2dup bounds-check? [ bounds-error ] unless ; inline MIXIN: immutable-sequence -TUPLE: immutable seq ; - -: immutable ( seq -- * ) \ immutable construct-boa throw ; +ERROR: immutable seq ; M: immutable-sequence set-nth immutable ; @@ -190,8 +185,7 @@ TUPLE: slice from to seq ; : collapse-slice ( m n slice -- m' n' seq ) dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline -TUPLE: slice-error reason ; -: slice-error ( str -- * ) \ slice-error construct-boa throw ; +ERROR: slice-error reason ; : check-slice ( from to seq -- from to seq ) pick 0 < [ "start < 0" slice-error ] when @@ -299,6 +293,8 @@ M: immutable-sequence clone-like like ; : append ( seq1 seq2 -- newseq ) over (append) ; +: prepend ( seq1 seq2 -- newseq ) swap append ; inline + : 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ; : change-nth ( i seq quot -- ) diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor new file mode 100755 index 0000000000..cc93aeeff2 --- /dev/null +++ b/core/slots/deprecated/deprecated.factor @@ -0,0 +1,95 @@ +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel kernel.private math namespaces +sequences strings words effects generic generic.standard +classes slots.private combinators slots ; +IN: slots.deprecated + +: reader-effect ( class spec -- effect ) + >r ?word-name 1array r> slot-spec-name 1array ; + +PREDICATE: word slot-reader "reading" word-prop >boolean ; + +: set-reader-props ( class spec -- ) + 2dup reader-effect + over slot-spec-reader + swap "declared-effect" set-word-prop + slot-spec-reader swap "reading" set-word-prop ; + +: define-reader ( class spec -- ) + dup slot-spec-reader [ + [ set-reader-props ] 2keep + dup slot-spec-offset + over slot-spec-reader + rot slot-spec-type reader-quot + define-slot-word + ] [ + 2drop + ] if ; + +: writer-effect ( class spec -- effect ) + slot-spec-name swap ?word-name 2array 0 ; + +PREDICATE: word slot-writer "writing" word-prop >boolean ; + +: set-writer-props ( class spec -- ) + 2dup writer-effect + over slot-spec-writer + swap "declared-effect" set-word-prop + slot-spec-writer swap "writing" set-word-prop ; + +: define-writer ( class spec -- ) + dup slot-spec-writer [ + [ set-writer-props ] 2keep + dup slot-spec-offset + swap slot-spec-writer + [ set-slot ] + define-slot-word + ] [ + 2drop + ] if ; + +: define-slot ( class spec -- ) + 2dup define-reader define-writer ; + +: define-slots ( class specs -- ) + [ define-slot ] with each ; + +: reader-word ( class name vocab -- word ) + >r >r "-" r> 3append r> create ; + +: writer-word ( class name vocab -- word ) + >r [ swap "set-" % % "-" % % ] "" make r> create ; + +: (simple-slot-word) ( class name -- class name vocab ) + over word-vocabulary >r >r word-name r> r> ; + +: simple-reader-word ( class name -- word ) + (simple-slot-word) reader-word ; + +: simple-writer-word ( class name -- word ) + (simple-slot-word) writer-word ; + +: short-slot ( class name # -- spec ) + >r object bootstrap-word over r> f f + 2over simple-reader-word over set-slot-spec-reader + -rot simple-writer-word over set-slot-spec-writer ; + +: long-slot ( spec # -- spec ) + >r [ dup array? [ first2 create ] when ] map first4 r> + -rot ; + +: simple-slots ( class slots base -- specs ) + over length [ + ] with map [ + { + { [ over not ] [ 2drop f ] } + { [ over string? ] [ >r dupd r> short-slot ] } + { [ over array? ] [ long-slot ] } + } cond + ] 2map [ ] subset nip ; + +: slot-of-reader ( reader specs -- spec/f ) + [ slot-spec-reader eq? ] with find nip ; + +: slot-of-writer ( writer specs -- spec/f ) + [ slot-spec-writer eq? ] with find nip ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor old mode 100644 new mode 100755 index d57c4053e6..e4bb307829 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -4,25 +4,86 @@ effects generic.standard tuples slots.private classes strings math ; IN: slots +ARTICLE: "accessors" "Slot accessors" +"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:" +{ $list + { "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." } + { "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." } +} +"In addition, two utility words are defined for each distinct slot name used in the system:" +{ $list + { "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." } + { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." } +} +"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names." +$nl +"In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:" +{ $code + "" + " \"Happy birthday\" >>subject" + " { \"bob@bigcorp.com\" } >>to" + " \"alice@bigcorp.com\" >>from" + "send-email" +} +"The following uses writers, and requires some stack shuffling:" +{ $code + "" + " \"Happy birthday\" over (>>subject)" + " { \"bob@bigcorp.com\" } over (>>to)" + " \"alice@bigcorp.com\" over (>>from)" + "send-email" +} +"Even if some of the slot values come from the stack underneath the tuple being constructed, setters win:" +{ $code + "" + " swap >>subject" + " swap >>to" + " \"alice@bigcorp.com\" >>from" + "send-email" +} +"This is because " { $link swap } " is easier to understand than " { $link tuck } ":" +{ $code + "" + " tuck (>>subject)" + " tuck (>>to)" + " \"alice@bigcorp.com\" over (>>from)" + "send-email" +} +"The changer word abstracts a common pattern where a slot value is read then stored again; so the following is not idiomatic code:" +{ $code + "find-manager" + " salary>> 0.75 * >>salary" +} +"The following version is preferred:" +{ $code + "find-manager" + " [ 0.75 * ] change-salary" +} +{ $see-also "slots" "mirrors" } ; + ARTICLE: "slots" "Slots" -"A " { $emphasis "slot" } " is a component of an object which can store a value. The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object." +"A " { $emphasis "slot" } " is a component of an object which can store a value." $nl { $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data." +"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object." $nl "The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance." { $subsection slot-spec } -"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not." -{ $subsection slot-spec-reader } -{ $subsection slot-spec-writer } -"Given a reader or writer word and a class, it is possible to find the slot specifier corresponding to this word:" -{ $subsection slot-of-reader } -{ $subsection slot-of-writer } -"Reader and writer words form classes:" -{ $subsection slot-reader } -{ $subsection slot-writer } -"Slot readers and writers type check, then call unsafe primitives:" -{ $subsection slot } -{ $subsection set-slot } ; +"The four words associated with a slot can be looked up in the " { $vocab-link "accessors" } " vocabulary:" +{ $subsection reader-word } +{ $subsection writer-word } +{ $subsection setter-word } +{ $subsection changer-word } +"Looking up a slot by name:" +{ $subsection slot-named } +"Defining slots dynamically:" +{ $subsection define-reader } +{ $subsection define-writer } +{ $subsection define-setter } +{ $subsection define-changer } +{ $subsection define-slot-methods } +{ $subsection define-accessors } +{ $see-also "accessors" "mirrors" } ; ABOUT: "slots" @@ -59,53 +120,32 @@ $low-level-note ; HELP: reader-effect { $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } } -{ $description "The stack effect of slot reader words is " { $snippet "( obj -- value )" } "." } ; - -HELP: reader-quot -{ $values { "decl" class } { "quot" "a quotation with stack effect " { $snippet "( obj n -- value )" } } } -{ $description "Outputs a quotation which reads the " { $snippet "n" } "th slot of an object and declares it as an instance of a class." } ; - -HELP: slot-reader -{ $class-description "The class of slot reader words." } -{ $examples - { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" } -} ; +{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ; HELP: define-reader -{ $values { "class" class } { "spec" slot-spec } } -{ $description "Defines a generic word " { $snippet "reader" } " to read a slot from instances of " { $snippet "class" } "." } +{ $values { "class" class } { "name" string } { "slot" integer } } +{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." } $low-level-note ; HELP: writer-effect { $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } } { $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ; -HELP: slot-writer -{ $class-description "The class of slot writer words." } -{ $examples - { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" } -} ; - HELP: define-writer -{ $values { "class" class } { "spec" slot-spec } } +{ $values { "class" class } { "name" string } { "slot" integer } } { $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." } $low-level-note ; -HELP: define-slot -{ $values { "class" class } { "spec" slot-spec } } -{ $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." } +HELP: define-slot-methods +{ $values { "class" class } { "name" string } { "slot" integer } } +{ $description "Defines a reader, writer, setter and changer for a slot in instances of " { $snippet "class" } "." } $low-level-note ; -HELP: define-slots +HELP: define-accessors { $values { "class" class } { "specs" "a sequence of " { $link slot-spec } " instances" } } -{ $description "Defines a set of slot reader/writer words." } +{ $description "Defines slot methods." } $low-level-note ; -HELP: simple-slots -{ $values { "class" class } { "slots" "a sequence of strings" } { "base" "a slot number" } { "specs" "a sequence of " { $link slot-spec } " instances" } } -{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." } -{ $notes "This word is used by " { $link define-tuple-class } " and " { $link POSTPONE: TUPLE: } "." } ; - HELP: slot ( obj m -- value ) { $values { "obj" object } { "m" "a non-negative fixnum" } { "value" object } } { $description "Reads the object stored at the " { $snippet "n" } "th slot of " { $snippet "obj" } "." } @@ -116,18 +156,6 @@ HELP: set-slot ( value obj n -- ) { $description "Writes " { $snippet "value" } " to the " { $snippet "n" } "th slot of " { $snippet "obj" } "." } { $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ; -HELP: slot-of-reader -{ $values { "reader" slot-reader } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } } -{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-reader } " is equal to " { $snippet "reader" } "." } ; - -HELP: slot-of-writer -{ $values { "writer" slot-writer } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } } -{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-writer } " is equal to " { $snippet "writer" } "." } ; - -HELP: reader-word -{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } } -{ $description "Creates a word named " { $snippet { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ; - -HELP: writer-word -{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } } -{ $description "Creates a word named " { $snippet "set-" { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ; +HELP: slot-named +{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } } +{ $description "Outputs the " { $link slot-spec } " with the given name." } ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 7e9046573f..ed5de3a439 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -16,9 +16,6 @@ C: slot-spec : define-slot-word ( class slot word quot -- ) rot >fixnum add* define-typecheck ; -: reader-effect ( class spec -- effect ) - >r ?word-name 1array r> slot-spec-name 1array ; - : reader-quot ( decl -- quot ) [ \ slot , @@ -26,91 +23,62 @@ C: slot-spec [ drop ] [ 1array , \ declare , ] if ] [ ] make ; -PREDICATE: word slot-reader "reading" word-prop >boolean ; - -: set-reader-props ( class spec -- ) - 2dup reader-effect - over slot-spec-reader - swap "declared-effect" set-word-prop - slot-spec-reader swap "reading" set-word-prop ; - -: define-reader ( class spec -- ) - dup slot-spec-reader [ - [ set-reader-props ] 2keep - dup slot-spec-offset - over slot-spec-reader - rot slot-spec-type reader-quot - define-slot-word - ] [ - 2drop - ] if ; - -: writer-effect ( class spec -- effect ) - slot-spec-name swap ?word-name 2array 0 ; - -PREDICATE: word slot-writer "writing" word-prop >boolean ; - -: set-writer-props ( class spec -- ) - 2dup writer-effect - over slot-spec-writer - swap "declared-effect" set-word-prop - slot-spec-writer swap "writing" set-word-prop ; - -: define-writer ( class spec -- ) - dup slot-spec-writer [ - [ set-writer-props ] 2keep - dup slot-spec-offset - swap slot-spec-writer - [ set-slot ] - define-slot-word - ] [ - 2drop - ] if ; - -: define-slot ( class spec -- ) - 2dup define-reader define-writer ; - -: define-slots ( class specs -- ) - [ define-slot ] with each ; - -: reader-word ( class name vocab -- word ) - >r >r "-" r> 3append r> create ; - -: writer-word ( class name vocab -- word ) - >r [ swap "set-" % % "-" % % ] "" make r> create ; - -: (simple-slot-word) ( class name -- class name vocab ) - over word-vocabulary >r >r word-name r> r> ; - -: simple-reader-word ( class name -- word ) - (simple-slot-word) reader-word ; - -: simple-writer-word ( class name -- word ) - (simple-slot-word) writer-word ; - -: short-slot ( class name # -- spec ) - >r object bootstrap-word over r> f f - 2over simple-reader-word over set-slot-spec-reader - -rot simple-writer-word over set-slot-spec-writer ; - -: long-slot ( spec # -- spec ) - >r [ dup array? [ first2 create ] when ] map first4 r> - -rot ; - -: simple-slots ( class slots base -- specs ) - over length [ + ] with map [ - { - { [ over not ] [ 2drop f ] } - { [ over string? ] [ >r dupd r> short-slot ] } - { [ over array? ] [ long-slot ] } - } cond - ] 2map [ ] subset nip ; - -: slot-of-reader ( reader specs -- spec/f ) - [ slot-spec-reader eq? ] with find nip ; - -: slot-of-writer ( writer specs -- spec/f ) - [ slot-spec-writer eq? ] with find nip ; - -: slot-named ( string specs -- spec/f ) +: slot-named ( name specs -- spec/f ) [ slot-spec-name = ] with find nip ; + +: create-accessor ( name effect -- word ) + >r "accessors" create dup r> + "declared-effect" set-word-prop ; + +: reader-effect T{ effect f { "object" } { "value" } } ; inline + +: reader-word ( name -- word ) + ">>" append reader-effect create-accessor ; + +: define-reader ( class slot name -- ) + reader-word object reader-quot define-slot-word ; + +: writer-effect T{ effect f { "value" "object" } { } } ; inline + +: writer-word ( name -- word ) + "(>>" swap ")" 3append writer-effect create-accessor ; + +: define-writer ( class slot name -- ) + writer-word [ set-slot ] define-slot-word ; + +: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline + +: setter-word ( name -- word ) + ">>" prepend setter-effect create-accessor ; + +: define-setter ( name -- ) + dup setter-word dup deferred? [ + [ \ over , swap writer-word , ] [ ] make define-inline + ] [ 2drop ] if ; + +: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline + +: changer-word ( name -- word ) + "change-" prepend changer-effect create-accessor ; + +: define-changer ( name -- ) + dup changer-word dup deferred? [ + [ + [ over >r >r ] % + over reader-word , + [ r> call r> swap ] % + swap setter-word , + ] [ ] make define-inline + ] [ 2drop ] if ; + +: define-slot-methods ( class slot name -- ) + dup define-changer + dup define-setter + 3dup define-reader + define-writer ; + +: define-accessors ( class specs -- ) + [ + dup slot-spec-offset swap slot-spec-name + define-slot-methods + ] with each ; diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index d60403362c..34757e6b22 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,4 +1,4 @@ -USING: splitting tools.test ; +USING: splitting tools.test kernel sequences arrays ; IN: splitting.tests [ { 1 2 3 } 0 group ] must-fail @@ -56,3 +56,9 @@ unit-test [ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test [ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test [ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test + +[ { V{ "a" "b" } V{ f f } } ] [ + V{ "a" "b" } clone 2 + 2 over set-length + >array +] unit-test diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 6416e27eaf..419a30dda4 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -17,7 +17,7 @@ M: groups length dup groups-seq length swap groups-n [ + 1- ] keep /i ; M: groups set-length - [ groups-n * ] keep delegate set-length ; + [ groups-n * ] keep groups-seq set-length ; : group@ ( n groups -- from to seq ) [ groups-n [ * dup ] keep + ] keep diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index dc06a239de..c0ceb4119a 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -227,6 +227,9 @@ HELP: foldable } "The last restriction ensures that words such as " { $link clone } " do not satisfy the foldable word contract. Indeed, " { $link clone } " will output a mutable object if its input is mutable, and so it is undesirable to evaluate it at compile-time, since doing so would give incorrect semantics for code that clones mutable objects and proceeds to mutate them." } +{ $notes + "Folding optimizations are not applied if the call site of a word is in the same source file as the word. This is a side-effect of the compilation unit system; see " { $link "compilation-units" } "." +} { $examples "Most operations on numbers are foldable. For example, " { $snippet "2 2 +" } " compiles to a literal 4, since " { $link + } " is declared foldable." } ; HELP: flushable @@ -556,10 +559,17 @@ HELP: PREDICATE: HELP: TUPLE: { $syntax "TUPLE: class slots... ;" } { $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } } -{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } "." +{ $description "Defines a new tuple class." $nl "Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ; +HELP: ERROR: +{ $syntax "ERROR: class slots... ;" } +{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } } +{ $description "Defines a new tuple class. Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ; + +{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words + HELP: C: { $syntax "C: constructor class" } { $values { "constructor" "a new word to define" } { "class" tuple-class } } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index d9870b08da..843f372542 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -163,6 +163,12 @@ IN: bootstrap.syntax [ construct-boa ] curry define-inline ] define-syntax + "ERROR:" [ + CREATE-CLASS dup ";" parse-tokens define-tuple-class + dup save-location + dup [ construct-boa throw ] curry define + ] define-syntax + "FORGET:" [ scan-word dup parsing? [ V{ } clone swap execute first ] when diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index 3af7d27d86..09d93884ad 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -3,11 +3,10 @@ tuples.private classes slots quotations words arrays generic.standard sequences definitions compiler.units ; IN: tuples -ARTICLE: "tuple-constructors" "Constructors and slots" -"Tuples are created by calling one of a number of words:" +ARTICLE: "tuple-constructors" "Constructors" +"Tuples are created by calling one of two words:" { $subsection construct-empty } { $subsection construct-boa } -{ $subsection construct } "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 "A shortcut for defining BOA constructors:" @@ -19,18 +18,13 @@ $nl "C: rgba" ": color construct-boa ; ! identical to above" "" - ": " - " { set-color-red set-color-green set-color-blue }" - " color construct ;" - ": f ; ! identical to above" + ": f ;" "" ": construct-empty ;" - ": { } color construct ; ! identical to above" ": f f f f ; ! identical to above" -} -"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ; +} ; -ARTICLE: "tuple-delegation" "Delegation" +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 } @@ -48,7 +42,7 @@ $nl "{ 0 0 } 10 \"my-ellipse\" set" "{ 1 0 0 } \"my-shape\" set" "\"my-ellipse\" get \"my-shape\" get set-delegate" - "\"my-shape\" get dup colored-color swap ellipse-center .s" + "\"my-shape\" get dup color>> swap center>> .s" "{ 0 0 }\n{ 1 0 0 }" } ; @@ -58,25 +52,90 @@ ARTICLE: "tuple-introspection" "Tuple introspection" { $subsection tuple>array } { $subsection tuple-slots } "Tuple classes can also be defined at run time:" -{ $subsection define-tuple-class } ; +{ $subsection define-tuple-class } +{ $see-also "slots" "mirrors" } ; + +ARTICLE: "tuple-examples" "Tuple examples" +"An example:" +{ $code "TUPLE: employee name salary position ;" } +"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:" +{ $table + { "Reader" "Writer" "Setter" "Changer" } + { { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } } + { { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } } + { { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } } +} +"We can define a constructor which makes an empty employee:" +{ $code ": ( -- employee )" + " employee construct-empty ;" } +"Or we may wish the default constructor to always give employees a starting salary:" +{ $code + ": ( -- employee )" + " employee construct-empty" + " 40000 >>salary ;" +} +"We can define more refined constructors:" +{ $code + ": ( -- manager )" + " \"project manager\" >>position ;" } +"An alternative strategy is to define the most general BOA constructor first:" +{ $code + ": ( name position -- person )" + " 40000 employee construct-boa ;" +} +"Now we can define more specific constructors:" +{ $code + ": ( name -- person )" + " \"manager\" ;" } +"An example using reader words:" +{ $code + "TUPLE: check to amount number ;" + "" + "SYMBOL: checks" + "" + ": ( to amount -- check )" + " checks counter check construct-boa ;" + "" + ": biweekly-paycheck ( employee -- check )" + " dup name>> swap salary>> 26 / ;" +} +"An example of using a changer:" +{ $code + ": positions" + " {" + " \"junior programmer\"" + " \"senior programmer\"" + " \"project manager\"" + " \"department manager\"" + " \"executive\"" + " \"CTO\"" + " \"CEO\"" + " \"enterprise Java world dictator\"" + " } ;" + "" + ": next-position ( role -- newrole )" + " positions [ index 1+ ] keep nth ;" + "" + ": promote ( person -- person )" + " [ 1.2 * ] change-salary" + " [ next-position ] change-position ;" +} ; ARTICLE: "tuples" "Tuples" -"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:" +"Tuples are user-defined classes composed of named slots." +{ $subsection "tuple-examples" } +"A parsing word defines tuple classes:" { $subsection POSTPONE: TUPLE: } -"An example:" -{ $code "TUPLE: person name address phone ;" "C: person" } -"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "" } ", and the following reader/writer words:" -{ $table - { "Reader" "Writer" } - { { $snippet "person-name" } { $snippet "set-person-name" } } - { { $snippet "person-address" } { $snippet "set-person-address" } } - { { $snippet "person-phone" } { $snippet "set-person-phone" } } -} +"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot." +$nl +"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:" +{ $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" } -{ $subsection "tuple-introspection" } ; +{ $subsection "tuple-introspection" } +"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ; ABOUT: "tuples" diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 63bb233654..b5076ea22b 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -236,7 +236,7 @@ C: erg's-reshape-problem [ "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval -] [ [ check-tuple? ] is? ] must-fail-with +] [ [ no-tuple-class? ] is? ] must-fail-with ! Hardcore unit tests USE: threads diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index e48a803659..02ce49d779 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -3,7 +3,8 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic -classes classes.private slots slots.private compiler.units ; +classes classes.private slots slots.deprecated slots.private +compiler.units ; IN: tuples M: tuple delegate 3 slot ; @@ -85,13 +86,14 @@ PRIVATE> dupd 4 simple-slots 2dup [ slot-spec-name ] map "slot-names" set-word-prop 2dup delegate-slot-spec add* "slots" set-word-prop - define-slots ; + 2dup define-slots + define-accessors ; -TUPLE: check-tuple class ; +ERROR: no-tuple-class class ; : check-tuple ( class -- ) dup tuple-class? - [ drop ] [ \ check-tuple construct-boa throw ] if ; + [ drop ] [ no-tuple-class ] if ; : define-tuple-class ( class slots -- ) 2dup check-shape diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index c7652c34c7..c0542f7b96 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -43,8 +43,6 @@ HELP: find-vocab-root { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } } { $description "Searches for a vocabulary in the vocabulary roots." } ; -{ vocab-root find-vocab-root } related-words - HELP: no-vocab { $values { "name" "a vocabulary name" } } { $description "Throws a " { $link no-vocab } "." } diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 015f54540d..85399ca9e7 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -13,15 +13,15 @@ debugger compiler.units tools.vocabs ; ] unit-test [ T{ vocab-link f "vocabs.loader.test" } ] -[ "vocabs.loader.test" f >vocab-link ] unit-test +[ "vocabs.loader.test" >vocab-link ] unit-test [ t ] -[ "kernel" f >vocab-link "kernel" vocab = ] unit-test +[ "kernel" >vocab-link "kernel" vocab = ] unit-test [ t ] [ "kernel" vocab-files "kernel" vocab vocab-files - "kernel" f vocab-files + "kernel" vocab-files 3array all-equal? ] unit-test @@ -36,7 +36,7 @@ IN: vocabs.loader.tests [ { 3 3 3 } ] [ "vocabs.loader.test.2" run "vocabs.loader.test.2" vocab run - "vocabs.loader.test.2" f run + "vocabs.loader.test.2" run 3array ] unit-test @@ -115,7 +115,7 @@ IN: vocabs.loader.tests [ 3 ] [ "count-me" get-global ] unit-test [ { "resource:core/kernel/kernel.factor" 1 } ] -[ "kernel" f where ] unit-test +[ "kernel" where ] unit-test [ { "resource:core/kernel/kernel.factor" 1 } ] [ "kernel" vocab where ] unit-test @@ -136,7 +136,7 @@ IN: vocabs.loader.tests [ { "2" "a" "b" "d" "e" "f" } [ - "vocabs.loader.test." swap append forget-vocab + "vocabs.loader.test." prepend forget-vocab ] each ] with-compilation-unit ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 96193ef664..9478c1f4f7 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -23,30 +23,30 @@ V{ [ >r dup peek r> append add ] when* "/" join ; -: vocab-path+ ( vocab path -- newpath ) - swap vocab-root dup [ swap path+ ] [ 2drop f ] if ; - -: vocab-source-path ( vocab -- path/f ) - dup ".factor" vocab-dir+ vocab-path+ ; - -: vocab-docs-path ( vocab -- path/f ) - dup "-docs.factor" vocab-dir+ vocab-path+ ; - : vocab-dir? ( root name -- ? ) over [ - ".factor" vocab-dir+ path+ resource-exists? + ".factor" vocab-dir+ append-path resource-exists? ] [ 2drop f ] if ; +SYMBOL: root-cache + +H{ } clone root-cache set-global + : find-vocab-root ( vocab -- path/f ) - vocab-roots get swap [ vocab-dir? ] curry find nip ; + vocab-name root-cache get [ + vocab-roots get swap [ vocab-dir? ] curry find nip + ] cache ; -M: string vocab-root - vocab dup [ vocab-root ] when ; +: vocab-append-path ( vocab path -- newpath ) + swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ; -M: vocab-link vocab-root - vocab-link-root ; +: vocab-source-path ( vocab -- path/f ) + dup ".factor" vocab-dir+ vocab-append-path ; + +: vocab-docs-path ( vocab -- path/f ) + dup "-docs.factor" vocab-dir+ vocab-append-path ; SYMBOL: load-help? @@ -56,7 +56,7 @@ SYMBOL: load-help? : load-source ( vocab -- ) [ source-wasn't-loaded ] keep - [ vocab-source-path bootstrap-file ] keep + [ vocab-source-path [ bootstrap-file ] when* ] keep source-was-loaded ; : docs-were-loaded t swap set-vocab-docs-loaded? ; @@ -70,18 +70,9 @@ SYMBOL: load-help? docs-were-loaded ] [ drop ] if ; -: create-vocab-with-root ( name root -- vocab ) - swap create-vocab [ set-vocab-root ] keep ; - -: update-root ( vocab -- ) - dup vocab-root - [ drop ] [ dup find-vocab-root swap set-vocab-root ] if ; - : reload ( name -- ) [ - dup vocab [ - dup update-root dup load-source load-docs - ] [ no-vocab ] ?if + dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if ] with-compiler-errors ; : require ( vocab -- ) @@ -104,22 +95,17 @@ SYMBOL: blacklist GENERIC: (load-vocab) ( name -- ) M: vocab (load-vocab) - dup update-root - - dup vocab-root [ - [ - dup vocab-source-loaded? [ dup load-source ] unless - dup vocab-docs-loaded? [ dup load-docs ] unless - ] [ [ swap add-to-blacklist ] keep rethrow ] recover - ] when drop ; - -M: string (load-vocab) - ! ".private" ?tail drop - dup find-vocab-root >vocab-link (load-vocab) ; + [ + dup vocab-source-loaded? [ dup load-source ] unless + dup vocab-docs-loaded? [ dup load-docs ] unless + drop + ] [ [ swap add-to-blacklist ] keep rethrow ] recover ; M: vocab-link (load-vocab) - dup vocab-name swap vocab-root dup - [ create-vocab-with-root (load-vocab) ] [ 2drop ] if ; + vocab-name create-vocab (load-vocab) ; + +M: string (load-vocab) + create-vocab (load-vocab) ; [ [ @@ -127,7 +113,11 @@ M: vocab-link (load-vocab) rethrow ] [ drop - [ (load-vocab) ] with-compiler-errors + dup find-vocab-root [ + [ (load-vocab) ] with-compiler-errors + ] [ + dup vocab [ drop ] [ no-vocab ] if + ] if ] if ] with-compiler-errors ] load-vocab-hook set-global diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor index f16a33f0d5..0d55499620 100755 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -16,7 +16,6 @@ $nl { $subsection vocab } "Accessors for various vocabulary attributes:" { $subsection vocab-name } -{ $subsection vocab-root } { $subsection vocab-main } { $subsection vocab-help } "Looking up existing vocabularies and creating new vocabularies:" @@ -50,10 +49,6 @@ HELP: vocab-name { $values { "vocab" "a vocabulary specifier" } { "name" string } } { $description "Outputs the name of a vocabulary." } ; -HELP: vocab-root -{ $values { "vocab" "a vocabulary specifier" } { "root" "a pathname string or " { $link f } } } -{ $description "Outputs the vocabulary root where the source code for a vocabulary is located, or " { $link f } " if the vocabulary is not defined in source files." } ; - HELP: vocab-words { $values { "vocab" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } } { $description "Outputs the words defined in a vocabulary." } ; @@ -101,11 +96,11 @@ HELP: child-vocabs } ; HELP: vocab-link -{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name, and " { $link vocab-root } " is a pathname string identifying the vocabulary root where the sources to this vocabulary are located, or " { $link f } " if the root is not known." +{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name." $nl "Vocabulary links are created by calling " { $link >vocab-link } "." } ; HELP: >vocab-link -{ $values { "name" string } { "root" "a pathname string or " { $link f } } { "vocab" "a vocabulary specifier" } } +{ $values { "name" string } { "vocab" "a vocabulary specifier" } } { $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 9d281c864b..f111b5bc74 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -7,8 +7,7 @@ IN: vocabs SYMBOL: dictionary TUPLE: vocab -name root -words +name words main help source-loaded? docs-loaded? ; @@ -60,16 +59,12 @@ M: f vocab-help ; : create-vocab ( name -- vocab ) dictionary get [ ] cache ; -TUPLE: no-vocab name ; - -: no-vocab ( name -- * ) - vocab-name \ no-vocab construct-boa throw ; +ERROR: no-vocab name ; SYMBOL: load-vocab-hook ! ( name -- ) : load-vocab ( name -- vocab ) - dup load-vocab-hook get call - dup vocab [ ] [ no-vocab ] ?if ; + dup load-vocab-hook get call vocab ; : vocabs ( -- seq ) dictionary get keys natural-sort ; @@ -92,10 +87,10 @@ SYMBOL: load-vocab-hook ! ( name -- ) : child-vocabs ( vocab -- seq ) vocab-name vocabs [ child-vocab? ] with subset ; -TUPLE: vocab-link name root ; +TUPLE: vocab-link name ; -: ( name root -- vocab-link ) - [ dup vocab-root ] unless* vocab-link construct-boa ; +: ( name -- vocab-link ) + vocab-link construct-boa ; M: vocab-link equal? over vocab-link? @@ -106,17 +101,14 @@ M: vocab-link hashcode* M: vocab-link vocab-name vocab-link-name ; -GENERIC# >vocab-link 1 ( name root -- vocab ) - -M: vocab >vocab-link drop ; - -M: vocab-link >vocab-link drop ; - -M: string >vocab-link - over vocab dup [ 2nip ] [ drop ] if ; - UNION: vocab-spec vocab vocab-link ; +GENERIC: >vocab-link ( name -- vocab ) + +M: vocab-spec >vocab-link ; + +M: string >vocab-link dup vocab [ ] [ ] ?if ; + : forget-vocab ( vocab -- ) dup words forget-all vocab-name dictionary get delete-at ; diff --git a/core/words/words.factor b/core/words/words.factor index a36cca00ac..de253e6fee 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ; M: word definition word-def ; -TUPLE: undefined ; - -: undefined ( -- * ) \ undefined construct-empty throw ; +ERROR: undefined ; PREDICATE: word deferred ( obj -- ? ) word-def [ undefined ] = ; @@ -189,12 +187,11 @@ M: word subwords drop f ; [ ] [ no-vocab ] ?if set-at ; -TUPLE: check-create name vocab ; +ERROR: bad-create name vocab ; : check-create ( name vocab -- name vocab ) - 2dup [ string? ] both? [ - \ check-create construct-boa throw - ] unless ; + 2dup [ string? ] both? + [ bad-create ] unless ; : create ( name vocab -- word ) check-create 2dup lookup diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor index 99d1e0a19d..8954ffd8cc 100644 --- a/extra/asn1/asn1.factor +++ b/extra/asn1/asn1.factor @@ -135,18 +135,18 @@ SYMBOL: end GENERIC: >ber ( obj -- byte-array ) M: fixnum >ber ( n -- byte-array ) >128-ber dup length 2 swap 2array - "cc" pack-native swap append ; + "cc" pack-native prepend ; : >ber-enumerated ( n -- byte-array ) >128-ber >byte-array dup length 10 swap 2array - "CC" pack-native swap append ; + "CC" pack-native prepend ; : >ber-length-encoding ( n -- byte-array ) dup 127 <= [ 1array "C" pack-be ] [ 1array "I" pack-be 0 swap remove dup length - HEX: 80 + 1array "C" pack-be swap append + HEX: 80 + 1array "C" pack-be prepend ] if ; ! ========================================================= @@ -158,7 +158,7 @@ M: bignum >ber ( n -- byte-array ) dup 126 > [ "range error in bignum" throw ] [ - 2 swap 2array "CC" pack-native swap append + 2 swap 2array "CC" pack-native prepend ] if ; ! ========================================================= diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 2500940373..b23ee1f830 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -41,7 +41,7 @@ IN: assocs.lib >r 2array flip r> assoc-like ; : generate-key ( assoc -- str ) - >r random-256 >hex r> + >r 256 random-bits >hex r> 2dup key? [ nip generate-key ] [ drop ] if ; : set-at-unique ( value assoc -- key ) diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index cd799d477e..b6d4152d0e 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -46,7 +46,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; : pattern>state ( {_a_b_c_} -- state ) rule> at ; -: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ; +: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ; : wrap-line ( a-line-z -- za-line-za ) dup peek 1array swap dup first 1array append append ; diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 211ab28c92..175f66f4a6 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -88,7 +88,7 @@ M: check< summary drop "Number exceeds upper bound" ; >r keys r> define-slots ; : define-setters ( classname slots -- ) - >r "with-" swap append r> + >r "with-" prepend r> dup values [setters] >r keys r> define-slots ; diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index df559f49da..a186954ef0 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -18,7 +18,7 @@ bootstrap.image sequences io ; : download-image ( arch -- ) boot-image-name dup need-new-image? [ "Downloading " write dup write "..." print - url swap append download + url prepend download ] [ "Boot image up to date" print drop diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor new file mode 100755 index 0000000000..b61e002526 --- /dev/null +++ b/extra/bootstrap/random/random.factor @@ -0,0 +1,13 @@ +USING: vocabs.loader sequences system +random random.mersenne-twister combinators init +namespaces ; + +"random.mersenne-twister" require + +{ + { [ windows? ] [ "random.windows" require ] } + { [ unix? ] [ "random.unix" require ] } +} cond + +[ millis random-generator set-global ] +"generator.random" add-init-hook diff --git a/extra/bootstrap/ui/tools/tools.factor b/extra/bootstrap/ui/tools/tools.factor index c4a555b3e2..a3d02a0016 100755 --- a/extra/bootstrap/ui/tools/tools.factor +++ b/extra/bootstrap/ui/tools/tools.factor @@ -1,7 +1,7 @@ USING: kernel vocabs vocabs.loader sequences system ; { "ui" "help" "tools" } -[ "bootstrap." swap append vocab ] all? [ +[ "bootstrap." prepend vocab ] all? [ "ui.tools" require "ui.cocoa" vocab [ diff --git a/extra/bootstrap/ui/ui.factor b/extra/bootstrap/ui/ui.factor index 86538e0000..f8db831dbc 100644 --- a/extra/bootstrap/ui/ui.factor +++ b/extra/bootstrap/ui/ui.factor @@ -8,7 +8,7 @@ vocabs vocabs.loader ; { [ windows? ] [ "windows" ] } { [ unix? ] [ "x11" ] } } cond - ] unless* "ui." swap append require + ] unless* "ui." prepend require "ui.freetype" require ] when diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 7d95ce2409..19734a3266 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -58,8 +58,8 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : copy-image ( -- ) - builds "factor" path+ my-boot-image-name path+ ".." copy-file-into - builds "factor" path+ my-boot-image-name path+ "." copy-file-into ; + builds "factor" append-path my-boot-image-name append-path ".." copy-file-into + builds "factor" append-path my-boot-image-name append-path "." copy-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -86,7 +86,7 @@ IN: builder +closed+ >>stdin "../test-log" >>stdout +stdout+ >>stderr - 45 minutes >>timeout ; + 120 minutes >>timeout ; : do-builder-test ( -- ) builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index f0cf0ee113..0e26abe02f 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -8,7 +8,7 @@ IN: builder.release ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : releases ( -- path ) - builds "releases" path+ + builds "releases" append-path dup exists? not [ dup make-directory ] when ; diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 82514ca43d..55ff38d408 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations io io.files io.launcher io.sockets math math.parser combinators sequences splitting quotations arrays strings tools.time - sequences.deep new-slots accessors assocs.lib + sequences.deep accessors assocs.lib io.encodings.utf8 combinators.cleave bake calendar calendar.format ; diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor index a3f6174726..643737b23c 100755 --- a/extra/bunny/deploy.factor +++ b/extra/bunny/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 1 } + { deploy-word-defs? f } + { deploy-random? f } { deploy-name "Bunny" } { deploy-threads? t } - { deploy-word-props? f } - { "stop-after-last-window?" t } - { deploy-ui? t } - { deploy-io 3 } { deploy-compiler? t } - { deploy-word-defs? f } + { deploy-math? t } { deploy-c-types? f } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? t } + { "stop-after-last-window?" t } + { deploy-word-props? f } } diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index d7aa90c464..76ce27975b 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -13,7 +13,7 @@ USING: alien alien.syntax combinators system ; IN: cairo.ffi << "cairo" { - { [ win32? ] [ "cairo.dll" ] } + { [ win32? ] [ "libcairo-2.dll" ] } ! { [ macosx? ] [ "libcairo.dylib" ] } { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } { [ unix? ] [ "libcairo.so.2" ] } diff --git a/extra/cairo/lib/lib.factor b/extra/cairo/lib/lib.factor old mode 100644 new mode 100755 index 9e226ee47a..1b969978a3 --- a/extra/cairo/lib/lib.factor +++ b/extra/cairo/lib/lib.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types cairo.ffi continuations destructors -kernel libc locals math combinators.cleave shuffle new-slots +kernel libc locals math combinators.cleave shuffle accessors ; IN: cairo.lib diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor old mode 100644 new mode 100755 index b9da14088c..55828cde9c --- a/extra/cairo/png/png.factor +++ b/extra/cairo/png/png.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators.cleave kernel new-slots +USING: arrays combinators.cleave kernel accessors math ui.gadgets ui.render opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib ; IN: cairo.png diff --git a/extra/calendar/backend/backend.factor b/extra/calendar/backend/backend.factor index 15b5e7cb8d..01c36c65ae 100644 --- a/extra/calendar/backend/backend.factor +++ b/extra/calendar/backend/backend.factor @@ -2,4 +2,4 @@ USING: kernel ; IN: calendar.backend SYMBOL: calendar-backend -HOOK: gmt-offset calendar-backend +HOOK: gmt-offset calendar-backend ( -- hours minutes seconds ) diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index 1041c79691..e49d3ad894 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -2,14 +2,14 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; IN: calendar.tests -[ f ] [ 2004 12 32 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 2 30 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2003 2 29 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 -2 9 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 0 0 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 1 24 0 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 1 23 60 0 0 valid-timestamp? ] unit-test -[ f ] [ 2004 12 1 23 59 60 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 2 30 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2003 2 29 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 -2 9 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 0 0 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 24 0 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 60 0 instant valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 59 60 instant valid-timestamp? ] unit-test [ t ] [ now valid-timestamp? ] unit-test [ f ] [ 1900 leap-year? ] unit-test @@ -18,126 +18,126 @@ IN: calendar.tests [ f ] [ 2001 leap-year? ] unit-test [ f ] [ 2006 leap-year? ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 1 seconds time+ - 2006 10 10 0 0 1 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 100 seconds time+ - 2006 10 10 0 1 40 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -100 seconds time+ - 2006 10 9 23 58 20 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 86400 seconds time+ - 2006 10 11 0 0 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 1 seconds time+ + 2006 10 10 0 0 1 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 100 seconds time+ + 2006 10 10 0 1 40 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -100 seconds time+ + 2006 10 9 23 58 20 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 86400 seconds time+ + 2006 10 11 0 0 0 instant = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 10 minutes time+ - 2006 10 10 0 10 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 10.5 minutes time+ - 2006 10 10 0 10 30 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 3/4 minutes time+ - 2006 10 10 0 0 45 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -3/4 minutes time+ - 2006 10 9 23 59 15 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 10 minutes time+ + 2006 10 10 0 10 0 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 10.5 minutes time+ + 2006 10 10 0 10 30 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 3/4 minutes time+ + 2006 10 10 0 0 45 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -3/4 minutes time+ + 2006 10 9 23 59 15 instant = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 7200 minutes time+ - 2006 10 15 0 0 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -10 minutes time+ - 2006 10 9 23 50 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 -100 minutes time+ - 2006 10 9 22 20 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant 7200 minutes time+ + 2006 10 15 0 0 0 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -10 minutes time+ + 2006 10 9 23 50 0 instant = ] unit-test +[ t ] [ 2006 10 10 0 0 0 instant -100 minutes time+ + 2006 10 9 22 20 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 hours time+ - 2006 1 1 1 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 24 hours time+ - 2006 1 2 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -24 hours time+ - 2005 12 31 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 12 hours time+ - 2006 1 1 12 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 72 hours time+ - 2006 1 4 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 hours time+ + 2006 1 1 1 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 24 hours time+ + 2006 1 2 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -24 hours time+ + 2005 12 31 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 12 hours time+ + 2006 1 1 12 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 72 hours time+ + 2006 1 4 0 0 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 days time+ - 2006 1 2 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -1 days time+ - 2005 12 31 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 365 days time+ - 2007 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -365 days time+ - 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 365 days time+ - 2004 12 31 0 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 366 days time+ - 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 days time+ + 2006 1 2 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -1 days time+ + 2005 12 31 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 365 days time+ + 2007 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -365 days time+ + 2005 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant 365 days time+ + 2004 12 31 0 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant 366 days time+ + 2005 1 1 0 0 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 11 months time+ - 2006 12 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 12 months time+ - 2007 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 24 months time+ - 2008 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 13 months time+ - 2007 2 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 months time+ - 2006 2 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 0 months time+ - 2006 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -1 months time+ - 2005 12 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -2 months time+ - 2005 11 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -13 months time+ - 2004 12 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -24 months time+ - 2004 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 12 months time+ - 2005 3 1 0 0 0 0 = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 -12 months time+ - 2003 3 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 11 months time+ + 2006 12 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 12 months time+ + 2007 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 24 months time+ + 2008 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 13 months time+ + 2007 2 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 months time+ + 2006 2 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 0 months time+ + 2006 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -1 months time+ + 2005 12 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -2 months time+ + 2005 11 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -13 months time+ + 2004 12 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -24 months time+ + 2004 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2004 2 29 0 0 0 instant 12 months time+ + 2005 3 1 0 0 0 instant = ] unit-test +[ t ] [ 2004 2 29 0 0 0 instant -12 months time+ + 2003 3 1 0 0 0 instant = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 0 years time+ - 2006 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 1 years time+ - 2007 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -1 years time+ - 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 -100 years time+ - 1906 1 1 0 0 0 0 = ] unit-test -! [ t ] [ 2004 2 29 0 0 0 0 -1 years time+ -! 2003 2 28 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 0 years time+ + 2006 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant 1 years time+ + 2007 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -1 years time+ + 2005 1 1 0 0 0 instant = ] unit-test +[ t ] [ 2006 1 1 0 0 0 instant -100 years time+ + 1906 1 1 0 0 0 instant = ] unit-test +! [ t ] [ 2004 2 29 0 0 0 instant -1 years time+ +! 2003 2 28 0 0 0 instant = ] unit-test -[ 5 ] [ 2006 7 14 0 0 0 0 day-of-week ] unit-test +[ 5 ] [ 2006 7 14 0 0 0 instant day-of-week ] unit-test -[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 ] 3keep 0 0 0 0 = ] unit-test +[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 instant ] 3keep 0 0 0 instant = ] unit-test -[ 1 ] [ 2006 1 1 0 0 0 0 day-of-year ] unit-test -[ 60 ] [ 2004 2 29 0 0 0 0 day-of-year ] unit-test -[ 61 ] [ 2004 3 1 0 0 0 0 day-of-year ] unit-test -[ 366 ] [ 2004 12 31 0 0 0 0 day-of-year ] unit-test -[ 365 ] [ 2003 12 31 0 0 0 0 day-of-year ] unit-test -[ 60 ] [ 2003 3 1 0 0 0 0 day-of-year ] unit-test +[ 1 ] [ 2006 1 1 0 0 0 instant day-of-year ] unit-test +[ 60 ] [ 2004 2 29 0 0 0 instant day-of-year ] unit-test +[ 61 ] [ 2004 3 1 0 0 0 instant day-of-year ] unit-test +[ 366 ] [ 2004 12 31 0 0 0 instant day-of-year ] unit-test +[ 365 ] [ 2003 12 31 0 0 0 instant day-of-year ] unit-test +[ 60 ] [ 2003 3 1 0 0 0 instant day-of-year ] unit-test -[ t ] [ 2004 12 31 0 0 0 0 dup = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 10 seconds 5 years time+ time+ - 2009 1 1 0 0 10 0 = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 -10 seconds -5 years time+ time+ - 1998 12 31 23 59 50 0 = ] unit-test +[ t ] [ 2004 12 31 0 0 0 instant dup = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant 10 seconds 5 years time+ time+ + 2009 1 1 0 0 10 instant = ] unit-test +[ t ] [ 2004 1 1 0 0 0 instant -10 seconds -5 years time+ time+ + 1998 12 31 23 59 50 instant = ] unit-test -[ t ] [ 2004 1 1 23 0 0 12 0 convert-timezone - 2004 1 1 11 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 5 0 0 -11 0 convert-timezone - 2004 1 1 16 0 0 0 = ] unit-test -[ t ] [ 2004 1 1 23 0 0 9+1/2 0 convert-timezone - 2004 1 1 13 30 0 0 = ] unit-test +[ t ] [ 2004 1 1 23 0 0 12 hours >gmt + 2004 1 1 11 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 5 0 0 -11 hours >gmt + 2004 1 1 16 0 0 instant = ] unit-test +[ t ] [ 2004 1 1 23 0 0 9+1/2 hours >gmt + 2004 1 1 13 30 0 instant = ] unit-test -[ 0 ] [ 2004 1 1 13 30 0 0 - 2004 1 1 12 30 0 -1 <=> ] unit-test +[ 0 ] [ 2004 1 1 13 30 0 instant + 2004 1 1 12 30 0 -1 hours <=> ] unit-test -[ 1 ] [ 2004 1 1 13 30 0 0 - 2004 1 1 12 30 0 0 <=> ] unit-test +[ 1 ] [ 2004 1 1 13 30 0 instant + 2004 1 1 12 30 0 instant <=> ] unit-test -[ -1 ] [ 2004 1 1 12 30 0 0 - 2004 1 1 13 30 0 0 <=> ] unit-test +[ -1 ] [ 2004 1 1 12 30 0 instant + 2004 1 1 13 30 0 instant <=> ] unit-test -[ 1 ] [ 2005 1 1 12 30 0 0 - 2004 1 1 13 30 0 0 <=> ] unit-test +[ 1 ] [ 2005 1 1 12 30 0 instant + 2004 1 1 13 30 0 instant <=> ] unit-test [ t ] [ now timestamp>millis millis - 1000 < ] unit-test [ t ] [ 0 millis>timestamp unix-1970 = ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 2b80a8dce6..06425975d4 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -3,20 +3,23 @@ USING: arrays kernel math math.functions namespaces sequences strings tuples system vocabs.loader calendar.backend threads -new-slots accessors combinators ; +accessors combinators locals ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; C: timestamp -: ( year month day -- timestamp ) - 0 0 0 gmt-offset ; - TUPLE: duration year month day hour minute second ; C: duration +: gmt-offset-duration ( -- duration ) + 0 0 0 gmt-offset ; + +: ( year month day -- timestamp ) + 0 0 0 gmt-offset-duration ; + : month-names { "Not a month" "January" "February" "March" "April" "May" "June" @@ -56,31 +59,29 @@ SYMBOL: m PRIVATE> -: julian-day-number ( year month day -- n ) +:: julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 - [ - 14 pick - 12 /i a set - pick 4800 + a get - y set - over 12 a get * + 3 - m set - 2nip 153 m get * 2 + 5 /i + 365 y get * + - y get 4 /i + y get 100 /i - y get 400 /i + 32045 - - ] with-scope ; + [let* | a [ 14 month - 12 /i ] + y [ year 4800 + a - ] + m [ month 12 a * + 3 - ] | + day 153 m * 2 + 5 /i + 365 y * + + y 4 /i + y 100 /i - y 400 /i + 32045 - + ] ; -: julian-day-number>date ( n -- year month day ) +:: julian-day-number>date ( n -- year month day ) #! Inverse of julian-day-number - [ - 32044 + a set - 4 a get * 3 + 146097 /i b set - a get 146097 b get * 4 /i - c set - 4 c get * 3 + 1461 /i d set - c get 1461 d get * 4 /i - e set - 5 e get * 2 + 153 /i m set - 100 b get * d get + 4800 - - m get 10 /i + m get 3 + - 12 m get 10 /i * - - e get 153 m get * 2 + 5 /i - 1+ - ] with-scope ; + [let* | a [ n 32044 + ] + b [ 4 a * 3 + 146097 /i ] + c [ a 146097 b * 4 /i - ] + d [ 4 c * 3 + 1461 /i ] + e [ c 1461 d * 4 /i - ] + m [ 5 e * 2 + 153 /i ] | + 100 b * d + 4800 - + m 10 /i + m 3 + + 12 m 10 /i * - + e 153 m * 2 + 5 /i - 1+ + ] ; : >date< ( timestamp -- year month day ) { year>> month>> day>> } get-slots ; @@ -226,16 +227,18 @@ M: duration <=> [ dt>years ] compare ; : dt>seconds ( dt -- x ) dt>years seconds-per-year * ; : dt>milliseconds ( dt -- x ) dt>seconds 1000 * ; -: convert-timezone ( timestamp n -- timestamp ) +GENERIC: time- ( time1 time2 -- time ) + +: convert-timezone ( timestamp duration -- timestamp ) over gmt-offset>> over = [ drop ] [ - [ over gmt-offset>> - hours time+ ] keep >>gmt-offset + [ over gmt-offset>> time- time+ ] keep >>gmt-offset ] if ; : >local-time ( timestamp -- timestamp ) - gmt-offset convert-timezone ; + gmt-offset-duration convert-timezone ; : >gmt ( timestamp -- timestamp ) - 0 convert-timezone ; + instant convert-timezone ; M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; @@ -245,8 +248,6 @@ M: timestamp <=> ( ts1 ts2 -- n ) [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; -GENERIC: time- ( time1 time2 -- time ) - M: timestamp time- #! Exact calendar-time difference (time-) seconds ; @@ -263,14 +264,14 @@ M: timestamp time- M: duration time- before time+ ; -: 0 0 0 0 0 0 0 ; +: 0 0 0 0 0 0 instant ; : valid-timestamp? ( timestamp -- ? ) - clone 0 >>gmt-offset + clone instant >>gmt-offset dup time- time+ = ; : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; foldable + 1970 1 1 0 0 0 instant ; foldable : millis>timestamp ( n -- timestamp ) >r unix-1970 r> milliseconds time+ ; diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor index eb32ce5b43..88bd0733c0 100755 --- a/extra/calendar/format/format-tests.factor +++ b/extra/calendar/format/format-tests.factor @@ -1,5 +1,6 @@ +USING: calendar.format calendar kernel tools.test +io.streams.string ; IN: calendar.format.tests -USING: calendar.format tools.test io.streams.string ; [ 0 ] [ "Z" [ read-rfc3339-gmt-offset ] with-string-reader @@ -20,3 +21,6 @@ USING: calendar.format tools.test io.streams.string ; [ 1+1/2 ] [ "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader ] unit-test + +[ ] [ now timestamp>rfc3339 drop ] unit-test +[ ] [ now timestamp>rfc822 drop ] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 89e09e0d0c..0ac0ebb2c3 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -1,6 +1,7 @@ -IN: calendar.format USING: math math.parser kernel sequences io calendar -accessors arrays io.streams.string combinators accessors ; +accessors arrays io.streams.string combinators accessors +combinators.cleave ; +IN: calendar.format GENERIC: day. ( obj -- ) @@ -54,17 +55,17 @@ M: timestamp year. ( timestamp -- ) : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] with-string-writer ; -: (write-gmt-offset) ( ratio -- ) - 1 /mod swap write-00 60 * write-00 ; +: (write-gmt-offset) ( duration -- ) + [ hour>> write-00 ] [ minute>> write-00 ] bi ; : write-gmt-offset ( gmt-offset -- ) - { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } - { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } + dup instant <=> { + { [ dup 0 = ] [ 2drop "GMT" write ] } + { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] } + { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] } } cond ; -: timestamp>rfc822-string ( timestamp -- str ) +: timestamp>rfc822 ( timestamp -- str ) #! RFC822 timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 +0200 [ @@ -76,14 +77,19 @@ M: timestamp year. ( timestamp -- ) : timestamp>http-string ( timestamp -- str ) #! http timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt timestamp>rfc822-string ; + >gmt timestamp>rfc822 ; -: write-rfc3339-gmt-offset ( n -- ) - dup zero? [ drop "Z" write ] [ - dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if - 60 * 60 /mod swap write-00 CHAR: : write1 write-00 - ] if ; +: (write-rfc3339-gmt-offset) ( duration -- ) + [ hour>> write-00 CHAR: : write1 ] + [ minute>> write-00 ] bi ; +: write-rfc3339-gmt-offset ( duration -- ) + dup instant <=> { + { [ dup 0 = ] [ 2drop "Z" write ] } + { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] } + { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] } + } cond ; + : (timestamp>rfc3339) ( timestamp -- ) dup year>> number>string write CHAR: - write1 dup month>> write-00 CHAR: - write1 diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor index 30e22c487b..2877fa07b5 100644 --- a/extra/calendar/unix/unix.factor +++ b/extra/calendar/unix/unix.factor @@ -1,6 +1,5 @@ - USING: alien alien.c-types arrays calendar.backend - kernel structs math unix.time namespaces ; +kernel structs math unix.time namespaces ; IN: calendar.unix @@ -8,11 +7,11 @@ TUPLE: unix-calendar ; T{ unix-calendar } calendar-backend set-global -: get-time +: get-time ( -- alien ) f time localtime ; -: timezone-name +: timezone-name ( -- string ) get-time tm-zone ; -M: unix-calendar gmt-offset - get-time tm-gmtoff 3600 / ; +M: unix-calendar gmt-offset ( -- hours minutes seconds ) + get-time tm-gmtoff 3600 /mod 60 /mod ; diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 9e34fdac00..6986902ff1 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -1,15 +1,21 @@ USING: calendar.backend namespaces alien.c-types -windows windows.kernel32 kernel math ; +windows windows.kernel32 kernel math combinators.cleave +combinators ; IN: calendar.windows TUPLE: windows-calendar ; T{ windows-calendar } calendar-backend set-global -: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline - -M: windows-calendar gmt-offset ( -- float ) +M: windows-calendar gmt-offset ( -- hours minutes seconds ) "TIME_ZONE_INFORMATION" - dup GetTimeZoneInformation - TIME_ZONE_ID_INVALID = [ win32-error ] when - TIME_ZONE_INFORMATION-Bias 60 / neg ; + dup GetTimeZoneInformation { + { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] } + { [ dup [ TIME_ZONE_ID_UNKNOWN = ] [ TIME_ZONE_ID_STANDARD = ] bi or ] [ + drop TIME_ZONE_INFORMATION-Bias ] } + { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ + drop + [ TIME_ZONE_INFORMATION-Bias ] + [ TIME_ZONE_INFORMATION-DaylightBias ] bi + + ] } + } cond neg 60 /mod 0 ; diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor index 2d8d003b8d..c9cfc83d27 100755 --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -14,7 +14,7 @@ IN: channels.remote PRIVATE> : publish ( channel -- id ) - random-256 dup >r remote-channels set-at r> ; + 256 random-bits dup >r remote-channels set-at r> ; : get-channel ( id -- channel ) remote-channels at ; diff --git a/extra/circular/circular-tests.factor b/extra/circular/circular-tests.factor old mode 100644 new mode 100755 index 8ca4574885..9023ab1dba --- a/extra/circular/circular-tests.factor +++ b/extra/circular/circular-tests.factor @@ -9,7 +9,6 @@ circular strings ; [ CHAR: t ] [ "test" 0 swap nth ] unit-test [ "test" ] [ "test" >string ] unit-test -[ "test" 5 swap nth ] must-fail [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test @@ -18,10 +17,13 @@ circular strings ; [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test [ "fob" ] [ "foo" CHAR: b 2 pick set-nth >string ] unit-test -[ "foo" CHAR: b 3 rot set-nth ] must-fail [ "boo" ] [ "foo" CHAR: b 3 pick set-nth-unsafe >string ] unit-test [ "ornact" ] [ "factor" 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test [ "bcd" ] [ 3 "abcd" [ over push-circular ] each >string ] unit-test [ { 0 0 } ] [ { 0 0 } -1 over change-circular-start >array ] unit-test + +! This no longer fails +! [ "test" 5 swap nth ] must-fail +! [ "foo" CHAR: b 3 rot set-nth ] must-fail diff --git a/extra/circular/circular.factor b/extra/circular/circular.factor old mode 100644 new mode 100755 index 8760e26586..08deb004e8 --- a/extra/circular/circular.factor +++ b/extra/circular/circular.factor @@ -18,9 +18,9 @@ M: circular length circular-seq length ; M: circular virtual@ circular-wrap circular-seq ; -M: circular nth bounds-check virtual@ nth ; +M: circular nth virtual@ nth ; -M: circular set-nth bounds-check virtual@ set-nth ; +M: circular set-nth virtual@ set-nth ; : change-circular-start ( n circular -- ) #! change start to (start + n) mod length diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index e2072f441c..480e19b005 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -59,7 +59,7 @@ objc-methods global [ H{ } assoc-like ] change-at : lookup-method ( selector -- method ) dup objc-methods get at - [ ] [ "No such method: " swap append throw ] ?if ; + [ ] [ "No such method: " prepend throw ] ?if ; : make-dip ( quot n -- quot' ) dup @@ -90,7 +90,7 @@ MACRO: (send) ( selector super? -- quot ) ! Runtime introspection : (objc-class) ( string word -- class ) dupd execute - [ ] [ "No such class: " swap append throw ] ?if ; inline + [ ] [ "No such class: " prepend throw ] ?if ; inline : objc-class ( string -- class ) \ objc_getClass (objc-class) ; diff --git a/extra/cocoa/windows/windows.factor b/extra/cocoa/windows/windows.factor index b45acaf852..74a181f9a2 100755 --- a/extra/cocoa/windows/windows.factor +++ b/extra/cocoa/windows/windows.factor @@ -30,7 +30,8 @@ IN: cocoa.windows : ( view rect -- window ) [ swap -> setContentView: ] keep dup dup -> contentView -> setInitialFirstResponder: - dup 1 -> setAcceptsMouseMovedEvents: ; + dup 1 -> setAcceptsMouseMovedEvents: + dup 0 -> setReleasedWhenClosed: ; : window-content-rect ( window -- rect ) NSWindow over -> frame rot -> styleMask diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 049c8bf2a9..1bc7480198 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -54,6 +54,8 @@ MACRO: 2cleave ( seq -- ) : bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline +: 2bi* ( w x y z p q -- p(x) q(y) ) >r -rot 2slip r> call ; inline + : tri* ( x y z p q r -- p(x) q(y) r(z) ) >r rot >r bi* r> r> call ; inline @@ -68,7 +70,7 @@ MACRO: spread ( seq -- ) dup [ drop [ >r ] ] map concat swap - [ [ r> ] swap append ] map concat + [ [ r> ] prepend ] map concat append ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index e177e33c15..459938c885 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -8,13 +8,6 @@ continuations ; IN: combinators.lib -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: generate ( generator predicate -- obj ) - #! Call 'generator' until the result satisfies 'predicate'. - [ slip over slip ] 2keep - roll [ 2drop ] [ rot drop generate ] if ; inline - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Generalized versions of core combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -82,11 +75,11 @@ MACRO: && ( quots -- ? ) [ [ not ] append [ f ] ] t short-circuit ; MACRO: <-&& ( quots -- ) - [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit + [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit [ nip ] append ; MACRO: <--&& ( quots -- ) - [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit + [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit [ 2nip ] append ; MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ; @@ -137,12 +130,12 @@ MACRO: map-call-with ( quots -- ) [ (make-call-with) ] keep length [ narray ] curry compose ; : (make-call-with2) ( quots -- quot ) - [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat + [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat [ 2drop ] append ; MACRO: map-call-with2 ( quots -- ) [ - [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat + [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat [ 2drop ] append ] keep length [ narray ] curry append ; @@ -175,3 +168,10 @@ MACRO: multikeep ( word out-indexes -- ... ) : retry ( quot n -- ) [ drop ] rot compose attempt-all ; inline + +: do-while ( pred body tail -- ) + >r tuck 2slip r> while ; + +: generate ( generator predicate -- obj ) + [ dup ] swap [ dup [ nip ] unless not ] 3compose + swap [ ] do-while ; diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index c0787a96a2..c007e9f152 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -3,7 +3,7 @@ USING: serialize sequences concurrency.messaging threads io io.server qualified arrays namespaces kernel io.encodings.binary combinators.cleave -new-slots accessors ; +accessors ; QUALIFIED: io.sockets IN: concurrency.distributed diff --git a/extra/concurrency/mailboxes/mailboxes-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor index 4937ef1fb9..50694776c5 100755 --- a/extra/concurrency/mailboxes/mailboxes-docs.factor +++ b/extra/concurrency/mailboxes/mailboxes-docs.factor @@ -49,8 +49,8 @@ HELP: while-mailbox-empty { $description "Repeatedly call the quotation while there are no items in the mailbox." } ; HELP: mailbox-get? -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" mailbox } +{ $values { "mailbox" mailbox } + { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } { "obj" object } } { $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ; diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 24d83b2961..2cb12bcaba 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -16,9 +16,9 @@ tools.test math kernel strings ; [ V{ 1 2 3 } ] [ 0 - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ integer? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread 1 over mailbox-put 2 over mailbox-put 3 swap mailbox-put @@ -27,10 +27,10 @@ tools.test math kernel strings ; [ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [ 0 - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ integer? ] swap mailbox-get? swap push ] in-thread - [ [ string? ] swap mailbox-get? swap push ] in-thread - [ [ string? ] swap mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread + [ [ integer? ] mailbox-get? swap push ] in-thread + [ [ string? ] mailbox-get? swap push ] in-thread + [ [ string? ] mailbox-get? swap push ] in-thread 1 over mailbox-put "junk" over mailbox-put [ 456 ] over mailbox-put diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index 28b2fb7221..7b6405679f 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -17,17 +17,17 @@ TUPLE: mailbox threads data ; [ mailbox-data push-front ] keep mailbox-threads notify-all yield ; -: block-unless-pred ( pred mailbox timeout -- ) - 2over mailbox-data dlist-contains? [ +: block-unless-pred ( mailbox timeout pred -- ) + pick mailbox-data over dlist-contains? [ 3drop ] [ - 2dup >r mailbox-threads r> "mailbox" wait + >r over mailbox-threads over "mailbox" wait r> block-unless-pred ] if ; inline : block-if-empty ( mailbox timeout -- mailbox ) over mailbox-empty? [ - 2dup >r mailbox-threads r> "mailbox" wait + over mailbox-threads over "mailbox" wait block-if-empty ] [ drop @@ -58,12 +58,12 @@ TUPLE: mailbox threads data ; 2drop ] if ; inline -: mailbox-get-timeout? ( pred mailbox timeout -- obj ) - [ block-unless-pred ] 3keep drop - mailbox-data delete-node-if ; inline +: mailbox-get-timeout? ( mailbox timeout pred -- obj ) + 3dup block-unless-pred + nip >r mailbox-data r> delete-node-if ; inline -: mailbox-get? ( pred mailbox -- obj ) - f mailbox-get-timeout? ; inline +: mailbox-get? ( mailbox pred -- obj ) + f swap mailbox-get-timeout? ; inline TUPLE: linked-error thread ; diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index cfa2aea30d..2cd83d43f5 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -26,10 +26,10 @@ M: thread send ( message thread -- ) my-mailbox swap mailbox-get-timeout ?linked ; : receive-if ( pred -- message ) - my-mailbox mailbox-get? ?linked ; inline + my-mailbox swap mailbox-get? ?linked ; inline -: receive-if-timeout ( pred timeout -- message ) - my-mailbox swap mailbox-get-timeout? ?linked ; inline +: receive-if-timeout ( timeout pred -- message ) + my-mailbox -rot mailbox-get-timeout? ?linked ; inline : rethrow-linked ( error process supervisor -- ) >r r> send ; @@ -40,7 +40,7 @@ M: thread send ( message thread -- ) TUPLE: synchronous data sender tag ; : ( data -- sync ) - self random-256 synchronous construct-boa ; + self 256 random-bits synchronous construct-boa ; TUPLE: reply data tag ; diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index 297e4aec87..73b8fce229 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -83,7 +83,7 @@ FUNCTION: void CFRelease ( void* cf ) ; dup [ CFBundleLoadExecutable drop ] [ - "Cannot load bundled named " swap append throw + "Cannot load bundled named " prepend throw ] ?if ; FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ; diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 24eceee744..d4574119b2 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -446,7 +446,7 @@ M: cpu reset ( cpu -- ) SYMBOL: rom-root : rom-dir ( -- string ) - rom-root get [ home "roms" path+ dup exists? [ drop f ] unless ] unless* ; + rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ; : load-rom* ( seq cpu -- ) #! 'seq' is an array of arrays. Each array contains @@ -455,7 +455,7 @@ SYMBOL: rom-root #! file path shoul dbe relative to the '/roms' resource path. rom-dir [ cpu-ram [ - swap first2 rom-dir swap path+ binary [ + swap first2 rom-dir prepend-path binary [ swap (load-rom) ] with-file-reader ] curry each @@ -1027,14 +1027,14 @@ SYMBOL: $4 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : ADC-R,(RR)-instruction ( -- parser ) "ADC-R,(RR)" "ADC" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : SBC-R,N-instruction ( -- parser ) "SBC-R,N" "SBC" complex-instruction @@ -1047,14 +1047,14 @@ SYMBOL: $4 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : SBC-R,(RR)-instruction ( -- parser ) "SBC-R,(RR)" "SBC" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : SUB-R-instruction ( -- parser ) "SUB-R" "SUB" complex-instruction @@ -1082,21 +1082,21 @@ SYMBOL: $4 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : ADD-RR,RR-instruction ( -- parser ) "ADD-RR,RR" "ADD" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : ADD-R,(RR)-instruction ( -- parser ) "ADD-R,(RR)" "ADD" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-RR,NN-instruction #! LD BC,nn @@ -1124,28 +1124,28 @@ SYMBOL: $4 16-bit-registers indirect sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-R,R-instruction "LD-R,R" "LD" complex-instruction 8-bit-registers sp <&> "," token <& 8-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-RR,RR-instruction "LD-RR,RR" "LD" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-R,(RR)-instruction "LD-R,(RR)" "LD" complex-instruction 8-bit-registers sp <&> "," token <& 16-bit-registers indirect <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : LD-(NN),RR-instruction "LD-(NN),RR" "LD" complex-instruction @@ -1194,14 +1194,14 @@ SYMBOL: $4 16-bit-registers indirect sp <&> "," token <& 16-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : EX-RR,RR-instruction "EX-RR,RR" "EX" complex-instruction 16-bit-registers sp <&> "," token <& 16-bit-registers <&> - just [ first2 swap first2 swap >r swap append r> curry ] <@ ; + just [ first2 swap first2 swap >r prepend r> curry ] <@ ; : 8080-generator-parser NOP-instruction diff --git a/extra/crypto/blum-blum-shub.factor b/extra/crypto/blum-blum-shub.factor deleted file mode 100644 index a1c196d08e..0000000000 --- a/extra/crypto/blum-blum-shub.factor +++ /dev/null @@ -1,36 +0,0 @@ -USING: kernel math sequences namespaces crypto math-contrib ; -IN: crypto-internals - -! TODO: take (log log M) bits instead of 1 bit -! Blum Blum Shub, M = pq -TUPLE: bbs x n ; - -: generate-bbs-primes ( numbits -- p q ) - #! two primes congruent to 3 (mod 4) - dup [ random-miller-rabin-prime==3(mod4) ] 2apply ; - -IN: crypto -: make-bbs ( numbits -- blum-blum-shub ) - #! returns a Blum-Blum-Shub tuple - generate-bbs-primes * [ find-relative-prime ] keep ; - -IN: crypto-internals -SYMBOL: blum-blum-shub 256 make-bbs blum-blum-shub set-global - -: next-bbs-bit ( bbs -- bit ) - #! x = x^2 mod n, return low bit of calculated x - [ [ bbs-x ] keep 2 swap bbs-n ^mod ] keep - [ set-bbs-x ] keep bbs-x 1 bitand ; - -SYMBOL: temp-bbs -: (bbs-bits) ( numbits bbs -- n ) - temp-bbs set [ [ temp-bbs get next-bbs-bit ] swap make-bits ] with-scope ; - -IN: crypto -: random-bbs-bits* ( numbits bbs -- n ) (bbs-bits) ; -: random-bits ( numbits -- n ) blum-blum-shub get (bbs-bits) ; -: random-bytes ( numbits -- n ) 8 * random-bits ; -: random ( n -- n ) - ! #! Cryptographically secure random number using Blum-Blum-Shub 256 - [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ; - diff --git a/extra/db/db.factor b/extra/db/db.factor index ac46be4422..f9e946fc20 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math namespaces sequences sequences.lib tuples words strings -tools.walker new-slots accessors ; +tools.walker accessors ; IN: db TUPLE: db diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 928b51dc59..270be886c5 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -4,7 +4,7 @@ USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators combinators.cleave libc shuffle calendar.format -byte-arrays destructors prettyprint new-slots accessors +byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.streams.byte-array ; IN: db.postgresql.lib diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index bca904279b..d7d954c0dc 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -71,7 +71,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) [ statement-in-params [ - [ sql-spec-column-name ":" swap append ] + [ sql-spec-column-name ":" prepend ] [ sql-spec-slot-name rot get-slot-named ] [ sql-spec-type ] tri 3array ] with map @@ -173,7 +173,7 @@ M: sqlite-db ( specs table -- sql ) ! : select-sequence ( seq name -- ) ; M: sqlite-db bind% ( spec -- ) - dup 1, sql-spec-column-name ":" swap append 0% ; + dup 1, sql-spec-column-name ":" prepend 0% ; M: sqlite-db ( tuple class -- statement ) [ diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index a0414f334d..94a8d6f392 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -127,7 +127,7 @@ TUPLE: no-sql-modifier ; : modifiers ( spec -- str ) sql-spec-modifiers [ lookup-modifier ] map " " join - dup empty? [ " " swap append ] unless ; + dup empty? [ " " prepend ] unless ; HOOK: bind% db ( spec -- ) diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor old mode 100644 new mode 100755 index 5c6fa9b2a1..1776c916ad --- a/extra/digraphs/digraphs.factor +++ b/extra/digraphs/digraphs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel new-slots sequences vectors ; +USING: accessors assocs kernel sequences vectors ; IN: digraphs TUPLE: digraph ; diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 993e69ec14..60ae592d4c 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -74,7 +74,7 @@ TUPLE: document locs ; 0 swap [ append ] change-nth ; : append-last ( str seq -- ) - [ length 1- ] keep [ swap append ] change-nth ; + [ length 1- ] keep [ prepend ] change-nth ; : loc-col/str ( loc document -- str col ) >r first2 swap r> nth swap ; diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor index eb31b2aa47..9da57e16bf 100755 --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -5,7 +5,7 @@ IN: editors.editpadpro : editpadpro-path \ editpadpro-path get-global [ - program-files "JGsoft" path+ + program-files "JGsoft" append-path t [ >lower "editpadpro.exe" tail? ] find-file ] unless* ; diff --git a/extra/editors/editplus/editplus.factor b/extra/editors/editplus/editplus.factor index ee24c99463..363d202f6c 100755 --- a/extra/editors/editplus/editplus.factor +++ b/extra/editors/editplus/editplus.factor @@ -4,7 +4,7 @@ IN: editors.editplus : editplus-path ( -- path ) \ editplus-path get-global [ - program-files "\\EditPlus 2\\editplus.exe" path+ + program-files "\\EditPlus 2\\editplus.exe" append-path ] unless* ; : editplus ( file line -- ) diff --git a/extra/editors/emeditor/emeditor.factor b/extra/editors/emeditor/emeditor.factor index bed333694c..8aecb49ae5 100755 --- a/extra/editors/emeditor/emeditor.factor +++ b/extra/editors/emeditor/emeditor.factor @@ -4,7 +4,7 @@ IN: editors.emeditor : emeditor-path ( -- path ) \ emeditor-path get-global [ - program-files "\\EmEditor\\EmEditor.exe" path+ + program-files "\\EmEditor\\EmEditor.exe" append-path ] unless* ; : emeditor ( file line -- ) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 030c968e81..489000498e 100755 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -4,6 +4,6 @@ IN: editors.gvim.windows M: windows-io gvim-path \ gvim-path get-global [ - program-files "vim" path+ + program-files "vim" append-path t [ "gvim.exe" tail? ] find-file ] unless* ; diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index 3ce2c40192..7b6066df7c 100644 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -8,7 +8,7 @@ io.encodings.utf8 ; IN: editors.jedit : jedit-server-info ( -- port auth ) - home "/.jedit/server" path+ ascii [ + home "/.jedit/server" append-path ascii [ readln drop readln string>number readln string>number @@ -32,7 +32,7 @@ IN: editors.jedit ] with-stream ; : jedit-location ( file line -- ) - number>string "+line:" swap append 2array + number>string "+line:" prepend 2array make-jedit-request send-jedit-request ; : jedit-file ( file -- ) diff --git a/extra/editors/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor index 72ac6c72d7..959e633cc3 100755 --- a/extra/editors/notepadpp/notepadpp.factor +++ b/extra/editors/notepadpp/notepadpp.factor @@ -4,7 +4,7 @@ IN: editors.notepadpp : notepadpp-path \ notepadpp-path get-global [ - program-files "notepad++\\notepad++.exe" path+ + program-files "notepad++\\notepad++.exe" append-path ] unless* ; : notepadpp ( file line -- ) diff --git a/extra/editors/scite/scite.factor b/extra/editors/scite/scite.factor index ac9a032abc..a0bacaabba 100755 --- a/extra/editors/scite/scite.factor +++ b/extra/editors/scite/scite.factor @@ -14,7 +14,7 @@ IN: editors.scite : scite-path ( -- path ) \ scite-path get-global [ - program-files "wscite\\SciTE.exe" path+ + program-files "wscite\\SciTE.exe" append-path ] unless* ; : scite-command ( file line -- cmd ) diff --git a/extra/editors/ted-notepad/ted-notepad.factor b/extra/editors/ted-notepad/ted-notepad.factor index 5d58e182a3..9b341dd2a8 100755 --- a/extra/editors/ted-notepad/ted-notepad.factor +++ b/extra/editors/ted-notepad/ted-notepad.factor @@ -4,7 +4,7 @@ IN: editors.ted-notepad : ted-notepad-path \ ted-notepad-path get-global [ - program-files "\\TED Notepad\\TedNPad.exe" path+ + program-files "\\TED Notepad\\TedNPad.exe" append-path ] unless* ; : ted-notepad ( file line -- ) diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor index f9d27174b3..1fef9f3350 100755 --- a/extra/editors/ultraedit/ultraedit.factor +++ b/extra/editors/ultraedit/ultraedit.factor @@ -5,7 +5,7 @@ IN: editors.ultraedit : ultraedit-path ( -- path ) \ ultraedit-path get-global [ program-files - "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+ + "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path ] unless* ; : ultraedit ( file line -- ) diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor index 5ad08b613b..d1f979e0f3 100755 --- a/extra/editors/wordpad/wordpad.factor +++ b/extra/editors/wordpad/wordpad.factor @@ -5,7 +5,7 @@ IN: editors.wordpad : wordpad-path ( -- path ) \ wordpad-path get [ - program-files "\\Windows NT\\Accessories\\wordpad.exe" path+ + program-files "\\Windows NT\\Accessories\\wordpad.exe" append-path ] unless* ; : wordpad ( file line -- ) diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index 7ad3900163..d7624466f7 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -79,7 +79,7 @@ C: faq "br" contained, nl, ; : toc-link, ( question-list number -- ) - number>string "#" swap append "href" swap 2array 1array + number>string "#" prepend "href" swap 2array 1array "a" swap [ question-list-title , ] tag*, br, ; : toc, ( faq -- ) diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor old mode 100644 new mode 100755 index ec4d6b79e1..861894c8f4 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -117,16 +117,16 @@ M: bitmap height ( bitmap -- ) bitmap-height ; load-bitmap [ "bitmap" open-window ] keep ; : test-bitmap24 ( -- ) - "misc/graphics/bmps/thiswayup24.bmp" resource-path bitmap. ; + "extra/graphics/bitmap/test-data/thiswayup24.bmp" resource-path bitmap. ; : test-bitmap8 ( -- ) - "misc/graphics/bmps/rgb8bit.bmp" resource-path bitmap. ; + "extra/graphics/bitmap/test-data/rgb8bit.bmp" resource-path bitmap. ; : test-bitmap4 ( -- ) - "misc/graphics/bmps/rgb4bit.bmp" resource-path + "extra/graphics/bitmap/test-data/rgb4bit.bmp" resource-path load-bitmap ; ! bitmap. ; : test-bitmap1 ( -- ) - "misc/graphics/bmps/1bit.bmp" resource-path bitmap. ; + "extra/graphics/bitmap/test-data/1bit.bmp" resource-path bitmap. ; diff --git a/misc/graphics/bmps/1bit.bmp b/extra/graphics/bitmap/test-images/1bit.bmp similarity index 100% rename from misc/graphics/bmps/1bit.bmp rename to extra/graphics/bitmap/test-images/1bit.bmp diff --git a/misc/graphics/bmps/rgb4bit.bmp b/extra/graphics/bitmap/test-images/rgb4bit.bmp similarity index 100% rename from misc/graphics/bmps/rgb4bit.bmp rename to extra/graphics/bitmap/test-images/rgb4bit.bmp diff --git a/misc/graphics/bmps/rgb8bit.bmp b/extra/graphics/bitmap/test-images/rgb8bit.bmp similarity index 100% rename from misc/graphics/bmps/rgb8bit.bmp rename to extra/graphics/bitmap/test-images/rgb8bit.bmp diff --git a/misc/graphics/bmps/thiswayup24.bmp b/extra/graphics/bitmap/test-images/thiswayup24.bmp similarity index 100% rename from misc/graphics/bmps/thiswayup24.bmp rename to extra/graphics/bitmap/test-images/thiswayup24.bmp diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index 43d8ca21ef..31f1181be2 100755 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 1 } - { deploy-compiler? t } { deploy-word-defs? f } - { deploy-word-props? f } - { deploy-math? t } + { deploy-random? f } { deploy-name "Hello world" } - { deploy-c-types? f } - { deploy-ui? t } { deploy-threads? t } + { deploy-compiler? t } + { deploy-math? t } + { deploy-c-types? f } + { deploy-io 1 } { deploy-reflection 1 } + { deploy-ui? t } { "stop-after-last-window?" t } + { deploy-word-props? f } } diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 2341aabc9d..77421938a9 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ + { deploy-word-defs? f } + { deploy-random? f } { deploy-name "Hello world (console)" } { deploy-threads? f } - { deploy-c-types? f } { deploy-compiler? f } - { deploy-ui? f } { deploy-math? f } - { deploy-reflection 1 } - { deploy-word-defs? f } + { deploy-c-types? f } { deploy-io 2 } - { deploy-word-props? f } + { deploy-reflection 1 } + { deploy-ui? f } { "stop-after-last-window?" t } + { deploy-word-props? f } } diff --git a/extra/help/help.factor b/extra/help/help.factor index 34e90b2ccf..9e4d02802b 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -25,10 +25,6 @@ GENERIC: word-help* ( word -- content ) M: word word-help* drop f ; -M: slot-reader word-help* drop \ $slot-reader ; - -M: slot-writer word-help* drop \ $slot-writer ; - M: predicate word-help* drop \ $predicate ; : all-articles ( -- seq ) @@ -98,7 +94,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; : about ( vocab -- ) dup require dup vocab [ ] [ - "No such vocabulary: " swap append throw + "No such vocabulary: " prepend throw ] ?if dup vocab-help [ help diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index d8a4f83169..b65e44fda4 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -39,8 +39,6 @@ IN: help.lint { $shuffle $values-x/y - $slot-reader - $slot-writer $predicate $class-description $error-description diff --git a/extra/help/markup/markup-tests.factor b/extra/help/markup/markup-tests.factor index 0b4b69bf59..6b138a18ab 100644 --- a/extra/help/markup/markup-tests.factor +++ b/extra/help/markup/markup-tests.factor @@ -4,18 +4,6 @@ IN: help.markup.tests TUPLE: blahblah quux ; -: test-slot blahblah "slots" word-prop second ; - -[ - { { "blahblah" { $instance blahblah } } { "quux" { $instance object } } } -] [ - test-slot blahblah ($spec-reader-values) -] unit-test - -[ ] [ - test-slot blahblah $spec-reader-values -] unit-test - [ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test [ ] [ \ blahblah-quux help ] unit-test diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 7cfe384bde..9c3615f629 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -159,7 +159,7 @@ M: f print-element drop ; [ first ($long-link) ] ($subsection) ; : ($vocab-link) ( text vocab -- ) - dup vocab-root >vocab-link write-link ; + >vocab-link write-link ; : $vocab-subsection ( element -- ) [ @@ -296,63 +296,6 @@ M: string ($instance) { $link with-pprint } " combinator." } $notes ; -: ($spec-reader-values) ( slot-spec class -- element ) - dup ?word-name swap 2array - over slot-spec-name - rot slot-spec-type 2array 2array - [ { $instance } swap add ] assoc-map ; - -: $spec-reader-values ( slot-spec class -- ) - ($spec-reader-values) $values ; - -: $spec-reader-description ( slot-spec class -- ) - [ - "Outputs the value stored in the " , - { $snippet } rot slot-spec-name add , - " slot of " , - { $instance } swap add , - " instance." , - ] { } make $description ; - -: $spec-reader ( reader slot-specs class -- ) - >r slot-of-reader r> - over [ - 2dup $spec-reader-values - 2dup $spec-reader-description - ] when 2drop ; - -GENERIC: slot-specs ( help-type -- specs ) - -M: word slot-specs "slots" word-prop ; - -: $slot-reader ( reader -- ) - first dup "reading" word-prop [ slot-specs ] keep - $spec-reader ; - -: $spec-writer-values ( slot-spec class -- ) - ($spec-reader-values) reverse $values ; - -: $spec-writer-description ( slot-spec class -- ) - [ - "Stores a new value to the " , - { $snippet } rot slot-spec-name add , - " slot of " , - { $instance } swap add , - " instance." , - ] { } make $description ; - -: $spec-writer ( writer slot-specs class -- ) - >r slot-of-writer r> - over [ - 2dup $spec-writer-values - 2dup $spec-writer-description - dup ?word-name 1array $side-effects - ] when 2drop ; - -: $slot-writer ( reader -- ) - first dup "writing" word-prop [ slot-specs ] keep - $spec-writer ; - GENERIC: elements* ( elt-type element -- ) M: simple-element elements* [ elements* ] with each ; diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 286037d4dc..754afb1ea7 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -38,7 +38,7 @@ IN: html.elements ! "Click me" write ! ! (url -- ) -! "click" write +! "click" write ! ! (url -- ) ! "click" write @@ -72,7 +72,7 @@ SYMBOL: html dup swap [ write-html ] curry empty-effect html-word ; -: - [ +path+ get "xxx" get "X" concat append ] >>submit - { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params + [ +append-path get "xxx" get "X" concat append ] >>submit + { { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params "action-2" set STRING: action-request-test-2 diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 52567ed352..f39980037d 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors new-slots sequences kernel assocs combinators +USING: accessors sequences kernel assocs combinators http.server http.server.validators http hashtables namespaces combinators.cleave fry continuations locals ; IN: http.server.actions -SYMBOL: +path+ +SYMBOL: +append-path SYMBOL: params @@ -40,7 +40,7 @@ TUPLE: action init display submit get-params post-params ; M: action call-responder ( path action -- response ) '[ , , - [ +path+ associate request-params union params set ] + [ +append-path associate request-params union params set ] [ action set ] bi* request get method>> { { "GET" [ handle-get ] } diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor index 2ea74febba..04c0e62d07 100755 --- a/extra/http/server/auth/basic/basic.factor +++ b/extra/http/server/auth/basic/basic.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors new-slots quotations assocs kernel splitting +USING: accessors quotations assocs kernel splitting base64 html.elements io combinators http.server http.server.auth.providers http.server.auth.providers.null http sequences ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 275fb0ff63..8c61a9dd47 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors new-slots quotations assocs kernel splitting +USING: accessors quotations assocs kernel splitting base64 html.elements io combinators http.server http.server.auth.providers http.server.auth.providers.null http.server.actions http.server.components http.server.sessions diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor index e8ab908406..18ec8da62a 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: http.server.auth.providers.assoc -USING: new-slots accessors assocs kernel +USING: accessors assocs kernel http.server.auth.providers ; TUPLE: users-in-memory assoc ; diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index aec64d3384..1e84e544b8 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db db.tuples db.types new-slots accessors +USING: db db.tuples db.types accessors http.server.auth.providers kernel continuations singleton ; IN: http.server.auth.providers.db diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index d51679016e..eda3babf0f 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel new-slots accessors random math.parser locals +USING: kernel accessors random math.parser locals sequences math crypto.sha2 ; IN: http.server.auth.providers @@ -27,7 +27,7 @@ GENERIC: new-user ( user provider -- user/f ) user email>> length 0 > [ user email>> email = [ user - random-256 >hex >>ticket + 256 random-bits >hex >>ticket dup provider update-user ] [ f ] if ] [ f ] if diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index eb264279cb..ab629ae236 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -2,7 +2,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: html http http.server io kernel math namespaces -continuations calendar sequences assocs new-slots hashtables +continuations calendar sequences assocs hashtables accessors arrays alarms quotations combinators combinators.cleave fry assocs.lib ; IN: http.server.callbacks diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 09d31202c5..d372865b7e 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -1,6 +1,6 @@ IN: http.server.components.tests USING: http.server.components http.server.validators -namespaces tools.test kernel accessors new-slots +namespaces tools.test kernel accessors tuple-syntax mirrors http.server.actions ; validation-failed? off diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 02c992651a..516abe79a5 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: new-slots html.elements http.server.validators accessors +USING: html.elements http.server.validators accessors namespaces kernel io math.parser assocs classes words tuples arrays sequences io.files http.server.templating.fhtml http.server.actions splitting mirrors hashtables @@ -13,7 +13,7 @@ TUPLE: component id required default ; : component ( name -- component ) dup components get at - [ ] [ "No such component: " swap append throw ] ?if ; + [ ] [ "No such component: " prepend throw ] ?if ; GENERIC: validate* ( value component -- result ) GENERIC: render-view* ( value component -- ) diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 4a2315b4fd..0b2e9bccc3 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db http.server kernel new-slots accessors +USING: db http.server kernel accessors continuations namespaces destructors combinators.cleave ; IN: http.server.db diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index e992a1b6fa..346a31f30f 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,5 +1,5 @@ USING: http.server tools.test kernel namespaces accessors -new-slots io http math sequences assocs ; +io http math sequences assocs ; IN: http.server.tests [ diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 7448752c60..6b3ae52730 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar -new-slots html.elements accessors math.parser combinators.lib +html.elements accessors math.parser combinators.lib tools.vocabs debugger html continuations random combinators destructors io.encodings.latin1 fry combinators.cleave ; IN: http.server diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index f45f10d25f..aea1bef930 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs calendar kernel math.parser namespaces random -new-slots accessors http http.server +accessors http http.server http.server.sessions.storage http.server.sessions.storage.assoc quotations hashtables sequences fry combinators.cleave html.elements symbols continuations destructors ; diff --git a/extra/http/server/sessions/storage/assoc/assoc.factor b/extra/http/server/sessions/storage/assoc/assoc.factor index 1339e3c867..f72f34e4d2 100755 --- a/extra/http/server/sessions/storage/assoc/assoc.factor +++ b/extra/http/server/sessions/storage/assoc/assoc.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs assocs.lib new-slots accessors +USING: assocs assocs.lib accessors http.server.sessions.storage combinators.cleave alarms kernel fry http.server ; IN: http.server.sessions.storage.assoc diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index 07cd22bc62..4d87aea5a3 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs new-slots accessors http.server.sessions.storage +USING: assocs accessors http.server.sessions.storage alarms kernel http.server db.tuples db.types singleton combinators.cleave math.parser ; IN: http.server.sessions.storage.db diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index b408b1b6b0..37c3a63d76 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -3,7 +3,7 @@ USING: calendar html io io.files kernel math math.parser http http.server namespaces parser sequences strings assocs hashtables debugger http.mime sorting html.elements logging -calendar.format new-slots accessors io.encodings.binary +calendar.format accessors io.encodings.binary combinators.cleave fry ; IN: http.server.static @@ -39,7 +39,7 @@ TUPLE: file-responder root hook special ; [ 2drop <304> ] [ file-responder get hook>> call ] if ; : serving-path ( filename -- filename ) - "" or file-responder get root>> swap path+ ; + "" or file-responder get root>> prepend-path ; : serve-file ( filename -- response ) dup mime-type @@ -68,7 +68,7 @@ TUPLE: file-responder root hook special ; swap '[ , directory. ] >>body ; : find-index ( filename -- path ) - { "index.html" "index.fhtml" } [ path+ ] with map + { "index.html" "index.fhtml" } [ append-path ] with map [ exists? ] find nip ; : serve-directory ( filename -- response ) diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index 9774e4c1f2..2e253d9132 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -5,7 +5,7 @@ IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) "resource:extra/http/server/templating/fhtml/test/" - swap append + prepend [ ".fhtml" append [ run-template ] with-string-writer ] keep diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 8567524217..630054ccfa 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -28,7 +28,7 @@ M: template-lexer skip-word { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } { [ t ] [ f skip ] } } cond - ] change-column ; + ] change-lexer-column ; DEFER: <% delimiter diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index 539a58d19f..b3710f6439 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences math namespaces -math.parser assocs new-slots regexp fry unicode.categories +math.parser assocs regexp fry unicode.categories combinators.cleave sequences ; IN: http.server.validators @@ -59,7 +59,7 @@ C: validation-error : v-regexp ( str what regexp -- str ) >r over r> matches? - [ drop ] [ "invalid " swap append throw ] if ; + [ drop ] [ "invalid " prepend throw ] if ; : v-email ( str -- str ) #! From http://www.regular-expressions.info/email.html diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index bd71b733f1..d3fe51f28d 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -1,18 +1,22 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ; +USING: io io.encodings kernel math io.encodings.private ; IN: io.encodings.ascii -: encode-check< ( string stream max -- ) - [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ; + [ drop replacement-char ] unless ] + [ drop f ] if* ; +PRIVATE> TUPLE: ascii ; -M: ascii stream-write-encoded ( string stream encoding -- ) - drop 128 encode-check< ; +M: ascii encode-char + 128 encode-if< ; -M: ascii decode-step - drop 128 push-if< ; +M: ascii decode-char + 128 decode-if< ; diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor index 71e98a1747..2b82318885 100755 --- a/extra/io/encodings/latin1/latin1.factor +++ b/extra/io/encodings/latin1/latin1.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.encodings strings kernel io.encodings.ascii sequences math ; +USING: io io.encodings kernel io.encodings.ascii.private ; IN: io.encodings.latin1 TUPLE: latin1 ; -M: latin1 stream-write-encoded - drop 256 encode-check< ; +M: latin1 encode-char + 256 encode-if< ; -M: latin1 decode-step - drop swap push ; +M: latin1 decode-char + drop stream-read1 ; diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index a501fad0bd..290761ec91 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -1,133 +1,101 @@ ! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary -io.encodings combinators splitting io byte-arrays ; +io.encodings combinators splitting io byte-arrays inspector ; IN: io.encodings.utf16 +TUPLE: utf16be ; + +TUPLE: utf16le ; + +TUPLE: utf16 ; + +r 2 shift r> BIN: 11 bitand bitor + over stream-read1 swap append-nums HEX: 10000 + + ] [ 2drop dup stream-read1 drop replacement-char ] if + ] when* ; + +: ignore ( stream -- stream char ) + dup stream-read1 drop replacement-char ; + +: begin-utf16be ( stream byte -- stream char ) dup -3 shift BIN: 11011 number= [ dup BIN: 00000100 bitand zero? - [ BIN: 11 bitand quad1 ] - [ drop do-ignore ] if - ] [ double ] if ; - -: handle-quad2be ( byte ch -- ch state ) - swap dup -2 shift BIN: 110111 number= [ - >r 2 shift r> BIN: 11 bitand bitor quad3 - ] [ 2drop do-ignore ] if ; - -: decode-utf16be-step ( buf byte ch state -- buf ch state ) - { - { begin [ drop begin-utf16be ] } - { double [ end-multibyte ] } - { quad1 [ append-nums quad2 ] } - { quad2 [ handle-quad2be ] } - { quad3 [ append-nums HEX: 10000 + push-decoded ] } - { ignore [ 2drop push-replacement ] } - } case ; - -: unpack-state-be ( encoding -- ch state ) - { utf16be-ch utf16be-state } get-slots ; - -: pack-state-be ( ch state encoding -- ) - { set-utf16be-ch set-utf16be-state } set-slots ; - -M: utf16be decode-step - [ unpack-state-be decode-utf16be-step ] keep pack-state-be drop ; - -M: utf16be init-decoder nip begin over set-utf16be-state ; + [ BIN: 11 bitand quad-be ] + [ drop ignore ] if + ] [ double-be ] if ; + +M: utf16be decode-char + drop dup stream-read1 dup [ begin-utf16be ] when nip ; ! UTF-16LE decoding -TUPLE: utf16le ch state ; +: quad-le ( stream ch -- stream char ) + over stream-read1 swap 10 shift bitor + over stream-read1 dup -2 shift BIN: 110111 = [ + BIN: 11 bitand append-nums HEX: 10000 + + ] [ 2drop replacement-char ] if ; -: handle-double ( buf byte ch -- buf ch state ) - swap dup -3 shift BIN: 11011 = [ +: double-le ( stream byte1 byte2 -- stream char ) + dup -3 shift BIN: 11011 = [ dup BIN: 100 bitand 0 number= - [ BIN: 11 bitand 8 shift bitor quad2 ] - [ 2drop push-replacement ] if - ] [ end-multibyte ] if ; + [ BIN: 11 bitand 8 shift bitor quad-le ] + [ 2drop replacement-char ] if + ] [ append-nums ] if ; -: handle-quad3le ( buf byte ch -- buf ch state ) - swap dup -2 shift BIN: 110111 = [ - BIN: 11 bitand append-nums HEX: 10000 + push-decoded - ] [ 2drop push-replacement ] if ; +: begin-utf16le ( stream byte -- stream char ) + over stream-read1 [ double-le ] [ drop replacement-char ] if* ; -: decode-utf16le-step ( buf byte ch state -- buf ch state ) - { - { begin [ drop double ] } - { double [ handle-double ] } - { quad1 [ append-nums quad2 ] } - { quad2 [ 10 shift bitor quad3 ] } - { quad3 [ handle-quad3le ] } - } case ; - -: unpack-state-le ( encoding -- ch state ) - { utf16le-ch utf16le-state } get-slots ; - -: pack-state-le ( ch state encoding -- ) - { set-utf16le-ch set-utf16le-state } set-slots ; - -M: utf16le decode-step - [ unpack-state-le decode-utf16le-step ] keep pack-state-le drop ; - -M: utf16le init-decoder nip begin over set-utf16le-state ; +M: utf16le decode-char + drop dup stream-read1 dup [ begin-utf16le ] when nip ; ! UTF-16LE/BE encoding -: encode-first +: encode-first ( char -- byte1 byte2 ) -10 shift dup -8 shift BIN: 11011000 bitor swap HEX: FF bitand ; -: encode-second +: encode-second ( char -- byte3 byte4 ) BIN: 1111111111 bitand dup -8 shift BIN: 11011100 bitor swap BIN: 11111111 bitand ; -: char>utf16be ( char -- ) +: stream-write2 ( stream char1 char2 -- ) + rot [ stream-write1 ] curry 2apply ; + +: char>utf16be ( stream char -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first swap write1 write1 - encode-second swap write1 write1 - ] [ h>b/b write1 write1 ] if ; + 2dup encode-first stream-write2 + encode-second stream-write2 + ] [ h>b/b swap stream-write2 ] if ; -: stream-write-utf16be ( string stream -- ) - [ [ char>utf16be ] each ] with-stream* ; +M: utf16be encode-char ( char stream encoding -- ) + drop swap char>utf16be ; -M: utf16be stream-write-encoded ( string stream encoding -- ) - drop stream-write-utf16be ; - -: char>utf16le ( char -- ) +: char>utf16le ( char stream -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first write1 write1 - encode-second write1 write1 - ] [ h>b/b swap write1 write1 ] if ; + 2dup encode-first swap stream-write2 + encode-second swap stream-write2 + ] [ h>b/b stream-write2 ] if ; -: stream-write-utf16le ( string stream -- ) - [ [ char>utf16le ] each ] with-stream* ; - -M: utf16le stream-write-encoded ( string stream encoding -- ) - drop stream-write-utf16le ; +M: utf16le encode-char ( char stream encoding -- ) + drop swap char>utf16le ; ! UTF-16 @@ -139,17 +107,18 @@ M: utf16le stream-write-encoded ( string stream encoding -- ) : start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ; -TUPLE: utf16 started? ; - -M: utf16 stream-write-encoded - dup utf16-started? [ drop ] - [ t swap set-utf16-started? bom-le over stream-write ] if - stream-write-utf16le ; +TUPLE: missing-bom ; +M: missing-bom summary drop "The BOM for a UTF-16 stream was missing" ; : bom>le/be ( bom -- le/be ) dup bom-le sequence= [ drop utf16le ] [ - bom-be sequence= [ utf16be ] [ decode-error ] if + bom-be sequence= [ utf16be ] [ missing-bom ] if ] if ; -M: utf16 init-decoder ( stream encoding -- newencoding ) - 2 rot stream-read bom>le/be construct-empty init-decoder ; +M: utf16 ( stream utf16 -- decoder ) + drop 2 over stream-read bom>le/be ; + +M: utf16 ( stream utf16 -- encoder ) + drop bom-le over stream-write utf16le ; + +PRIVATE> diff --git a/extra/io/files/unique/backend/backend.factor b/extra/io/files/unique/backend/backend.factor index b26557688b..7b9809fa28 100644 --- a/extra/io/files/unique/backend/backend.factor +++ b/extra/io/files/unique/backend/backend.factor @@ -1,5 +1,5 @@ USING: io.backend ; IN: io.files.unique.backend -HOOK: (make-unique-file) io-backend ( path -- stream ) +HOOK: (make-unique-file) io-backend ( path -- ) HOOK: temporary-path io-backend ( -- path ) diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor index 61f960d9f7..01b8e131cc 100644 --- a/extra/io/files/unique/unique-docs.factor +++ b/extra/io/files/unique/unique-docs.factor @@ -6,18 +6,16 @@ ARTICLE: "unique" "Making and using unique files" "Files:" { $subsection make-unique-file } { $subsection with-unique-file } -{ $subsection with-temporary-file } "Directories:" { $subsection make-unique-directory } -{ $subsection with-unique-directory } -{ $subsection with-temporary-directory } ; +{ $subsection with-unique-directory } ; ABOUT: "unique" -HELP: make-unique-file ( prefix suffix -- path stream ) +HELP: make-unique-file ( prefix suffix -- path ) { $values { "prefix" "a string" } { "suffix" "a string" } -{ "path" "a pathname string" } { "stream" "an output stream" } } -{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname and a " { $link } " stream." } +{ "path" "a pathname string" } } +{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } { $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." } { $see-also with-unique-file } ; @@ -27,24 +25,13 @@ HELP: make-unique-directory ( -- path ) { $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." } { $see-also with-unique-directory } ; -HELP: with-unique-file ( quot -- path ) -{ $values { "quot" "a quotation" } { "path" "a pathname string" } } -{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. Returns the full pathname after the stream has been closed." } -{ $notes "The unique file will remain after calling this word." } -{ $see-also with-temporary-file } ; +HELP: with-unique-file ( prefix suffix quot -- ) +{ $values { "prefix" "a string" } { "suffix" "a string" } +{ "quot" "a quotation" } } +{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." } +{ $notes "The unique file will be deleted after calling this word." } ; -HELP: with-unique-directory ( quot -- path ) -{ $values { "quot" "a quotation" } { "path" "a pathname string" } } -{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. Returns the full pathname after the quotation has been called." } -{ $notes "The directory will remain after calling this word." } -{ $see-also with-temporary-directory } ; - -HELP: with-temporary-file ( quot -- ) +HELP: with-unique-directory ( quot -- ) { $values { "quot" "a quotation" } } -{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. The file is deleted after the quotation returns." } -{ $see-also with-unique-file } ; - -HELP: with-temporary-directory ( quot -- ) -{ $values { "quot" "a quotation" } } -{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. The directory is deleted after the quotation returns." } -{ $see-also with-unique-directory } ; +{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack." } +{ $notes "The directory will be deleted after calling this word." } ; diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 1e77cd6814..a180a28f23 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.bitfields combinators.lib math.parser random sequences sequences.lib continuations namespaces -io.files io.backend io.nonblocking io arrays -io.files.unique.backend system combinators vocabs.loader ; +io.files io arrays io.files.unique.backend system +combinators vocabs.loader ; IN: io.files.unique -: make-unique-file ( prefix suffix -- path stream ) +: make-unique-file ( prefix suffix -- path ) temporary-path -rot [ - unique-length random-name swap 3append path+ + unique-length random-name swap 3append append-path dup (make-unique-file) ] 3curry unique-retries retry ; -: with-unique-file ( quot -- path ) - >r f f make-unique-file r> rot [ with-stream ] dip ; inline - -: with-temporary-file ( quot -- ) - with-unique-file delete-file ; inline +: with-unique-file ( prefix suffix quot -- ) + >r make-unique-file r> keep delete-file ; inline : make-unique-directory ( -- path ) [ - temporary-path unique-length random-name path+ + temporary-path unique-length random-name append-path dup make-directory ] unique-retries retry ; -: with-unique-directory ( quot -- path ) +: with-unique-directory ( quot -- ) >r make-unique-directory r> - [ with-directory ] curry keep ; inline - -: with-temporary-directory ( quot -- ) - with-unique-directory delete-tree ; inline + [ with-directory ] curry keep delete-tree ; inline { { [ unix? ] [ "io.unix.files.unique" ] } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index e133416101..9c7d64934e 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -3,7 +3,7 @@ USING: io io.backend io.timeouts system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math io.encodings io.streams.duplex -io.nonblocking new-slots accessors ; +io.nonblocking accessors ; IN: io.launcher diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 4acfb9acad..6c73669e9f 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,11 +1,11 @@ -USING: io.files kernel sequences new-slots accessors +USING: io.files kernel sequences accessors dlists arrays sequences.lib ; IN: io.paths TUPLE: directory-iterator path bfs queue ; : qualified-directory ( path -- seq ) - dup directory [ first2 >r path+ r> 2array ] with map ; + dup directory [ first2 >r append-path r> 2array ] with map ; : push-directory ( path iter -- ) >r qualified-directory r> [ diff --git a/extra/io/priority/priority.factor b/extra/io/priority/priority.factor new file mode 100644 index 0000000000..0790563072 --- /dev/null +++ b/extra/io/priority/priority.factor @@ -0,0 +1,5 @@ +USING: io.backend kernel ; +IN: io.priority + +HOOK: get-priority io-backend ( -- n ) +HOOK: set-priority io-backend ( n -- ) diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index ef660a6f0d..f1031e98e2 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel calendar alarms io.streams.duplex ; +USING: kernel calendar alarms io.streams.duplex io.encodings ; IN: io.timeouts ! Won't need this with new slot accessors @@ -12,6 +12,10 @@ M: duplex-stream set-timeout duplex-stream-in set-timeout duplex-stream-out set-timeout ; +M: decoder set-timeout decoder-stream set-timeout ; + +M: encoder set-timeout encoder-stream set-timeout ; + GENERIC: timed-out ( obj -- ) M: object timed-out drop ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 93691c63e2..c9bd331bcd 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -72,6 +72,9 @@ M: mx unregister-io-task ( task mx -- ) : (io-error) ( -- * ) err_no strerror throw ; +: check-errno ( -- ) + err_no dup zero? [ drop ] [ strerror throw ] if ; + : check-null ( n -- ) zero? [ (io-error) ] when ; : io-error ( n -- ) 0 < [ (io-error) ] when ; diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index 185d9cd405..c5365d8d5c 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -5,8 +5,7 @@ IN: io.unix.files.unique : open-unique-flags ( -- flags ) { O_RDWR O_CREAT O_EXCL } flags ; -M: unix-io (make-unique-file) ( path -- duplex-stream ) - open-unique-flags file-mode open dup io-error - ; +M: unix-io (make-unique-file) ( path -- ) + open-unique-flags file-mode open dup io-error close ; M: unix-io temporary-path ( -- path ) "/tmp" ; diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 6fa8c913aa..9e19245d01 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,6 +1,6 @@ IN: io.unix.launcher.tests USING: io.files tools.test io.launcher arrays io namespaces -continuations math io.encodings.ascii io.encodings.latin1 +continuations math io.encodings.binary io.encodings.ascii accessors kernel sequences ; [ ] [ @@ -64,7 +64,7 @@ accessors kernel sequences ; [ ] [ 2 [ - "launcher-test-1" temp-file ascii [ + "launcher-test-1" temp-file binary [ swap >>stdout "echo Hello" >>command @@ -84,7 +84,7 @@ accessors kernel sequences ; "env" >>command { { "A" "B" } } >>environment - latin1 lines + ascii lines "A=B" swap member? ] unit-test @@ -93,5 +93,5 @@ accessors kernel sequences ; "env" >>command { { "A" "B" } } >>environment +replace-environment+ >>environment-mode - latin1 lines + ascii lines ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 7b4831a2c5..a1e42fddf2 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend io.unix.files io.nonblocking sequences kernel namespaces math system alien.c-types debugger continuations arrays assocs combinators unix.process strings threads unix -io.unix.launcher.parser io.encodings.latin1 accessors new-slots ; +io.unix.launcher.parser io.encodings.latin1 accessors ; IN: io.unix.launcher ! Search unix first diff --git a/extra/io/unix/priority/priority.factor b/extra/io/unix/priority/priority.factor new file mode 100644 index 0000000000..deb801e3cf --- /dev/null +++ b/extra/io/unix/priority/priority.factor @@ -0,0 +1,21 @@ +USING: alien.syntax kernel io.priority io.unix.backend +unix ; +IN: io.unix.priority + +: PRIO_PROCESS 0 ; inline +: PRIO_PGRP 1 ; inline +: PRIO_USER 2 ; inline + +: PRIO_MIN -20 ; inline +: PRIO_MAX 20 ; inline + +! which/who = 0 for current process +FUNCTION: int getpriority ( int which, int who ) ; +FUNCTION: int setpriority ( int which, int who, int prio ) ; + +M: unix-io get-priority ( -- n ) + clear_err_no + 0 0 getpriority dup -1 = [ check-errno ] when ; + +M: unix-io set-priority ( n -- ) + 0 0 rot setpriority io-error ; diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 1f0492a060..bd58761a5b 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend +io.unix.launcher io.unix.mmap io.backend io.unix.priority combinators namespaces system vocabs.loader sequences ; "io.unix." os append require diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 0823c3f0f3..7e7610eb72 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,9 +1,10 @@ USING: kernel system io.files.unique.backend -windows.kernel32 io.windows io.nonblocking ; +windows.kernel32 io.windows io.nonblocking windows ; IN: io.windows.files.unique -M: windows-io (make-unique-file) ( path -- stream ) - GENERIC_WRITE CREATE_NEW 0 open-file 0 ; +M: windows-io (make-unique-file) ( path -- ) + GENERIC_WRITE CREATE_NEW 0 open-file + CloseHandle win32-error=0/f ; M: windows-io temporary-path ( -- path ) "TEMP" os-env ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 3e49f1dc10..ca8f5f3e59 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system threads init strings combinators -io.backend new-slots accessors concurrency.flags ; +io.backend accessors concurrency.flags ; IN: io.windows.launcher TUPLE: CreateProcess-args diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index dda94da892..7cf056674f 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -32,9 +32,9 @@ M: windows-nt-io root-directory? ( path -- ? ) } && [ 2 head ] [ "Not an absolute path" throw ] if ; : prepend-prefix ( string -- string' ) - unicode-prefix swap append ; + unicode-prefix prepend ; -: windows-path+ ( cwd path -- newpath ) +: windows-append-path ( cwd path -- newpath ) { ! empty { [ dup empty? ] [ drop ] } @@ -43,7 +43,7 @@ M: windows-nt-io root-directory? ( path -- ? ) ! \\\\?\\c:\\foo { [ dup unicode-prefix head? ] [ nip ] } ! ..\\foo - { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] } + { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-append-path ] } ! .\\foo { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } ! \\foo @@ -62,7 +62,7 @@ M: windows-nt-io normalize-pathname ( string -- string ) dup string? [ "Pathname must be a string" throw ] unless dup empty? [ "Empty pathname" throw ] when { { CHAR: / CHAR: \\ } } substitute - cwd swap windows-path+ + cwd swap windows-append-path [ "/\\." member? ] right-trim dup peek CHAR: : = [ "\\" append ] when ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index c4ac99fe4a..6353bfe86e 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -22,15 +22,15 @@ IN: io.windows.nt.tests [ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ "C:\\builds\\factor\\12345\\" - "..\\log.txt" windows-path+ + "..\\log.txt" windows-append-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." windows-path+ + "..\\.." windows-append-path ] unit-test [ "\\\\?\\C:\\builds\\" ] [ "C:\\builds\\factor\\12345\\" - "..\\.." windows-path+ + "..\\.." windows-append-path ] unit-test diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index eb6dae2a0a..f2aca0470d 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays destructors io io.windows libc windows.types math windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random -combinators new-slots accessors ; +combinators accessors ; IN: io.windows.nt.pipes ! This code is based on @@ -56,7 +56,7 @@ TUPLE: pipe in out ; "\\\\.\\pipe\\factor-" % pipe counter # "-" % - (random) # + 32 random-bits # "-" % millis # ] "" make ; diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 69de838eec..71cbb1d951 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -33,7 +33,7 @@ SYMBOL: terms { { [ dup 1 = ] [ drop " + " ] } { [ dup -1 = ] [ drop " - " ] } - { [ t ] [ number>string " + " swap append ] } + { [ t ] [ number>string " + " prepend ] } } cond ; : (alt.) ( basis n -- str ) @@ -155,7 +155,7 @@ DEFER: (d) : (tensor) ( seq1 seq2 -- seq ) [ - [ swap append natural-sort ] curry map + [ prepend natural-sort ] curry map ] with map concat ; : tensor ( graded-basis1 graded-basis2 -- bigraded-basis ) @@ -202,7 +202,7 @@ DEFER: (d) : bigraded-betti ( u-generators z-generators -- seq ) [ basis graded ] 2apply tensor bigraded-ker/im-d [ [ [ first ] map ] map ] keep - [ [ second ] map 2 head* { 0 0 } swap append ] map + [ [ second ] map 2 head* { 0 0 } prepend ] map 1 tail dup first length 0 add [ v- ] 2map ; diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor index 62f2eac513..372a567550 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -25,7 +25,7 @@ $with-locals-note ; HELP: [let { $syntax "[let | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" } -{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." } +{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." } { $examples { $example "USING: kernel locals math math.functions prettyprint sequences ;" @@ -38,6 +38,24 @@ HELP: [let } $with-locals-note ; +HELP: [let* +{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" } +{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated sequentially, and may refer to previous bindings from the same " { $link POSTPONE: [let* } " form; for Lisp programmers, this means that " { $link POSTPONE: [let* } " is equivalent to the Lisp " { $snippet "let*" } ", not " { $snippet "let" } "." } +{ $examples + { $example + "USING: kernel locals math math.functions prettyprint sequences ;" + ":: frobnicate ( n seq -- newseq )" + " [let* | a [ n 3 + ]" + " b [ a 4 * ] |" + " seq [ b / ] map ] ;" + "1 { 32 48 } frobnicate ." + "{ 2 3 }" + } +} +$with-locals-note ; + +{ POSTPONE: [let POSTPONE: [let* } related-words + HELP: [wlet { $syntax "[wlet | binding1 [ body1... ]\n binding2 [ body2... ]\n ... |\n body... ]" } { $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." } @@ -106,6 +124,7 @@ $nl { $subsection with-locals } "Lexical binding forms:" { $subsection POSTPONE: [let } +{ $subsection POSTPONE: [let* } { $subsection POSTPONE: [wlet } "Lambda abstractions:" { $subsection POSTPONE: [| } diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index bd1e62f22a..4ee9b48bb7 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -195,3 +195,36 @@ DEFER: xyzzy ] unit-test [ 5 ] [ 10 xyzzy ] unit-test + +:: let*-test-1 ( a -- b ) + [let* | b [ a 1+ ] + c [ b 1+ ] | + a b c 3array ] ; + +[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test + +:: let*-test-2 ( a -- b ) + [let* | b [ a 1+ ] + c! [ b 1+ ] | + a b c 3array ] ; + +[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test + +:: let*-test-3 ( a -- b ) + [let* | b [ a 1+ ] + c! [ b 1+ ] | + c 1+ c! a b c 3array ] ; + +[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test + +:: let*-test-4 ( a b -- c d ) + [let | a [ b ] + b [ a ] | + [let* | a' [ a ] + a'' [ a' ] + b' [ b ] + b'' [ b' ] | + a'' b'' ] ] ; + +[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test + diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index a8f5e139e7..640ae0c9ea 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables combinators.lib prettyprint.sections sequences.private effects generic -compiler.units combinators.cleave ; +compiler.units combinators.cleave accessors ; IN: locals ! Inspired by @@ -17,11 +17,15 @@ TUPLE: lambda vars body ; C: lambda -TUPLE: let bindings vars body ; +TUPLE: let bindings body ; C: let -TUPLE: wlet bindings vars body ; +TUPLE: let* bindings body ; + +C: let* + +TUPLE: wlet bindings body ; C: wlet @@ -137,7 +141,7 @@ M: object free-vars drop { } ; M: quotation free-vars { } [ add-if-free ] reduce ; M: lambda free-vars - dup lambda-vars swap lambda-body free-vars seq-diff ; + dup vars>> swap body>> free-vars seq-diff ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! lambda-rewrite @@ -164,19 +168,19 @@ M: callable block-body ; M: callable local-rewrite* [ [ local-rewrite* ] each ] [ ] make , ; -M: lambda block-vars lambda-vars ; +M: lambda block-vars vars>> ; -M: lambda block-body lambda-body ; +M: lambda block-body body>> ; M: lambda local-rewrite* - dup lambda-vars swap lambda-body + dup vars>> swap body>> [ local-rewrite* \ call , ] [ ] make , ; M: block lambda-rewrite* #! Turn free variables into bound variables, curry them #! onto the body dup free-vars [ ] map dup % [ - over block-vars swap append + over block-vars prepend swap block-body [ [ lambda-rewrite* ] each ] [ ] make swap point-free , ] keep length \ curry % ; @@ -187,24 +191,18 @@ M: object local-rewrite* , ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: make-locals ( seq -- words assoc ) - [ - "!" ?tail [ ] [ ] if - ] map dup [ - dup - [ dup word-name set ] each - [ - dup local-reader? [ - dup word-name set - ] [ - drop - ] if - ] each - ] H{ } make-assoc ; +: make-local ( name -- word ) + "!" ?tail [ + + dup dup word-name set + ] [ ] if + dup dup word-name set ; -: make-local-words ( seq -- words assoc ) - [ dup ] { } map>assoc - dup values swap ; +: make-locals ( seq -- words assoc ) + [ [ make-local ] map ] H{ } make-assoc ; + +: make-local-word ( name -- word ) + dup dup word-name set ; : push-locals ( assoc -- ) use get push ; @@ -213,41 +211,75 @@ M: object local-rewrite* , ; use get delete ; : (parse-lambda) ( assoc end -- quot ) - over push-locals parse-until >quotation swap pop-locals ; + parse-until >quotation swap pop-locals ; : parse-lambda ( -- lambda ) - "|" parse-tokens make-locals \ ] (parse-lambda) ; + "|" parse-tokens make-locals dup push-locals + \ ] (parse-lambda) ; -: (parse-bindings) ( -- ) +: parse-binding ( -- pair/f ) scan dup "|" = [ - drop + drop f ] [ scan { { "[" [ \ ] parse-until >quotation ] } { "[|" [ parse-lambda ] } - } case 2array , - (parse-bindings) + } case 2array ] if ; -: parse-bindings ( -- alist ) - scan "|" assert= [ (parse-bindings) ] { } make dup keys ; +: (parse-bindings) ( -- ) + parse-binding [ + first2 >r make-local r> 2array , + (parse-bindings) + ] when* ; + +: parse-bindings ( -- bindings vars ) + [ + [ (parse-bindings) ] H{ } make-assoc + dup push-locals + ] { } make swap ; + +: parse-bindings* ( -- words assoc ) + [ + [ + namespace push-locals + + (parse-bindings) + ] { } make-assoc + ] { } make swap ; + +: (parse-wbindings) ( -- ) + parse-binding [ + first2 >r make-local-word r> 2array , + (parse-wbindings) + ] when* ; + +: parse-wbindings ( -- bindings vars ) + [ + [ (parse-wbindings) ] H{ } make-assoc + dup push-locals + ] { } make swap ; + +: let-rewrite ( body bindings -- ) + [ + >r 1array r> spin [ call ] curry compose + ] assoc-each local-rewrite* \ call , ; M: let local-rewrite* - { let-bindings let-vars let-body } get-slots -rot - [ ] 2apply - [ - 1array -rot second -rot - [ call ] curry compose - ] 2each local-rewrite* \ call , ; + { body>> bindings>> } get-slots let-rewrite ; + +M: let* local-rewrite* + { body>> bindings>> } get-slots let-rewrite ; M: wlet local-rewrite* - dup wlet-bindings values over wlet-vars rot wlet-body - [ call ] curry compose local-rewrite* \ call , ; + { body>> bindings>> } get-slots + [ [ ] curry ] assoc-map + let-rewrite ; -: parse-locals +: parse-locals ( -- vars assoc ) parse-effect word [ over "declared-effect" set-word-prop ] when* - effect-in make-locals ; + effect-in make-locals dup push-locals ; : parse-locals-definition ( word -- word quot ) scan "(" assert= parse-locals \ ; (parse-lambda) @@ -263,14 +295,17 @@ PRIVATE> : [| parse-lambda parsed ; parsing : [let - parse-bindings - make-locals \ ] (parse-lambda) - parsed ; parsing + scan "|" assert= parse-bindings +\ ] (parse-lambda) parsed ; parsing + +: [let* + scan "|" assert= parse-bindings* + >r \ ] parse-until >quotation parsed r> pop-locals ; + parsing : [wlet - parse-bindings - make-local-words \ ] (parse-lambda) - parsed ; parsing + scan "|" assert= parse-wbindings + \ ] (parse-lambda) parsed ; parsing MACRO: with-locals ( form -- quot ) lambda-rewrite ; @@ -297,31 +332,30 @@ SYMBOL: | M: lambda pprint* > pprint-vars \ | pprint-word - f + f > pprint-elements block> \ ] pprint-word block> ; -: pprint-let ( body vars bindings -- ) +: pprint-let ( let word -- ) + pprint-word + { body>> bindings>> } get-slots \ | pprint-word t r pprint-var r> pprint* block> ] 2each + [ r pprint-var r> pprint* block> ] assoc-each block> \ | pprint-word - block> ; - -M: let pprint* - \ [let pprint-word - { let-body let-vars let-bindings } get-slots pprint-let + block> \ ] pprint-word ; -M: wlet pprint* - \ [wlet pprint-word - { wlet-body wlet-vars wlet-bindings } get-slots pprint-let - \ ] pprint-word ; +M: let pprint* \ [let pprint-let ; + +M: wlet pprint* \ [wlet pprint-let ; + +M: let* pprint* \ [let* pprint-let ; PREDICATE: word lambda-word "lambda" word-prop >boolean ; @@ -329,7 +363,7 @@ PREDICATE: word lambda-word M: lambda-word definer drop \ :: \ ; ; M: lambda-word definition - "lambda" word-prop lambda-body ; + "lambda" word-prop body>> ; : lambda-word-synopsis ( word -- ) dup definer. @@ -345,7 +379,7 @@ PREDICATE: macro lambda-macro M: lambda-macro definer drop \ MACRO:: \ ; ; M: lambda-macro definition - "lambda" word-prop lambda-body ; + "lambda" word-prop body>> ; M: lambda-macro synopsis* lambda-word-synopsis ; @@ -355,10 +389,10 @@ PREDICATE: method-body lambda-method M: lambda-method definer drop \ M:: \ ; ; M: lambda-method definition - "lambda" word-prop lambda-body ; + "lambda" word-prop body>> ; : method-stack-effect ( method -- effect ) - dup "lambda" word-prop lambda-vars + dup "lambda" word-prop vars>> swap "method-generic" word-prop stack-effect dup [ effect-out ] when ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 372216c45e..bed6a2fec3 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -11,10 +11,10 @@ IN: logging.server \ log-root get "logs" resource-path or ; : log-path ( service -- path ) - log-root swap path+ ; + log-root prepend-path ; : log# ( path n -- path' ) - number>string ".log" append path+ ; + number>string ".log" append append-path ; SYMBOL: log-files diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor index 13eaa479a5..91d9fd8ece 100644 --- a/extra/math/haar/haar.factor +++ b/extra/math/haar/haar.factor @@ -12,4 +12,4 @@ IN: math.haar 2 group dup averages [ differences ] keep ; : haar ( seq -- seq ) - dup length 1 <= [ haar-step haar swap append ] unless ; + dup length 1 <= [ haar-step haar prepend ] unless ; diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index 3985906b32..ea7f02829d 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -19,8 +19,6 @@ SYMBOL: trials : next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; -: random-bits ( m -- n ) 2^ random ; foldable - TUPLE: positive-even-expected n ; : (factor-2s) ( r s -- r s ) diff --git a/extra/math/ranges/ranges-docs.factor b/extra/math/ranges/ranges-docs.factor new file mode 100644 index 0000000000..a8783ee410 --- /dev/null +++ b/extra/math/ranges/ranges-docs.factor @@ -0,0 +1,21 @@ +USING: help.syntax help.markup ; + +IN: math.ranges + +ARTICLE: "ranges" "Ranges" + + "A " { $emphasis "range" } " is a virtual sequence with elements " + "ranging from a to b by step." + + $nl + + "Creating ranges:" + + { $subsection } + { $subsection [a,b] } + { $subsection (a,b] } + { $subsection [a,b) } + { $subsection (a,b) } + { $subsection [0,b] } + { $subsection [1,b] } + { $subsection [0,b) } ; \ No newline at end of file diff --git a/extra/math/ranges/ranges.factor b/extra/math/ranges/ranges.factor index ade3b63a5c..9215fc3acd 100755 --- a/extra/math/ranges/ranges.factor +++ b/extra/math/ranges/ranges.factor @@ -3,7 +3,7 @@ IN: math.ranges TUPLE: range from length step ; -: ( from to step -- range ) +: ( a b step -- range ) >r over - r> [ / 1+ 0 max >integer ] keep range construct-boa ; @@ -22,19 +22,19 @@ INSTANCE: range immutable-sequence : ,b) dup neg rot + swap ; inline -: [a,b] twiddle ; +: [a,b] ( a b -- range ) twiddle ; -: (a,b] twiddle (a, ; +: (a,b] ( a b -- range ) twiddle (a, ; -: [a,b) twiddle ,b) ; +: [a,b) ( a b -- range ) twiddle ,b) ; -: (a,b) twiddle (a, ,b) ; +: (a,b) ( a b -- range ) twiddle (a, ,b) ; -: [0,b] 0 swap [a,b] ; +: [0,b] ( b -- range ) 0 swap [a,b] ; -: [1,b] 1 swap [a,b] ; +: [1,b] ( b -- range ) 1 swap [a,b] ; -: [0,b) 0 swap [a,b) ; +: [0,b) ( b -- range ) 0 swap [a,b) ; : range-increasing? ( range -- ? ) range-step 0 > ; diff --git a/extra/new-slots/authors.txt b/extra/new-slots/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/new-slots/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor deleted file mode 100755 index 3273036b8b..0000000000 --- a/extra/new-slots/new-slots.factor +++ /dev/null @@ -1,67 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: effects words kernel sequences slots slots.private -assocs parser mirrors namespaces math vocabs tuples ; -IN: new-slots - -: create-accessor ( name effect -- word ) - >r "accessors" create dup r> - "declared-effect" set-word-prop ; - -: reader-effect T{ effect f { "object" } { "value" } } ; inline - -: reader-word ( name -- word ) - ">>" append reader-effect create-accessor ; - -: define-reader ( class slot name -- ) - reader-word [ slot ] define-slot-word ; - -: writer-effect T{ effect f { "value" "object" } { } } ; inline - -: writer-word ( name -- word ) - "(>>" swap ")" 3append writer-effect create-accessor ; - -: define-writer ( class slot name -- ) - writer-word [ set-slot ] define-slot-word ; - -: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline - -: setter-word ( name -- word ) - ">>" swap append setter-effect create-accessor ; - -: define-setter ( name -- ) - dup setter-word dup deferred? [ - [ \ over , swap writer-word , ] [ ] make define-inline - ] [ 2drop ] if ; - -: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline - -: changer-word ( name -- word ) - "change-" swap append changer-effect create-accessor ; - -: define-changer ( name -- ) - dup changer-word dup deferred? [ - [ - [ over >r >r ] % - over reader-word , - [ r> call r> swap ] % - swap setter-word , - ] [ ] make define-inline - ] [ 2drop ] if ; - -: define-new-slot ( class slot name -- ) - dup define-changer - dup define-setter - 3dup define-reader - define-writer ; - -: define-new-slots ( tuple-class -- ) - [ "slot-names" word-prop >alist ] keep - [ swap first2 >r 4 + r> define-new-slot ] curry each ; - -: TUPLE: - CREATE-CLASS - dup ";" parse-tokens define-tuple-class - define-new-slots ; parsing - -"accessors" create-vocab drop diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index 3cbddf8296..1f5453798d 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -65,7 +65,7 @@ MATCH-VARS: ?a ?b ?c ; M: #shuffle node>quot dup node-in-d over node-out-d pretty-shuffle [ , ] [ >r drop t r> ] if* - dup effect-str "#shuffle: " swap append comment, ; + dup effect-str "#shuffle: " prepend comment, ; : pushed-literals node-out-d [ value-literal literalize ] map ; diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 452da8df05..54639431a4 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -15,11 +15,8 @@ IN: peg.ebnf.tests { T{ ebnf-rule f "digit" - V{ - T{ ebnf-choice f - V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } } - } - f + T{ ebnf-choice f + V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } } } } } [ @@ -29,11 +26,8 @@ IN: peg.ebnf.tests { T{ ebnf-rule f "digit" - V{ - T{ ebnf-sequence f - V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } } - } - f + T{ ebnf-sequence f + V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } } } } } [ @@ -83,7 +77,7 @@ IN: peg.ebnf.tests } } } [ - "one {(two | three) four}" 'choice' parse parse-result-ast + "one ((two | three) four)*" 'choice' parse parse-result-ast ] unit-test { @@ -95,5 +89,57 @@ IN: peg.ebnf.tests } } } [ - "one [ two ] three" 'choice' parse parse-result-ast + "one ( two )? three" 'choice' parse parse-result-ast ] unit-test + +{ "foo" } [ + "\"foo\"" 'identifier' parse parse-result-ast +] unit-test + +{ "foo" } [ + "'foo'" 'identifier' parse parse-result-ast +] unit-test + +{ "foo" } [ + "foo" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol +] unit-test + +{ "foo" } [ + "foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol +] unit-test + +{ V{ "a" "b" } } [ + "ab" [EBNF foo='a' 'b' EBNF] call parse-result-ast +] unit-test + +{ V{ 1 "b" } } [ + "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call parse-result-ast +] unit-test + +{ V{ 1 2 } } [ + "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call parse-result-ast +] unit-test + +{ CHAR: A } [ + "A" [EBNF foo=[A-Z] EBNF] call parse-result-ast +] unit-test + +{ CHAR: Z } [ + "Z" [EBNF foo=[A-Z] EBNF] call parse-result-ast +] unit-test + +{ f } [ + "0" [EBNF foo=[A-Z] EBNF] call +] unit-test + +{ CHAR: 0 } [ + "0" [EBNF foo=[^A-Z] EBNF] call parse-result-ast +] unit-test + +{ f } [ + "A" [EBNF foo=[^A-Z] EBNF] call +] unit-test + +{ f } [ + "Z" [EBNF foo=[^A-Z] EBNF] call +] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 5d7d7297ef..ab7baa547e 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -1,185 +1,289 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel parser words arrays strings math.parser sequences +USING: kernel compiler.units parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - peg.parsers unicode.categories ; + peg.parsers unicode.categories multiline combinators.lib + splitting ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; TUPLE: ebnf-terminal symbol ; +TUPLE: ebnf-any-character ; +TUPLE: ebnf-range pattern ; +TUPLE: ebnf-ensure group ; +TUPLE: ebnf-ensure-not group ; TUPLE: ebnf-choice options ; TUPLE: ebnf-sequence elements ; TUPLE: ebnf-repeat0 group ; +TUPLE: ebnf-repeat1 group ; TUPLE: ebnf-optional elements ; TUPLE: ebnf-rule symbol elements ; -TUPLE: ebnf-action word ; +TUPLE: ebnf-action parser code ; TUPLE: ebnf rules ; C: ebnf-non-terminal C: ebnf-terminal +C: ebnf-any-character +C: ebnf-range +C: ebnf-ensure +C: ebnf-ensure-not C: ebnf-choice C: ebnf-sequence C: ebnf-repeat0 +C: ebnf-repeat1 C: ebnf-optional C: ebnf-rule C: ebnf-action C: ebnf -SYMBOL: parsers -SYMBOL: non-terminals -SYMBOL: last-parser +: syntax ( string -- parser ) + #! Parses the string, ignoring white space, and + #! does not put the result in the AST. + token sp hide ; -: reset-parser-generation ( -- ) - V{ } clone parsers set - H{ } clone non-terminals set - f last-parser set ; +: syntax-pack ( begin parser end -- parser ) + #! Parse 'parser' surrounded by syntax elements + #! begin and end. + [ syntax ] dipd syntax pack ; -: store-parser ( parser -- number ) - parsers get [ push ] keep length 1- ; - -: get-parser ( index -- parser ) - parsers get nth ; - -: non-terminal-index ( name -- number ) - dup non-terminals get at [ - nip - ] [ - f store-parser [ swap non-terminals get set-at ] keep - ] if* ; - -GENERIC: (generate-parser) ( ast -- id ) - -: generate-parser ( ast -- id ) - (generate-parser) dup last-parser set ; - -M: ebnf-terminal (generate-parser) ( ast -- id ) - ebnf-terminal-symbol token sp store-parser ; - -M: ebnf-non-terminal (generate-parser) ( ast -- id ) +: 'identifier' ( -- parser ) + #! Return a parser that parses an identifer delimited by + #! a quotation character. The quotation can be single + #! or double quotes. The AST produced is the identifier + #! between the quotes. [ - ebnf-non-terminal-symbol dup non-terminal-index , - parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or , - ] [ ] make delay sp store-parser ; - -M: ebnf-choice (generate-parser) ( ast -- id ) - ebnf-choice-options [ - generate-parser get-parser - ] map choice store-parser ; - -M: ebnf-sequence (generate-parser) ( ast -- id ) - ebnf-sequence-elements [ - generate-parser get-parser - ] map seq store-parser ; - -M: ebnf-repeat0 (generate-parser) ( ast -- id ) - ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ; - -M: ebnf-optional (generate-parser) ( ast -- id ) - ebnf-optional-elements generate-parser get-parser optional store-parser ; - -M: ebnf-rule (generate-parser) ( ast -- id ) - dup ebnf-rule-symbol non-terminal-index swap - ebnf-rule-elements generate-parser get-parser ! nt-id body - swap [ parsers get set-nth ] keep ; - -M: ebnf-action (generate-parser) ( ast -- id ) - ebnf-action-word search 1quotation - last-parser get get-parser swap action store-parser ; - -M: vector (generate-parser) ( ast -- id ) - [ generate-parser ] map peek ; - -M: f (generate-parser) ( ast -- id ) - drop last-parser get ; - -M: ebnf (generate-parser) ( ast -- id ) - ebnf-rules [ - generate-parser - ] map peek ; - -DEFER: 'rhs' - + [ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by , + [ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by , + ] choice* [ >string ] action ; + : 'non-terminal' ( -- parser ) - CHAR: a CHAR: z range "-" token [ first ] action 2array choice repeat1 [ >string ] action ; + #! A non-terminal is the name of another rule. It can + #! be any non-blank character except for characters used + #! in the EBNF syntax itself. + [ + { + [ dup blank? ] + [ dup CHAR: " = ] + [ dup CHAR: ' = ] + [ dup CHAR: | = ] + [ dup CHAR: { = ] + [ dup CHAR: } = ] + [ dup CHAR: = = ] + [ dup CHAR: ) = ] + [ dup CHAR: ( = ] + [ dup CHAR: ] = ] + [ dup CHAR: [ = ] + [ dup CHAR: . = ] + [ dup CHAR: ! = ] + [ dup CHAR: & = ] + [ dup CHAR: * = ] + [ dup CHAR: + = ] + [ dup CHAR: ? = ] + } || not nip + ] satisfy repeat1 [ >string ] action ; : 'terminal' ( -- parser ) - "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string ] action ; + #! A terminal is an identifier enclosed in quotations + #! and it represents the literal value of the identifier. + 'identifier' [ ] action ; +: 'any-character' ( -- parser ) + #! A parser to match the symbol for any character match. + [ CHAR: . = ] satisfy [ drop ] action ; + +: 'range-parser' ( -- parser ) + #! Match the syntax for declaring character ranges + [ + [ "[" syntax , "[" token ensure-not , ] seq* hide , + [ CHAR: ] = not ] satisfy repeat1 , + "]" syntax , + ] seq* [ first >string ] action ; + : 'element' ( -- parser ) - 'non-terminal' 'terminal' 2array choice ; + #! An element of a rule. It can be a terminal or a + #! non-terminal but must not be followed by a "=". + #! The latter indicates that it is the beginning of a + #! new rule. + [ + [ + 'non-terminal' , + 'terminal' , + 'range-parser' , + 'any-character' , + ] choice* , + "=" syntax ensure-not , + ] seq* [ first ] action ; DEFER: 'choice' +: grouped ( quot suffix -- parser ) + #! Parse a group of choices, with a suffix indicating + #! the type of group (repeat0, repeat1, etc) and + #! an quot that is the action that produces the AST. + "(" [ 'choice' sp ] delay ")" syntax-pack + swap 2seq + [ first ] rot compose action ; + : 'group' ( -- parser ) - "(" token sp hide - [ 'choice' sp ] delay - ")" token sp hide - 3array seq [ first ] action ; + #! A grouping with no suffix. Used for precedence. + [ ] [ + "*" token sp ensure-not , + "+" token sp ensure-not , + "?" token sp ensure-not , + ] seq* hide grouped ; : 'repeat0' ( -- parser ) - "{" token sp hide - [ 'choice' sp ] delay - "}" token sp hide - 3array seq [ first ] action ; + [ ] "*" syntax grouped ; + +: 'repeat1' ( -- parser ) + [ ] "+" syntax grouped ; : 'optional' ( -- parser ) - "[" token sp hide - [ 'choice' sp ] delay - "]" token sp hide - 3array seq [ first ] action ; + [ ] "?" syntax grouped ; -: 'sequence' ( -- parser ) +: 'factor-code' ( -- parser ) + [ + "]]" token ensure-not , + [ drop t ] satisfy , + ] seq* [ first ] action repeat0 [ >string ] action ; + +: 'ensure-not' ( -- parser ) + #! Parses the '!' syntax to ensure that + #! something that matches the following elements do + #! not exist in the parse stream. + [ + "!" syntax , + 'group' sp , + ] seq* [ first ] action ; + +: 'ensure' ( -- parser ) + #! Parses the '&' syntax to ensure that + #! something that matches the following elements does + #! exist in the parse stream. + [ + "&" syntax , + 'group' sp , + ] seq* [ first ] action ; + +: ('sequence') ( -- parser ) + #! A sequence of terminals and non-terminals, including + #! groupings of those. [ + 'ensure-not' sp , + 'ensure' sp , 'element' sp , 'group' sp , 'repeat0' sp , + 'repeat1' sp , 'optional' sp , - ] { } make choice - repeat1 [ - dup length 1 = [ first ] [ ] if - ] action ; + ] choice* ; +: 'sequence' ( -- parser ) + #! A sequence of terminals and non-terminals, including + #! groupings of those. + [ + [ + ('sequence') , + "[[" 'factor-code' "]]" syntax-pack , + ] seq* [ first2 ] action , + ('sequence') , + ] choice* repeat1 [ + dup length 1 = [ first ] [ ] if + ] action ; + : 'choice' ( -- parser ) 'sequence' sp "|" token sp list-of [ dup length 1 = [ first ] [ ] if - ] action ; - -: 'action' ( -- parser ) - "=>" token hide - [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp - 2array seq [ first ] action ; - -: 'rhs' ( -- parser ) - 'choice' 'action' sp optional 2array seq ; + ] action ; : 'rule' ( -- parser ) - 'non-terminal' [ ebnf-non-terminal-symbol ] action - "=" token sp hide - 'rhs' - 3array seq [ first2 ] action ; + [ + 'non-terminal' [ ebnf-non-terminal-symbol ] action , + "=" syntax , + 'choice' , + ] seq* [ first2 ] action ; : 'ebnf' ( -- parser ) - 'rule' sp "." token sp hide list-of [ ] action ; + 'rule' sp repeat1 [ ] action ; -: ebnf>quot ( string -- quot ) - 'ebnf' parse [ - parse-result-ast [ - reset-parser-generation - generate-parser drop - [ - non-terminals get - [ - get-parser [ - swap , \ in , \ get , \ create , - 1quotation , \ define , - ] [ - drop - ] if* - ] assoc-each - ] [ ] make - ] with-scope - ] [ - f - ] if* ; +GENERIC: (transform) ( ast -- parser ) + +SYMBOL: parser +SYMBOL: main + +: transform ( ast -- object ) + H{ } clone dup dup [ parser set swap (transform) main set ] bind ; + +M: ebnf (transform) ( ast -- parser ) + ebnf-rules [ (transform) ] map peek ; + +M: ebnf-rule (transform) ( ast -- parser ) + dup ebnf-rule-elements (transform) [ + swap ebnf-rule-symbol set + ] keep ; + +M: ebnf-sequence (transform) ( ast -- parser ) + ebnf-sequence-elements [ (transform) ] map seq ; + +M: ebnf-choice (transform) ( ast -- parser ) + ebnf-choice-options [ (transform) ] map choice ; + +M: ebnf-any-character (transform) ( ast -- parser ) + drop any-char ; + +M: ebnf-range (transform) ( ast -- parser ) + ebnf-range-pattern range-pattern ; + +M: ebnf-ensure (transform) ( ast -- parser ) + ebnf-ensure-group (transform) ensure ; + +M: ebnf-ensure-not (transform) ( ast -- parser ) + ebnf-ensure-not-group (transform) ensure-not ; + +M: ebnf-repeat0 (transform) ( ast -- parser ) + ebnf-repeat0-group (transform) repeat0 ; + +M: ebnf-repeat1 (transform) ( ast -- parser ) + ebnf-repeat1-group (transform) repeat1 ; + +M: ebnf-optional (transform) ( ast -- parser ) + ebnf-optional-elements (transform) optional ; + +M: ebnf-action (transform) ( ast -- parser ) + [ ebnf-action-parser (transform) ] keep + ebnf-action-code string-lines [ parse-lines ] with-compilation-unit action ; + +M: ebnf-terminal (transform) ( ast -- parser ) + ebnf-terminal-symbol token sp ; + +M: ebnf-non-terminal (transform) ( ast -- parser ) + ebnf-non-terminal-symbol [ + , parser get , \ at , + ] [ ] make delay sp ; + +: transform-ebnf ( string -- object ) + 'ebnf' parse parse-result-ast transform ; + +: check-parse-result ( result -- result ) + dup [ + dup parse-result-remaining empty? [ + [ + "Unable to fully parse EBNF. Left to parse was: " % + parse-result-remaining % + ] "" make throw + ] unless + ] [ + "Could not parse EBNF" throw + ] if ; + +: ebnf>quot ( string -- hashtable quot ) + 'ebnf' parse check-parse-result + parse-result-ast transform dup main swap at compile ; + +: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing + +: EBNF: + CREATE-WORD dup + ";EBNF" parse-multiline-string + ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing -: " parse-tokens " " join ebnf>quot call ; parsing diff --git a/extra/peg/expr/authors.txt b/extra/peg/expr/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/peg/expr/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/peg/expr/expr-tests.factor b/extra/peg/expr/expr-tests.factor new file mode 100644 index 0000000000..b6f3163bf4 --- /dev/null +++ b/extra/peg/expr/expr-tests.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +USING: kernel tools.test peg peg.expr multiline sequences ; +IN: peg.expr.tests + +{ 5 } [ + "2+3" eval-expr +] unit-test + +{ 6 } [ + "2*3" eval-expr +] unit-test + +{ 14 } [ + "2+3*4" eval-expr +] unit-test + +{ 17 } [ + "2+3*4+3" eval-expr +] unit-test + +{ 23 } [ + "2+3*(4+3)" eval-expr +] unit-test diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor new file mode 100644 index 0000000000..6b690cb5ee --- /dev/null +++ b/extra/peg/expr/expr.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2008 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel arrays strings math.parser sequences +peg peg.ebnf peg.parsers memoize math ; +IN: peg.expr + +: operator-fold ( lhs seq -- value ) + #! Perform a fold of a lhs, followed by a sequence of pairs being + #! { operator rhs } in to a tree structure of the correct precedence. + swap [ first2 swap call ] reduce ; + +EBNF: expr +times = "*" [[ drop [ * ] ]] +divide = "/" [[ drop [ / ] ]] +add = "+" [[ drop [ + ] ]] +subtract = "-" [[ drop [ - ] ]] + +digit = [0-9] [[ digit> ]] +number = (digit)+ [[ unclip [ swap 10 * + ] reduce ]] + +value = number | ("(" expr ")") [[ second ]] +product = (value ((times | divide) value)*) [[ first2 operator-fold ]] +sum = (product ((add | subtract) product)*) [[ first2 operator-fold ]] +expr = sum +;EBNF + +: eval-expr ( string -- number ) + expr parse-result-ast ; + diff --git a/extra/peg/expr/summary.txt b/extra/peg/expr/summary.txt new file mode 100644 index 0000000000..6c3c140b2b --- /dev/null +++ b/extra/peg/expr/summary.txt @@ -0,0 +1 @@ +Simple expression evaluator using EBNF diff --git a/extra/peg/expr/tags.txt b/extra/peg/expr/tags.txt new file mode 100644 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/peg/expr/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor index 1991cba0eb..d49f1158dd 100755 --- a/extra/peg/parsers/parsers-docs.factor +++ b/extra/peg/parsers/parsers-docs.factor @@ -159,3 +159,21 @@ HELP: 'string' } { $description "Returns a parser that matches an string composed of a \", anything that is not \", and another \"." } { $see-also 'integer' } ; + +HELP: range-pattern +{ $values + { "pattern" "a string" } + { "parser" "a parser" } +} { $description +"Returns a parser that matches a single character based on the set " +"of characters in the pattern string." +"Any single character in the pattern matches that character. " +"If the pattern begins with a ^ then the set is negated " +"(the element matches any character not in the set). Any pair " +"of characters separated with a dash (-) represents the " +"range of characters from the first to the second, inclusive." +{ $examples + { $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" } + { $example "USING: peg peg.parsers prettyprint ;" "\"0\" \"^0-9\" range-pattern parse ." "f" } +} +} ; diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 87306e1469..3ccb1e7d10 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle - vectors arrays combinators.lib memoize math.parser match - unicode.categories sequences.deep peg peg.private ; + vectors arrays combinators.lib math.parser match + unicode.categories sequences.deep peg peg.private + peg.search math.ranges ; IN: peg.parsers TUPLE: just-parser p1 ; @@ -18,26 +19,26 @@ TUPLE: just-parser p1 ; M: just-parser compile ( parser -- quot ) just-parser-p1 compile just-pattern append ; -MEMO: just ( parser -- parser ) - just-parser construct-boa init-parser ; +: just ( parser -- parser ) + just-parser construct-boa ; -MEMO: 1token ( ch -- parser ) 1string token ; +: 1token ( ch -- parser ) 1string token ; r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq [ unclip 1vector swap first append ] action ; PRIVATE> -MEMO: list-of ( items separator -- parser ) +: list-of ( items separator -- parser ) hide f (list-of) ; -MEMO: list-of-many ( items separator -- parser ) +: list-of-many ( items separator -- parser ) hide t (list-of) ; -MEMO: epsilon ( -- parser ) V{ } token ; +: epsilon ( -- parser ) V{ } token ; -MEMO: any-char ( -- parser ) [ drop t ] satisfy ; +: any-char ( -- parser ) [ drop t ] satisfy ; -MEMO: exactly-n ( parser n -- parser' ) +: exactly-n ( parser n -- parser' ) swap seq ; -MEMO: at-most-n ( parser n -- parser' ) +: at-most-n ( parser n -- parser' ) dup zero? [ 2drop epsilon ] [ @@ -57,29 +58,56 @@ MEMO: at-most-n ( parser n -- parser' ) -rot 1- at-most-n 2choice ] if ; -MEMO: at-least-n ( parser n -- parser' ) +: at-least-n ( parser n -- parser' ) dupd exactly-n swap repeat0 2seq [ flatten-vectors ] action ; -MEMO: from-m-to-n ( parser m n -- parser' ) +: from-m-to-n ( parser m n -- parser' ) >r [ exactly-n ] 2keep r> swap - at-most-n 2seq [ flatten-vectors ] action ; -MEMO: pack ( begin body end -- parser ) +: pack ( begin body end -- parser ) >r >r hide r> r> hide 3seq [ first ] action ; -MEMO: surrounded-by ( parser begin end -- parser' ) +: surrounded-by ( parser begin end -- parser' ) [ token ] 2apply swapd pack ; -MEMO: 'digit' ( -- parser ) +: 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] action ; -MEMO: 'integer' ( -- parser ) +: 'integer' ( -- parser ) 'digit' repeat1 [ 10 digits>integer ] action ; -MEMO: 'string' ( -- parser ) +: 'string' ( -- parser ) [ [ CHAR: " = ] satisfy hide , [ CHAR: " = not ] satisfy repeat0 , [ CHAR: " = ] satisfy hide , ] { } make seq [ first >string ] action ; + +: (range-pattern) ( pattern -- string ) + #! Given a range pattern, produce a string containing + #! all characters within that range. + [ + any-char , + [ CHAR: - = ] satisfy hide , + any-char , + ] seq* [ + first2 [a,b] >string + ] action + replace ; + +: range-pattern ( pattern -- parser ) + #! 'pattern' is a set of characters describing the + #! parser to be produced. Any single character in + #! the pattern matches that character. If the pattern + #! begins with a ^ then the set is negated (the element + #! matches any character not in the set). Any pair of + #! characters separated with a dash (-) represents the + #! range of characters from the first to the second, + #! inclusive. + dup first CHAR: ^ = [ + 1 tail (range-pattern) [ member? not ] curry satisfy + ] [ + (range-pattern) [ member? ] curry satisfy + ] if ; diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 7a1ce99883..89cc243863 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -4,10 +4,6 @@ USING: kernel tools.test strings namespaces arrays sequences peg peg.private ; IN: peg.tests -{ 0 1 2 } [ - 0 next-id set-global get-next-id get-next-id get-next-id -] unit-test - { f } [ "endbegin" "begin" token parse ] unit-test diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 16cf40f884..b3200ec5eb 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle - vectors arrays combinators.lib memoize math.parser match + vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser words ; IN: peg @@ -10,70 +10,14 @@ TUPLE: parse-result remaining ast ; GENERIC: compile ( parser -- quot ) -: (parse) ( state parser -- result ) +: parse ( state parser -- result ) compile call ; - - ( remaining ast -- parse-result ) parse-result construct-boa ; -SYMBOL: next-id - -: get-next-id ( -- number ) - next-id get-global 0 or dup 1+ next-id set-global ; - -TUPLE: parser id ; - -: init-parser ( parser -- parser ) - get-next-id parser construct-boa over set-delegate ; - -: from ( slice-or-string -- index ) - dup slice? [ slice-from ] [ drop 0 ] if ; - -: get-cached ( input parser -- result ) - [ from ] dip parser-id packrat-cache get at at* [ - drop not-in-cache - ] unless ; - -: put-cached ( result input parser -- ) - parser-id dup packrat-cache get at [ - nip - ] [ - H{ } clone dup >r swap packrat-cache get set-at r> - ] if* - [ from ] dip set-at ; - -PRIVATE> - -: parse ( input parser -- result ) - packrat-cache get [ - 2dup get-cached dup not-in-cache? [ -! "cache missed: " write over parser-id number>string write " - " write nl ! pick . - drop - #! Protect against left recursion blowing the callstack - #! by storing a failed parse in the cache. - [ f ] dipd [ put-cached ] 2keep - [ (parse) dup ] 2keep put-cached - ] [ -! "cache hit: " write over parser-id number>string write " - " write nl ! pick . - 2nip - ] if - ] [ - (parse) - ] if ; - -: packrat-parse ( input parser -- result ) - H{ } clone packrat-cache [ parse ] with-variable ; - -MEMO: token ( string -- parser ) - token-parser construct-boa init-parser ; +: token ( string -- parser ) + token-parser construct-boa ; : satisfy ( quot -- parser ) - satisfy-parser construct-boa init-parser ; + satisfy-parser construct-boa ; -MEMO: range ( min max -- parser ) - range-parser construct-boa init-parser ; +: range ( min max -- parser ) + range-parser construct-boa ; : seq ( seq -- parser ) - seq-parser construct-boa init-parser ; + seq-parser construct-boa ; : 2seq ( parser1 parser2 -- parser ) 2array seq ; @@ -320,7 +264,7 @@ MEMO: range ( min max -- parser ) { } make seq ; inline : choice ( seq -- parser ) - choice-parser construct-boa init-parser ; + choice-parser construct-boa ; : 2choice ( parser1 parser2 -- parser ) 2array choice ; @@ -334,32 +278,32 @@ MEMO: range ( min max -- parser ) : choice* ( quot -- paser ) { } make choice ; inline -MEMO: repeat0 ( parser -- parser ) - repeat0-parser construct-boa init-parser ; +: repeat0 ( parser -- parser ) + repeat0-parser construct-boa ; -MEMO: repeat1 ( parser -- parser ) - repeat1-parser construct-boa init-parser ; +: repeat1 ( parser -- parser ) + repeat1-parser construct-boa ; -MEMO: optional ( parser -- parser ) - optional-parser construct-boa init-parser ; +: optional ( parser -- parser ) + optional-parser construct-boa ; -MEMO: ensure ( parser -- parser ) - ensure-parser construct-boa init-parser ; +: ensure ( parser -- parser ) + ensure-parser construct-boa ; -MEMO: ensure-not ( parser -- parser ) - ensure-not-parser construct-boa init-parser ; +: ensure-not ( parser -- parser ) + ensure-not-parser construct-boa ; : action ( parser quot -- parser ) - action-parser construct-boa init-parser ; + action-parser construct-boa ; -MEMO: sp ( parser -- parser ) - sp-parser construct-boa init-parser ; +: sp ( parser -- parser ) + sp-parser construct-boa ; -MEMO: hide ( parser -- parser ) +: hide ( parser -- parser ) [ drop ignore ] action ; -MEMO: delay ( quot -- parser ) - delay-parser construct-boa init-parser ; +: delay ( quot -- parser ) + delay-parser construct-boa ; : PEG: (:) [ diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index fa8ac89f57..b3d2135da7 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -1,13 +1,91 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.pl0 ; +USING: kernel tools.test peg peg.pl0 multiline sequences ; IN: peg.pl0.tests -{ "abc" } [ - "abc" ident parse parse-result-ast +{ t } [ + <" +VAR x, squ; + +PROCEDURE square; +BEGIN + squ := x * x +END; + +BEGIN + x := 1; + WHILE x <= 10 DO + BEGIN + CALL square; + x := x + 1; + END +END. +"> pl0 parse-result-remaining empty? ] unit-test -{ 55 } [ - "55abc" number parse parse-result-ast -] unit-test +{ f } [ + <" +CONST + m = 7, + n = 85; + +VAR + x, y, z, q, r; + +PROCEDURE multiply; +VAR a, b; + +BEGIN + a := x; + b := y; + z := 0; + WHILE b > 0 DO BEGIN + IF ODD b THEN z := z + a; + a := 2 * a; + b := b / 2; + END +END; + +PROCEDURE divide; +VAR w; +BEGIN + r := x; + q := 0; + w := y; + WHILE w <= r DO w := 2 * w; + WHILE w > y DO BEGIN + q := 2 * q; + w := w / 2; + IF w <= r THEN BEGIN + r := r - w; + q := q + 1 + END + END +END; + +PROCEDURE gcd; +VAR f, g; +BEGIN + f := x; + g := y; + WHILE f # g DO BEGIN + IF f < g THEN g := g - f; + IF g < f THEN f := f - g; + END; + z := f +END; + +BEGIN + x := m; + y := n; + CALL multiply; + x := 25; + y := 3; + CALL divide; + x := 84; + y := 36; + CALL gcd; +END. + "> pl0 parse-result-remaining empty? +] unit-test \ No newline at end of file diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index 6844eb44dc..f7eb3cad23 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -1,30 +1,26 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays strings math.parser sequences -peg peg.ebnf peg.parsers memoize ; +peg peg.ebnf peg.parsers memoize namespaces math ; IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 -MEMO: ident ( -- parser ) - CHAR: a CHAR: z range - CHAR: A CHAR: Z range 2array choice repeat1 - [ >string ] action ; -MEMO: number ( -- parser ) - CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ; - -=' | '>') expression . -expression = ['+' | '-'] term {('+' | '-') term } . -term = factor {('*' | '/') factor } . -factor = ident | number | '(' expression ')' -EBNF> +EBNF: pl0 +block = ( "CONST" ident "=" number ( "," ident "=" number )* ";" )? + ( "VAR" ident ( "," ident )* ";" )? + ( "PROCEDURE" ident ";" ( block ";" )? )* statement +statement = ( ident ":=" expression | "CALL" ident | + "BEGIN" statement (";" statement )* "END" | + "IF" condition "THEN" statement | + "WHILE" condition "DO" statement )? +condition = "ODD" expression | + expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression +expression = ("+" | "-")? term (("+" | "-") term )* +term = factor (("*" | "/") factor )* +factor = ident | number | "(" expression ")" +ident = (([a-zA-Z])+) [[ >string ]] +digit = ([0-9]) [[ digit> ]] +number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]] +program = block "." +;EBNF diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index 0b8f773887..b660ed0958 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -41,7 +41,7 @@ PRIVATE> : fib-upto* ( n -- seq ) 0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip - 1 head-slice* { 0 1 } swap append ; + 1 head-slice* { 0 1 } prepend ; : euler002a ( -- answer ) 1000000 fib-upto* [ even? ] subset sum ; diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor index d8d38d1647..9873abf05c 100755 --- a/extra/project-euler/035/035.factor +++ b/extra/project-euler/035/035.factor @@ -34,7 +34,7 @@ IN: project-euler.035 ] if ; : rotate ( seq n -- seq ) - cut* swap append ; + cut* prepend ; : (circular?) ( seq n -- ? ) dup 0 > [ diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 25ddd9a60b..04339ad5b7 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -30,7 +30,7 @@ IN: project-euler number>string 3 CHAR: 0 pad-left ; : solution-path ( n -- str/f ) - number>euler "project-euler." swap append + number>euler "project-euler." prepend vocab where dup [ first ?resource-path ] when ; PRIVATE> @@ -40,7 +40,7 @@ PRIVATE> : run-project-euler ( -- ) problem-prompt dup problem-solved? [ - dup number>euler "project-euler." swap append run + dup number>euler "project-euler." prepend run "Answer: " swap dup number? [ number>string ] when append print "Source: " swap solution-path append print ] [ diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor new file mode 100755 index 0000000000..2e59b625b1 --- /dev/null +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -0,0 +1,36 @@ +USING: kernel math sequences namespaces +math.miller-rabin combinators.cleave combinators.lib +math.functions accessors random ; +IN: random.blum-blum-shub + +! TODO: take (log log M) bits instead of 1 bit +! Blum Blum Shub, M = pq +TUPLE: blum-blum-shub x n ; + +C: blum-blum-shub + +: generate-bbs-primes ( numbits -- p q ) + #! two primes congruent to 3 (mod 4) + [ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ; + +IN: crypto +: ( numbits -- blum-blum-shub ) + #! returns a Blum-Blum-Shub tuple + generate-bbs-primes * + [ find-relative-prime ] keep + blum-blum-shub construct-boa ; + +! 256 make-bbs blum-blum-shub set-global + +: next-bbs-bit ( bbs -- bit ) + #! x = x^2 mod n, return low bit of calculated x + [ [ x>> 2 ] [ n>> ] bi ^mod ] + [ [ >>x ] keep x>> 1 bitand ] bi ; + +IN: crypto +! : random ( n -- n ) + ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256 + ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ; + +M: blum-blum-shub random-32 ( bbs -- r ) + ; diff --git a/extra/random/dummy/dummy.factor b/extra/random/dummy/dummy.factor new file mode 100755 index 0000000000..12607456ec --- /dev/null +++ b/extra/random/dummy/dummy.factor @@ -0,0 +1,11 @@ +USING: kernel random math accessors ; +IN: random.dummy + +TUPLE: random-dummy i ; +C: random-dummy + +M: random-dummy seed-random ( seed obj -- ) + (>>i) ; + +M: random-dummy random-32 ( obj -- r ) + [ dup 1+ ] change-i drop ; diff --git a/extra/random/authors.txt b/extra/random/mersenne-twister/authors.txt similarity index 100% rename from extra/random/authors.txt rename to extra/random/mersenne-twister/authors.txt diff --git a/extra/random/random-docs.factor b/extra/random/mersenne-twister/mersenne-twister-docs.factor.bak similarity index 78% rename from extra/random/random-docs.factor rename to extra/random/mersenne-twister/mersenne-twister-docs.factor.bak index 1d8334ab31..981b206b29 100644 --- a/extra/random/random-docs.factor +++ b/extra/random/mersenne-twister/mersenne-twister-docs.factor.bak @@ -1,17 +1,17 @@ USING: help.markup help.syntax math ; -IN: random +IN: random.mersenne-twister ARTICLE: "random-numbers" "Generating random integers" "The " { $vocab-link "random" } " vocabulary implements the ``Mersenne Twister'' pseudo-random number generator algorithm." -{ $subsection init-random } +! { $subsection init-random } { $subsection (random) } { $subsection random } ; ABOUT: "random-numbers" -HELP: init-random -{ $values { "seed" integer } } -{ $description "Initializes the random number generator with the given seed. This word is called on startup to initialize the random number generator with the current time." } ; +! HELP: init-random +! { $values { "seed" integer } } +! { $description "Initializes the random number generator with the given seed. This word is called on startup to initialize the random number generator with the current time." } ; HELP: (random) { $values { "rand" "an integer between 0 and 2^32-1" } } diff --git a/extra/random/mersenne-twister/mersenne-twister-tests.factor b/extra/random/mersenne-twister/mersenne-twister-tests.factor new file mode 100755 index 0000000000..49bf4ad3f3 --- /dev/null +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -0,0 +1,29 @@ +USING: kernel math random namespaces random.mersenne-twister +sequences tools.test ; +IN: random.mersenne-twister.tests + +: check-random ( max -- ? ) + dup >r random 0 r> between? ; + +[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test + +: make-100-randoms + [ 100 [ 100 random , ] times ] { } make ; + +: test-rng ( seed quot -- ) + >r r> with-random ; + +[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test + +[ 1333075495 ] [ + 0 [ 1000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng +] unit-test + +[ 1575309035 ] [ + 0 [ 10000 [ drop random-generator get random-32 drop ] each random-generator get random-32 ] test-rng +] unit-test + + +[ 3 ] [ 101 [ 3 random-bytes length ] test-rng ] unit-test +[ 33 ] [ 101 [ 33 random-bytes length ] test-rng ] unit-test +[ t ] [ 101 [ 100 random-bits log2 90 > ] test-rng ] unit-test diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor new file mode 100755 index 0000000000..bf2ff78f2d --- /dev/null +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -0,0 +1,77 @@ +! Copyright (C) 2005, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +! mersenne twister based on +! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c + +USING: arrays kernel math namespaces sequences system init +accessors math.ranges combinators.cleave random ; +IN: random.mersenne-twister + += [ - ] [ drop ] if ; inline +: mt-wrap ( x -- y ) mt-n wrap ; inline + +: set-generated ( mt y from-elt to -- ) + >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi + r> bitxor bitxor r> new-set-nth drop ; inline + +: calculate-y ( mt y1 y2 -- y ) + >r over r> + [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline + +: (mt-generate) ( mt-seq n -- y to from-elt ) + [ dup 1+ mt-wrap calculate-y ] + [ mt-m + mt-wrap new-nth ] + [ nip ] 2tri ; + +: mt-generate ( mt -- ) + [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ] + [ 0 >>i drop ] bi ; + +: init-mt-first ( seed -- seq ) + >r mt-n 0 r> + HEX: ffffffff bitand 0 new-set-nth ; + +: init-mt-formula ( seq i -- f(seq[i]) ) + tuck new-nth dup -30 shift bitxor 1812433253 * + + 1+ HEX: ffffffff bitand ; + +: init-mt-rest ( seq -- ) + mt-n 1- [0,b) [ + dupd [ init-mt-formula ] keep 1+ new-set-nth drop + ] with each ; + +: init-mt-seq ( seed -- seq ) + init-mt-first dup init-mt-rest ; + +: mt-temper ( y -- yt ) + dup -11 shift bitxor + dup 7 shift HEX: 9d2c5680 bitand bitxor + dup 15 shift HEX: efc60000 bitand bitxor + dup -18 shift bitxor ; inline + +PRIVATE> + +: ( seed -- obj ) + init-mt-seq 0 mersenne-twister construct-boa + dup mt-generate ; + +M: mersenne-twister seed-random ( mt seed -- ) + init-mt-seq >>seq drop ; + +M: mersenne-twister random-32 ( mt -- r ) + dup [ seq>> ] [ i>> ] bi + dup mt-n < [ drop 0 pick mt-generate ] unless + new-nth mt-temper + swap [ 1+ ] change-i drop ; diff --git a/extra/random/summary.txt b/extra/random/mersenne-twister/summary.txt similarity index 100% rename from extra/random/summary.txt rename to extra/random/mersenne-twister/summary.txt diff --git a/extra/random/random-tests.factor b/extra/random/random-tests.factor deleted file mode 100644 index d431e57d01..0000000000 --- a/extra/random/random-tests.factor +++ /dev/null @@ -1,15 +0,0 @@ -USING: kernel math random namespaces sequences tools.test ; -IN: random.tests - -: check-random ( max -- ? ) - dup >r random 0 r> between? ; - -[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test - -: make-100-randoms - [ 100 [ 100 random , ] times ] { } make ; - -[ f ] [ make-100-randoms make-100-randoms = ] unit-test - -[ 1333075495 ] [ 0 init-random 1000 [ drop (random) drop ] each (random) ] unit-test -[ 1575309035 ] [ 0 init-random 10000 [ drop (random) drop ] each (random) ] unit-test diff --git a/extra/random/random.factor b/extra/random/random.factor index db2aacd2b0..0d8b137fc5 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -1,107 +1,39 @@ -! Copyright (C) 2005, 2007 Doug Coleman. +! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. - -! mersenne twister based on -! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c - -USING: arrays kernel math namespaces sequences -system init alien.c-types ; +USING: alien.c-types kernel math namespaces sequences +io.backend ; IN: random - mersenne-twister +: (random-bytes) ( tuple n -- byte-array ) + [ drop random-32 ] with map >c-uint-array ; -: mt-n 624 ; inline -: mt-m 397 ; inline -: mt-a HEX: 9908b0df ; inline -: mt-hi HEX: 80000000 ; inline -: mt-lo HEX: 7fffffff ; inline +SYMBOL: random-generator -SYMBOL: mt - -: mt-seq ( -- seq ) - mt get mersenne-twister-seq ; inline - -: mt-nth ( n -- nth ) - mt-seq nth ; inline - -: mt-i ( -- i ) - mt get mersenne-twister-i ; inline - -: mti-inc ( -- ) - mt get [ mersenne-twister-i 1+ ] keep set-mersenne-twister-i ; inline - -: set-mt-ith ( y i-get i-set -- ) - >r mt-nth >r - [ 2/ ] keep odd? mt-a 0 ? r> bitxor bitxor r> - mt-seq set-nth ; inline - -: mt-y ( y1 y2 -- y ) - mt-nth mt-lo bitand - >r mt-nth mt-hi bitand r> bitor ; inline - -: mod* ( x n -- y ) - #! no floating point - 2dup >= [ - ] [ drop ] if ; inline - -: (mt-generate) ( n -- y n n+(mt-m) ) - dup [ 1+ 624 mod* mt-y ] keep [ mt-m + 624 mod* ] keep ; - -: mt-generate ( -- ) - mt-n [ (mt-generate) set-mt-ith ] each - 0 mt get set-mersenne-twister-i ; - -: init-mt-first ( seed -- seq ) - >r mt-n 0 r> - HEX: ffffffff bitand 0 pick set-nth ; - -: init-mt-formula ( seq i -- f(seq[i]) ) - dup rot nth dup -30 shift bitxor - 1812433253 * + HEX: ffffffff bitand 1+ ; inline - -: init-mt-rest ( seq -- ) - mt-n 1 head* [ - [ init-mt-formula ] 2keep 1+ swap set-nth - ] with each ; - -: mt-temper ( y -- yt ) - dup -11 shift bitxor - dup 7 shift HEX: 9d2c5680 bitand bitxor - dup 15 shift HEX: efc60000 bitand bitxor - dup -18 shift bitxor ; inline - -PRIVATE> - -: init-random ( seed -- ) - global [ - dup init-mt-first - [ init-mt-rest ] keep - 0 mt set - mt-generate - ] bind ; - -: (random) ( -- rand ) - global [ - mt-i dup mt-n < [ drop mt-generate 0 ] unless - mt-nth mti-inc - mt-temper - ] bind ; - -: big-random ( n -- r ) - [ drop (random) ] map >c-uint-array byte-array>bignum ; - -: random-256 ( -- r ) 8 big-random ; inline +: random-bytes ( n -- r ) + [ + 4 /mod zero? [ 1+ ] unless + random-generator get swap (random-bytes) + ] keep head ; : random ( seq -- elt ) dup empty? [ drop f ] [ [ - length dup log2 31 + 32 /i big-random swap mod + length dup log2 7 + 8 /i + random-bytes byte-array>bignum swap mod ] keep nth ] if ; -[ millis init-random ] "random" add-init-hook +: random-bits ( n -- r ) 2^ random ; + +: with-random ( tuple quot -- ) + random-generator swap with-variable ; inline diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor new file mode 100644 index 0000000000..f41a3ae0e8 --- /dev/null +++ b/extra/random/unix/unix.factor @@ -0,0 +1,22 @@ +USING: alien.c-types io io.files io.nonblocking kernel +namespaces random io.encodings.binary singleton ; +IN: random.unix + +SINGLETON: unix-random + +: file-read-unbuffered ( n path -- bytes ) + over default-buffer-size [ + binary [ read ] with-stream + ] with-variable ; + +M: unix-random os-crypto-random-bytes ( n -- byte-array ) + "/dev/random" file-read-unbuffered ; + +M: unix-random os-random-bytes ( n -- byte-array ) + "/dev/urandom" file-read-unbuffered ; + +M: unix-random os-crypto-random-32 ( -- r ) + 4 os-crypto-random-bytes *uint ; + +M: unix-random os-random-32 ( -- r ) + 4 os-random-bytes *uint ; diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor new file mode 100644 index 0000000000..8b3c1012c8 --- /dev/null +++ b/extra/random/windows/windows.factor @@ -0,0 +1,3 @@ +IN: random.windows + +! M: windows-io diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index 8a642a8692..b57724d1db 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -292,7 +292,7 @@ TUPLE: regexp source parser ignore-case? ; : parse-regexp ( accum end -- accum ) lexer get dup skip-blank [ [ index* dup 1+ swap ] 2keep swapd subseq swap - ] change-column + ] change-lexer-column lexer get (parse-token) parse-options parsed ; : R! CHAR: ! parse-regexp ; parsing diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor old mode 100644 new mode 100755 index be0789ba5e..69c7baba9f --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors db.tuples hashtables kernel new-slots +USING: accessors db.tuples hashtables kernel semantic-db semantic-db.relations sequences sequences.deep ; IN: semantic-db.hierarchy diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor old mode 100644 new mode 100755 index e8075c016d..27e0159596 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ; +USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser sequences ; IN: semantic-db TUPLE: node id content ; diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 36d5e40b77..7bcc336962 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -11,7 +11,7 @@ io.binary strings classes words sbufs tuples arrays vectors byte-arrays bit-arrays quotations hashtables assocs help.syntax help.markup float-arrays splitting io.streams.byte-array io.encodings.string io.encodings.utf8 io.encodings.binary -combinators combinators.cleave new-slots accessors locals +combinators combinators.cleave accessors locals prettyprint compiler.units sequences.private tuples.private ; IN: serialize diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index a941b14a47..13db422621 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -4,11 +4,11 @@ USING: namespaces io io.timeouts kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings math.parser random system calendar io.encodings.ascii -calendar.format new-slots accessors ; +calendar.format accessors ; IN: smtp SYMBOL: smtp-domain -SYMBOL: smtp-server "localhost" 25 smtp-server set-global +SYMBOL: smtp-server "localhost" "smtp" smtp-server set-global SYMBOL: read-timeout 1 minutes read-timeout set-global SYMBOL: esmtp t esmtp set-global @@ -25,22 +25,24 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) : crlf "\r\n" write ; +: command ( string -- ) write crlf flush ; + : helo ( -- ) - esmtp get "EHLO " "HELO " ? write host-name write crlf ; + esmtp get "EHLO " "HELO " ? host-name append command ; : validate-address ( string -- string' ) #! Make sure we send funky stuff to the server by accident. dup "\r\n>" seq-intersect empty? - [ "Bad e-mail address: " swap append throw ] unless ; + [ "Bad e-mail address: " prepend throw ] unless ; : mail-from ( fromaddr -- ) - "MAIL FROM:<" write validate-address write ">" write crlf ; + "MAIL FROM:<" swap validate-address ">" 3append command ; : rcpt-to ( to -- ) - "RCPT TO:<" write validate-address write ">" write crlf ; + "RCPT TO:<" swap validate-address ">" 3append command ; : data ( -- ) - "DATA" write crlf ; + "DATA" command ; : validate-message ( msg -- msg' ) "." over member? [ "Message cannot contain . on a line by itself" throw ] when ; @@ -49,10 +51,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) string-lines validate-message [ write crlf ] each - "." write crlf ; + "." command ; : quit ( -- ) - "QUIT" write crlf ; + "QUIT" command ; LOG: smtp-response DEBUG @@ -85,11 +87,11 @@ LOG: smtp-response DEBUG readln dup multiline? [ 3 head process-multiline ] when ; -: get-ok ( -- ) flush receive-response check-response ; +: get-ok ( -- ) receive-response check-response ; : validate-header ( string -- string' ) dup "\r\n" seq-intersect empty? - [ "Invalid header string: " swap append throw ] unless ; + [ "Invalid header string: " prepend throw ] unless ; : write-header ( key value -- ) swap @@ -125,7 +127,7 @@ M: email clone : message-id ( -- string ) [ "<" % - 2 big-random # + 64 random-bits # "-" % millis # "@" % @@ -143,7 +145,7 @@ M: email clone dup to>> ", " join "To" set-header [ [ extract-email ] map ] change-to dup subject>> "Subject" set-header - now timestamp>rfc822-string "Date" set-header + now timestamp>rfc822 "Date" set-header message-id "Message-Id" set-header ; : ( -- email ) @@ -164,7 +166,7 @@ M: email clone ! : (cram-md5-auth) ( -- response ) ! swap challenge get ! string>md5-hmac hex-string -! " " swap append append +! " " prepend append ! >base64 ; ! ! : cram-md5-auth ( key login -- ) diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index 7f13cd58a9..c6299e6b08 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -7,7 +7,7 @@ IN: strings.lib : >Upper ( str -- str ) dup empty? [ - unclip ch>upper 1string swap append + unclip ch>upper 1string prepend ] unless ; : >Upper-dashes ( str -- str ) diff --git a/extra/sudoku/deploy.factor b/extra/sudoku/deploy.factor index 11a06f46bc..ba1ac1a32a 100755 --- a/extra/sudoku/deploy.factor +++ b/extra/sudoku/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ + { deploy-word-defs? f } + { deploy-random? f } { deploy-name "Sudoku" } { deploy-threads? f } - { deploy-c-types? f } { deploy-compiler? t } - { deploy-ui? f } { deploy-math? f } - { deploy-reflection 1 } - { deploy-word-defs? f } + { deploy-c-types? f } { deploy-io 2 } - { deploy-word-props? f } + { deploy-reflection 1 } + { deploy-ui? f } { "stop-after-last-window?" t } + { deploy-word-props? f } } diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 06e9644370..d1c4b148a5 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -89,12 +89,12 @@ TUPLE: unimplemented-typeflag header ; tar-header-typeflag 1string \ unimplemented-typeflag construct-boa ; -: tar-path+ ( path -- newpath ) - base-dir get swap path+ ; +: tar-append-path ( path -- newpath ) + base-dir get prepend-path ; ! Normal file : typeflag-0 - tar-header-name tar-path+ binary + tar-header-name tar-append-path binary [ read-data-blocks ] keep dispose ; ! Hard link @@ -115,7 +115,7 @@ TUPLE: unimplemented-typeflag header ; ! Directory : typeflag-5 ( header -- ) - tar-header-name tar-path+ make-directories ; + tar-header-name tar-append-path make-directories ; ! FIFO : typeflag-6 ( header -- ) @@ -166,7 +166,7 @@ TUPLE: unimplemented-typeflag header ; [ read-data-blocks ] keep >string [ zero? ] right-trim filename set global [ "long filename: " write filename get . flush ] bind - filename get tar-path+ make-directories ; + filename get tar-append-path make-directories ; ! Multi volume continuation entry : typeflag-M ( header -- ) @@ -226,7 +226,7 @@ TUPLE: unimplemented-typeflag header ; ! drop ! ] [ ! dup tar-header-name - ! dup parent-dir base-dir swap path+ + ! dup parent-dir base-dir prepend-path ! global [ dup [ . flush ] when* ] bind ! make-directories ! out-stream set diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 60dc11257f..172a80b612 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -40,48 +40,63 @@ IN: tools.deploy.backend "compiler" deploy-compiler? get ?, "ui" deploy-ui? get ?, "io" native-io? ?, + "random" deploy-random? get ?, ] { } make ; -: staging-image-name ( -- name ) +: staging-image-name ( profile -- name ) "staging." - bootstrap-profile strip-word-names? [ "strip" add ] when - "-" join ".image" 3append ; + swap strip-word-names? [ "strip" add ] when + "-" join ".image" 3append temp-file ; -: staging-command-line ( config -- flags ) +DEFER: ?make-staging-image + +: staging-command-line ( profile -- flags ) [ - [ + dup empty? [ "-i=" my-boot-image-name append , + ] [ + dup 1 head* ?make-staging-image - "-output-image=" staging-image-name append , + "-resource-path=" "" resource-path append , - "-include=" bootstrap-profile " " join append , + "-i=" over 1 head* staging-image-name append , - strip-word-names? [ "-no-stack-traces" , ] when + "-run=tools.deploy.restage" , + ] if - "-no-user-init" , - ] { } make - ] bind ; + "-output-image=" over staging-image-name append , + + "-include=" swap " " join append , + + strip-word-names? [ "-no-stack-traces" , ] when + + "-no-user-init" , + ] { } make ; : run-factor ( vm flags -- ) swap add* dup . run-with-output ; inline -: make-staging-image ( config -- ) +: make-staging-image ( profile -- ) vm swap staging-command-line run-factor ; -: ?make-staging-image ( config -- ) - dup [ staging-image-name ] bind exists? +: ?make-staging-image ( profile -- ) + dup staging-image-name exists? [ drop ] [ make-staging-image ] if ; : deploy-command-line ( image vocab config -- flags ) [ + bootstrap-profile ?make-staging-image + [ - "-i=" staging-image-name append , + "-i=" bootstrap-profile staging-image-name append , + + "-resource-path=" "" resource-path append , "-run=tools.deploy.shaker" , - "-deploy-vocab=" swap append , + "-deploy-vocab=" prepend , - "-output-image=" swap append , + "-output-image=" prepend , strip-word-names? [ "-no-stack-traces" , ] when ] { } make @@ -89,7 +104,6 @@ IN: tools.deploy.backend : make-deploy-image ( vm image vocab config -- ) make-boot-image - dup ?make-staging-image deploy-command-line run-factor ; SYMBOL: deploy-implementation diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor index 846bb5c274..4af1219daf 100755 --- a/extra/tools/deploy/config/config-docs.factor +++ b/extra/tools/deploy/config/config-docs.factor @@ -16,6 +16,8 @@ ARTICLE: "deploy-flags" "Deployment flags" "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:" { $subsection deploy-math? } { $subsection deploy-compiler? } +{ $subsection deploy-random? } +{ $subsection deploy-threads? } { $subsection deploy-ui? } "The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:" { $subsection deploy-io } @@ -66,16 +68,21 @@ HELP: deploy-math? $nl "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ; -HELP: deploy-threads? -{ $description "Deploy flag. If set, the deployed image will contain support for threads." -$nl -"On by default. Often the programmer will use threads without realizing it. A small amount of space can be saved by stripping this feature out, but some code may require changes to work properly." } ; - HELP: deploy-compiler? { $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible." $nl "On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ; +HELP: deploy-random? +{ $description "Deploy flag. If set, the random number generator protocol is included, together with two implementations: a native OS-specific random number generator, and the Mersenne Twister." +$nl +"On by default. If your program does not generate random numbers you can disable this to save some space." } ; + +HELP: deploy-threads? +{ $description "Deploy flag. If set, thread support will be included in the final image." +$nl +"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, alarms, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ; + HELP: deploy-ui? { $description "Deploy flag. If set, the Factor UI will be included in the deployed image." $nl diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 78f1d487de..7ebedf7ca1 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -10,6 +10,7 @@ SYMBOL: deploy-name SYMBOL: deploy-ui? SYMBOL: deploy-compiler? SYMBOL: deploy-math? +SYMBOL: deploy-random? SYMBOL: deploy-threads? SYMBOL: deploy-io @@ -57,6 +58,7 @@ SYMBOL: deploy-image { deploy-reflection 1 } { deploy-compiler? t } { deploy-threads? t } + { deploy-random? t } { deploy-math? t } { deploy-word-props? f } { deploy-word-defs? f } @@ -66,7 +68,7 @@ SYMBOL: deploy-image } union ; : deploy-config-path ( vocab -- string ) - vocab-dir "deploy.factor" path+ ; + vocab-dir "deploy.factor" append-path ; : deploy-config ( vocab -- assoc ) dup default-config swap diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 6d3385d0a4..8db34320de 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,6 +1,7 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config -tools.deploy.backend math sequences io.launcher arrays ; +tools.deploy.backend math sequences io.launcher arrays +namespaces ; : shake-and-bake ( vocab -- ) "." resource-path [ @@ -26,6 +27,11 @@ tools.deploy.backend math sequences io.launcher arrays ; [ ] [ "hello-ui" shake-and-bake ] unit-test +[ "staging.math-compiler-ui-strip.image" ] [ + "hello-ui" deploy-config + [ bootstrap-profile staging-image-name file-name ] bind +] unit-test + [ t ] [ 2000000 small-enough? ] unit-test diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 6db19cf868..9fe35647fe 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -10,15 +10,15 @@ IN: tools.deploy.macosx vm parent-directory parent-directory ; : copy-bundle-dir ( bundle-name dir -- ) - bundle-dir over path+ -rot - "Contents" swap path+ path+ copy-tree ; + bundle-dir over append-path -rot + "Contents" prepend-path append-path copy-tree ; : copy-vm ( executable bundle-name -- vm ) - "Contents/MacOS/" path+ swap path+ vm over copy-file ; + "Contents/MacOS/" append-path prepend-path vm over copy-file ; : copy-fonts ( name -- ) "fonts/" resource-path - swap "Contents/Resources/" path+ copy-tree-into ; + swap "Contents/Resources/" append-path copy-tree-into ; : app-plist ( executable bundle-name -- string ) [ @@ -30,12 +30,12 @@ IN: tools.deploy.macosx file-name "CFBundleName" set dup "CFBundleExecutable" set - "org.factor." swap append "CFBundleIdentifier" set + "org.factor." prepend "CFBundleIdentifier" set ] H{ } make-assoc plist>string ; : create-app-plist ( vocab bundle-name -- ) [ app-plist ] keep - "Contents/Info.plist" path+ + "Contents/Info.plist" append-path utf8 set-file-contents ; : create-app-dir ( vocab bundle-name -- vm ) diff --git a/extra/tools/deploy/restage/restage.factor b/extra/tools/deploy/restage/restage.factor new file mode 100644 index 0000000000..c75abf9dd3 --- /dev/null +++ b/extra/tools/deploy/restage/restage.factor @@ -0,0 +1,8 @@ +IN: tools.deploy.restage +USING: bootstrap.stage2 namespaces memory ; + +: restage ( -- ) + load-components + "output-image" get save-image-and-exit ; + +MAIN: restage diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 44fb15ac7e..76e4a212b2 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -19,7 +19,6 @@ QUALIFIED: libc.private QUALIFIED: libc.private QUALIFIED: listener QUALIFIED: prettyprint.config -QUALIFIED: random.private QUALIFIED: source-files QUALIFIED: threads QUALIFIED: vocabs @@ -108,8 +107,6 @@ IN: tools.deploy.shaker : stripped-globals ( -- seq ) [ - random.private:mt , - { bootstrap.stage2:bootstrap-time continuations:error @@ -145,12 +142,14 @@ IN: tools.deploy.shaker vocabs:dictionary lexer-factory vocabs:load-vocab-hook + root-cache layouts:num-tags layouts:num-types layouts:tag-mask layouts:tag-numbers layouts:type-numbers classes:typemap + classes:class-map vocab-roots definitions:crossref compiled-crossref diff --git a/extra/tools/deploy/shaker/strip-libc.factor b/extra/tools/deploy/shaker/strip-libc.factor old mode 100644 new mode 100755 index 898399b092..ba1436fd17 --- a/extra/tools/deploy/shaker/strip-libc.factor +++ b/extra/tools/deploy/shaker/strip-libc.factor @@ -1,10 +1,10 @@ USING: libc.private ; IN: libc -: malloc (malloc) ; +: malloc (malloc) check-ptr ; + +: realloc (realloc) check-ptr ; + +: calloc (calloc) check-ptr ; : free (free) ; - -: realloc (realloc) ; - -: calloc (calloc) ; diff --git a/extra/tools/deploy/test/1/deploy.factor b/extra/tools/deploy/test/1/deploy.factor index f06bcbc0f0..490c21a067 100755 --- a/extra/tools/deploy/test/1/deploy.factor +++ b/extra/tools/deploy/test/1/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ + { deploy-word-defs? f } + { deploy-random? f } + { deploy-name "tools.deploy.test.1" } + { deploy-threads? t } + { deploy-compiler? t } + { deploy-math? t } { deploy-c-types? f } { deploy-io 2 } { deploy-reflection 1 } - { deploy-threads? t } - { deploy-word-props? f } - { deploy-word-defs? f } - { deploy-name "tools.deploy.test.1" } - { deploy-math? t } - { deploy-compiler? t } - { "stop-after-last-window?" t } { deploy-ui? f } + { "stop-after-last-window?" t } + { deploy-word-props? f } } diff --git a/extra/tools/deploy/test/2/deploy.factor b/extra/tools/deploy/test/2/deploy.factor index bd087d65bf..b8c37af20a 100755 --- a/extra/tools/deploy/test/2/deploy.factor +++ b/extra/tools/deploy/test/2/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ + { deploy-word-defs? f } + { deploy-random? f } + { deploy-name "tools.deploy.test.2" } + { deploy-threads? t } + { deploy-compiler? t } + { deploy-math? t } { deploy-c-types? f } { deploy-io 2 } { deploy-reflection 1 } - { deploy-threads? t } - { deploy-word-props? f } - { deploy-word-defs? f } - { deploy-name "tools.deploy.test.2" } - { deploy-math? t } - { deploy-compiler? t } - { "stop-after-last-window?" t } { deploy-ui? f } + { "stop-after-last-window?" t } + { deploy-word-props? f } } diff --git a/extra/tools/deploy/test/3/deploy.factor b/extra/tools/deploy/test/3/deploy.factor index b8b8bf4aa2..dde8291658 100755 --- a/extra/tools/deploy/test/3/deploy.factor +++ b/extra/tools/deploy/test/3/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 1 } + { deploy-word-defs? f } + { deploy-random? f } { deploy-name "tools.deploy.test.3" } { deploy-threads? t } - { deploy-word-props? f } - { "stop-after-last-window?" t } - { deploy-ui? f } - { deploy-io 3 } { deploy-compiler? t } - { deploy-word-defs? f } + { deploy-math? t } { deploy-c-types? f } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { "stop-after-last-window?" t } + { deploy-word-props? f } } diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 6a2ce448af..1c9a8195c5 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -6,7 +6,7 @@ prettyprint windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-vm ( executable bundle-name -- vm ) - swap path+ ".exe" append + prepend-path ".exe" append vm over copy-file ; : copy-fonts ( bundle-name -- ) @@ -23,7 +23,7 @@ IN: tools.deploy.windows copy-vm ; : image-name ( vocab bundle-name -- str ) - swap path+ ".image" append ; + prepend-path ".image" append ; TUPLE: windows-deploy-implementation ; diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor index 2c66305d47..69ad9272a7 100755 --- a/extra/tools/vocabs/browser/browser.factor +++ b/extra/tools/vocabs/browser/browser.factor @@ -31,7 +31,7 @@ IN: tools.vocabs.browser ] with-row ; : root-heading. ( root -- ) - [ "Children from " swap append ] [ "Children" ] if* + [ "Children from " prepend ] [ "Children" ] if* $heading ; : vocabs. ( assoc -- ) @@ -127,7 +127,7 @@ C: vocab-author : $describe-vocab ( element -- ) first dup describe-children - dup vocab-root over vocab-dir? [ + dup find-vocab-root [ dup describe-summary dup describe-tags dup describe-authors @@ -195,7 +195,7 @@ M: vocab-tag summary article-title ; M: vocab-author >link ; M: vocab-author article-title - vocab-author-name "Vocabularies by " swap append ; + vocab-author-name "Vocabularies by " prepend ; M: vocab-author article-name vocab-author-name ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 82c411cbfb..b086b30a5e 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -6,29 +6,27 @@ memoize inspector sorting splitting combinators source-files io debugger continuations compiler.errors init io.crc32 ; IN: tools.vocabs -: vocab-tests-file, ( vocab -- ) - dup "-tests.factor" vocab-dir+ vocab-path+ - dup resource-exists? [ , ] [ drop ] if ; +: vocab-tests-file ( vocab -- path ) + dup "-tests.factor" vocab-dir+ vocab-append-path dup + [ dup resource-exists? [ drop f ] unless ] [ drop f ] if ; -: vocab-tests-dir, ( vocab -- ) - dup vocab-dir "tests" path+ vocab-path+ - dup resource-exists? [ - dup ?resource-path directory keys - [ ".factor" tail? ] subset - [ path+ , ] with each - ] [ drop ] if ; +: vocab-tests-dir ( vocab -- paths ) + dup vocab-dir "tests" append-path vocab-append-path dup [ + dup resource-exists? [ + dup ?resource-path directory keys + [ ".factor" tail? ] subset + [ append-path ] with map + ] [ drop f ] if + ] [ drop f ] if ; : vocab-tests ( vocab -- tests ) - dup vocab-root dup [ - [ - >vocab-link dup - vocab-tests-file, - vocab-tests-dir, - ] { } make - ] [ 2drop f ] if ; + [ + dup vocab-tests-file [ , ] when* + vocab-tests-dir [ % ] when* + ] { } make ; : vocab-files ( vocab -- seq ) - dup find-vocab-root >vocab-link [ + [ dup vocab-source-path [ , ] when* dup vocab-docs-path [ , ] when* vocab-tests % @@ -36,8 +34,13 @@ IN: tools.vocabs : source-modified? ( path -- ? ) dup source-files get at [ - dup source-file-path ?resource-path utf8 file-lines lines-crc32 - swap source-file-checksum = not + dup source-file-path ?resource-path + dup exists? [ + utf8 file-lines lines-crc32 + swap source-file-checksum = not + ] [ + 2drop f + ] if ] [ resource-exists? ] ?if ; @@ -53,12 +56,8 @@ IN: tools.vocabs : modified-docs ( vocabs -- seq ) [ vocab-docs-path ] modified ; -: update-roots ( vocabs -- ) - [ dup find-vocab-root swap vocab set-vocab-root ] each ; - : to-refresh ( prefix -- modified-sources modified-docs ) child-vocabs - dup update-roots dup modified-sources swap modified-docs ; : vocab-heading. ( vocab -- ) @@ -109,11 +108,12 @@ MEMO: (vocab-file-contents) ( path -- lines ) [ utf8 file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) - vocab-path+ dup [ (vocab-file-contents) ] when ; + vocab-append-path dup [ (vocab-file-contents) ] when ; : set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-path+ [ + dupd vocab-append-path [ ?resource-path utf8 set-file-lines + \ (vocab-file-contents) reset-memoized ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" @@ -121,7 +121,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) ] ?if ; : vocab-summary-path ( vocab -- string ) - vocab-dir "summary.txt" path+ ; + vocab-dir "summary.txt" append-path ; : vocab-summary ( vocab -- summary ) dup dup vocab-summary-path vocab-file-contents @@ -147,7 +147,7 @@ M: vocab-link summary vocab-summary ; set-vocab-file-contents ; : vocab-tags-path ( vocab -- string ) - vocab-dir "tags.txt" path+ ; + vocab-dir "tags.txt" append-path ; : vocab-tags ( vocab -- tags ) dup vocab-tags-path vocab-file-contents ; @@ -159,7 +159,7 @@ M: vocab-link summary vocab-summary ; [ vocab-tags append prune ] keep set-vocab-tags ; : vocab-authors-path ( vocab -- string ) - vocab-dir "authors.txt" path+ ; + vocab-dir "authors.txt" append-path ; : vocab-authors ( vocab -- authors ) dup vocab-authors-path vocab-file-contents ; @@ -171,7 +171,7 @@ M: vocab-link summary vocab-summary ; directory [ second ] subset keys natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) - [ vocab-dir path+ ?resource-path subdirs ] keep + [ vocab-dir append-path ?resource-path subdirs ] keep dup empty? [ drop ] [ @@ -180,7 +180,7 @@ M: vocab-link summary vocab-summary ; : vocabs-in-dir ( root name -- ) dupd (all-child-vocabs) [ - 2dup vocab-dir? [ 2dup swap >vocab-link , ] when + 2dup vocab-dir? [ dup >vocab-link , ] when vocabs-in-dir ] with each ; @@ -233,7 +233,7 @@ MEMO: all-vocabs-seq ( -- seq ) : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . add ] unless vocabs - [ vocab-root not ] subset + [ find-vocab-root not ] subset [ vocab-name swap ?head CHAR: . rot member? not and ] with subset @@ -241,10 +241,9 @@ MEMO: all-vocabs-seq ( -- seq ) : all-child-vocabs ( prefix -- assoc ) vocab-roots get [ - over dupd dupd (all-child-vocabs) - swap [ >vocab-link ] curry map + dup pick (all-child-vocabs) [ >vocab-link ] map ] { } map>assoc - f rot unrooted-child-vocabs 2array add ; + swap unrooted-child-vocabs f swap 2array add ; : all-child-vocabs-seq ( prefix -- assoc ) vocab-roots get swap [ @@ -262,6 +261,7 @@ MEMO: all-authors ( -- seq ) all-vocabs-seq [ vocab-authors ] map>set ; : reset-cache ( -- ) + root-cache get-global clear-assoc \ (vocab-file-contents) reset-memoized \ all-vocabs-seq reset-memoized \ all-authors reset-memoized diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 610d3db0a3..6ef5309214 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -30,8 +30,6 @@ DEFER: start-walker-thread 2dup start-walker-thread ] if* ; -USING: io.streams.c prettyprint ; - : show-walker ( -- thread ) get-walker-thread [ show-walker-hook get call ] keep ; @@ -40,7 +38,7 @@ USING: io.streams.c prettyprint ; { { [ dup continuation? ] [ (continue) ] } { [ dup quotation? ] [ call ] } - { [ dup not ] [ "Single stepping abandoned" throw ] } + { [ dup not ] [ "Single stepping abandoned" rethrow ] } } cond ; : break ( -- ) diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor index 7a1df7ac1d..061deec6ec 100644 --- a/extra/tuple-arrays/tuple-arrays.factor +++ b/extra/tuple-arrays/tuple-arrays.factor @@ -15,7 +15,7 @@ TUPLE: tuple-array example ; [ set-tuple-array-example ] keep ; : reconstruct ( seq example -- tuple ) - swap append >tuple ; + prepend >tuple ; M: tuple-array nth [ delegate nth ] keep diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 572e798bd0..79b7041dcb 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math arrays cocoa cocoa.application command-line kernel memory namespaces cocoa.messages cocoa.runtime @@ -8,6 +8,10 @@ ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views core-foundation threads ; IN: ui.cocoa +TUPLE: handle view window ; + +C: handle + TUPLE: cocoa-ui-backend ; SYMBOL: stop-after-last-window? @@ -47,27 +51,30 @@ M: pasteboard set-clipboard-contents dup rot world>NSRect dup install-window-delegate over -> release - 2array + ] keep set-world-handle ; M: cocoa-ui-backend set-title ( string world -- ) - world-handle second swap -> setTitle: ; + world-handle handle-window swap -> setTitle: ; : enter-fullscreen ( world -- ) - world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ; + world-handle handle-view + NSScreen -> mainScreen + f -> enterFullScreenMode:withOptions: + drop ; : exit-fullscreen ( world -- ) - world-handle first f -> exitFullScreenModeWithOptions: ; + world-handle handle-view f -> exitFullScreenModeWithOptions: ; M: cocoa-ui-backend set-fullscreen* ( ? world -- ) swap [ enter-fullscreen ] [ exit-fullscreen ] if ; M: cocoa-ui-backend fullscreen* ( world -- ? ) - world-handle first -> isInFullScreenMode zero? not ; + world-handle handle-view -> isInFullScreenMode zero? not ; : auto-position ( world -- ) dup world-loc { 0 0 } = [ - world-handle second -> center + world-handle handle-window -> center ] [ drop ] if ; @@ -75,27 +82,29 @@ M: cocoa-ui-backend fullscreen* ( world -- ? ) M: cocoa-ui-backend (open-window) ( world -- ) dup gadget-window dup auto-position - world-handle second f -> makeKeyAndOrderFront: ; + world-handle handle-window f -> makeKeyAndOrderFront: ; M: cocoa-ui-backend (close-window) ( handle -- ) - first unregister-window ; + handle-window -> release ; M: cocoa-ui-backend close-window ( gadget -- ) find-world [ - world-handle second f -> performClose: + world-handle [ + handle-window f -> performClose: + ] when* ] when* ; M: cocoa-ui-backend raise-window* ( world -- ) world-handle [ - second dup f -> orderFront: -> makeKeyWindow + handle-window dup f -> orderFront: -> makeKeyWindow NSApp 1 -> activateIgnoringOtherApps: ] when* ; M: cocoa-ui-backend select-gl-context ( handle -- ) - first -> openGLContext -> makeCurrentContext ; + handle-view -> openGLContext -> makeCurrentContext ; M: cocoa-ui-backend flush-gl-context ( handle -- ) - first -> openGLContext -> flushBuffer ; + handle-view -> openGLContext -> flushBuffer ; SYMBOL: cocoa-init-hook diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index a965e8a30c..5b975f40de 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -313,6 +313,7 @@ CLASS: { { "dealloc" "void" { "id" "SEL" } [ drop + dup unregister-window dup remove-observer SUPER-> dealloc ] @@ -349,7 +350,13 @@ CLASS: { { "windowShouldClose:" "bool" { "id" "SEL" "id" } [ - 2nip -> contentView window ungraft t + 3drop t + ] +} + +{ "windowWillClose:" "void" { "id" "SEL" "id" } + [ + 2nip -> object -> contentView window ungraft ] } ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index ed3631bca5..267f6f0f0f 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -46,7 +46,7 @@ M: array rect-dim drop { 0 0 } ; TUPLE: gadget pref-dim parent children orientation focus -visible? root? clipped? layout-state graft-state +visible? root? clipped? layout-state graft-state graft-node interior boundary model ; @@ -254,17 +254,20 @@ M: gadget layout* drop ; : graft-queue \ graft-queue get ; : unqueue-graft ( gadget -- ) - dup graft-queue dlist-delete [ "Not queued" throw ] unless + graft-queue over gadget-graft-node delete-node dup gadget-graft-state first { t t } { f f } ? swap set-gadget-graft-state ; +: (queue-graft) ( gadget flags -- ) + over set-gadget-graft-state + dup graft-queue push-front* swap set-gadget-graft-node + notify-ui-thread ; + : queue-graft ( gadget -- ) - { f t } over set-gadget-graft-state - graft-queue push-front notify-ui-thread ; + { f t } (queue-graft) ; : queue-ungraft ( gadget -- ) - { t f } over set-gadget-graft-state - graft-queue push-front notify-ui-thread ; + { t f } (queue-graft) ; : graft-later ( gadget -- ) dup gadget-graft-state { diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 5fbe9ba0eb..3bac7969c5 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -27,7 +27,7 @@ TUPLE: list index presenter color hook ; swap set-list-index ; : list-presentation-hook ( list -- quot ) - list-hook [ [ [ list? ] is? ] find-parent ] swap append ; + list-hook [ [ [ list? ] is? ] find-parent ] prepend ; : ( hook elt presenter -- gadget ) keep diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index 9aa763d7ec..eca5740bbc 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -35,6 +35,7 @@ TUPLE: deploy-gadget vocab settings ; deploy-compiler? get "Use optimizing compiler" gadget, deploy-math? get "Rational and complex number support" gadget, deploy-threads? get "Threading support" gadget, + deploy-random? get "Random number generator support" gadget, deploy-word-props? get "Retain all word properties" gadget, deploy-word-defs? get "Retain all word definitions" gadget, deploy-c-types? get "Retain all C types" gadget, ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 0c9c23cf76..f47a82275b 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -376,22 +376,6 @@ SYMBOL: trace-messages? : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ; -! ! ! ! -: set-world-dim ( dim world -- ) - swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0 - SetWindowPos drop ; -USE: random -USE: arrays - -: twiddle - 100 500 random + - 100 500 random + - 2array - "x" get-global find-world - set-world-dim - yield ; -! ! ! ! - : event-loop ( msg -- ) { { [ windows get empty? ] [ drop ] } diff --git a/extra/unix/stat/freebsd/32/32.factor b/extra/unix/stat/freebsd/32/32.factor new file mode 100644 index 0000000000..a81fc4f02e --- /dev/null +++ b/extra/unix/stat/freebsd/32/32.factor @@ -0,0 +1,30 @@ +USING: kernel alien.syntax math ; + +IN: unix.stat + +! FreeBSD 8.0-CURRENT + +C-STRUCT: stat + { "__dev_t" "st_dev" } + { "ino_t" "st_ino" } + { "mode_t" "st_mode" } + { "nlink_t" "st_nlink" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "__dev_t" "st_rdev" } + { "timespec" "st_atim" } + { "timespec" "st_mtim" } + { "timespec" "st_ctim" } + { "off_t" "st_size" } + { "blkcnt_t" "st_blocks" } + { "blksize_t" "st_blksize" } + { "fflags_t" "st_flags" } + { "__uint32_t" "st_gen" } + { "__int32_t" "st_lspare" } + { "timespec" "st_birthtimespec" } +! not sure about the padding here. + { "__uint32_t" "pad0" } + { "__uint32_t" "pad1" } ; + +FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; \ No newline at end of file diff --git a/extra/unix/stat/freebsd/64/64.factor b/extra/unix/stat/freebsd/64/64.factor new file mode 100644 index 0000000000..75d51cd6ae --- /dev/null +++ b/extra/unix/stat/freebsd/64/64.factor @@ -0,0 +1,30 @@ +USING: kernel alien.syntax math ; +IN: unix.stat + +! FreeBSD 8.0-CURRENT +! untested + +C-STRUCT: stat + { "__dev_t" "st_dev" } + { "ino_t" "st_ino" } + { "mode_t" "st_mode" } + { "nlink_t" "st_nlink" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "__dev_t" "st_rdev" } + { "timespec" "st_atim" } + { "timespec" "st_mtim" } + { "timespec" "st_ctim" } + { "off_t" "st_size" } + { "blkcnt_t" "st_blocks" } + { "blksize_t" "st_blksize" } + { "fflags_t" "st_flags" } + { "__uint32_t" "st_gen" } + { "__int32_t" "st_lspare" } + { "timespec" "st_birthtimespec" } +! not sure about the padding here. + { "__uint32_t" "pad0" } + { "__uint32_t" "pad1" } ; + +FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/freebsd/freebsd.factor b/extra/unix/stat/freebsd/freebsd.factor index a81fc4f02e..299d0ecab5 100644 --- a/extra/unix/stat/freebsd/freebsd.factor +++ b/extra/unix/stat/freebsd/freebsd.factor @@ -1,30 +1,7 @@ -USING: kernel alien.syntax math ; - +USING: layouts combinators vocabs.loader ; IN: unix.stat -! FreeBSD 8.0-CURRENT - -C-STRUCT: stat - { "__dev_t" "st_dev" } - { "ino_t" "st_ino" } - { "mode_t" "st_mode" } - { "nlink_t" "st_nlink" } - { "uid_t" "st_uid" } - { "gid_t" "st_gid" } - { "__dev_t" "st_rdev" } - { "timespec" "st_atim" } - { "timespec" "st_mtim" } - { "timespec" "st_ctim" } - { "off_t" "st_size" } - { "blkcnt_t" "st_blocks" } - { "blksize_t" "st_blksize" } - { "fflags_t" "st_flags" } - { "__uint32_t" "st_gen" } - { "__int32_t" "st_lspare" } - { "timespec" "st_birthtimespec" } -! not sure about the padding here. - { "__uint32_t" "pad0" } - { "__uint32_t" "pad1" } ; - -FUNCTION: int stat ( char* pathname, stat* buf ) ; -FUNCTION: int lstat ( char* pathname, stat* buf ) ; \ No newline at end of file +cell-bits { + { 32 [ "unix.stat.freebsd.32" require ] } + { 64 [ "unix.stat.freebsd.64" require ] } +} case diff --git a/extra/unix/stat/netbsd/netbsd.factor b/extra/unix/stat/netbsd/netbsd.factor new file mode 100644 index 0000000000..bb2df6d6d3 --- /dev/null +++ b/extra/unix/stat/netbsd/netbsd.factor @@ -0,0 +1,26 @@ +USING: kernel alien.syntax math ; +IN: unix.stat + +! NetBSD 4.0 + +C-STRUCT: stat + { "dev_t" "st_dev" } + { "mode_t" "st_mode" } + { "ino_t" "st_ino" } + { "nlink_t" "st_nlink" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "dev_t" "st_rdev" } + { "timespec" "st_atim" } + { "timespec" "st_mtim" } + { "timespec" "st_ctim" } + { "timespec" "st_birthtim" } + { "off_t" "st_size" } + { "blkcnt_t" "st_blocks" } + { "blksize_t" "st_blksize" } + { "uint32_t" "st_flags" } + { "uint32_t" "st_gen" } + { { "uint32_t" 2 } "st_qspare" } ; + +FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/openbsd/openbsd.factor b/extra/unix/stat/openbsd/openbsd.factor new file mode 100644 index 0000000000..decfb0dbb1 --- /dev/null +++ b/extra/unix/stat/openbsd/openbsd.factor @@ -0,0 +1,28 @@ +USING: kernel alien.syntax math ; +IN: unix.stat + +! OpenBSD 4.2 + +C-STRUCT: stat + { "dev_t" "st_dev" } + { "ino_t" "st_ino" } + { "mode_t" "st_mode" } + { "nlink_t" "st_nlink" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "dev_t" "st_rdev" } + { "int32_t" "st_lspare0" } + { "timespec" "st_atim" } + { "timespec" "st_mtim" } + { "timespec" "st_ctim" } + { "off_t" "st_size" } + { "int64_t" "st_blocks" } + { "u_int32_t" "st_blksize" } + { "u_int32_t" "st_flags" } + { "u_int32_t" "st_gen" } + { "int32_t" "st_lspare1" } + { "timespec" "st_birthtim" } + { { "int64_t" 2 } "st_qspare" } ; + +FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor index e0a6a9fb76..f7432332b9 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -63,7 +63,8 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; { "linux" [ "unix.stat.linux" require ] } { "macosx" [ "unix.stat.macosx" require ] } { "freebsd" [ "unix.stat.freebsd" require ] } - [ drop ] + { "netbsd" [ "unix.stat.netbsd" require ] } + { "openbsd" [ "unix.stat.openbsd" require ] } } case >> diff --git a/extra/unix/types/netbsd/netbsd.factor b/extra/unix/types/netbsd/netbsd.factor new file mode 100755 index 0000000000..77636a6d6d --- /dev/null +++ b/extra/unix/types/netbsd/netbsd.factor @@ -0,0 +1,32 @@ +USING: alien.syntax ; +IN: unix.types + +! NetBSD 4.0 + +TYPEDEF: short __int16_t +TYPEDEF: ushort __uint16_t +TYPEDEF: int __int32_t +TYPEDEF: uint __uint32_t +TYPEDEF: longlong __int64_t +TYPEDEF: longlong __uint64_t + +TYPEDEF: int int32_t +TYPEDEF: uint uint32_t +TYPEDEF: uint u_int32_t +TYPEDEF: longlong int64_t +TYPEDEF: ulonglong u_int64_t + +TYPEDEF: __uint32_t __dev_t +TYPEDEF: __uint32_t dev_t +TYPEDEF: __uint64_t ino_t +TYPEDEF: __uint32_t mode_t +TYPEDEF: __uint32_t nlink_t +TYPEDEF: __uint32_t uid_t +TYPEDEF: __uint32_t gid_t +TYPEDEF: __int64_t off_t +TYPEDEF: __int64_t blkcnt_t +TYPEDEF: __uint32_t blksize_t +TYPEDEF: __uint32_t fflags_t +TYPEDEF: int ssize_t +TYPEDEF: int pid_t +TYPEDEF: int time_t diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor new file mode 100755 index 0000000000..5bdda212d8 --- /dev/null +++ b/extra/unix/types/openbsd/openbsd.factor @@ -0,0 +1,32 @@ +USING: alien.syntax ; +IN: unix.types + +! OpenBSD 4.2 + +TYPEDEF: short __int16_t +TYPEDEF: ushort __uint16_t +TYPEDEF: int __int32_t +TYPEDEF: uint __uint32_t +TYPEDEF: longlong __int64_t +TYPEDEF: longlong __uint64_t + +TYPEDEF: int int32_t +TYPEDEF: uint u_int32_t +TYPEDEF: uint uint32_t +TYPEDEF: longlong int64_t +TYPEDEF: ulonglong u_int64_t + +TYPEDEF: __uint32_t __dev_t +TYPEDEF: __uint32_t dev_t +TYPEDEF: __uint32_t ino_t +TYPEDEF: __uint32_t mode_t +TYPEDEF: __uint32_t nlink_t +TYPEDEF: __uint32_t uid_t +TYPEDEF: __uint32_t gid_t +TYPEDEF: __int64_t off_t +TYPEDEF: __int64_t blkcnt_t +TYPEDEF: __uint32_t blksize_t +TYPEDEF: __uint32_t fflags_t +TYPEDEF: int ssize_t +TYPEDEF: int pid_t +TYPEDEF: int time_t diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor index f046197d30..983d5d677d 100644 --- a/extra/unix/types/types.factor +++ b/extra/unix/types/types.factor @@ -10,6 +10,8 @@ os { "linux" [ "unix.types.linux" require ] } { "macosx" [ "unix.types.macosx" require ] } { "freebsd" [ "unix.types.freebsd" require ] } - [ drop ] + { "openbsd" [ "unix.types.openbsd" require ] } + { "netbsd" [ "unix.types.netbsd" require ] } + { "winnt" [ ] } } -case \ No newline at end of file +case diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index e1d49b8c6c..09d77fee11 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -27,6 +27,7 @@ TYPEDEF: ulong size_t ! ! ! Unix functions LIBRARY: factor FUNCTION: int err_no ( ) ; +FUNCTION: void clear_err_no ( ) ; LIBRARY: libc diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor old mode 100644 new mode 100755 index 32e7433d88..5884c18aee --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types kernel windows.ole32 combinators.lib parser splitting sequences.lib -sequences namespaces new-slots combinators.cleave +sequences namespaces combinators.cleave assocs quotations shuffle accessors words macros alien.syntax fry ; IN: windows.com.syntax diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor old mode 100644 new mode 100755 index e910ca2888..63b12de1ff --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -8,7 +8,7 @@ IN: windows.time 32 shift bitor ; : windows-1601 ( -- timestamp ) - 1601 1 1 0 0 0 0 ; + 1601 1 1 0 0 0 instant ; : FILETIME>windows-time ( FILETIME -- n ) [ FILETIME-dwLowDateTime ] keep diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor index 41dea1bd13..a2ca25ce6e 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -29,4 +29,4 @@ SYMBOL: width broken-lines "\n" join ; : indented-break ( string width indent -- newstring ) - [ length - broken-lines ] keep [ swap append ] curry map "\n" join ; + [ length - broken-lines ] keep [ prepend ] curry map "\n" join ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 6bff786fff..c7eaafe887 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -37,13 +37,13 @@ TAGS> MEMO: (load-mode) ( name -- rule-sets ) modes at mode-file - "extra/xmode/modes/" swap append + "extra/xmode/modes/" prepend resource-path utf8 parse-mode ; SYMBOL: rule-sets : no-such-rule-set ( name -- * ) - "No such rule set: " swap append throw ; + "No such rule set: " prepend throw ; : get-rule-set ( name -- rule-sets rules ) dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if* diff --git a/misc/factor.sh b/misc/factor.sh index b96aa8d24b..9d4f26fa46 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -88,6 +88,9 @@ set_md5sum() { set_gcc() { case $OS in openbsd) ensure_program_installed egcc; CC=egcc;; + netbsd) if [[ $WORD -eq 64 ]] ; then + CC=/usr/pkg/gcc34/bin/gcc + fi ;; *) CC=gcc;; esac } @@ -306,7 +309,10 @@ update_boot_images() { get_url http://factorcode.org/images/latest/checksums.txt factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`; set_md5sum - disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`; + case $OS in + netbsd) disk_md5=`md5 $BOOT_IMAGE | cut -f4 -d' '`;; + *) disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '` ;; + esac echo "Factorcode md5: $factorcode_md5"; echo "Disk md5: $disk_md5"; if [[ "$factorcode_md5" == "$disk_md5" ]] ; then diff --git a/misc/target b/misc/target deleted file mode 100755 index 880de8f47a..0000000000 --- a/misc/target +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/sh - -if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ] -then - echo freebsd-x86-32 -elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ] -then - echo macosx-ppc -elif [ `uname -s` = Darwin ] -then - echo macosx-x86-`./misc/wordsize` -elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ] -then - echo linux-x86-32 -elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ] -then - echo linux-x86-64 -elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ] -then - echo winnt-x86-`./misc/wordsize` -else - echo help -fi diff --git a/misc/version.sh b/misc/version.sh deleted file mode 100644 index 9c5d02d463..0000000000 --- a/misc/version.sh +++ /dev/null @@ -1 +0,0 @@ -export VERSION=0.92 diff --git a/vm/Config.openbsd b/vm/Config.openbsd index 61534d4e66..240adf8087 100644 --- a/vm/Config.openbsd +++ b/vm/Config.openbsd @@ -1,4 +1,5 @@ include vm/Config.unix PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o +CC = egcc CFLAGS += -export-dynamic -LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) +LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz diff --git a/vm/io.c b/vm/io.c index faf681bbef..bc561f5e5b 100755 --- a/vm/io.c +++ b/vm/io.c @@ -194,3 +194,8 @@ int err_no(void) { return errno; } + +void clear_err_no(void) +{ + errno = 0; +} diff --git a/vm/io.h b/vm/io.h index a19da3887c..f4af9b8bec 100755 --- a/vm/io.h +++ b/vm/io.h @@ -1,6 +1,7 @@ void init_c_io(void); void io_error(void); int err_no(void); +void clear_err_no(void); DECLARE_PRIMITIVE(fopen); DECLARE_PRIMITIVE(fgetc); @@ -12,5 +13,5 @@ DECLARE_PRIMITIVE(fclose); /* Platform specific primitives */ DECLARE_PRIMITIVE(open_file); -DECLARE_PRIMITIVE(stat); +DECLARE_PRIMITIVE(existsp); DECLARE_PRIMITIVE(read_dir); diff --git a/vm/os-freebsd-x86.64.h b/vm/os-freebsd-x86.64.h new file mode 100644 index 0000000000..23e1ff5733 --- /dev/null +++ b/vm/os-freebsd-x86.64.h @@ -0,0 +1,9 @@ +#include + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.mc_rsp; +} + +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip) diff --git a/vm/os-openbsd-x86.32.h b/vm/os-openbsd-x86.32.h index 7e1e4894c2..0617e62c0d 100644 --- a/vm/os-openbsd-x86.32.h +++ b/vm/os-openbsd-x86.32.h @@ -1,7 +1,10 @@ +#include + INLINE void *openbsd_stack_pointer(void *uap) { - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->sc_esp; + struct sigcontext *sc = (struct sigcontext*) uap; + return (void *)sc->sc_esp; } #define ucontext_stack_pointer openbsd_stack_pointer +#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip) diff --git a/vm/os-openbsd-x86.64.h b/vm/os-openbsd-x86.64.h index ff225c3cd6..3386e80a4b 100644 --- a/vm/os-openbsd-x86.64.h +++ b/vm/os-openbsd-x86.64.h @@ -1,7 +1,10 @@ +#include + INLINE void *openbsd_stack_pointer(void *uap) { - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->sc_rsp; + struct sigcontext *sc = (struct sigcontext*) uap; + return (void *)sc->sc_rsp; } #define ucontext_stack_pointer openbsd_stack_pointer +#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip) diff --git a/vm/os-openbsd.h b/vm/os-openbsd.h index af47f7bcea..21e34c98f8 100644 --- a/vm/os-openbsd.h +++ b/vm/os-openbsd.h @@ -1,2 +1,6 @@ #define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) #define DIRECTORY_P(file) ((file)->d_type == DT_DIR) + +#ifndef environ + extern char **environ; +#endif diff --git a/vm/os-unix.c b/vm/os-unix.c index 37dceb0d37..74320288aa 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -41,24 +41,10 @@ void ffi_dlclose(F_DLL *dll) dll->dll = NULL; } -DEFINE_PRIMITIVE(stat) +DEFINE_PRIMITIVE(existsp) { struct stat sb; - - if(stat(unbox_char_string(),&sb) < 0) - { - dpush(F); - dpush(F); - dpush(F); - dpush(F); - } - else - { - box_boolean(S_ISDIR(sb.st_mode)); - box_signed_4(sb.st_mode & ~S_IFMT); - box_unsigned_8(sb.st_size); - box_unsigned_8(sb.st_mtime); - } + box_boolean(stat(unbox_char_string(),&sb) >= 0); } /* Allocates memory */ diff --git a/vm/os-windows.c b/vm/os-windows.c index f9b80ea32a..1be41f8b57 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -87,14 +87,6 @@ const F_CHAR *vm_executable_path(void) return safe_strdup(full_path); } -void stat_not_found(void) -{ - dpush(F); - dpush(F); - dpush(F); - dpush(F); -} - void find_file_stat(F_CHAR *path) { // FindFirstFile is the only call that can stat c:\pagefile.sys @@ -102,56 +94,45 @@ void find_file_stat(F_CHAR *path) HANDLE h; if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st))) - stat_not_found(); + dpush(F); else { - box_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); - dpush(tag_fixnum(0)); - box_unsigned_8( - (u64)st.nFileSizeLow | (u64)st.nFileSizeHigh << 32); - - u64 lo = st.ftLastWriteTime.dwLowDateTime; - u64 hi = st.ftLastWriteTime.dwHighDateTime; - u64 modTime = (hi << 32) + lo; - - box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000); FindClose(h); + dpush(T); } } -DEFINE_PRIMITIVE(stat) +DEFINE_PRIMITIVE(existsp) { - HANDLE h; BY_HANDLE_FILE_INFORMATION bhfi; F_CHAR *path = unbox_u16_string(); //wprintf(L"path = %s\n", path); - h = CreateFileW(path, - GENERIC_READ, - FILE_SHARE_READ, - NULL, - OPEN_EXISTING, - FILE_FLAG_BACKUP_SEMANTICS, - NULL); + HANDLE h = CreateFileW(path, + GENERIC_READ, + FILE_SHARE_READ, + NULL, + OPEN_EXISTING, + FILE_FLAG_BACKUP_SEMANTICS, + NULL); + if(h == INVALID_HANDLE_VALUE) { - find_file_stat(path); + // FindFirstFile is the only call that can stat c:\pagefile.sys + WIN32_FIND_DATA st; + HANDLE h; + + if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st))) + dpush(F); + else + { + FindClose(h); + dpush(T); + } return; } - if(!GetFileInformationByHandle(h, &bhfi)) - stat_not_found(); - else { - box_boolean(bhfi.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); - dpush(tag_fixnum(0)); - box_unsigned_8( - (u64)bhfi.nFileSizeLow | (u64)bhfi.nFileSizeHigh << 32); - u64 lo = bhfi.ftLastWriteTime.dwLowDateTime; - u64 hi = bhfi.ftLastWriteTime.dwHighDateTime; - u64 modTime = (hi << 32) + lo; - - box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000); - } + box_boolean(GetFileInformationByHandle(h, &bhfi)); CloseHandle(h); } diff --git a/vm/platform.h b/vm/platform.h index 66f22bbf96..cd2b6e0a0e 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -49,6 +49,8 @@ #if defined(FACTOR_X86) #include "os-freebsd-x86.32.h" + #elif defined(FACTOR_AMD64) + #include "os-freebsd-x86.64.h" #else #error "Unsupported FreeBSD flavor" #endif diff --git a/vm/primitives.c b/vm/primitives.c index d1d956dca0..ce26c20f63 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -88,7 +88,7 @@ void *primitives[] = { primitive_eq, primitive_getenv, primitive_setenv, - primitive_stat, + primitive_existsp, primitive_read_dir, primitive_data_gc, primitive_code_gc,