diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 475cf72d28..7bba9d7332 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -65,8 +65,7 @@ HELP: dlclose ( dll -- ) HELP: load-library { $values { "name" "a string" } { "dll" "a DLL handle" } } -{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } -{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ; +{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ; HELP: add-library { $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } @@ -211,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" } "." @@ -291,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-tests.factor b/core/alien/alien-tests.factor index 5f7b9fff21..28a1e98710 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,7 +1,7 @@ IN: alien.tests -USING: alien alien.accessors byte-arrays arrays kernel -kernel.private namespaces tools.test sequences libc math system -prettyprint layouts ; +USING: alien alien.accessors alien.syntax byte-arrays arrays +kernel kernel.private namespaces tools.test sequences libc math +system prettyprint layouts ; [ t ] [ -1 alien-address 0 > ] unit-test @@ -68,3 +68,7 @@ cell 8 = [ [ f ] [ 0 B{ 1 2 3 } pinned-c-ptr? ] unit-test [ "( displaced alien )" ] [ 0 B{ 1 2 3 } unparse ] unit-test + +[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test + +[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 0369d55fb3..fc89586b68 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! 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 ; +kernel.private tuples bit-arrays byte-arrays float-arrays +arrays ; IN: alien ! Some predicate classes used by the compiler for optimization @@ -57,7 +58,7 @@ TUPLE: library path abi dll ; over dup [ dlopen ] when \ library construct-boa ; : load-library ( name -- dll ) - library library-dll ; + library dup [ library-dll ] when ; : add-library ( name path abi -- ) swap libraries get set-at ; 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 c3f5c64b29..f1d8abdc1e 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -262,8 +262,8 @@ M: long-long-type box-return ( type -- ) r> add* ] when ; -: malloc-file-contents ( path -- alien ) - binary file-contents malloc-byte-array ; +: malloc-file-contents ( path -- alien len ) + binary file-contents dup malloc-byte-array swap length ; [ [ alien-cell ] 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/syntax/syntax.factor b/core/alien/syntax/syntax.factor index b81a91efcb..3bd68bfde7 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -32,7 +32,7 @@ PRIVATE> >r >r swapd roll indirect-quot r> r> -rot define-declared ; -: DLL" skip-blank parse-string dlopen parsed ; parsing +: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing : ALIEN: scan string>number parsed ; parsing diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 52067b888c..e407bfd143 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -30,6 +30,7 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set +H{ } clone root-cache set ! Trivial recompile hook. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. @@ -87,11 +88,7 @@ call "words.private" "vectors" "vectors.private" -} [ - dup find-vocab-root swap create-vocab - [ set-vocab-root ] keep - f swap set-vocab-source-loaded? -] each +} [ create-vocab drop ] each H{ } clone source-files set H{ } clone 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..53d18b53ca 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -80,7 +80,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/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index dd9a453cfc..b854b4ef0d 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -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/debugger/debugger.factor b/core/debugger/debugger.factor index 40bcbe78b1..ad2fa14954 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -214,7 +214,7 @@ M: check-closed summary drop "Attempt to perform I/O on closed stream" ; M: check-method summary - drop "Invalid parameters for define-method" ; + drop "Invalid parameters for create-method" ; M: check-tuple summary drop "Invalid class for define-constructor" ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 4e8fb255dd..ebbce4d7e2 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -1,10 +1,10 @@ IN: definitions.tests USING: tools.test generic kernel definitions sequences -compiler.units ; +compiler.units words ; TUPLE: combination-1 ; -M: combination-1 perform-combination 2drop { } [ ] each [ ] ; +M: combination-1 perform-combination 2drop [ ] ; M: combination-1 make-default-method 2drop [ "No method" throw ] ; @@ -13,7 +13,7 @@ SYMBOL: generic-1 [ generic-1 T{ combination-1 } define-generic - [ ] object \ generic-1 define-method + object \ generic-1 create-method [ ] define ] with-compilation-unit [ ] [ diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 9b799d9143..62b85dde3a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -34,7 +34,7 @@ $nl { $subsection define-generic } { $subsection define-simple-generic } "Methods can be added to existing generic words:" -{ $subsection define-method } +{ $subsection create-method } "Method definitions can be looked up:" { $subsection method } { $subsection methods } @@ -123,7 +123,7 @@ HELP: method { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } } { $description "Looks up a method definition." } ; -{ method define-method POSTPONE: M: } related-words +{ method create-method POSTPONE: M: } related-words HELP: { $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } } @@ -140,16 +140,17 @@ HELP: order HELP: check-method { $values { "class" class } { "generic" generic } } { $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." } -{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ; +{ $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 -- )" } } } { $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 ; -HELP: define-method -{ $values { "quot" quotation } { "class" class } { "generic" generic } } -{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ; +HELP: create-method +{ $values { "class" class } { "generic" generic } { "method" method-body } } +{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." } +{ $notes "To define a method, pass the output value to " { $link define } "." } ; HELP: implementors { $values { "class" class } { "seq" "a sequence of generic words" } } diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 2dc699f87b..785600cfb0 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -238,3 +238,31 @@ M: sequence generic-forget-test-2 = ; \ = usage [ word? ] subset [ word-name "generic-forget-test-2/sequence" = ] contains? ] unit-test + +GENERIC: generic-forget-test-3 + +M: f generic-forget-test-3 ; + +[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test + +[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test + +[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test + +[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test + +[ f ] [ f generic-forget-test-3 ] unit-test + +: a-word ; + +GENERIC: a-generic + +M: integer a-generic a-word ; + +[ ] [ \ integer \ a-generic method "m" set ] unit-test + +[ t ] [ "m" get \ a-word usage memq? ] unit-test + +[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test + +[ f ] [ "m" get \ a-word usage memq? ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 3c83b87d49..8fe5e4921a 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -17,10 +17,6 @@ M: object perform-combination #! the method will throw an error. We don't want that. nip [ "Invalid method combination" throw ] curry [ ] like ; -GENERIC: method-prologue ( class combination -- quot ) - -M: object method-prologue 2drop [ ] ; - GENERIC: make-default-method ( generic combination -- method ) PREDICATE: word generic "combination" word-prop >boolean ; @@ -50,55 +46,49 @@ TUPLE: check-method class generic ; : check-method ( class generic -- class generic ) over class? over generic? and [ \ check-method construct-boa throw - ] unless ; + ] unless ; inline -: with-methods ( word quot -- ) +: with-methods ( generic quot -- ) swap [ "methods" word-prop swap call ] keep make-generic ; inline : method-word-name ( class word -- string ) word-name "/" rot word-name 3append ; -: make-method-def ( quot class generic -- quot ) - "combination" word-prop method-prologue swap append ; - -PREDICATE: word method-body "method-def" word-prop >boolean ; +PREDICATE: word method-body + "method-generic" word-prop >boolean ; M: method-body stack-effect "method-generic" word-prop stack-effect ; -: method-word-props ( quot class generic -- assoc ) +: method-word-props ( class generic -- assoc ) [ "method-generic" set "method-class" set - "method-def" set ] H{ } make-assoc ; -: ( quot class generic -- method ) +: ( class generic -- method ) check-method - [ make-method-def ] 3keep [ method-word-props ] 2keep method-word-name f - tuck set-word-props - dup rot define ; + [ set-word-props ] keep ; -: redefine-method ( quot class generic -- ) - [ method swap "method-def" set-word-prop ] 3keep - [ make-method-def ] 2keep - method swap define ; +: reveal-method ( method class generic -- ) + [ set-at ] with-methods ; -: define-method ( quot class generic -- ) - >r bootstrap-word r> - 2dup method [ - redefine-method +: create-method ( class generic -- method ) + 2dup method dup [ + 2nip ] [ - [ ] 2keep - [ set-at ] with-methods + drop [ dup ] 2keep reveal-method ] if ; +: ( generic combination -- method ) + object bootstrap-word pick + [ -rot make-default-method define ] keep ; + : define-default-method ( generic combination -- ) - dupd make-default-method object bootstrap-word pick - "default-method" set-word-prop ; + dupd "default-method" set-word-prop ; ! Definition protocol M: method-spec where @@ -108,30 +98,31 @@ M: method-spec set-where first2 method set-where ; M: method-spec definer - drop \ M: \ ; ; + first2 method definer ; M: method-spec definition - first2 method dup - [ "method-def" word-prop ] when ; + first2 method definition ; : forget-method ( class generic -- ) - check-method - [ delete-at* ] with-methods - [ forget-word ] [ drop ] if ; + dup generic? [ + [ delete-at* ] with-methods + [ forget-word ] [ drop ] if + ] [ + 2drop + ] if ; M: method-spec forget* - first2 forget-method ; + first2 method forget* ; M: method-body definer drop \ M: \ ; ; -M: method-body definition - "method-def" word-prop ; - M: method-body forget* - dup "method-class" word-prop - swap "method-generic" word-prop - forget-method ; + dup "forgotten" word-prop [ drop ] [ + dup "method-class" word-prop + over "method-generic" word-prop forget-method + t "forgotten" set-word-prop + ] if ; : implementors* ( classes -- words ) all-words [ @@ -163,16 +154,12 @@ M: assoc update-methods ( assoc -- ) make-generic ] if ; -GENERIC: subwords ( word -- seq ) - -M: word subwords drop f ; - M: generic subwords dup "methods" word-prop values swap "default-method" word-prop add ; M: generic forget-word - dup subwords [ forget-word ] each (forget-word) ; + dup subwords [ forget ] each (forget-word) ; : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 27b0ddb7a2..b01fb87f72 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ; : applicable-method ( generic class -- quot ) over method - [ word-def ] + [ 1quotation ] [ default-math-method ] ?if ; : object-method ( generic -- quot ) @@ -53,7 +53,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 313f487c99..35161319ef 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,10 +8,6 @@ IN: generic.standard TUPLE: standard-combination # ; -M: standard-combination method-prologue - standard-combination-# object - swap add* [ declare ] curry ; - C: standard-combination SYMBOL: (dispatch#) @@ -165,7 +161,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 @@ -174,7 +170,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/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 17197db667..67b8616c61 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units -system layouts ; +system layouts vectors ; ! Make sure these compile even though this is invalid code [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test @@ -294,4 +294,6 @@ cell-bits 32 = [ \ >= inlined? ] unit-test - +[ t ] [ + [ { vector } declare nth-unsafe ] \ nth-unsafe inlined? +] unit-test 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..548d2cd7fc 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -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" } +HELP: decode-char ( stream encoding -- char/f ) +{ $values { "stream" "an underlying input 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." } ; +{ $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 ( char stream encoding -- ) +{ $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..03ea2262a8 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -2,62 +2,43 @@ ! 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 decoding -- newstream ) -! Decoding +: replacement-char HEX: fffd ; + +TUPLE: decoder stream code cr ; TUPLE: decode-error ; : decode-error ( -- * ) \ decode-error construct-empty throw ; -SYMBOL: begin +GENERIC: ( stream encoding -- newstream ) -: push-decoded ( buf ch -- buf ch state ) - over push 0 begin ; +TUPLE: encoder stream code ; -: push-replacement ( buf -- buf ch state ) - ! This is the replacement character - HEX: fffd push-decoded ; +TUPLE: encode-error ; -: space ( resizable -- room-left ) - dup underlying swap [ length ] 2apply - ; +: encode-error ( -- * ) \ encode-error construct-empty throw ; -: full? ( resizable -- ? ) space zero? ; +! Decoding -: end-read-loop ( buf ch state stream quot -- string/f ) - 2drop 2drop >string f like ; +string ] [ - over stream-read1 [ - -rot tuck >r >r >r dupd r> decode-step r> r> - decode-read-loop - ] [ 2drop >string f like ] if* - ] if ; +M: tuple-class construct-empty ; +M: tuple f decoder construct-boa ; -: 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 +63,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..1ee9d19e4a 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 } @@ -224,7 +224,7 @@ HELP: stat ( path -- directory? permissions length modified ) { stat exists? directory? } related-words -HELP: path+ +HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Concatenates two pathnames." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 18cdbd3791..0d00197415 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* ; @@ -86,16 +89,10 @@ SYMBOL: +unknown+ : stat ( path -- directory? permissions length modified ) normalize-pathname (stat) ; -! : file-length ( path -- n ) stat drop 2nip ; - : file-modified ( path -- n ) stat >r 3drop r> ; -! : file-permissions ( path -- perm ) stat 2drop nip ; - : exists? ( path -- ? ) file-modified >boolean ; -! : directory? ( path -- ? ) stat 3drop ; - : directory? ( path -- ? ) file-info file-info-type +directory+ = ; ! Current working directory @@ -125,7 +122,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 ; @@ -133,7 +130,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 -- ) @@ -152,7 +149,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 -- ) @@ -185,7 +182,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 @@ -200,7 +197,7 @@ DEFER: copy-tree-into ! Special paths : resource-path ( path -- newpath ) \ resource-path get [ image parent-directory ] unless* - swap path+ ; + prepend-path ; : ?resource-path ( path -- newpath ) "resource:" ?head [ resource-path ] when ; @@ -222,10 +219,7 @@ M: pathname <=> [ pathname-string ] compare ; >r r> with-stream ; inline : file-contents ( path encoding -- str ) - dupd [ file-info file-info-size read ] with-file-reader ; - -! : file-contents ( path encoding -- str ) -! dupd [ file-length read ] with-file-reader ; + contents ; : with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline @@ -245,7 +239,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.factor b/core/io/io.factor index 2d927d088a..ef9eae7902 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables generic kernel math namespaces sequences strings - continuations assocs io.styles sbufs ; +USING: hashtables generic kernel math namespaces sequences +continuations assocs io.styles ; IN: io GENERIC: stream-readln ( stream -- str ) @@ -88,4 +88,6 @@ SYMBOL: stderr [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ; : contents ( stream -- str ) - 2048 [ stream-copy ] keep >string ; + [ + [ 65536 read dup ] [ ] [ drop ] unfold concat f like + ] with-stream ; 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/c/c-docs.factor b/core/io/streams/c/c-docs.factor old mode 100644 new mode 100755 index 5d9c7b1a53..6c640bbdeb --- a/core/io/streams/c/c-docs.factor +++ b/core/io/streams/c/c-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.files threads -strings byte-arrays io.streams.lines io.streams.plain ; +strings byte-arrays io.streams.plain ; IN: io.streams.c ARTICLE: "io.streams.c" "ANSI C streams" 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/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 10a9fda3ea..560a174289 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -24,20 +24,40 @@ IN: optimizer.specializers \ dispatch , ] [ ] make ; -: specializer-methods ( quot word -- default alist ) +: specializer-cases ( quot word -- default alist ) dup [ array? ] all? [ 1array ] unless [ [ make-specializer ] keep [ declare ] curry pick append ] { } map>assoc ; +: method-declaration ( method -- quot ) + dup "method-generic" word-prop dispatch# object + swap "method-class" word-prop add* ; + +: specialize-method ( quot method -- quot' ) + method-declaration [ declare ] curry prepend ; + +: specialize-quot ( quot specializer -- quot' ) + dup { number } = [ + drop tag-specializer + ] [ + specializer-cases alist>quot + ] if ; + +: standard-method? ( method -- ? ) + dup method-body? [ + "method-generic" word-prop standard-generic? + ] [ drop f ] if ; + : specialized-def ( word -- quot ) - dup word-def swap "specializer" word-prop [ - dup { number } = [ - drop tag-specializer - ] [ - specializer-methods alist>quot - ] if - ] when* ; + dup word-def swap { + { [ dup standard-method? ] [ specialize-method ] } + { + [ dup "specializer" word-prop ] + [ "specializer" word-prop specialize-quot ] + } + { [ t ] [ drop ] } + } cond ; : specialized-length ( specializer -- n ) dup [ array? ] all? [ first ] when length ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a69e28ab97..e46f179424 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 ; +sorting tuples compiler.units debugger vocabs.loader ; IN: parser.tests [ @@ -397,35 +397,47 @@ IN: parser.tests ] unit-test [ ] [ - "IN: parser.tests TUPLE: foo ; GENERIC: foo" - "redefining-a-class-5" parse-stream drop + [ + "redefining-a-class-5" forget-source + "redefining-a-class-6" forget-source + "redefining-a-class-7" forget-source + ] with-compilation-unit ] unit-test -[ ] [ - "IN: parser.tests M: f foo ;" - "redefining-a-class-6" parse-stream drop -] unit-test +2 [ + [ ] [ + "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "redefining-a-class-5" parse-stream drop + ] unit-test -[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test + [ ] [ + "IN: parser.tests M: f foo ;" + "redefining-a-class-6" parse-stream drop + ] unit-test -[ ] [ - "IN: parser.tests TUPLE: foo ; GENERIC: foo" - "redefining-a-class-5" parse-stream drop -] unit-test + [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test -[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test + [ ] [ + "IN: parser.tests TUPLE: foo ; GENERIC: foo" + "redefining-a-class-5" parse-stream drop + ] unit-test -[ ] [ - "IN: parser.tests TUPLE: foo ; GENERIC: foo" + [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test + + [ ] [ + "IN: parser.tests TUPLE: foo ; GENERIC: foo" "redefining-a-class-7" parse-stream drop -] unit-test + ] unit-test -[ ] [ - "IN: parser.tests TUPLE: foo ;" - "redefining-a-class-7" parse-stream drop -] unit-test + [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test -[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test + [ ] [ + "IN: parser.tests TUPLE: foo ;" + "redefining-a-class-7" parse-stream drop + ] unit-test + + [ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test +] times [ "resource:core/parser/test/assert-depth.factor" run-file ] [ relative-overflow-stack { 1 2 3 } sequence= ] @@ -447,3 +459,5 @@ must-fail-with "d-f-s-test" parse-stream drop ] unit-test ] times + +[ ] [ "parser" reload ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 50f8f582d3..fd93479283 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -215,9 +215,6 @@ SYMBOL: in : set-in ( name -- ) check-vocab-string dup in set create-vocab (use+) ; -: create-in ( string -- word ) - in get create dup set-word dup save-location ; - TUPLE: unexpected want got ; : unexpected ( want got -- * ) @@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof : parse-tokens ( end -- seq ) 100 swap (parse-tokens) >array ; +: create-in ( string -- word ) + in get create dup set-word dup save-location ; + : CREATE ( -- word ) scan create-in ; +: CREATE-GENERIC ( -- word ) CREATE dup reset-word ; + +: CREATE-WORD ( -- word ) CREATE dup reset-generic ; + : create-class-in ( word -- word ) in get create dup save-class-location @@ -284,6 +288,12 @@ M: no-word summary ] ?if ] when ; +: create-method-in ( class generic -- method ) + create-method f set-word dup save-location ; + +: CREATE-METHOD ( -- method ) + scan-word bootstrap-word scan-word create-method-in ; + TUPLE: staging-violation word ; : staging-violation ( word -- * ) @@ -355,7 +365,9 @@ TUPLE: bad-number ; : parse-definition ( -- quot ) \ ; parse-until >quotation ; -: (:) CREATE dup reset-generic parse-definition ; +: (:) CREATE-WORD parse-definition ; + +: (M:) CREATE-METHOD parse-definition ; GENERIC: expected>string ( obj -- str ) @@ -466,7 +478,15 @@ SYMBOL: interactive-vocabs : smudged-usage ( -- usages referenced removed ) removed-definitions filter-moved keys [ outside-usages - [ empty? swap pathname? or not ] assoc-subset + [ + empty? [ drop f ] [ + { + { [ dup pathname? ] [ f ] } + { [ dup method-body? ] [ f ] } + { [ t ] [ t ] } + } cond nip + ] if + ] assoc-subset dup values concat prune swap keys ] keep ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 20130d7f7e..8df97effb6 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -317,3 +317,15 @@ unit-test [ ] [ 1 \ + curry unparse drop ] unit-test [ ] [ 1 \ + compose unparse drop ] unit-test + +GENERIC: generic-see-test-with-f ( obj -- obj ) + +M: f generic-see-test-with-f ; + +[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [ + [ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer +] unit-test + +[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [ + [ \ f \ generic-see-test-with-f method see ] with-string-writer +] unit-test diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 6cb03e4199..8bce81650f 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -172,13 +172,13 @@ M: hook-generic synopsis* stack-effect. ; M: method-spec synopsis* - dup definer. [ pprint-word ] each ; + first2 method synopsis* ; M: method-body synopsis* dup dup definer. - "method-class" word-prop pprint* - "method-generic" word-prop pprint* ; + "method-class" word-prop pprint-word + "method-generic" word-prop pprint-word ; M: mixin-instance synopsis* dup definer. diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9fc5264440..3c69bfa41c 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -299,6 +299,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/slots.factor b/core/slots/slots.factor index 92d22247bd..7e9046573f 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ; C: slot-spec : define-typecheck ( class generic quot -- ) - over define-simple-generic -rot define-method ; + over define-simple-generic + >r create-method r> define ; : define-slot-word ( class slot word quot -- ) rot >fixnum add* define-typecheck ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 79a5553228..8cc9211599 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -97,7 +97,7 @@ IN: bootstrap.syntax "parsing" [ word t "parsing" set-word-prop ] define-syntax "SYMBOL:" [ - CREATE dup reset-generic define-symbol + CREATE-WORD define-symbol ] define-syntax "DEFER:" [ @@ -111,31 +111,26 @@ IN: bootstrap.syntax ] define-syntax "GENERIC:" [ - CREATE dup reset-word - define-simple-generic + CREATE-GENERIC define-simple-generic ] define-syntax "GENERIC#" [ - CREATE dup reset-word + CREATE-GENERIC scan-word define-generic ] define-syntax "MATH:" [ - CREATE dup reset-word + CREATE-GENERIC T{ math-combination } define-generic ] define-syntax "HOOK:" [ - CREATE dup reset-word scan-word + CREATE-GENERIC scan-word define-generic ] define-syntax "M:" [ - f set-word - location >r - scan-word bootstrap-word scan-word - [ parse-definition -rot define-method ] 2keep - 2array r> remember-definition + (M:) define ] define-syntax "UNION:" [ @@ -163,11 +158,16 @@ IN: bootstrap.syntax ] define-syntax "C:" [ - CREATE dup reset-generic + CREATE-WORD scan-word dup check-tuple [ construct-boa ] curry define-inline ] define-syntax + "ERROR:" [ + CREATE-CLASS dup ";" parse-tokens define-tuple-class + dup [ construct-boa throw ] curry define + ] define-syntax + "FORGET:" [ scan-word dup parsing? [ V{ } clone swap execute first ] when diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index c2e627e7bf..d746404cba 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -14,3 +14,5 @@ yield [ 3 ] [ [ 3 swap resume-with ] "Test suspend" suspend ] unit-test + +[ f ] [ f get-global ] unit-test diff --git a/core/threads/threads.factor b/core/threads/threads.factor index b4fd6eee60..d7d7988893 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -32,8 +32,6 @@ mailbox variables sleep-entry ; : threads 41 getenv ; -threads global [ H{ } assoc-like ] change-at - : thread ( id -- thread ) threads at ; : thread-registered? ( thread -- ? ) diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index c03b9784ee..3af7d27d86 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -12,6 +12,22 @@ ARTICLE: "tuple-constructors" "Constructors and slots" $nl "A shortcut for defining BOA constructors:" { $subsection POSTPONE: C: } +"Examples of constructors:" +{ $code + "TUPLE: color red green blue alpha ;" + "" + "C: rgba" + ": color construct-boa ; ! identical to above" + "" + ": " + " { set-color-red set-color-green set-color-blue }" + " color construct ;" + ": f ; ! identical to above" + "" + ": 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" @@ -48,8 +64,8 @@ ARTICLE: "tuples" "Tuples" "Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:" { $subsection POSTPONE: TUPLE: } "An example:" -{ $code "TUPLE: person name address phone ;" } -"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:" +{ $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" } } 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 514e45f10f..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 @@ -78,6 +78,8 @@ IN: vocabs.loader.tests ] with-compilation-unit ] unit-test +[ f ] [ "vocabs.loader.test.b" vocab-files empty? ] unit-test + [ ] [ [ "vocabs.loader.test.b" vocab-files @@ -113,11 +115,18 @@ 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 +[ ] [ + [ + "vocabs.loader.test.c" forget-vocab + "vocabs.loader.test.d" forget-vocab + ] with-compilation-unit +] unit-test + [ t ] [ [ "vocabs.loader.test.d" require ] [ :1 ] recover "vocabs.loader.test.d" vocab-source-loaded? @@ -127,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 fa9ff5b504..103b5290a4 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 - dup vocab [ vocab-root ] [ find-vocab-root ] ?if ; +: 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? ; @@ -66,24 +66,13 @@ SYMBOL: load-help? : load-docs ( vocab -- ) load-help? get [ [ docs-weren't-loaded ] keep - [ vocab-docs-path ?run-file ] keep + [ vocab-docs-path [ ?run-file ] when* ] keep docs-were-loaded ] [ drop ] if ; -: create-vocab-with-root ( vocab-link -- vocab ) - dup vocab-name create-vocab - swap vocab-root over set-vocab-root ; - : reload ( name -- ) [ - f >vocab-link - dup vocab-root [ - dup vocab-source-path resource-exists? [ - create-vocab-with-root - dup load-source - load-docs - ] [ no-vocab ] if - ] [ no-vocab ] if + dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if ] with-compiler-errors ; : require ( vocab -- ) @@ -100,33 +89,33 @@ SYMBOL: load-help? SYMBOL: blacklist -GENERIC: (load-vocab) ( name -- vocab ) - : add-to-blacklist ( error vocab -- ) vocab-name blacklist get dup [ set-at ] [ 3drop ] if ; +GENERIC: (load-vocab) ( name -- ) + M: vocab (load-vocab) [ - dup vocab-root [ - dup vocab-source-loaded? [ dup load-source ] unless - dup vocab-docs-loaded? [ dup load-docs ] unless - ] when + 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: string (load-vocab) - [ ".private" ?tail drop reload ] keep vocab ; - M: vocab-link (load-vocab) - vocab-name (load-vocab) ; + vocab-name create-vocab (load-vocab) ; + +M: string (load-vocab) + create-vocab (load-vocab) ; [ - dup vocab-name blacklist get at* [ - rethrow - ] [ - drop - [ dup vocab swap or (load-vocab) ] with-compiler-errors - ] if - + [ + dup vocab-name blacklist get at* [ + rethrow + ] [ + drop + [ (load-vocab) ] with-compiler-errors + ] if + ] with-compiler-errors ] load-vocab-hook set-global : vocab-where ( vocab -- loc ) 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 1a3fecc3fb..807e08f73b 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -15,8 +15,8 @@ source-loaded? docs-loaded? ; M: vocab equal? 2drop f ; : ( name -- vocab ) - H{ } clone t - { set-vocab-name set-vocab-words set-vocab-source-loaded? } + H{ } clone + { set-vocab-name set-vocab-words } \ vocab construct ; GENERIC: vocab ( vocab-spec -- vocab ) @@ -60,9 +60,16 @@ M: f vocab-help ; : create-vocab ( name -- vocab ) dictionary get [ ] cache ; -SYMBOL: load-vocab-hook +TUPLE: no-vocab name ; -: load-vocab ( name -- vocab ) load-vocab-hook get call ; +: no-vocab ( name -- * ) + vocab-name \ no-vocab construct-boa throw ; + +SYMBOL: load-vocab-hook ! ( name -- ) + +: load-vocab ( name -- vocab ) + dup load-vocab-hook get call + dup vocab [ ] [ no-vocab ] ?if ; : vocabs ( -- seq ) dictionary get keys natural-sort ; @@ -85,10 +92,10 @@ SYMBOL: load-vocab-hook : 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? @@ -99,24 +106,16 @@ 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 ; M: vocab-spec forget* forget-vocab ; - -TUPLE: no-vocab name ; - -: no-vocab ( name -- * ) - vocab-name \ no-vocab construct-boa throw ; diff --git a/core/words/words.factor b/core/words/words.factor index ce69c1ff2e..a36cca00ac 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,7 +68,7 @@ SYMBOL: bootstrapping? : crossref? ( word -- ? ) { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method-def" word-prop ] [ t ] } + { [ dup "method-generic" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; @@ -169,7 +169,12 @@ SYMBOL: changed-words "declared-effect" "constructor-quot" "delimiter" } reset-props ; +GENERIC: subwords ( word -- seq ) + +M: word subwords drop f ; + : reset-generic ( word -- ) + dup subwords [ forget ] each dup reset-word { "methods" "combination" "default-method" } reset-props ; 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/help/help.factor b/extra/bootstrap/help/help.factor index 1680278fad..4326fcf61b 100755 --- a/extra/bootstrap/help/help.factor +++ b/extra/bootstrap/help/help.factor @@ -9,11 +9,10 @@ IN: bootstrap.help t load-help? set-global - [ vocab ] load-vocab-hook [ + [ drop ] load-vocab-hook [ vocabs - [ vocab-root ] subset - [ vocab-source-loaded? ] subset - [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each + [ vocab-docs-loaded? not ] subset + [ load-docs ] each ] with-variable ; load-help 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 100644 index 0000000000..7132860e1c --- /dev/null +++ b/extra/bootstrap/random/random.factor @@ -0,0 +1,8 @@ +USING: vocabs.loader sequences system ; + +"random.mersenne-twister" require + +{ + { [ windows? ] [ "random.windows" require ] } + { [ unix? ] [ "random.unix" require ] } +} cond diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index 0bf7a032ee..670bca4903 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -13,5 +13,6 @@ USING: vocabs.loader sequences ; "tools.threads" "tools.vocabs" "tools.vocabs.browser" + "tools.vocabs.monitor" "editors" } [ require ] each 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/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor index 444e5b6ea7..2f38462976 100644 --- a/extra/builder/benchmark/benchmark.factor +++ b/extra/builder/benchmark/benchmark.factor @@ -4,10 +4,12 @@ USING: kernel continuations arrays assocs sequences sorting math IN: builder.benchmark -: passing-benchmarks ( table -- table ) - [ second first2 number? swap number? and ] subset ; +! : passing-benchmarks ( table -- table ) +! [ second first2 number? swap number? and ] subset ; -: simplify-table ( table -- table ) [ first2 second 2array ] map ; +: passing-benchmarks ( table -- table ) [ second number? ] subset ; + +! : simplify-table ( table -- table ) [ first2 second 2array ] map ; : benchmark-difference ( old-table benchmark-result -- result-diff ) first2 >r @@ -17,7 +19,7 @@ IN: builder.benchmark 2array ; : compare-tables ( old new -- table ) - [ passing-benchmarks simplify-table ] 2apply + [ passing-benchmarks ] 2apply [ benchmark-difference ] with map ; : benchmark-deltas ( -- table ) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 7d95ce2409..ea404d6efa 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 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/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 012aa1fd78..6295e3b9de 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,5 +1,5 @@ USING: arrays bunny.model bunny.cel-shaded -combinators.lib continuations kernel math multiline +combinators.cleave continuations kernel math multiline opengl opengl.shaders opengl.framebuffers opengl.gl opengl.capabilities sequences ui.gadgets combinators.cleave ; IN: bunny.outlined diff --git a/extra/cairo-demo/cairo-demo.factor b/extra/cairo-demo/cairo-demo.factor index ab8858efb3..29fb99a301 100644 --- a/extra/cairo-demo/cairo-demo.factor +++ b/extra/cairo-demo/cairo-demo.factor @@ -22,11 +22,11 @@ IN: cairo-demo TUPLE: cairo-gadget image-array cairo-t ; -! M: cairo-gadget draw-gadget* ( gadget -- ) -! 0 0 glRasterPos2i -! 1.0 -1.0 glPixelZoom -! >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r> -! cairo-gadget-image-array glDrawPixels ; +M: cairo-gadget draw-gadget* ( gadget -- ) + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r> + cairo-gadget-image-array glDrawPixels ; : create-surface ( gadget -- cairo_surface_t ) make-image-array @@ -60,8 +60,8 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ; M: cairo-gadget graft* ( gadget -- ) dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ; -! M: cairo-gadget ungraft* ( gadget -- ) -! cairo-gadget-cairo-t cairo_destroy ; +M: cairo-gadget ungraft* ( gadget -- ) + cairo-gadget-cairo-t cairo_destroy ; : ( -- gadget ) cairo-gadget construct-gadget ; 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..457b0bea11 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 ; +new-slots 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" @@ -226,16 +229,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 +250,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 +266,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..acbae2fcd3 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -8,8 +8,14 @@ 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 ] } + { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ] + [ TIME_ZONE_INFORMATION-Bias 60 / neg ] } + { [ dup TIME_ZONE_ID_DAYLIGHT = ] [ + [ TIME_ZONE_INFORMATION-Bias 60 / neg ] + [ TIME_ZONE_INFORMATION-DaylightBias ] bi + ] } + } cond ; 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/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 7c93f805cd..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,11 +130,14 @@ 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 -- ) - [ (make-call-with2) ] keep length [ narray ] curry append ; + [ + [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat + [ 2drop ] append + ] keep length [ narray ] curry append ; MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ; @@ -163,5 +159,19 @@ MACRO: construct-slots ( assoc tuple-class -- tuple ) : and? ( obj quot1 quot2 -- ? ) >r keep r> rot [ call ] [ 2drop f ] if ; inline +MACRO: multikeep ( word out-indexes -- ... ) + [ + dup >r [ \ npick \ >r 3array % ] each + % + r> [ drop \ r> , ] each + ] [ ] make ; + : 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/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index cfa2aea30d..e566a83fdf 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -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/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 41d2844811..55f2462061 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -150,7 +150,8 @@ SYMBOL: event-stream-callbacks : event-stream-counter \ event-stream-counter counter ; [ - H{ } clone event-stream-callbacks set-global + event-stream-callbacks global + [ [ drop expired? not ] assoc-subset ] change-at 1 \ event-stream-counter set-global ] "core-foundation" add-init-hook 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 309847209f..ac46be4422 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -33,6 +33,19 @@ HOOK: db-close db ( handle -- ) TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; +TUPLE: nonthrowable-statement ; +: make-nonthrowable ( obj -- obj' ) + dup sequence? [ + [ make-nonthrowable ] map + ] [ + nonthrowable-statement construct-delegate + ] if ; + +MIXIN: throwable-statement +INSTANCE: statement throwable-statement +INSTANCE: simple-statement throwable-statement +INSTANCE: prepared-statement throwable-statement + TUPLE: result-set sql in-params out-params handle n max ; : ( sql in out -- statement ) { (>>sql) (>>in-params) (>>out-params) } statement construct ; @@ -50,13 +63,22 @@ GENERIC# row-column-typed 1 ( result-set column -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) -: execute-statement ( statement -- ) +GENERIC: execute-statement ( statement -- ) + +M: throwable-statement execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each ] [ query-results dispose ] if ; +M: nonthrowable-statement execute-statement ( statement -- ) + dup sequence? [ + [ execute-statement ] each + ] [ + [ query-results dispose ] [ 2drop ] recover + ] if ; + : bind-statement ( obj statement -- ) swap >>bind-params [ bind-statement* ] keep diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index b48c87f0ca..928b51dc59 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -73,7 +73,7 @@ IN: db.postgresql.lib sql-spec-type { { FACTOR-BLOB [ dup [ - binary [ serialize ] with-byte-writer + object>bytes malloc-byte-array/length ] [ 0 ] if ] } { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] } @@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) { BLOB [ pq-get-blob ] } { FACTOR-BLOB [ pq-get-blob - dup [ binary [ deserialize ] with-byte-reader ] when ] } + dup [ bytes>object ] when ] } [ no-sql-type ] } case ; ! PQgetlength PQgetisnull diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index b2042c98bd..8a6f8632ec 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -10,6 +10,7 @@ IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; TUPLE: postgresql-statement ; +INSTANCE: postgresql-statement throwable-statement TUPLE: postgresql-result-set ; : ( statement in out -- postgresql-statement ) @@ -194,7 +195,7 @@ M: postgresql-db ( class -- statement ) ");" 0% ] postgresql-make ; -M: postgresql-db ( class -- statement ) +M: postgresql-db ( class -- statement ) [ "insert into " 0% 0% "(" 0% diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index d630522eb8..f81d7de4b8 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -94,7 +94,7 @@ IN: db.sqlite.lib { TIMESTAMP [ sqlite-bind-text-by-name ] } { BLOB [ sqlite-bind-blob-by-name ] } { FACTOR-BLOB [ - binary [ serialize ] with-byte-writer + object>bytes sqlite-bind-blob-by-name ] } { +native-id+ [ sqlite-bind-int-by-name ] } @@ -106,6 +106,8 @@ IN: db.sqlite.lib : sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; : sqlite-#columns ( query -- int ) sqlite3_column_count ; : sqlite-column ( handle index -- string ) sqlite3_column_text ; +: sqlite-column-name ( handle index -- string ) sqlite3_column_name ; +: sqlite-column-type ( handle index -- string ) sqlite3_column_type ; : sqlite-column-blob ( handle index -- byte-array/f ) [ sqlite3_column_bytes ] 2keep @@ -119,6 +121,7 @@ IN: db.sqlite.lib dup array? [ first ] when { { +native-id+ [ sqlite3_column_int64 ] } + { +random-id+ [ sqlite3_column_int64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } { DOUBLE [ sqlite3_column_double ] } @@ -131,7 +134,7 @@ IN: db.sqlite.lib { BLOB [ sqlite-column-blob ] } { FACTOR-BLOB [ sqlite-column-blob - dup [ binary [ deserialize ] with-byte-reader ] when + dup [ bytes>object ] when ] } ! { NULL [ 2drop f ] } [ no-sql-type ] @@ -140,7 +143,7 @@ IN: db.sqlite.lib : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; -: sqlite-step-has-more-rows? ( step-result -- bool ) +: sqlite-step-has-more-rows? ( prepared -- bool ) dup SQLITE_ROW = [ drop t ] [ diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 3466301390..d7d954c0dc 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -6,6 +6,7 @@ prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators combinators.cleave io namespaces.lib ; +USE: tools.walker IN: db.sqlite TUPLE: sqlite-db path ; @@ -22,6 +23,8 @@ M: sqlite-db dispose ( db -- ) dispose-db ; : with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline TUPLE: sqlite-statement ; +INSTANCE: sqlite-statement throwable-statement + TUPLE: sqlite-result-set has-more? ; M: sqlite-db ( str in out -- obj ) @@ -33,12 +36,20 @@ M: sqlite-db ( str in out -- obj ) set-statement-in-params set-statement-out-params } statement construct - db get db-handle over statement-sql sqlite-prepare - over set-statement-handle sqlite-statement construct-delegate ; +: sqlite-maybe-prepare ( statement -- statement ) + dup statement-handle [ + [ + delegate + db get db-handle over statement-sql sqlite-prepare + swap set-statement-handle + ] keep + ] unless ; + M: sqlite-statement dispose ( statement -- ) - statement-handle sqlite-finalize ; + statement-handle + [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ; M: sqlite-result-set dispose ( result-set -- ) f swap set-result-set-handle ; @@ -46,9 +57,12 @@ M: sqlite-result-set dispose ( result-set -- ) : sqlite-bind ( triples handle -- ) swap [ first3 sqlite-bind-type ] with each ; -: reset-statement ( statement -- ) statement-handle sqlite-reset ; +: reset-statement ( statement -- ) + sqlite-maybe-prepare + statement-handle sqlite-reset ; M: sqlite-statement bind-statement* ( statement -- ) + sqlite-maybe-prepare dup statement-bound? [ dup reset-statement ] when [ statement-bind-params ] [ statement-handle ] bi sqlite-bind ; @@ -57,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 @@ -89,6 +103,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? ) sqlite-result-set-has-more? ; M: sqlite-statement query-results ( query -- result-set ) + sqlite-maybe-prepare dup statement-handle sqlite-result-set dup advance-row ; @@ -125,7 +140,7 @@ M: sqlite-db ( tuple -- statement ) ");" 0% ] sqlite-make ; -M: sqlite-db ( tuple -- statement ) +M: sqlite-db ( tuple -- statement ) ; : where-primary-key% ( specs -- ) @@ -158,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 ) [ @@ -175,6 +190,8 @@ M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } + { +random-id+ "primary key" } + ! { +nonnative-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } @@ -193,6 +210,7 @@ M: sqlite-db compound-type ( str seq -- str' ) M: sqlite-db type-table ( -- assoc ) H{ { +native-id+ "integer primary key" } + { +random-id+ "integer primary key" } { INTEGER "integer" } { TEXT "text" } { VARCHAR "text" } diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index ba6441bc53..6b61981119 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -9,7 +9,7 @@ IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real ts date time blob factor-blob ; -: ( name age real ts date time blob -- person ) +: ( name age real ts date time blob factor-blob -- person ) { set-person-the-name set-person-the-number @@ -190,11 +190,11 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-postgresql ( -- ) >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; -[ native-person-schema test-tuples ] test-sqlite -[ assigned-person-schema test-tuples ] test-sqlite - -! [ native-person-schema test-tuples ] test-postgresql -! [ assigned-person-schema test-tuples ] test-postgresql +: test-repeated-insert + [ ] [ person ensure-table ] unit-test + + [ ] [ person1 get insert-tuple ] unit-test + [ person1 get insert-tuple ] must-fail ; TUPLE: serialize-me id data ; @@ -240,8 +240,33 @@ TUPLE: exam id name score ; ! [ test-ranges ] test-sqlite -\ insert-tuple must-infer -\ update-tuple must-infer -\ delete-tuple must-infer -\ select-tuple must-infer -\ define-persistent must-infer +TUPLE: secret n message ; +C: secret + +: test-random-id + secret "SECRET" + { + { "n" "ID" +random-id+ } + { "message" "MESSAGE" TEXT } + } define-persistent + + [ ] [ secret ensure-table ] unit-test + [ ] [ f "kilroy was here" insert-tuple ] unit-test + [ ] [ T{ secret } select-tuples ] unit-test + ; + + + +! [ test-random-id ] test-sqlite + [ native-person-schema test-tuples ] test-sqlite + [ assigned-person-schema test-tuples ] test-sqlite +! [ assigned-person-schema test-repeated-insert ] test-sqlite +! [ native-person-schema test-tuples ] test-postgresql +! [ assigned-person-schema test-tuples ] test-postgresql +! [ assigned-person-schema test-repeated-insert ] test-postgresql + +! \ insert-tuple must-infer +! \ update-tuple must-infer +! \ delete-tuple must-infer +! \ select-tuple must-infer +! \ define-persistent must-infer diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index d50e42c0fb..0f69b0fafb 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -28,7 +28,7 @@ HOOK: create-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj ) HOOK: db ( class -- obj ) -HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) @@ -75,21 +75,25 @@ HOOK: insert-tuple* db ( tuple statement -- ) drop-sql-statement [ execute-statement ] with-disposals ; : ensure-table ( class -- ) - [ dup drop-table ] ignore-errors create-table ; + [ + drop-sql-statement make-nonthrowable + [ execute-statement ] with-disposals + ] [ create-table ] bi ; : insert-native ( tuple -- ) dup class db get db-insert-statements [ ] cache [ bind-tuple ] 2keep insert-tuple* ; -: insert-assigned ( tuple -- ) +: insert-nonnative ( tuple -- ) +! TODO logic here for unique ids dup class - db get db-insert-statements [ ] cache + db get db-insert-statements [ ] cache [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - dup class db-columns find-primary-key assigned-id? [ - insert-assigned + dup class db-columns find-primary-key nonnative-id? [ + insert-nonnative ] [ insert-native ] if ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 7014aaa943..94a8d6f392 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -3,7 +3,8 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes -mirrors tuples combinators calendar.format symbols ; +mirrors tuples combinators calendar.format symbols +singleton ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -14,22 +15,30 @@ HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; -SYMBOLS: +native-id+ +assigned-id+ +autoincrement+ -+serial+ +unique+ +default+ +null+ +not-null+ +SINGLETON: +native-id+ +SINGLETON: +assigned-id+ +SINGLETON: +random-id+ +UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ; +UNION: +nonnative-id+ +random-id+ +assigned-id+ ; + +SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ +foreign-id+ +has-many+ ; -: (primary-key?) ( obj -- ? ) - { +native-id+ +assigned-id+ } member? ; - : primary-key? ( spec -- ? ) - sql-spec-primary-key (primary-key?) ; + sql-spec-primary-key +primary-key+? ; + +: native-id? ( spec -- ? ) + sql-spec-primary-key +native-id+? ; + +: nonnative-id? ( spec -- ? ) + sql-spec-primary-key +nonnative-id+? ; : normalize-spec ( spec -- ) - dup sql-spec-type dup (primary-key?) [ + dup sql-spec-type dup +primary-key+? [ swap set-sql-spec-primary-key ] [ drop dup sql-spec-modifiers [ - (primary-key?) + +primary-key+? ] deep-find [ swap set-sql-spec-primary-key ] [ drop ] if* ] if ; @@ -37,12 +46,6 @@ SYMBOLS: +native-id+ +assigned-id+ +autoincrement+ : find-primary-key ( specs -- obj ) [ sql-spec-primary-key ] find nip ; -: native-id? ( spec -- ? ) - sql-spec-primary-key +native-id+ = ; - -: assigned-id? ( spec -- ? ) - sql-spec-primary-key +assigned-id+ = ; - : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR @@ -69,7 +72,7 @@ TUPLE: no-sql-modifier ; dup number? [ number>string ] when ; : maybe-remove-id ( specs -- obj ) - [ native-id? not ] subset ; + [ +native-id+? not ] subset ; : remove-relations ( specs -- newcolumns ) [ relation? not ] subset ; @@ -124,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/delegate/delegate.factor b/extra/delegate/delegate.factor index 654d096b26..67b8a39320 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -7,7 +7,7 @@ IN: delegate swap { } like "protocol-words" set-word-prop ; : PROTOCOL: - CREATE dup reset-generic dup define-symbol + CREATE-WORD dup define-symbol parse-definition swap define-protocol ; parsing PREDICATE: word protocol "protocol-words" word-prop ; @@ -27,11 +27,11 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add spin define-method ; + pick add >r swap create-method r> define ; : define-consult ( class group quot -- ) - >r group-words r> - swapd [ define-consult-method ] 2curry each ; + >r group-words swap r> + [ define-consult-method ] 2curry each ; : CONSULT: scan-word scan-word parse-definition swapd define-consult ; parsing @@ -39,7 +39,7 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ "method-def" word-prop spin define-method ] + [ >r swap create-method r> word-def define ] [ 3drop ] if ] 2curry each ; 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/fry/fry-docs.factor b/extra/fry/fry-docs.factor index 31b544d488..739e7d012c 100755 --- a/extra/fry/fry-docs.factor +++ b/extra/fry/fry-docs.factor @@ -46,7 +46,7 @@ $nl } "The " { $link , } " and " { $link @ } " specifiers may be freely mixed:" { $code - "{ 8 13 14 27 } [ even? ] 5 [ @ dup , ? ] map" + "{ 8 13 14 27 } [ even? ] 5 '[ @ dup , ? ] map" "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map" "{ 8 13 14 27 } [ even? dup 5 ? ] map" } diff --git a/extra/help/help-tests.factor b/extra/help/help-tests.factor new file mode 100644 index 0000000000..e38f2fc15d --- /dev/null +++ b/extra/help/help-tests.factor @@ -0,0 +1,5 @@ +IN: help.tests +USING: tools.test help kernel ; + +[ 3 throw ] must-fail +[ ] [ :help ] unit-test diff --git a/extra/help/help.factor b/extra/help/help.factor index 85f5a35a5c..4cb8cfe854 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -98,7 +98,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 @@ -136,7 +136,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ":edit - jump to source location (parse errors only)" print ":get ( var -- value ) accesses variables at time of the error" print - ":vars - list all variables at error time"; + ":vars - list all variables at error time" print ; : :help ( -- ) error get delegates [ error-help ] map [ ] subset diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 710671857e..47a40d6948 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -158,7 +158,8 @@ M: f print-element drop ; : $subsection ( element -- ) [ first ($long-link) ] ($subsection) ; -: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ; +: ($vocab-link) ( text vocab -- ) + >vocab-link write-link ; : $vocab-subsection ( element -- ) [ diff --git a/extra/help/stylesheet/stylesheet.factor b/extra/help/stylesheet/stylesheet.factor index 945d9a4ce1..68810e2369 100755 --- a/extra/help/stylesheet/stylesheet.factor +++ b/extra/help/stylesheet/stylesheet.factor @@ -82,6 +82,7 @@ H{ { page-color { 0.95 0.95 0.95 1 } } { border-color { 1 0 0 1 } } { border-width 5 } + { wrap-margin 500 } } warning-style set-global SYMBOL: table-content-style 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 91671392c7..287f6dd907 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces combinators.cleave fry continuations locals ; IN: http.server.actions -SYMBOL: +path+ +SYMBOL: +append-path SYMBOL: params @@ -38,10 +38,13 @@ TUPLE: action init display submit get-params post-params ; action get display>> call exit-with ; M: action call-responder ( path action -- response ) - [ +path+ associate request-params union params set ] - [ action set ] bi* - request get method>> { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case ; + '[ + , , + [ +append-path associate request-params union params set ] + [ action set ] bi* + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] with-exit-continuation ; diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor index 1b1534b85e..69a3c76c2b 100755 --- a/extra/http/server/auth/auth.factor +++ b/extra/http/server/auth/auth.factor @@ -1,9 +1,26 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: http.server.sessions accessors -http.server.auth.providers ; +http.server.auth.providers assocs namespaces kernel ; IN: http.server.auth SYMBOL: logged-in-user +SYMBOL: user-profile-changed? + +GENERIC: init-user-profile ( responder -- ) + +M: object init-user-profile drop ; : uid ( -- string ) logged-in-user sget username>> ; + +: profile ( -- assoc ) logged-in-user sget profile>> ; + +: uget ( key -- value ) + profile at ; + +: uset ( value key -- ) + profile set-at user-profile-changed? on ; + +: uchange ( quot key -- ) + profile swap change-at + user-profile-changed? on ; inline diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index a1c99f749c..275fb0ff63 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -7,16 +7,29 @@ http.server.actions http.server.components http.server.sessions http.server.templating.fhtml http.server.validators http.server.auth http sequences io.files namespaces hashtables fry io.sockets combinators.cleave arrays threads locals -qualified ; +qualified continuations destructors ; IN: http.server.auth.login QUALIFIED: smtp +SYMBOL: post-login-url +SYMBOL: login-failed? + TUPLE: login users ; : users login get users>> ; -SYMBOL: post-login-url -SYMBOL: login-failed? +! Destructor +TUPLE: user-saver user ; + +C: user-saver + +M: user-saver dispose + user-profile-changed? get [ + user>> users update-user + ] [ drop ] if ; + +: save-user-after ( user -- ) + add-always-destructor ; ! ! ! Login @@ -116,6 +129,8 @@ SYMBOL: user-exists? ] unless* successful-login + + login get responder>> init-user-profile ] >>submit ] ; @@ -155,23 +170,21 @@ SYMBOL: previous-page form validate-form + logged-in-user sget + "password" value empty? [ - logged-in-user sget - ] [ same-password-twice "password" value uid users check-login [ login-failed? on validation-failed ] unless - "new-password" value uid users set-password - [ "User deleted" throw ] unless* - ] if + "new-password" value set-password + ] unless "realname" value >>realname "email" value >>email - dup users update-user - logged-in-user sset + user-profile-changed? on previous-page sget f ] >>submit @@ -330,6 +343,7 @@ C: protected M: protected call-responder ( path responder -- response ) logged-in-user sget [ + dup save-user-after request get request-url previous-page sset responder>> call-responder ] [ diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index ae4c5d051f..f99e4d3d2e 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -22,11 +22,11 @@ namespaces accessors kernel ; [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test -[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test +[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test -[ f ] [ "xx" "blah" "provider" get set-password ] unit-test +[ t ] [ "user" get >boolean ] unit-test -[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test +[ ] [ "user" get "fdasf" set-password drop ] unit-test [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 1ee7278163..340e1bb35d 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -12,26 +12,28 @@ users-in-db "provider" set [ t ] [ - "slava" >>username - "foobar" >>password - "slava@factorcode.org" >>email - "provider" get new-user - username>> "slava" = + "slava" >>username + "foobar" >>password + "slava@factorcode.org" >>email + "provider" get new-user + username>> "slava" = ] unit-test [ f ] [ - "slava" >>username + "slava" >>username "provider" get new-user ] unit-test [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test - [ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test + [ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test - [ f ] [ "xx" "blah" "provider" get set-password ] unit-test + [ t ] [ "user" get >boolean ] unit-test - [ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test + [ ] [ "user" get "fdasf" set-password drop ] unit-test + + [ ] [ "user" get "provider" get update-user ] unit-test [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index cd9cc995c7..cdad4815a6 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel new-slots accessors random math.parser locals -sequences math ; +sequences math crypto.sha2 ; IN: http.server.auth.providers TUPLE: user username realname password email ticket profile ; @@ -17,14 +17,7 @@ GENERIC: new-user ( user provider -- user/f ) : check-login ( password username provider -- user/f ) get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; -:: set-password ( password username provider -- user/f ) - [let | user [ username provider get-user ] | - user [ - user - password >>password - dup provider update-user - ] [ f ] if - ] ; +: set-password ( user password -- user ) >>password ; ! Password recovery support @@ -34,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 45a6ff85f8..eb264279cb 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -98,11 +98,18 @@ SYMBOL: current-show cont-id query-param swap callbacks>> at ; M: callback-responder call-responder ( path responder -- response ) - [ callback-responder set ] - [ request get resuming-callback ] bi + '[ + , , - [ invoke-callback ] - [ callback-responder get responder>> call-responder ] ?if ; + [ callback-responder set ] + [ request get resuming-callback ] bi + + [ + invoke-callback + ] [ + callback-responder get responder>> call-responder + ] ?if + ] with-exit-continuation ; : show-page ( quot -- ) >r redirect-to-here store-current-show r> diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 02c992651a..8581335f3d 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -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/server.factor b/extra/http/server/server.factor index ce6a1244cb..7448752c60 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -185,21 +185,20 @@ SYMBOL: exit-continuation : exit-with exit-continuation get continue-with ; +: with-exit-continuation ( quot -- ) + '[ exit-continuation set @ ] callcc1 exit-continuation off ; + : do-request ( request -- response ) - '[ - exit-continuation set , - [ - [ log-request ] - [ request set ] - [ path>> main-responder get call-responder ] tri - [ <404> ] unless* - ] [ - [ \ do-request log-error ] - [ <500> ] - bi - ] recover - ] callcc1 - exit-continuation off ; + [ + [ log-request ] + [ request set ] + [ path>> main-responder get call-responder ] tri + [ <404> ] unless* + ] [ + [ \ do-request log-error ] + [ <500> ] + bi + ] recover ; : default-timeout 1 minutes stdio get set-timeout ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index a6a42f9129..26e6927d7c 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -1,8 +1,8 @@ IN: http.server.sessions.tests USING: tools.test http http.server.sessions http.server.sessions.storage http.server.sessions.storage.assoc -http.server math namespaces kernel accessors prettyprint -io.streams.string splitting destructors ; +http.server.actions http.server math namespaces kernel accessors +prettyprint io.streams.string splitting destructors sequences ; [ H{ } ] [ H{ } add-session-id ] unit-test @@ -72,9 +72,9 @@ M: foo call-responder : url-responder-mock-test [ - "GET" >>method - "id" get session-id-key set-query-param - "/" >>path + "GET" >>method + "id" get session-id-key set-query-param + "/" >>path request set "/" "manager" get call-responder [ write-response-body drop ] with-string-writer @@ -107,9 +107,9 @@ response set : cookie-responder-mock-test [ - "GET" >>method - "cookies" get >>cookies - "/" >>path + "GET" >>method + "cookies" get >>cookies + "/" >>path request set "/" "manager" get call-responder [ write-response-body drop ] with-string-writer @@ -118,3 +118,28 @@ response set [ "2" ] [ cookie-responder-mock-test ] unit-test [ "3" ] [ cookie-responder-mock-test ] unit-test [ "4" ] [ cookie-responder-mock-test ] unit-test + +: + + [ + "text/plain" exit-with + ] >>display ; + +[ + [ ] [ + + "GET" >>method + "id" get session-id-key set-query-param + "/" >>path + request set + + [ + "/" + call-responder + ] with-destructors response set + ] unit-test + + [ "text/plain" ] [ response get "content-type" header ] unit-test + + [ f ] [ response get cookies>> empty? ] unit-test +] with-scope diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 76f022e28c..f45f10d25f 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -13,7 +13,7 @@ IN: http.server.sessions GENERIC: init-session* ( responder -- ) -M: dispatcher init-session* drop ; +M: object init-session* drop ; TUPLE: session-manager responder sessions ; @@ -56,8 +56,11 @@ M: session-saver dispose sessions update-session ] [ drop ] if ; +: save-session-after ( id session -- ) + add-always-destructor ; + : call-responder/session ( path responder id session -- response ) - [ add-always-destructor ] + [ save-session-after ] [ [ session-id set ] [ session set ] bi* ] 2bi [ session-manager set ] [ responder>> call-responder ] bi ; diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index 6ef655bde2..07cd22bc62 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -21,23 +21,18 @@ session "SESSIONS" session construct-empty swap dup [ string>number ] when >>id ; -USING: namespaces io prettyprint ; M: sessions-in-db get-session ( id storage -- namespace/f ) - global [ "get " write over print flush ] bind drop dup [ - select-tuple dup [ namespace>> ] when global [ dup . ] bind + select-tuple dup [ namespace>> ] when ] when ; M: sessions-in-db update-session ( namespace id storage -- ) - global [ "update " write over print flush ] bind drop - swap global [ dup . ] bind >>namespace - dup update-tuple - id>> select-tuple global [ . flush ] bind - ; + swap >>namespace + update-tuple ; M: sessions-in-db delete-session ( id storage -- ) drop @@ -45,8 +40,7 @@ M: sessions-in-db delete-session ( id storage -- ) delete-tuple ; M: sessions-in-db new-session ( namespace storage -- id ) - global [ "new " print flush ] bind drop f - swap global [ dup . ] bind >>namespace + swap >>namespace [ insert-tuple ] [ id>> number>string ] bi ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index b408b1b6b0..b001242776 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -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/validators/validators.factor b/extra/http/server/validators/validators.factor index 539a58d19f..f2d1f568e6 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -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..05dc7235f6 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 prepend-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/unique.factor b/extra/io/files/unique/unique.factor index 1e77cd6814..9a271e402c 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -24,7 +24,7 @@ PRIVATE> : make-unique-file ( prefix suffix -- path stream ) 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 ; @@ -36,7 +36,7 @@ PRIVATE> : 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 ; diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 4acfb9acad..163194195d 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -5,7 +5,7 @@ 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/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/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor old mode 100644 new mode 100755 index aa54d3ec94..9e19245d01 --- 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 ; [ ] [ @@ -34,7 +34,7 @@ accessors kernel sequences ; ascii contents ] unit-test -[ "" ] [ +[ f ] [ "cat" "launcher-test-1" temp-file @@ -55,7 +55,7 @@ accessors kernel sequences ; try-process ] unit-test -[ "" ] [ +[ f ] [ "cat" "launcher-test-1" temp-file 2array @@ -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/unix.factor b/extra/io/unix/unix.factor index 01e29866eb..1f0492a060 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -3,5 +3,3 @@ io.unix.launcher io.unix.mmap io.backend combinators namespaces system vocabs.loader sequences ; "io.unix." os append require - -"tools.vocabs.monitor" require 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/nt.factor b/extra/io/windows/nt/nt.factor index 319acc35f8..1baec5658f 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -13,5 +13,3 @@ USE: io.windows.files USE: io.backend T{ windows-nt-io } set-io-backend - -"tools.vocabs.monitor" require 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-tests.factor b/extra/locals/locals-tests.factor index b4f1b0a61e..bd1e62f22a 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -1,5 +1,6 @@ USING: locals math sequences tools.test hashtables words kernel -namespaces arrays strings prettyprint ; +namespaces arrays strings prettyprint io.streams.string parser +; IN: locals.tests :: foo ( a b -- a a ) a a ; @@ -178,3 +179,19 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; [ "[| a! | ]" ] [ [| a! | ] unparse ] unit-test + +DEFER: xyzzy + +[ ] [ + "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;" + "lambda-generic-test" parse-stream drop +] unit-test + +[ 10 ] [ 10 xyzzy ] unit-test + +[ ] [ + "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;" + "lambda-generic-test" parse-stream drop +] unit-test + +[ 5 ] [ 10 xyzzy ] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 9819e65e37..9f96a3444d 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -176,7 +176,7 @@ 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 % ; @@ -249,13 +249,14 @@ M: wlet local-rewrite* word [ over "declared-effect" set-word-prop ] when* effect-in make-locals ; -: ((::)) ( word -- word quot ) +: parse-locals-definition ( word -- word quot ) scan "(" assert= parse-locals \ ; (parse-lambda) 2dup "lambda" set-word-prop lambda-rewrite first ; -: (::) ( -- word quot ) - CREATE dup reset-generic ((::)) ; +: (::) CREATE-WORD parse-locals-definition ; + +: (M::) CREATE-METHOD parse-locals-definition ; PRIVATE> @@ -275,18 +276,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ; : :: (::) define ; parsing -! This will be cleaned up when method tuples and method words -! are unified -: create-method ( class generic -- method ) - 2dup method dup - [ 2nip ] - [ drop 2dup [ ] -rot define-method create-method ] if ; - -: CREATE-METHOD ( -- class generic body ) - scan-word bootstrap-word scan-word 2dup - create-method f set-word dup save-location ; - -: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing +: M:: (M::) define ; parsing : MACRO:: (::) define-macro ; parsing diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 5846515dca..42545500a5 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -127,8 +127,7 @@ PRIVATE> : LOG: #! Syntax: name level - CREATE - dup reset-generic + CREATE-WORD dup scan-word [ >r >r 1array stack>message r> r> log-message ] 2curry define ; parsing 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/memoize/memoize.factor b/extra/memoize/memoize.factor index 3b0b8fd29f..ab915ae7d5 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -40,7 +40,7 @@ IN: memoize over make-memoizer define ; : MEMO: - CREATE dup reset-generic parse-definition define-memoized ; parsing + CREATE-WORD parse-definition define-memoized ; parsing PREDICATE: word memoized "memoize" word-prop ; diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor index 5baa205d15..079f484274 100755 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -18,7 +18,7 @@ IN: multiline lexer get next-line ; : STRING: - CREATE dup reset-generic + CREATE-WORD parse-here 1quotation define-inline ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor index 3273036b8b..9773da7b41 100755 --- a/extra/new-slots/new-slots.factor +++ b/extra/new-slots/new-slots.factor @@ -27,7 +27,7 @@ IN: new-slots : setter-effect T{ effect f { "object" "value" } { "value" } } ; inline : setter-word ( name -- word ) - ">>" swap append setter-effect create-accessor ; + ">>" prepend setter-effect create-accessor ; : define-setter ( name -- ) dup setter-word dup deferred? [ @@ -37,7 +37,7 @@ IN: new-slots : changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline : changer-word ( name -- word ) - "change-" swap append changer-effect create-accessor ; + "change-" prepend changer-effect create-accessor ; : define-changer ( name -- ) dup changer-word dup deferred? [ diff --git a/extra/opengl/gl/gl-docs.factor b/extra/opengl/gl/gl-docs.factor index 84004cbbdf..f244b4d119 100644 --- a/extra/opengl/gl/gl-docs.factor +++ b/extra/opengl/gl/gl-docs.factor @@ -5,7 +5,8 @@ IN: opengl.gl ARTICLE: "opengl-low-level" "OpenGL Library (low level)" { $subsection "opengl-specifying-vertices" } - { $subsection "opengl-geometric-primitives" } ; + { $subsection "opengl-geometric-primitives" } + { $subsection "opengl-modeling-transformations" } ; ARTICLE: "opengl-specifying-vertices" "Specifying Vertices" @@ -67,4 +68,18 @@ HELP: glPolygonMode { $list { $link GL_POINT } { $link GL_LINE } - { $link GL_FILL } } } } } ; \ No newline at end of file + { $link GL_FILL } } } } } ; + +ARTICLE: "opengl-modeling-transformations" "Modeling Transformations" + { $subsection glTranslatef } + { $subsection glTranslated } + { $subsection glRotatef } + { $subsection glRotated } + { $subsection glScalef } + { $subsection glScaled } ; + + +{ glTranslatef glTranslated glRotatef glRotated glScalef glScaled } +related-words + + diff --git a/extra/opengl/gl/macosx/macosx.factor b/extra/opengl/gl/macosx/macosx.factor index 3d4cb6ae93..eb8dda5e33 100644 --- a/extra/opengl/gl/macosx/macosx.factor +++ b/extra/opengl/gl/macosx/macosx.factor @@ -2,5 +2,5 @@ USING: kernel alien ; IN: opengl.gl.macosx : gl-function-context ( -- context ) 0 ; inline -: gl-function-address ( name -- address ) "gl" load-library dlsym ; inline +: gl-function-address ( name -- address ) f dlsym ; inline : gl-function-calling-convention ( -- str ) "cdecl" ; inline diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor index ceda434c75..7403b7cb05 100755 --- a/extra/opengl/shaders/shaders.factor +++ b/extra/opengl/shaders/shaders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel opengl.gl alien.c-types continuations namespaces assocs alien libc opengl math sequences combinators.lib -macros arrays combinators.cleave ; +combinators.cleave macros arrays ; IN: opengl.shaders : with-gl-shader-source-ptr ( string quot -- ) @@ -92,10 +92,11 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; GL_ATTACHED_SHADERS gl-program-get-int ; inline : gl-program-shaders ( program -- shaders ) - dup gl-program-shaders-length [ - dup "GLuint" - [ 0 swap glGetAttachedShaders ] keep - ] keep c-uint-array> ; + dup gl-program-shaders-length + dup "GLuint" + 0 swap + [ glGetAttachedShaders ] { 3 1 } multikeep + c-uint-array> ; : delete-gl-program-only ( program -- ) glDeleteProgram ; inline diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor index bc65f72435..d06afdc5ea 100755 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -11,7 +11,7 @@ IN: openssl.libcrypto << "libcrypto" { - { [ win32? ] [ "libeay32.dll" "stdcall" ] } + { [ win32? ] [ "libeay32.dll" "cdecl" ] } { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] } { [ unix? ] [ "libcrypto.so" "cdecl" ] } } cond add-library diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor old mode 100644 new mode 100755 index d8709cbf53..11dcee31f6 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -10,7 +10,7 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl << "libssl" { - { [ win32? ] [ "ssleay32.dll" "stdcall" ] } + { [ win32? ] [ "ssleay32.dll" "cdecl" ] } { [ macosx? ] [ "libssl.dylib" "cdecl" ] } { [ unix? ] [ "libssl.so" "cdecl" ] } } cond add-library >> diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index c40bc5628b..2d0f5bb5d0 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -21,55 +21,55 @@ namespaces math math.parser openssl prettyprint sequences tools.test ; ! Initialize context ! ========================================================= -init load-error-strings +[ ] [ init load-error-strings ] unit-test -ssl-v23 new-ctx +[ ] [ ssl-v23 new-ctx ] unit-test -get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain +[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test ! TODO: debug 'Memory protection fault at address 6c' ! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd -get-ctx "password" string>char-alien set-default-passwd-userdata +[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test ! Enter PEM pass phrase: password -get-ctx "/extra/openssl/test/server.pem" resource-path -SSL_FILETYPE_PEM use-private-key +[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path +SSL_FILETYPE_PEM use-private-key ] unit-test -get-ctx "/extra/openssl/test/root.pem" resource-path f -verify-load-locations +[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f +verify-load-locations ] unit-test -get-ctx 1 set-verify-depth +[ ] [ get-ctx 1 set-verify-depth ] unit-test ! ========================================================= ! Load Diffie-Hellman parameters ! ========================================================= -"/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file +[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test -get-bio f f f read-pem-dh-params +[ ] [ get-bio f f f read-pem-dh-params ] unit-test -get-bio bio-free +[ ] [ get-bio bio-free ] unit-test ! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol' -! get-ctx get-dh set-tmp-dh-callback +[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test ! Workaround (this function should never be called directly) -get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl +! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test ! ========================================================= ! Generate ephemeral RSA key ! ========================================================= -512 RSA_F4 f f generate-rsa-key +[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test ! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol' ! get-ctx get-rsa set-tmp-rsa-callback ! Workaround (this function should never be called directly) -get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl +[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test -get-rsa free-rsa +[ ] [ get-rsa free-rsa ] unit-test ! ========================================================= ! Listen and accept on socket @@ -129,11 +129,11 @@ get-rsa free-rsa ! Dump errors to file ! ========================================================= -"/extra/openssl/test/errors.txt" resource-path "w" bio-new-file +[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test [ 6 ] [ get-bio "Hello\n" bio-print ] unit-test -get-bio bio-free +[ ] [ get-bio bio-free ] unit-test ! ========================================================= ! Clean-up 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..8846a9c94c 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test peg peg.ebnf ; +USING: kernel tools.test peg peg.ebnf compiler.units ; IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ @@ -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,33 @@ 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" } } [ + "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast +] unit-test + +{ V{ 1 "b" } } [ + "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast +] unit-test + +{ V{ 1 2 } } [ + "foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast +] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 5d7d7297ef..e2c2dd5006 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -2,24 +2,31 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - 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-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-ensure-not C: ebnf-choice C: ebnf-sequence C: ebnf-repeat0 +C: ebnf-repeat1 C: ebnf-optional C: ebnf-rule C: ebnf-action @@ -27,12 +34,10 @@ C: ebnf SYMBOL: parsers SYMBOL: non-terminals -SYMBOL: last-parser : reset-parser-generation ( -- ) V{ } clone parsers set - H{ } clone non-terminals set - f last-parser set ; + H{ } clone non-terminals set ; : store-parser ( parser -- number ) parsers get [ push ] keep length 1- ; @@ -50,7 +55,7 @@ SYMBOL: last-parser GENERIC: (generate-parser) ( ast -- id ) : generate-parser ( ast -- id ) - (generate-parser) dup last-parser set ; + (generate-parser) ; M: ebnf-terminal (generate-parser) ( ast -- id ) ebnf-terminal-symbol token sp store-parser ; @@ -61,6 +66,9 @@ M: ebnf-non-terminal (generate-parser) ( ast -- id ) parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or , ] [ ] make delay sp store-parser ; +M: ebnf-any-character (generate-parser) ( ast -- id ) + drop [ drop t ] satisfy store-parser ; + M: ebnf-choice (generate-parser) ( ast -- id ) ebnf-choice-options [ generate-parser get-parser @@ -71,9 +79,15 @@ M: ebnf-sequence (generate-parser) ( ast -- id ) generate-parser get-parser ] map seq store-parser ; +M: ebnf-ensure-not (generate-parser) ( ast -- id ) + ebnf-ensure-not-group generate-parser get-parser ensure-not store-parser ; + M: ebnf-repeat0 (generate-parser) ( ast -- id ) ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ; +M: ebnf-repeat1 (generate-parser) ( ast -- id ) + ebnf-repeat1-group generate-parser get-parser repeat1 store-parser ; + M: ebnf-optional (generate-parser) ( ast -- id ) ebnf-optional-elements generate-parser get-parser optional store-parser ; @@ -83,15 +97,12 @@ M: ebnf-rule (generate-parser) ( ast -- id ) 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 ; + [ ebnf-action-parser generate-parser get-parser ] keep + ebnf-action-code string-lines parse-lines 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 @@ -99,67 +110,153 @@ M: ebnf (generate-parser) ( ast -- id ) DEFER: 'rhs' +: syntax ( string -- parser ) + #! Parses the string, ignoring white space, and + #! does not put the result in the AST. + token sp hide ; + +: syntax-pack ( begin parser end -- parser ) + #! Parse 'parser' surrounded by syntax elements + #! begin and end. + [ syntax ] dipd syntax pack ; + +: '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. + [ + [ 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: ? = ] + } || 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 ; + : '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' , + '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 , + "[[" 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 ; + +: 'factor-code' ( -- parser ) + [ + "]]" token ensure-not , + [ drop t ] satisfy , + ] seq* [ first ] action repeat0 [ >string ] action ; + +: 'action' ( -- parser ) + [ + "(" [ 'choice' sp ] delay ")" syntax-pack , + "[[" 'factor-code' "]]" syntax-pack , + ] seq* [ first2 ] 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 ; : 'sequence' ( -- parser ) + #! A sequence of terminals and non-terminals, including + #! groupings of those. [ + 'ensure-not' sp , 'element' sp , 'group' sp , 'repeat0' sp , + 'repeat1' sp , 'optional' sp , - ] { } make choice - repeat1 [ + 'action' sp , + ] choice* repeat1 [ dup length 1 = [ first ] [ ] if - ] action ; + ] 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 [ @@ -182,4 +279,4 @@ DEFER: 'choice' f ] if* ; -: " parse-tokens " " join ebnf>quot call ; parsing +: " parse-multiline-string 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.factor b/extra/peg/expr/expr.factor new file mode 100644 index 0000000000..ed13ac0e50 --- /dev/null +++ b/extra/peg/expr/expr.factor @@ -0,0 +1,30 @@ +! 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 ; + +number ]] + +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 parse-result-ast ; \ No newline at end of file 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/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index fa8ac89f57..bf321d54e9 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -1,7 +1,7 @@ ! 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" } [ @@ -11,3 +11,89 @@ IN: peg.pl0.tests { 55 } [ "55abc" number parse parse-result-ast ] unit-test + +{ 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. +"> program parse parse-result-remaining empty? +] 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. + "> program parse 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..1ef7a23b41 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -1,30 +1,31 @@ ! 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 ; 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 ; + [ + CHAR: a CHAR: z range , + CHAR: A CHAR: Z range , + ] 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 ')' +program = block "." +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 ")" 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/promises/promises.factor b/extra/promises/promises.factor index 3724b929f0..469f6a91ed 100755 --- a/extra/promises/promises.factor +++ b/extra/promises/promises.factor @@ -40,6 +40,6 @@ TUPLE: promise quot forced? value ; ] [ ] make ; : LAZY: - CREATE dup reset-generic + CREATE-WORD dup parse-definition make-lazy-quot define ; parsing 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 100644 index 0000000000..e1ba48281a --- /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 new-slots 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 100644 index 0000000000..af6e2365bb --- /dev/null +++ b/extra/random/dummy/dummy.factor @@ -0,0 +1,11 @@ +USING: kernel random math new-slots 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 100644 index 0000000000..afd9d085b6 --- /dev/null +++ b/extra/random/mersenne-twister/mersenne-twister-tests.factor @@ -0,0 +1,30 @@ +USING: kernel math random namespaces random.mersenne-twister +sequences tools.test ; +IN: random.mersenne-twister.tests +USE: tools.walker + +: 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 get random-32 drop ] each \ random get random-32 ] test-rng +] unit-test + +[ 1575309035 ] [ + 0 [ 10000 [ drop \ random get random-32 drop ] each \ random 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..79101c083e --- /dev/null +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -0,0 +1,80 @@ +! 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 new-slots accessors +math.ranges combinators.cleave circular 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 ; + +[ millis \ random set-global ] "random" add-init-hook 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 old mode 100755 new mode 100644 index db2aacd2b0..bbf54e21eb --- 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 +DEFER: random -SYMBOL: mt +: random-bytes ( n -- r ) + [ + 4 /mod zero? [ 1+ ] unless + \ random get swap (random-bytes) + ] keep head ; -: 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-bits ( n -- r ) 2^ random ; : 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 +: with-random ( tuple quot -- ) + \ random 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/reports/noise/noise.factor b/extra/reports/noise/noise.factor new file mode 100755 index 0000000000..f4b10a7d81 --- /dev/null +++ b/extra/reports/noise/noise.factor @@ -0,0 +1,174 @@ +USING: assocs math kernel shuffle combinators.lib +words quotations arrays combinators sequences math.vectors +io.styles combinators.cleave prettyprint vocabs sorting io +generic locals.private math.statistics ; +IN: reports.noise + +: badness ( word -- n ) + H{ + { -nrot 5 } + { -roll 4 } + { -rot 3 } + { 2apply 1 } + { 2curry 1 } + { 2drop 1 } + { 2dup 1 } + { 2keep 1 } + { 2nip 2 } + { 2over 4 } + { 2slip 2 } + { 2swap 3 } + { 2with 2 } + { 2with* 3 } + { 3apply 1/2 } + { 3curry 2 } + { 3drop 1 } + { 3dup 2 } + { 3keep 3 } + { 3nip 4 } + { 3slip 3 } + { 3with 3 } + { 3with* 4 } + { 4drop 2 } + { 4dup 3 } + { 4slip 4 } + { compose 1/2 } + { curry 1/3 } + { dip 1 } + { dipd 2 } + { drop 1/3 } + { dup 1/3 } + { if 1/3 } + { when 1/4 } + { unless 1/4 } + { when* 1/3 } + { unless* 1/3 } + { ?if 1/2 } + { cond 1/2 } + { case 1/2 } + { keep 1 } + { napply 2 } + { ncurry 3 } + { ndip 5 } + { ndrop 2 } + { ndup 3 } + { nip 2 } + { nipd 3 } + { nkeep 5 } + { npick 6 } + { nrev 5 } + { nrot 5 } + { nslip 5 } + { ntuck 6 } + { nwith 4 } + { over 2 } + { pick 4 } + { roll 4 } + { rot 3 } + { slip 1 } + { spin 3 } + { swap 1 } + { swapd 3 } + { tuck 2 } + { tuckd 4 } + { with 1/2 } + { with* 2 } + { r> 1 } + { >r 1 } + + { bi 1/2 } + { tri 1 } + { bi* 1/2 } + { tri* 1 } + + { cleave 2 } + { spread 2 } + } at 0 or ; + +: vsum { 0 0 } [ v+ ] reduce ; + +GENERIC: noise ( obj -- pair ) + +M: word noise badness 1 2array ; + +M: wrapper noise wrapped noise ; + +M: let noise let-body noise ; + +M: wlet noise wlet-body noise ; + +M: lambda noise lambda-body noise ; + +M: object noise drop { 0 0 } ; + +M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ; + +M: array noise [ noise ] map vsum ; + +: noise-factor / 100 * >integer ; + +: quot-noise-factor ( quot -- n ) + #! For very short words, noise doesn't count so much + #! (so dup foo swap bar isn't penalized as badly). + noise first2 { + { [ over 4 <= ] [ >r drop 0 r> ] } + { [ over 15 >= ] [ >r 2 * r> ] } + { [ t ] [ ] } + } cond + { + ! short words are easier to read + { [ dup 10 <= ] [ >r 2 / r> ] } + { [ dup 5 <= ] [ >r 3 / r> ] } + ! long words are penalized even more + { [ dup 25 >= ] [ >r 2 * r> 20 max ] } + { [ dup 20 >= ] [ >r 5/3 * r> ] } + { [ dup 15 >= ] [ >r 3/2 * r> ] } + { [ t ] [ ] } + } cond noise-factor ; + +GENERIC: word-noise-factor ( word -- factor ) + +M: word word-noise-factor + word-def quot-noise-factor ; + +M: lambda-word word-noise-factor + "lambda" word-prop quot-noise-factor ; + +: flatten-generics ( words -- words' ) + [ + dup generic? [ methods values ] [ 1array ] if + ] map concat ; + +: noisy-words ( -- alist ) + all-words flatten-generics + [ dup word-noise-factor ] { } map>assoc + sort-values reverse ; + +: noise. ( alist -- ) + standard-table-style [ + [ + [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row + ] assoc-each + ] tabular-output ; + +: vocab-noise-factor ( vocab -- factor ) + words flatten-generics + [ word-noise-factor dup 20 < [ drop 0 ] when ] map + dup empty? [ drop 0 ] [ + [ [ sum ] [ length 5 max ] bi /i ] + [ supremum ] + bi + + ] if ; + +: noisy-vocabs ( -- alist ) + vocabs [ dup vocab-noise-factor ] { } map>assoc + sort-values reverse ; + +: noise-report ( -- ) + "NOISY WORDS:" print + noisy-words 80 head noise. + nl + "NOISY VOCABS:" print + noisy-vocabs 80 head noise. ; + +MAIN: noise-report diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor new file mode 100755 index 0000000000..42e72dee45 --- /dev/null +++ b/extra/reports/optimizer/optimizer.factor @@ -0,0 +1,33 @@ +USING: assocs words sequences arrays compiler tools.time +io.styles io prettyprint vocabs kernel sorting generator +optimizer math combinators.cleave ; +IN: report.optimizer + +: count-optimization-passes ( nodes n -- n ) + >r optimize-1 + [ r> 1+ count-optimization-passes ] [ drop r> ] if ; + +: results + [ [ second ] swap compose compare ] curry sort 20 tail* + print + standard-table-style + [ + [ [ [ pprint-cell ] each ] with-row ] each + ] tabular-output ; inline + +: optimizer-measurements ( -- alist ) + all-words [ compiled? ] subset + [ + dup [ + word-dataflow nip 1 count-optimization-passes + ] benchmark nip 2array + ] { } map>assoc ; + +: optimizer-measurements. ( alist -- ) + [ [ first ] "Worst number of optimizer passes:" results ] + [ [ second ] "Worst compile times:" results ] bi ; + +: optimizer-report ( -- ) + optimizer-measurements optimizer-measurements. ; + +MAIN: optimizer-report diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 1831495924..c5734b2ae8 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -4,7 +4,7 @@ USING: tools.test kernel serialize io io.streams.byte-array math alien arrays byte-arrays sequences math prettyprint parser classes math.constants io.encodings.binary random -combinators.lib ; +combinators.lib assocs ; IN: serialize.tests : test-serialize-cell @@ -56,19 +56,23 @@ C: serialize-test } ; : check-serialize-1 ( obj -- ? ) + "=====" print dup class . + dup . dup - binary [ serialize ] with-byte-writer - binary [ deserialize ] with-byte-reader = ; + object>bytes + bytes>object + dup . = ; : check-serialize-2 ( obj -- ? ) dup number? over wrapper? or [ drop t ! we don't care if numbers aren't interned ] [ + "=====" print dup class . - dup 2array - binary [ serialize ] with-byte-writer - binary [ deserialize ] with-byte-reader + dup 2array dup . + object>bytes + bytes>object dup . first2 eq? ] if ; @@ -79,3 +83,17 @@ C: serialize-test [ t ] [ pi check-serialize-1 ] unit-test [ serialize ] must-infer [ deserialize ] must-infer + +[ t ] [ + V{ } dup dup push + object>bytes + bytes>object + dup first eq? +] unit-test + +[ t ] [ + H{ } dup dup dup set-at + object>bytes + bytes>object + dup keys first eq? +] unit-test diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index f573499695..36d5e40b77 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -6,13 +6,14 @@ ! ! See http://factorcode.org/license.txt for BSD license. ! -IN: serialize USING: namespaces sequences kernel math io math.functions -io.binary strings classes words sbufs tuples arrays -vectors byte-arrays bit-arrays quotations hashtables -assocs help.syntax help.markup float-arrays splitting -io.encodings.string io.encodings.utf8 combinators new-slots -accessors ; +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 +prettyprint compiler.units sequences.private tuples.private ; +IN: serialize ! Variable holding a assoc of objects already serialized SYMBOL: serialized @@ -69,7 +70,8 @@ GENERIC: (serialize) ( obj -- ) : serialize-shared ( obj quot -- ) >r dup object-id - [ CHAR: o write1 serialize-cell drop ] r> if* ; inline + [ CHAR: o write1 serialize-cell drop ] + r> if* ; inline M: f (serialize) ( obj -- ) drop CHAR: n write1 ; @@ -96,75 +98,93 @@ M: ratio (serialize) ( obj -- ) dup numerator (serialize) denominator (serialize) ; -: serialize-string ( obj code -- ) - write1 - dup utf8 encode dup length serialize-cell write - add-object ; - -M: string (serialize) ( obj -- ) - [ CHAR: s serialize-string ] serialize-shared ; - -: serialize-elements ( seq -- ) - [ (serialize) ] each CHAR: . write1 ; +: serialize-seq ( obj code -- ) + [ + write1 + [ add-object ] + [ length serialize-cell ] + [ [ (serialize) ] each ] tri + ] curry serialize-shared ; M: tuple (serialize) ( obj -- ) [ CHAR: T write1 - dup tuple>array serialize-elements - add-object + [ class (serialize) ] + [ add-object ] + [ tuple>array 1 tail (serialize) ] + tri ] serialize-shared ; -: serialize-seq ( seq code -- ) - [ - write1 - dup serialize-elements - add-object - ] curry serialize-shared ; - M: array (serialize) ( obj -- ) CHAR: a serialize-seq ; -M: byte-array (serialize) ( obj -- ) - [ - CHAR: A write1 - dup dup length serialize-cell write - add-object - ] serialize-shared ; - -M: bit-array (serialize) ( obj -- ) - [ - CHAR: b write1 - dup length serialize-cell - dup [ 1 0 ? ] B{ } map-as write - add-object - ] serialize-shared ; - M: quotation (serialize) ( obj -- ) - CHAR: q serialize-seq ; - -M: float-array (serialize) ( obj -- ) [ - CHAR: f write1 - dup length serialize-cell - dup [ double>bits 8 >be write ] each - add-object + CHAR: q write1 [ >array (serialize) ] [ add-object ] bi ] serialize-shared ; M: hashtable (serialize) ( obj -- ) [ CHAR: h write1 - dup >alist (serialize) - add-object + [ add-object ] [ >alist (serialize) ] bi ] serialize-shared ; -M: word (serialize) ( obj -- ) +M: bit-array (serialize) ( obj -- ) + CHAR: b serialize-seq ; + +M: byte-array (serialize) ( obj -- ) [ - CHAR: w write1 - dup word-name (serialize) - dup word-vocabulary (serialize) - add-object + CHAR: A write1 + [ add-object ] + [ length serialize-cell ] + [ write ] tri ] serialize-shared ; +M: float-array (serialize) ( obj -- ) + [ + CHAR: f write1 + [ add-object ] + [ length serialize-cell ] + [ [ double>bits 8 >be write ] each ] + tri + ] serialize-shared ; + +M: string (serialize) ( obj -- ) + [ + CHAR: s write1 + [ add-object ] + [ + utf8 encode + [ length serialize-cell ] + [ write ] bi + ] bi + ] serialize-shared ; + +: serialize-true ( word -- ) + drop CHAR: t write1 ; + +: serialize-gensym ( word -- ) + [ + CHAR: G write1 + [ add-object ] + [ word-def (serialize) ] + [ word-props (serialize) ] + tri + ] serialize-shared ; + +: serialize-word ( word -- ) + CHAR: w write1 + [ word-name (serialize) ] + [ word-vocabulary (serialize) ] + bi ; + +M: word (serialize) ( obj -- ) + { + { [ dup t eq? ] [ serialize-true ] } + { [ dup word-vocabulary not ] [ serialize-gensym ] } + { [ t ] [ serialize-word ] } + } cond ; + M: wrapper (serialize) ( obj -- ) CHAR: W write1 wrapped (serialize) ; @@ -179,6 +199,9 @@ SYMBOL: deserialized : deserialize-false ( -- f ) f ; +: deserialize-true ( -- f ) + t ; + : deserialize-positive-integer ( -- number ) deserialize-cell ; @@ -204,53 +227,63 @@ SYMBOL: deserialized (deserialize-string) dup intern-object ; : deserialize-word ( -- word ) - (deserialize) dup (deserialize) lookup - [ dup intern-object ] [ "Unknown word" throw ] ?if ; + (deserialize) (deserialize) 2dup lookup + dup [ 2nip ] [ + "Unknown word: " -rot + 2array unparse append throw + ] if ; + +: deserialize-gensym ( -- word ) + gensym + dup intern-object + dup (deserialize) define + dup (deserialize) swap set-word-props ; : deserialize-wrapper ( -- wrapper ) (deserialize) ; -SYMBOL: +stop+ - -: (deserialize-seq) ( -- seq ) - [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ; - -: deserialize-seq ( seq -- array ) - >r (deserialize-seq) r> like dup intern-object ; +:: (deserialize-seq) ( exemplar quot -- seq ) + deserialize-cell exemplar new + [ intern-object ] + [ dup [ drop quot call ] change-each ] bi ; inline : deserialize-array ( -- array ) - { } deserialize-seq ; + { } [ (deserialize) ] (deserialize-seq) ; : deserialize-quotation ( -- array ) - [ ] deserialize-seq ; - -: (deserialize-byte-array) ( -- byte-array ) - deserialize-cell read B{ } like ; + (deserialize) >quotation dup intern-object ; : deserialize-byte-array ( -- byte-array ) - (deserialize-byte-array) dup intern-object ; + B{ } [ read1 ] (deserialize-seq) ; : deserialize-bit-array ( -- bit-array ) - (deserialize-byte-array) [ 0 > ] ?{ } map-as - dup intern-object ; + ?{ } [ (deserialize) ] (deserialize-seq) ; : deserialize-float-array ( -- float-array ) - deserialize-cell - 8 * read 8 [ be> bits>double ] F{ } map-as - dup intern-object ; + F{ } [ 8 read be> bits>double ] (deserialize-seq) ; : deserialize-hashtable ( -- hashtable ) - (deserialize) >hashtable dup intern-object ; + H{ } clone + [ intern-object ] + [ (deserialize) update ] + [ ] tri ; + +: copy-seq-to-tuple ( seq tuple -- ) + >r dup length [ 1+ ] map r> [ set-array-nth ] curry 2each ; : deserialize-tuple ( -- array ) - (deserialize-seq) >tuple dup intern-object ; + #! Ugly because we have to intern the tuple before reading + #! slots + (deserialize) construct-empty + [ intern-object ] + [ + [ (deserialize) ] + [ [ copy-seq-to-tuple ] keep ] bi* + ] bi ; : deserialize-unknown ( -- object ) deserialize-cell deserialized get nth ; -: deserialize-stop ( -- object ) - +stop+ get ; - : deserialize* ( -- object ? ) read1 [ { @@ -265,14 +298,15 @@ SYMBOL: +stop+ { CHAR: h [ deserialize-hashtable ] } { CHAR: m [ deserialize-negative-integer ] } { CHAR: n [ deserialize-false ] } + { CHAR: t [ deserialize-true ] } { CHAR: o [ deserialize-unknown ] } { CHAR: p [ deserialize-positive-integer ] } { CHAR: q [ deserialize-quotation ] } { CHAR: r [ deserialize-ratio ] } { CHAR: s [ deserialize-string ] } { CHAR: w [ deserialize-word ] } + { CHAR: G [ deserialize-word ] } { CHAR: z [ deserialize-zero ] } - { CHAR: . [ deserialize-stop ] } } case t ] [ f f @@ -282,14 +316,16 @@ SYMBOL: +stop+ deserialize* [ "End of stream" throw ] unless ; : deserialize ( -- obj ) - [ - V{ } clone deserialized set - gensym +stop+ set - (deserialize) - ] with-scope ; + ! [ + V{ } clone deserialized + [ (deserialize) ] with-variable ; + ! ] with-compilation-unit ; : serialize ( obj -- ) - [ - H{ } clone serialized set - (serialize) - ] with-scope ; \ No newline at end of file + H{ } clone serialized [ (serialize) ] with-variable ; + +: bytes>object ( bytes -- obj ) + binary [ deserialize ] with-byte-reader ; + +: object>bytes ( obj -- bytes ) + binary [ serialize ] with-byte-writer ; \ No newline at end of file diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index a941b14a47..f7cdf9e64d 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -31,7 +31,7 @@ LOG: log-smtp-connection NOTICE ( addrspec -- ) : 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 ; @@ -89,7 +89,7 @@ LOG: smtp-response DEBUG : 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 @@ -143,7 +143,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 +164,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/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..2476077ba9 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -79,9 +79,9 @@ IN: tools.deploy.backend "-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 diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 78f1d487de..c527cb945c 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -66,7 +66,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..3b88d14fb3 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,10 @@ 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 [ staging-image-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/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index edf78de479..44fb15ac7e 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -133,9 +133,10 @@ IN: tools.deploy.shaker strip-io? [ io.backend:io-backend , ] when [ - io.backend:io-backend + io.backend:io-backend , "default-buffer-size" "io.nonblocking" lookup , - ] { "alarms" "io" "tools" } strip-vocab-globals % + ] { } make + { "alarms" "io" "tools" } strip-vocab-globals % strip-dictionary? [ { } { "cpu" } strip-vocab-globals % @@ -193,7 +194,7 @@ IN: tools.deploy.shaker global swap '[ drop , member? not ] assoc-subset [ drop string? not ] assoc-subset ! strip CLI args - dup keys . + dup keys unparse show 21 setenv ] [ drop ] if ; 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/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 675a2e1d6e..d7e1070666 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 ( vocab -- tests ) - dup vocab-root [ - [ - f >vocab-link dup - vocab-tests-file, - vocab-tests-dir, - ] { } make +: 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-tests-file [ , ] when* + vocab-tests-dir [ % ] when* + ] { } make ; + : vocab-files ( vocab -- seq ) - f >vocab-link [ + [ dup vocab-source-path [ , ] when* dup vocab-docs-path [ , ] when* vocab-tests % @@ -53,12 +51,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,10 +103,10 @@ 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 ] [ "The " swap vocab-name @@ -121,7 +115,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 +141,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 +153,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 +165,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 +174,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 +227,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 +235,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 +255,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/debug/debug.factor b/extra/tools/walker/debug/debug.factor index c8c0ff28a6..1fded308b4 100755 --- a/extra/tools/walker/debug/debug.factor +++ b/extra/tools/walker/debug/debug.factor @@ -2,17 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.promises models tools.walker kernel sequences concurrency.messaging locals continuations -threads namespaces namespaces.private ; +threads namespaces namespaces.private assocs ; IN: tools.walker.debug :: test-walker ( quot -- data ) - [let | p [ ] - s [ f ] - c [ f ] | + [let | p [ ] | [ H{ } clone >n - [ s c start-walker-thread p fulfill ] new-walker-hook set - [ drop ] show-walker-hook set + + [ + p promise-fulfilled? + [ drop ] [ p fulfill ] if + 2drop + ] show-walker-hook set break @@ -23,9 +25,7 @@ IN: tools.walker.debug p ?promise send-synchronous drop - detach p ?promise - send-synchronous drop - - c model-value continuation-data + thread-variables walker-continuation swap at + model-value continuation-data ] ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index e86cee0c47..6ef5309214 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -3,32 +3,48 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words -sequences.private assocs models ; +sequences.private assocs models combinators.cleave ; IN: tools.walker -SYMBOL: new-walker-hook ! ( -- ) -SYMBOL: show-walker-hook ! ( thread -- ) +SYMBOL: show-walker-hook ! ( status continuation thread -- ) -! Thread local +! Thread local in thread being walked SYMBOL: walker-thread -SYMBOL: walking-thread -: get-walker-thread ( -- thread ) +! Thread local in walker thread +SYMBOL: walking-thread +SYMBOL: walker-status +SYMBOL: walker-continuation +SYMBOL: walker-history + +DEFER: start-walker-thread + +: get-walker-thread ( -- status continuation thread ) walker-thread tget [ - dup show-walker-hook get call + [ thread-variables walker-status swap at ] + [ thread-variables walker-continuation swap at ] + [ ] tri ] [ - new-walker-hook get call - walker-thread tget + f + f + 2dup start-walker-thread ] if* ; +: show-walker ( -- thread ) + get-walker-thread + [ show-walker-hook get call ] keep ; + +: after-break ( object -- ) + { + { [ dup continuation? ] [ (continue) ] } + { [ dup quotation? ] [ call ] } + { [ dup not ] [ "Single stepping abandoned" rethrow ] } + } cond ; + : break ( -- ) continuation callstack over set-continuation-call - - get-walker-thread send-synchronous { - { [ dup continuation? ] [ (continue) ] } - { [ dup quotation? ] [ call ] } - { [ dup not ] [ "Single stepping abandoned" throw ] } - } cond ; + show-walker send-synchronous + after-break ; \ break t "break?" set-word-prop @@ -71,15 +87,9 @@ SYMBOL: detach SYMBOL: abandon SYMBOL: call-in -! Thread locals -SYMBOL: walker-status -SYMBOL: walker-continuation -SYMBOL: walker-history - SYMBOL: +running+ SYMBOL: +suspended+ SYMBOL: +stopped+ -SYMBOL: +detached+ : change-frame ( continuation quot -- continuation' ) #! Applies quot to innermost call frame of the @@ -145,34 +155,20 @@ SYMBOL: +detached+ : set-status ( symbol -- ) walker-status tget set-model ; -: unassociate-thread ( -- ) - walker-thread walking-thread tget thread-variables delete-at - [ ] walking-thread tget set-thread-exit-handler ; - -: detach-msg ( -- ) - +detached+ set-status - unassociate-thread ; - : keep-running ( -- ) +running+ set-status ; : walker-stopped ( -- ) +stopped+ set-status - [ status +stopped+ eq? ] [ - [ - { - { detach [ detach-msg ] } - [ drop ] - } case f - ] handle-synchronous - ] [ ] while ; + [ status +stopped+ eq? ] + [ [ drop f ] handle-synchronous ] + [ ] while ; : step-into-all-loop ( -- ) +running+ set-status [ status +running+ eq? ] [ [ { - { detach [ detach-msg f ] } { step [ f ] } { step-out [ f ] } { step-into [ f ] } @@ -201,10 +197,6 @@ SYMBOL: +detached+ { ! These are sent by the walker tool. We reply ! and keep cycling. - { detach [ detach-msg ] } - ! These change the state of the thread being - ! interpreted, so we modify the continuation and - ! output f. { step [ step-msg keep-running ] } { step-out [ step-out-msg keep-running ] } { step-into [ step-into-msg keep-running ] } @@ -221,10 +213,9 @@ SYMBOL: +detached+ : walker-loop ( -- ) +running+ set-status - [ status +detached+ eq? not ] [ + [ status +stopped+ eq? not ] [ [ { - { detach [ detach-msg f ] } ! ignore these commands while the thread is ! running { step [ f ] } 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/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 8dca72c29e..e9527e6f9a 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -73,10 +73,7 @@ M: freetype-renderer free-fonts ( world -- ) ] keep *void* ; : open-face ( font style -- face ) - ttf-name ttf-path - dup malloc-file-contents - swap file-info file-info-size - (open-face) ; + ttf-name ttf-path malloc-file-contents (open-face) ; SYMBOL: dpi 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/walker/walker.factor b/extra/ui/tools/walker/walker.factor index bc038cd244..a9fe38a14c 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -4,14 +4,18 @@ USING: kernel concurrency.messaging inspector ui.tools.listener ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets models ui.tools.workspace ui.gestures ui.gadgets.labels ui threads -namespaces tools.walker assocs ; +namespaces tools.walker assocs combinators combinators.cleave ; IN: ui.tools.walker -TUPLE: walker-gadget status continuation thread traceback ; +TUPLE: walker-gadget +status continuation thread +traceback +closing? ; : walker-command ( walker msg -- ) - over walker-gadget-thread thread-registered? - [ swap walker-gadget-thread send-synchronous drop ] + swap + dup walker-gadget-thread thread-registered? + [ walker-gadget-thread send-synchronous drop ] [ 2drop ] if ; : com-step ( walker -- ) step walker-command ; @@ -27,7 +31,9 @@ TUPLE: walker-gadget status continuation thread traceback ; : com-abandon ( walker -- ) abandon walker-command ; M: walker-gadget ungraft* - dup delegate ungraft* detach walker-command ; + [ t swap set-walker-gadget-closing? ] + [ com-continue ] + [ delegate ungraft* ] tri ; M: walker-gadget focusable-child* walker-gadget-traceback ; @@ -41,7 +47,6 @@ M: walker-gadget focusable-child* { +stopped+ "Stopped" } { +suspended+ "Suspended" } { +running+ "Running" } - { +detached+ "Detached" } } at % ")" % drop @@ -51,7 +56,7 @@ M: walker-gadget focusable-child* [ walker-state-string ] curry ; : ( status continuation thread -- gadget ) - over walker-gadget construct-boa [ + over f walker-gadget construct-boa [ toolbar, g walker-gadget-status self f track, g walker-gadget-traceback 1 track, @@ -72,16 +77,20 @@ walker-gadget "toolbar" f { { T{ key-down f f "F1" } walker-help } } define-command-map -: walker-window ( -- ) - f f 2dup start-walker-thread - [ ] keep thread-name open-status-window ; +: walker-for-thread? ( thread gadget -- ? ) + { + { [ dup walker-gadget? not ] [ 2drop f ] } + { [ dup walker-gadget-closing? ] [ 2drop f ] } + { [ t ] [ walker-gadget-thread eq? ] } + } cond ; -[ [ walker-window ] with-ui ] new-walker-hook set-global +: find-walker-window ( thread -- world/f ) + [ swap walker-for-thread? ] curry find-window ; + +: walker-window ( status continuation thread -- ) + [ ] [ thread-name ] bi open-status-window ; [ - [ - >r dup walker-gadget? - [ walker-gadget-thread r> eq? ] - [ r> 2drop f ] if - ] curry find-window raise-window + dup find-walker-window dup + [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if ] show-walker-hook set-global diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 8eb5fe59aa..f47a82275b 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -436,17 +436,16 @@ SYMBOL: trace-messages? : init-win32-ui ( -- ) V{ } clone nc-buttons set-global - "MSG" msg-obj set-global + "MSG" malloc-object msg-obj set-global "Factor-window" malloc-u16-string class-name-ptr set-global register-wndclassex drop GetDoubleClickTime double-click-timeout set-global ; : cleanup-win32-ui ( -- ) - class-name-ptr get-global [ - dup f UnregisterClass drop - free - ] when* - f class-name-ptr set-global ; + class-name-ptr get-global [ dup f UnregisterClass drop free ] when* + msg-obj get-global [ free ] when* + f class-name-ptr set-global + f msg-obj set-global ; : setup-pixel-format ( hdc -- ) 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 11be803893..d8e1e8937a 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -5,7 +5,7 @@ IN: unicode.data << : VALUE: - CREATE dup reset-generic { f } clone [ first ] curry define ; parsing + CREATE-WORD { f } clone [ first ] curry define ; parsing : set-value ( value word -- ) word-def first set-first ; diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor old mode 100755 new mode 100644 diff --git a/extra/windows/advapi32/authors.txt b/extra/windows/advapi32/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/ce/authors.txt b/extra/windows/ce/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/ce/ce.factor b/extra/windows/ce/ce.factor index 1180d78a2b..948612b2b2 100644 --- a/extra/windows/ce/ce.factor +++ b/extra/windows/ce/ce.factor @@ -11,4 +11,5 @@ USING: alien sequences ; ! { "gl" "libGLES_CM.dll" "stdcall" } ! { "glu" "libGLES_CM.dll" "stdcall" } ! { "freetype" "libfreetype-6.dll" "stdcall" } + { "ole32" "ole32.dll" "stdcall" } } [ first3 add-library ] each diff --git a/extra/windows/com/authors.txt b/extra/windows/com/authors.txt new file mode 100644 index 0000000000..6a1b3e726a --- /dev/null +++ b/extra/windows/com/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/windows/com/com-docs.factor b/extra/windows/com/com-docs.factor new file mode 100644 index 0000000000..901a88675f --- /dev/null +++ b/extra/windows/com/com-docs.factor @@ -0,0 +1,15 @@ +USING: help.markup help.syntax io kernel math quotations +multiline ; +IN: windows.com + +HELP: com-query-interface +{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } } +{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ; + +HELP: com-add-ref +{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } } +{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ; + +HELP: com-release +{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } } +{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ; diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor new file mode 100644 index 0000000000..4a2f465fef --- /dev/null +++ b/extra/windows/com/com-tests.factor @@ -0,0 +1,93 @@ +USING: kernel windows.com windows.com.syntax windows.ole32 +alien alien.syntax tools.test libc alien.c-types arrays.lib +namespaces arrays continuations ; +IN: windows.com.tests + +! Create some test COM interfaces + +COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} + HRESULT returnOK ( ) + HRESULT returnError ( ) ; + +COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} + int getX ( ) + void setX ( int newX ) ; + +! Implement the IInherited interface in factor using alien-callbacks + +C-STRUCT: test-implementation + { "void*" "vtbl" } + { "int" "x" } ; + +: QueryInterface-callback + "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ] + alien-callback ; +: AddRef-callback + "ULONG" { "void*" } "stdcall" [ drop 2 ] + alien-callback ; +: Release-callback + "ULONG" { "void*" } "stdcall" [ drop 1 ] + alien-callback ; +: returnOK-callback + "HRESULT" { "void*" } "stdcall" [ drop S_OK ] + alien-callback ; +: returnError-callback + "HRESULT" { "void*" } "stdcall" [ drop E_FAIL ] + alien-callback ; +: getX-callback + "int" { "void*" } "stdcall" [ test-implementation-x ] + alien-callback ; +: setX-callback + "void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ] + alien-callback ; + +SYMBOL: +test-implementation-vtbl+ +SYMBOL: +guinea-pig-implementation+ + +: (make-test-implementation) ( x imp -- imp ) + [ set-test-implementation-x ] keep + +test-implementation-vtbl+ get over set-test-implementation-vtbl ; + +: ( x -- imp ) + "test-implementation" (make-test-implementation) ; + +: ( x -- imp ) + "test-implementation" heap-size malloc (make-test-implementation) ; + +QueryInterface-callback +AddRef-callback +Release-callback +returnOK-callback +returnError-callback +getX-callback +setX-callback +7 narray >c-void*-array +dup byte-length [ + [ byte-array>memory ] keep + +test-implementation-vtbl+ set + + ! Test that the words defined by COM-INTERFACE: do their magic + + "{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test + "{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test + "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test + S_OK 1array [ 0 ISimple::returnOK ] unit-test + E_FAIL *long 1array [ 0 ISimple::returnError ] unit-test + 1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test + + ! Test that the helper functions for QueryInterface, AddRef, Release work + + 0 +guinea-pig-implementation+ set + [ + +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get com-add-ref + ] unit-test + + { } [ +guinea-pig-implementation+ get com-release ] unit-test + + +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get IUnknown-iid com-query-interface + ] unit-test + + ] [ +guinea-pig-implementation+ get free ] [ ] cleanup +] with-malloc diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor new file mode 100644 index 0000000000..b78d9b5b91 --- /dev/null +++ b/extra/windows/com/com.factor @@ -0,0 +1,22 @@ +USING: alien alien.c-types windows.com.syntax windows.ole32 +windows.types continuations kernel ; +IN: windows.com + +COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} + HRESULT QueryInterface ( REFGUID iid, void** ppvObject ) + ULONG AddRef ( ) + ULONG Release ( ) ; + +: com-query-interface ( interface iid -- interface' ) + f + [ IUnknown::QueryInterface ole32-error ] keep + *void* ; + +: com-add-ref ( interface -- interface ) + [ IUnknown::AddRef drop ] keep ; inline + +: com-release ( interface -- ) + IUnknown::Release drop ; inline + +: with-com-interface ( interface quot -- ) + [ keep ] [ com-release ] [ ] cleanup ; inline diff --git a/extra/windows/com/summary.txt b/extra/windows/com/summary.txt new file mode 100644 index 0000000000..779367e673 --- /dev/null +++ b/extra/windows/com/summary.txt @@ -0,0 +1 @@ +COM interface diff --git a/extra/windows/com/syntax/authors.txt b/extra/windows/com/syntax/authors.txt new file mode 100644 index 0000000000..6a1b3e726a --- /dev/null +++ b/extra/windows/com/syntax/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/windows/com/syntax/summary.txt b/extra/windows/com/syntax/summary.txt new file mode 100644 index 0000000000..6c2977a108 --- /dev/null +++ b/extra/windows/com/syntax/summary.txt @@ -0,0 +1 @@ +Parsing words for defining COM interfaces diff --git a/extra/windows/com/syntax/syntax-docs.factor b/extra/windows/com/syntax/syntax-docs.factor new file mode 100644 index 0000000000..fa06d5e4e7 --- /dev/null +++ b/extra/windows/com/syntax/syntax-docs.factor @@ -0,0 +1,26 @@ +USING: help.markup help.syntax io kernel math quotations +multiline ; +IN: windows.com.syntax + +HELP: COM-INTERFACE: +{ $syntax <" +COM-INTERFACE: + ( ) + ( ) + ... ; +"> } +{ $description "\nFor the interface " { $snippet "" } ", a word " { $snippet "-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "::" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "" } ". A " { $snippet "" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" } +{ $code <" +COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} + HRESULT QueryInterface ( REFGUID iid, void** ppvObject ) + ULONG AddRef ( ) + ULONG Release ( ) ; + +COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} + HRESULT returnOK ( ) + HRESULT returnError ( ) ; + +COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} + int getX ( ) + void setX ( int newX ) ; +"> } ; diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor new file mode 100644 index 0000000000..32e7433d88 --- /dev/null +++ b/extra/windows/com/syntax/syntax.factor @@ -0,0 +1,90 @@ +USING: alien alien.c-types kernel windows.ole32 +combinators.lib parser splitting sequences.lib +sequences namespaces new-slots combinators.cleave +assocs quotations shuffle accessors words macros +alien.syntax fry ; +IN: windows.com.syntax + + com-interface-definition + +TUPLE: com-function-definition name return parameters ; +C: com-function-definition + +SYMBOL: +com-interface-definitions+ ++com-interface-definitions+ get-global +[ H{ } +com-interface-definitions+ set-global ] +unless + +: find-com-interface-definition ( name -- definition ) + dup "f" = [ drop f ] [ + dup +com-interface-definitions+ get-global at* + [ nip ] + [ swap " COM interface hasn't been defined" append throw ] + if + ] if ; + +: save-com-interface-definition ( definition -- ) + dup name>> +com-interface-definitions+ get-global set-at ; + +: (parse-com-function) ( tokens -- definition ) + [ second ] + [ first ] + [ 3 tail 2 group [ first ] map "void*" add* ] + tri + ; + +: parse-com-functions ( -- functions ) + ";" parse-tokens { ")" } split + [ empty? not ] subset + [ (parse-com-function) ] map ; + +: (iid-word) ( definition -- word ) + name>> "-iid" append create-in ; + +: (function-word) ( function interface -- word ) + name>> "::" rot name>> 3append create-in ; + +: all-functions ( definition -- functions ) + dup parent>> [ all-functions ] [ { } ] if* + swap functions>> append ; + +: (define-word-for-function) ( function interface n -- ) + -rot [ (function-word) swap ] 2keep drop + { return>> parameters>> } get-slots + [ com-invoke ] 3curry + define ; + +: define-words-for-com-interface ( definition -- ) + [ [ (iid-word) ] [ iid>> 1quotation ] bi define ] + [ name>> "com-interface" swap typedef ] + [ + dup all-functions + [ (define-word-for-function) ] with each-index + ] + tri ; + +PRIVATE> + +: COM-INTERFACE: + scan + scan find-com-interface-definition + scan string>guid + parse-com-functions + + dup save-com-interface-definition + define-words-for-com-interface + ; parsing + diff --git a/extra/windows/com/syntax/tags.txt b/extra/windows/com/syntax/tags.txt new file mode 100644 index 0000000000..49139bab66 --- /dev/null +++ b/extra/windows/com/syntax/tags.txt @@ -0,0 +1,3 @@ +windows +com +bindings diff --git a/extra/windows/com/tags.txt b/extra/windows/com/tags.txt new file mode 100644 index 0000000000..49139bab66 --- /dev/null +++ b/extra/windows/com/tags.txt @@ -0,0 +1,3 @@ +windows +com +bindings diff --git a/extra/windows/errors/authors.txt b/extra/windows/errors/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/errors/errors.factor b/extra/windows/errors/errors.factor old mode 100755 new mode 100644 diff --git a/extra/windows/gdi32/authors.txt b/extra/windows/gdi32/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/kernel32/authors.txt b/extra/windows/kernel32/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor old mode 100755 new mode 100644 diff --git a/extra/windows/messages/authors.txt b/extra/windows/messages/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/messages/messages.factor b/extra/windows/messages/messages.factor old mode 100755 new mode 100644 diff --git a/extra/windows/nt/authors.txt b/extra/windows/nt/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/nt/nt.factor b/extra/windows/nt/nt.factor index 8a709416d8..1dc997b38a 100644 --- a/extra/windows/nt/nt.factor +++ b/extra/windows/nt/nt.factor @@ -12,4 +12,5 @@ USING: alien sequences ; { "gl" "opengl32.dll" "stdcall" } { "glu" "glu32.dll" "stdcall" } { "freetype" "freetype6.dll" "cdecl" } + { "ole32" "ole32.dll" "stdcall" } } [ first3 add-library ] each diff --git a/extra/windows/ole32/authors.txt b/extra/windows/ole32/authors.txt new file mode 100644 index 0000000000..6a1b3e726a --- /dev/null +++ b/extra/windows/ole32/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor new file mode 100644 index 0000000000..44ea853af0 --- /dev/null +++ b/extra/windows/ole32/ole32.factor @@ -0,0 +1,59 @@ +USING: alien alien.syntax alien.c-types math kernel sequences +windows windows.types combinators.lib ; +IN: windows.ole32 + +LIBRARY: ole32 + +C-STRUCT: GUID + { "DWORD" "part1" } + { "DWORD" "part2" } + { "DWORD" "part3" } + { "DWORD" "part4" } ; + +TYPEDEF: void* REFGUID +TYPEDEF: void* LPUNKNOWN +TYPEDEF: ushort* LPOLESTR +TYPEDEF: ushort* LPCOLESTR + +TYPEDEF: REFGUID REFIID +TYPEDEF: REFGUID REFCLSID + +FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ; +FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ; +FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ; +FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ; + +: S_OK 0 ; inline +: S_FALSE 1 ; inline +: E_FAIL HEX: 80004005 ; inline +: E_INVALIDARG HEX: 80070057 ; inline + +: MK_ALT HEX: 20 ; inline +: DROPEFFECT_NONE 0 ; inline +: DROPEFFECT_COPY 1 ; inline +: DROPEFFECT_MOVE 2 ; inline +: DROPEFFECT_LINK 4 ; inline +: DROPEFFECT_SCROLL HEX: 80000000 ; inline +: DD_DEFSCROLLINSET 11 ; inline +: DD_DEFSCROLLDELAY 50 ; inline +: DD_DEFSCROLLINTERVAL 50 ; inline +: DD_DEFDRAGDELAY 200 ; inline +: DD_DEFDRAGMINDIST 2 ; inline + +: ole32-error ( n -- ) + dup S_OK = [ + drop + ] [ (win32-error-string) throw ] if ; + +: guid= ( a b -- ? ) + IsEqualGUID c-bool> ; + +: GUID-STRING-LENGTH + "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline + +: string>guid ( string -- guid ) + string>u16-alien "GUID" [ CLSIDFromString ole32-error ] keep ; +: guid>string ( guid -- string ) + GUID-STRING-LENGTH 1+ [ "ushort" ] keep + [ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ; + diff --git a/extra/windows/opengl32/authors.txt b/extra/windows/opengl32/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/opengl32/opengl32.factor b/extra/windows/opengl32/opengl32.factor old mode 100755 new mode 100644 diff --git a/extra/windows/shell32/authors.txt b/extra/windows/shell32/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor index 501f49edfe..d64fb68cb3 100644 --- a/extra/windows/shell32/shell32.factor +++ b/extra/windows/shell32/shell32.factor @@ -1,5 +1,6 @@ USING: alien alien.c-types alien.syntax combinators -kernel windows windows.user32 ; +kernel windows windows.user32 windows.ole32 +windows.com windows.com.syntax ; IN: windows.shell32 : CSIDL_DESKTOP HEX: 00 ; inline @@ -68,10 +69,6 @@ IN: windows.shell32 : CSIDL_FLAG_MASK HEX: ff00 ; inline -: S_OK 0 ; inline -: S_FALSE 1 ; inline -: E_FAIL HEX: 80004005 ; inline -: E_INVALIDARG HEX: 80070057 ; inline : ERROR_FILE_NOT_FOUND 2 ; inline : SHGFP_TYPE_CURRENT 0 ; inline @@ -89,15 +86,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi f "open" rot f f SW_SHOWNORMAL ShellExecute drop ; : shell32-error ( n -- ) - dup S_OK = [ - drop - ] [ - { - ! { ERROR_FILE_NOT_FOUND [ "file not found" throw ] } - ! { E_INVALIDARG [ "invalid arg" throw ] } - [ (win32-error-string) throw ] - } case - ] if ; + ole32-error ; inline : shell32-directory ( n -- str ) f swap f SHGFP_TYPE_DEFAULT @@ -130,3 +119,96 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi : program-files-common-x86 ( -- str ) CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ; + +: SHCONTF_FOLDERS 32 ; inline +: SHCONTF_NONFOLDERS 64 ; inline +: SHCONTF_INCLUDEHIDDEN 128 ; inline +: SHCONTF_INIT_ON_FIRST_NEXT 256 ; inline +: SHCONTF_NETPRINTERSRCH 512 ; inline +: SHCONTF_SHAREABLE 1024 ; inline +: SHCONTF_STORAGE 2048 ; inline + +TYPEDEF: DWORD SHCONTF + +: SHGDN_NORMAL 0 ; inline +: SHGDN_INFOLDER 1 ; inline +: SHGDN_FOREDITING HEX: 1000 ; inline +: SHGDN_INCLUDE_NONFILESYS HEX: 2000 ; inline +: SHGDN_FORADDRESSBAR HEX: 4000 ; inline +: SHGDN_FORPARSING HEX: 8000 ; inline + +TYPEDEF: DWORD SHGDNF + +: SFGAO_CANCOPY DROPEFFECT_COPY ; inline +: SFGAO_CANMOVE DROPEFFECT_MOVE ; inline +: SFGAO_CANLINK DROPEFFECT_LINK ; inline +: SFGAO_CANRENAME HEX: 00000010 ; inline +: SFGAO_CANDELETE HEX: 00000020 ; inline +: SFGAO_HASPROPSHEET HEX: 00000040 ; inline +: SFGAO_DROPTARGET HEX: 00000100 ; inline +: SFGAO_CAPABILITYMASK HEX: 00000177 ; inline +: SFGAO_LINK HEX: 00010000 ; inline +: SFGAO_SHARE HEX: 00020000 ; inline +: SFGAO_READONLY HEX: 00040000 ; inline +: SFGAO_GHOSTED HEX: 00080000 ; inline +: SFGAO_HIDDEN HEX: 00080000 ; inline +: SFGAO_DISPLAYATTRMASK HEX: 000F0000 ; inline +: SFGAO_FILESYSANCESTOR HEX: 10000000 ; inline +: SFGAO_FOLDER HEX: 20000000 ; inline +: SFGAO_FILESYSTEM HEX: 40000000 ; inline +: SFGAO_HASSUBFOLDER HEX: 80000000 ; inline +: SFGAO_CONTENTSMASK HEX: 80000000 ; inline +: SFGAO_VALIDATE HEX: 01000000 ; inline +: SFGAO_REMOVABLE HEX: 02000000 ; inline +: SFGAO_COMPRESSED HEX: 04000000 ; inline +: SFGAO_BROWSABLE HEX: 08000000 ; inline +: SFGAO_NONENUMERATED HEX: 00100000 ; inline +: SFGAO_NEWCONTENT HEX: 00200000 ; inline + +TYPEDEF: ULONG SFGAOF + +C-STRUCT: SHITEMID + { "USHORT" "cb" } + { "BYTE[1]" "abID" } ; +TYPEDEF: SHITEMID* LPSHITEMID +TYPEDEF: SHITEMID* LPCSHITEMID + +C-STRUCT: ITEMIDLIST + { "SHITEMID" "mkid" } ; +TYPEDEF: ITEMIDLIST* LPITEMIDLIST +TYPEDEF: ITEMIDLIST* LPCITEMIDLIST +TYPEDEF: ITEMIDLIST ITEMID_CHILD +TYPEDEF: ITEMID_CHILD* PITEMID_CHILD +TYPEDEF: ITEMID_CHILD* PCUITEMID_CHILD + +: STRRET_WSTR 0 ; inline +: STRRET_OFFSET 1 ; inline +: STRRET_CSTR 2 ; inline + +C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ; +C-STRUCT: STRRET + { "int" "uType" } + { "STRRET-union" "union" } ; + +COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046} + HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched ) + HRESULT Skip ( ULONG celt ) + HRESULT Reset ( ) + HRESULT Clone ( IEnumIDList** ppenum ) ; + +COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046} + HRESULT ParseDisplayName ( HWND hwndOwner, void* pbcReserved, LPOLESTR lpszDisplayName, ULONG* pchEaten, LPITEMIDLIST* ppidl, ULONG* pdwAttributes ) + HRESULT EnumObjects ( HWND hwndOwner, SHCONTF grfFlags, IEnumIDList** ppenumIDList ) + HRESULT BindToObject ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvOut ) + HRESULT BindToStorage ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvObj ) + HRESULT CompareIDs ( LPARAM lParam, LPCITEMIDLIST pidl1, LPCITEMIDLIST pidl2 ) + HRESULT CreateViewObject ( HWND hwndOwner, REFGUID riid, void** ppvOut ) + HRESULT GetAttributesOf ( UINT cidl, LPCITEMIDLIST* apidl, SFGAOF* rgfInOut ) + HRESULT GetUIObjectOf ( HWND hwndOwner, UINT cidl, LPCITEMIDLIST* apidl, REFGUID riid, UINT* prgfInOut, void** ppvOut ) + HRESULT GetDisplayNameOf ( LPCITEMIDLIST pidl, SHGDNF uFlags, STRRET* lpName ) + HRESULT SetNameOf ( HWND hwnd, LPCITEMIDLIST pidl, LPCOLESTR lpszName, SHGDNF uFlags, LPITEMIDLIST* ppidlOut ) ; + +FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ; + +FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ; +: StrRetToBuf StrRetToBufW ; inline diff --git a/extra/windows/time/authors.txt b/extra/windows/time/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/time/time-tests.factor b/extra/windows/time/time-tests.factor old mode 100755 new mode 100644 diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor old mode 100755 new mode 100644 diff --git a/extra/windows/types/authors.txt b/extra/windows/types/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/user32/authors.txt b/extra/windows/user32/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor old mode 100755 new mode 100644 index 39879bf91d..e3e8a23ca7 --- a/extra/windows/user32/user32.factor +++ b/extra/windows/user32/user32.factor @@ -1283,7 +1283,13 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ; ! FUNCTION: SetWindowLongA ! FUNCTION: SetWindowLongW ! FUNCTION: SetWindowPlacement -! FUNCTION: SetWindowPos +FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ; + +: HWND_BOTTOM ALIEN: 1 ; +: HWND_NOTOPMOST ALIEN: -2 ; +: HWND_TOP ALIEN: 0 ; +: HWND_TOPMOST ALIEN: -1 ; + ! FUNCTION: SetWindowRgn ! FUNCTION: SetWindowsHookA ! FUNCTION: SetWindowsHookExA diff --git a/extra/windows/windows.factor b/extra/windows/windows.factor old mode 100755 new mode 100644 diff --git a/extra/windows/winsock/authors.txt b/extra/windows/winsock/authors.txt old mode 100755 new mode 100644 diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor old mode 100755 new mode 100644 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.el b/misc/factor.el index 5515476c22..7513c3640d 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -158,6 +158,11 @@ (insert str) (comint-send-input)))) +(defun factor-send-definition () + (interactive) + (factor-send-region (search-backward ":") + (search-forward ";"))) + (defun factor-see () (interactive) (comint-send-string "*factor*" "\\ ") @@ -187,6 +192,7 @@ (define-key factor-mode-map "\C-c\C-f" 'factor-run-file) (define-key factor-mode-map "\C-c\C-r" 'factor-send-region) +(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition) (define-key factor-mode-map "\C-c\C-s" 'factor-see) (define-key factor-mode-map "\C-ce" 'factor-edit) (define-key factor-mode-map "\C-c\C-h" 'factor-help) @@ -211,4 +217,6 @@ (defun factor-refresh-all () (interactive) - (comint-send-string "*factor*" "refresh-all\n")) \ No newline at end of file + (comint-send-string "*factor*" "refresh-all\n")) + + diff --git a/vm/alien.c b/vm/alien.c index 26d9464700..a7dd654cf2 100755 --- a/vm/alien.c +++ b/vm/alien.c @@ -197,15 +197,15 @@ DEFINE_PRIMITIVE(dlsym) F_DLL *d; if(dll == F) - d = NULL; + box_alien(ffi_dlsym(NULL,sym)); else { d = untag_dll(dll); if(d->dll == NULL) dpush(F); + else + box_alien(ffi_dlsym(d,sym)); } - - box_alien(ffi_dlsym(d,sym)); } /* close a native library handle */ diff --git a/vm/code_gc.c b/vm/code_gc.c index 5c51fe7e8b..5b0d2ebabb 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -375,6 +375,8 @@ void forward_object_xts(void) F_WORD *word = untag_object(obj); word->code = forward_xt(word->code); + if(word->profiling) + word->profiling = forward_xt(word->profiling); } else if(type_of(obj) == QUOTATION_TYPE) { diff --git a/vm/data_gc.h b/vm/data_gc.h index d9c3d8eb1c..8f93ce79a1 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -263,13 +263,18 @@ DEFPUSHPOP(root_,extra_roots) #define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0) #define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop()) +INLINE bool in_data_heap_p(CELL ptr) +{ + return (ptr >= data_heap->segment->start + && ptr <= data_heap->segment->end); +} + /* We ignore strings which point outside the data heap, but we might be given a char* which points inside the data heap, in which case it is a root, for example if we call unbox_char_string() the result is placed in a byte array */ INLINE bool root_push_alien(const void *ptr) { - if((CELL)ptr > data_heap->segment->start - && (CELL)ptr < data_heap->segment->end) + if(in_data_heap_p((CELL)ptr)) { F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1; if(objptr->header == tag_header(BYTE_ARRAY_TYPE))