diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 475cf72d28..95b29ee50b 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\"" } } } 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 b58c685cf8..ca35cb3696 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -58,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.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/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..0b686e3c7f 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -87,11 +87,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 class { $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..9fd5481a39 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 ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 313f487c99..c634e02e75 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#) 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/files/files.factor b/core/io/files/files.factor index 18cdbd3791..a6320a7507 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -86,16 +86,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 @@ -222,10 +216,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 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/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/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 10a9fda3ea..5153d84c7f 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 swap append ; + +: 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/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..d9870b08da 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,7 +158,7 @@ IN: bootstrap.syntax ] define-syntax "C:" [ - CREATE dup reset-generic + CREATE-WORD scan-word dup check-tuple [ construct-boa ] curry define-inline ] define-syntax 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-tests.factor b/core/vocabs/loader/loader-tests.factor index 514e45f10f..015f54540d 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -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 @@ -118,6 +120,13 @@ IN: vocabs.loader.tests [ { "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? diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index fa9ff5b504..96193ef664 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -43,7 +43,7 @@ V{ vocab-roots get swap [ vocab-dir? ] curry find nip ; M: string vocab-root - dup vocab [ vocab-root ] [ find-vocab-root ] ?if ; + vocab dup [ vocab-root ] when ; M: vocab-link vocab-root vocab-link-root ; @@ -66,24 +66,22 @@ 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 ; +: create-vocab-with-root ( name root -- vocab ) + swap create-vocab [ set-vocab-root ] keep ; + +: update-root ( vocab -- ) + dup vocab-root + [ drop ] [ dup find-vocab-root swap set-vocab-root ] if ; : reload ( name -- ) [ - 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 update-root dup load-source load-docs + ] [ no-vocab ] ?if ] with-compiler-errors ; : require ( vocab -- ) @@ -100,33 +98,38 @@ 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 update-root + + dup vocab-root [ + [ dup vocab-source-loaded? [ dup load-source ] unless dup vocab-docs-loaded? [ dup load-docs ] unless - ] when - ] [ [ swap add-to-blacklist ] keep rethrow ] recover ; + ] [ [ swap add-to-blacklist ] keep rethrow ] recover + ] when drop ; M: string (load-vocab) - [ ".private" ?tail drop reload ] keep vocab ; + ! ".private" ?tail drop + dup find-vocab-root >vocab-link (load-vocab) ; M: vocab-link (load-vocab) - vocab-name (load-vocab) ; + dup vocab-name swap vocab-root dup + [ create-vocab-with-root (load-vocab) ] [ 2drop ] if ; [ - 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.factor b/core/vocabs/vocabs.factor index 1a3fecc3fb..9d281c864b 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 ; @@ -115,8 +122,3 @@ UNION: vocab-spec vocab vocab-link ; 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/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/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/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/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/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/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..bca904279b 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 ; @@ -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 -- ) @@ -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..a0414f334d 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 ; 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/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..34e90b2ccf 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -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..7cfe384bde 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 -- ) + dup vocab-root >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/http/http-tests.factor b/extra/http/http-tests.factor index 66182b10ae..2e7370bc39 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -5,8 +5,8 @@ IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test [ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test -[ "" ] [ "%XX%XX%XX" url-decode ] unit-test -[ "" ] [ "%XX%XX%X" url-decode ] unit-test +[ f ] [ "%XX%XX%XX" url-decode ] unit-test +[ f ] [ "%XX%XX%X" url-decode ] unit-test [ "hello world" ] [ "hello+world" url-decode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 91671392c7..52567ed352 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -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 ; + '[ + , , + [ +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..d51679016e 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 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/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/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor old mode 100644 new mode 100755 index aa54d3ec94..6fa8c913aa --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -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 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/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/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..a8f5e139e7 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -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/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/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/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/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/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/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/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 675a2e1d6e..82c411cbfb 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -19,16 +19,16 @@ IN: tools.vocabs ] [ drop ] if ; : vocab-tests ( vocab -- tests ) - dup vocab-root [ + dup vocab-root dup [ [ - f >vocab-link dup + >vocab-link dup vocab-tests-file, vocab-tests-dir, ] { } make - ] [ drop f ] if ; + ] [ 2drop f ] if ; : vocab-files ( vocab -- seq ) - f >vocab-link [ + dup find-vocab-root >vocab-link [ dup vocab-source-path [ , ] when* dup vocab-docs-path [ , ] when* vocab-tests % 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..610d3db0a3 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -3,33 +3,51 @@ 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* ; -: break ( -- ) - continuation callstack over set-continuation-call +USING: io.streams.c prettyprint ; - get-walker-thread send-synchronous { +: 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" throw ] } } cond ; +: break ( -- ) + continuation callstack over set-continuation-call + show-walker send-synchronous + after-break ; + \ break t "break?" set-word-prop : walk ( quot -- quot' ) @@ -71,15 +89,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 +157,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 +199,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 +215,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/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/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..0c9c23cf76 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -376,6 +376,22 @@ SYMBOL: trace-messages? : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ; +! ! ! ! +: set-world-dim ( dim world -- ) + swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0 + SetWindowPos drop ; +USE: random +USE: arrays + +: twiddle + 100 500 random + + 100 500 random + + 2array + "x" get-global find-world + set-world-dim + yield ; +! ! ! ! + : event-loop ( msg -- ) { { [ windows get empty? ] [ drop ] } @@ -436,17 +452,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/user32/user32.factor b/extra/windows/user32/user32.factor index 39879bf91d..e3e8a23ca7 100644 --- 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/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))