From 382868b3623d7da5508d3e04021abdfe496f6773 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 15 Mar 2008 23:21:53 -0500 Subject: [PATCH 01/38] add a test to make sure assigned ids can't be inserted twice fix a bug with sqlite finalizers --- extra/db/sqlite/lib/lib.factor | 4 +++- extra/db/sqlite/sqlite.factor | 3 ++- extra/db/tuples/tuples-tests.factor | 13 +++++++++++-- 3 files changed, 16 insertions(+), 4 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index d630522eb8..ec07adca25 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -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 @@ -140,7 +142,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..b8ef5c7b17 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -38,7 +38,8 @@ M: sqlite-db ( str in out -- obj ) sqlite-statement construct-delegate ; M: sqlite-statement dispose ( statement -- ) - statement-handle sqlite-finalize ; + statement-handle + [ sqlite3_reset drop ] keep sqlite-finalize ; M: sqlite-result-set dispose ( result-set -- ) f swap set-result-set-handle ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index ba6441bc53..8e347490e4 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -193,8 +193,17 @@ TUPLE: annotation n paste-id summary author mode contents ; [ 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 ; + +[ native-person-schema test-tuples ] test-postgresql +[ assigned-person-schema test-tuples ] test-postgresql + +[ assigned-person-schema test-repeated-insert ] test-sqlite +[ assigned-person-schema test-repeated-insert ] test-postgresql TUPLE: serialize-me id data ; From 20ed8ab9a2074caf486ee0f9ee4c2069041ff599 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:17:05 -0500 Subject: [PATCH 02/38] Fix code heap compaction bug --- vm/code_gc.c | 2 ++ vm/data_gc.h | 9 +++++++-- 2 files changed, 9 insertions(+), 2 deletions(-) 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)) From ae480fb329f686e16642cfcc03384fa3ba6c7cc3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:17:32 -0500 Subject: [PATCH 03/38] SetWindowPos --- extra/windows/user32/user32.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor index 39879bf91d..e3e8a23ca7 100755 --- 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 From d0687751ed4fa9838ecfd509d3327560ba787213 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:18:05 -0500 Subject: [PATCH 04/38] Fix Windows UI memory corruption --- extra/ui/windows/windows.factor | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) 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 From 194b0d827efa8e2dc7e35c2beb42d1f77b8ebea8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:18:28 -0500 Subject: [PATCH 05/38] Clarify docs for constructors --- core/tuples/tuples-docs.factor | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) 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" } } From 91f4dadea80b2cce376d68c0630d96498e916b61 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:19:04 -0500 Subject: [PATCH 06/38] Fix openssl binding on Windows --- extra/openssl/libcrypto/libcrypto.factor | 2 +- extra/openssl/libssl/libssl.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/openssl/libssl/libssl.factor 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 >> From 8b956d1efa50f8df464c864d30f540adad489d14 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:21:51 -0500 Subject: [PATCH 07/38] Fixing deployment --- core/alien/c-types/c-types.factor | 4 ++-- core/io/files/files.factor | 5 +---- core/io/io.factor | 8 +++++--- extra/bootstrap/tools/tools.factor | 1 + extra/io/unix/unix.factor | 2 -- extra/io/windows/nt/nt.factor | 2 -- extra/tools/deploy/shaker/shaker.factor | 7 ++++--- extra/ui/freetype/freetype.factor | 5 +---- 8 files changed, 14 insertions(+), 20 deletions(-) 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/io/files/files.factor b/core/io/files/files.factor index 18cdbd3791..5de86d0baa 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -222,10 +222,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/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/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/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/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 From ec698b7f53fbd5af40a5eef170eb0dc93e243e5d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:43:00 -0500 Subject: [PATCH 08/38] Parser overhaul --- core/debugger/debugger.factor | 2 +- core/generic/generic-docs.factor | 13 ++--- core/generic/generic.factor | 54 +++++++------------ core/generic/math/math.factor | 2 +- core/generic/standard/standard.factor | 4 -- .../specializers/specializers.factor | 36 ++++++++++--- core/parser/parser.factor | 20 +++++-- core/slots/slots.factor | 3 +- core/syntax/syntax.factor | 19 +++---- core/words/words.factor | 2 +- extra/delegate/delegate.factor | 2 +- extra/locals/locals-tests.factor | 19 ++++++- extra/locals/locals.factor | 20 ++----- extra/memoize/memoize.factor | 2 +- extra/multiline/multiline.factor | 2 +- extra/promises/promises.factor | 2 +- extra/unicode/data/data.factor | 2 +- 17 files changed, 111 insertions(+), 93 deletions(-) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 40bcbe78b1..ad2fa14954 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -214,7 +214,7 @@ M: check-closed summary drop "Attempt to perform I/O on closed stream" ; M: check-method summary - drop "Invalid parameters for define-method" ; + drop "Invalid parameters for create-method" ; M: check-tuple summary drop "Invalid class for define-constructor" ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 9b799d9143..62b85dde3a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -34,7 +34,7 @@ $nl { $subsection define-generic } { $subsection define-simple-generic } "Methods can be added to existing generic words:" -{ $subsection define-method } +{ $subsection create-method } "Method definitions can be looked up:" { $subsection method } { $subsection methods } @@ -123,7 +123,7 @@ HELP: method { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } } { $description "Looks up a method definition." } ; -{ method define-method POSTPONE: M: } related-words +{ method create-method POSTPONE: M: } related-words HELP: { $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } } @@ -140,16 +140,17 @@ HELP: order HELP: check-method { $values { "class" class } { "generic" generic } } { $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." } -{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ; +{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ; HELP: with-methods { $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } } { $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." } $low-level-note ; -HELP: define-method -{ $values { "quot" quotation } { "class" class } { "generic" generic } } -{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ; +HELP: create-method +{ $values { "class" class } { "generic" generic } { "method" method-body } } +{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." } +{ $notes "To define a method, pass the output value to " { $link define } "." } ; HELP: implementors { $values { "class" class } { "seq" "a sequence of generic words" } } diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 3c83b87d49..ad31831e94 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,11 +98,10 @@ 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 @@ -125,9 +114,6 @@ M: method-spec 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 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/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.factor b/core/parser/parser.factor index 50f8f582d3..c955817ab9 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 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 ) 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/words/words.factor b/core/words/words.factor index ce69c1ff2e..73b877fdbb 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 ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 654d096b26..9eabfae95c 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 ; 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/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/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/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 ; From bc71849bf665e071a291bfdfbdee9ca031193b86 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:44:17 -0500 Subject: [PATCH 09/38] Fix bogus f variable in global namespace --- core/threads/threads-tests.factor | 2 ++ core/threads/threads.factor | 2 -- 2 files changed, 2 insertions(+), 2 deletions(-) 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 -- ? ) From d06db3f628693ad5d40933cb6ca8b8bf056ba24d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:44:39 -0500 Subject: [PATCH 10/38] Fix bootstrap error exit code --- core/bootstrap/stage1.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 0e038d0a10..74b4d03cbb 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ; "listener" vocab [ restarts. vocab-main execute ] [ die ] if* + 1 exit ] recover ] [ "Cannot find " write write "." print From 7d3c590cfe1a35437d8236629d46bce154f3b24a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:45:45 -0500 Subject: [PATCH 11/38] Update logging for parser change --- extra/logging/logging.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) 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 From 254d8455a3875d80e4d9328b98292a5892c32361 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 03:43:24 -0500 Subject: [PATCH 12/38] load-library returns f if library not defined --- core/alien/alien-docs.factor | 3 +-- core/alien/alien.factor | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) 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.factor b/core/alien/alien.factor index 0369d55fb3..bce2e16d73 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -57,7 +57,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 ; From 4a4eb8b7bb59f9528ebed001c2cdd136680361f6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 03:43:30 -0500 Subject: [PATCH 13/38] Fix :help --- extra/help/help-tests.factor | 5 +++++ extra/help/help.factor | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) create mode 100644 extra/help/help-tests.factor 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 From 8a8a94206d62abdf8f36ff2c26384ed39c65e646 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 03:51:43 -0500 Subject: [PATCH 14/38] Update unit tests --- core/definitions/definitions-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 4e8fb255dd..ebbce4d7e2 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -1,10 +1,10 @@ IN: definitions.tests USING: tools.test generic kernel definitions sequences -compiler.units ; +compiler.units words ; TUPLE: combination-1 ; -M: combination-1 perform-combination 2drop { } [ ] each [ ] ; +M: combination-1 perform-combination 2drop [ ] ; M: combination-1 make-default-method 2drop [ "No method" throw ] ; @@ -13,7 +13,7 @@ SYMBOL: generic-1 [ generic-1 T{ combination-1 } define-generic - [ ] object \ generic-1 define-method + object \ generic-1 create-method [ ] define ] with-compilation-unit [ ] [ From d46de0ae592b4edae72f819cce08522b58d11f66 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 16 Mar 2008 15:57:22 -0600 Subject: [PATCH 15/38] io.files: remove old code --- core/io/files/files.factor | 6 ------ extra/builder/benchmark/benchmark.factor | 10 ++++++---- 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 18cdbd3791..e5c6ca9ce5 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 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 ) From 3cc32597f83dc86831f3d828b48417f0bc0acab7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 16 Mar 2008 15:57:37 -0600 Subject: [PATCH 16/38] factor.el: minor additions --- misc/factor.el | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) 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")) + + From 3d2ee2a35c0477804f533585455fece81101e27e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 16 Mar 2008 15:57:56 -0600 Subject: [PATCH 17/38] Add more gl-docs --- extra/opengl/gl/gl-docs.factor | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) 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 + + From ea2723a5a0661f2c2b8d14adaa31e9912c84cc41 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 23:41:26 -0500 Subject: [PATCH 18/38] Fix serialization of circular structure --- extra/db/postgresql/lib/lib.factor | 4 +- extra/db/sqlite/lib/lib.factor | 4 +- extra/reports/optimizer/optimizer.factor | 28 +++ extra/serialize/serialize-tests.factor | 30 +++- extra/serialize/serialize.factor | 206 +++++++++++++---------- 5 files changed, 177 insertions(+), 95 deletions(-) create mode 100755 extra/reports/optimizer/optimizer.factor 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/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index d630522eb8..2e9248c429 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 ] } @@ -131,7 +131,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 ] diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor new file mode 100755 index 0000000000..294ec8c979 --- /dev/null +++ b/extra/reports/optimizer/optimizer.factor @@ -0,0 +1,28 @@ +USING: assocs words sequences arrays compiler tools.time +io.styles io prettyprint vocabs kernel sorting generator +optimizer math ; +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 ; + +: optimizer-report + all-words [ compiled? ] subset + [ + dup [ + word-dataflow nip 1 count-optimization-passes + ] benchmark nip 2array + ] { } map>assoc + [ first ] "Worst number of optimizer passes:" results + [ second ] "Worst compile times:" results ; + +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..65464d4e32 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -11,8 +11,9 @@ 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.encodings.string io.encodings.utf8 combinators +combinators.cleave new-slots accessors locals prettyprint +compiler.units sequences.private tuples.private ; ! 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 @@ -283,13 +317,15 @@ SYMBOL: +stop+ : 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 From 2947297cefc8e60fe1524f6ae9825992775a7c17 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 23:42:21 -0500 Subject: [PATCH 19/38] Reports --- extra/reports/noise/noise.factor | 129 +++++++++++++++++++++++ extra/reports/optimizer/optimizer.factor | 17 +-- 2 files changed, 140 insertions(+), 6 deletions(-) create mode 100755 extra/reports/noise/noise.factor diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor new file mode 100755 index 0000000000..230eef523e --- /dev/null +++ b/extra/reports/noise/noise.factor @@ -0,0 +1,129 @@ +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 ; +IN: reports.noise + +: badness ( word -- n ) + H{ + { -nrot 5 } + { -roll 4 } + { -rot 3 } + { 2apply 1 } + { 2curry 1 } + { 2drop 1 } + { 2dup 2 } + { 2keep 2 } + { 2nip 3 } + { 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/2 } + { dip 1 } + { dipd 2 } + { drop 1/2 } + { dup 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 3 } + { with 1 } + { with* 2 } + { r> 1/2 } + { >r 1/2 } + + { 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/3 0 } v+ ; + +M: array noise [ noise ] map vsum { 1/3 0 } v+ ; + +: 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 15 max / 100 * >integer ; + +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 ; + +: noisy-words ( -- alist ) + all-words [ + dup generic? [ methods values ] [ 1array ] if + ] map concat [ dup word-noise-factor ] { } map>assoc + sort-values reverse ; + +: noisy-words. ( alist -- ) + standard-table-style [ + [ + [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row + ] assoc-each + ] tabular-output ; + +: noise-report ( -- ) + noisy-words 40 head noisy-words. ; + +MAIN: noise-report diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor index 294ec8c979..42e72dee45 100755 --- a/extra/reports/optimizer/optimizer.factor +++ b/extra/reports/optimizer/optimizer.factor @@ -1,6 +1,6 @@ USING: assocs words sequences arrays compiler tools.time io.styles io prettyprint vocabs kernel sorting generator -optimizer math ; +optimizer math combinators.cleave ; IN: report.optimizer : count-optimization-passes ( nodes n -- n ) @@ -13,16 +13,21 @@ IN: report.optimizer standard-table-style [ [ [ [ pprint-cell ] each ] with-row ] each - ] tabular-output ; + ] tabular-output ; inline -: optimizer-report +: optimizer-measurements ( -- alist ) all-words [ compiled? ] subset [ dup [ word-dataflow nip 1 count-optimization-passes ] benchmark nip 2array - ] { } map>assoc - [ first ] "Worst number of optimizer passes:" results - [ second ] "Worst compile times:" results ; + ] { } 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 From 16e6f36fc97ef2ddd2880b0775007ead904e822f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 17 Mar 2008 00:26:05 -0500 Subject: [PATCH 20/38] refactor db start on random-id --- extra/db/db.factor | 24 ++++++++++++++++- extra/db/postgresql/postgresql.factor | 3 ++- extra/db/sqlite/sqlite.factor | 25 ++++++++++++++---- extra/db/tuples/tuples-tests.factor | 8 +++--- extra/db/tuples/tuples.factor | 16 +++++++----- extra/db/types/types.factor | 37 +++++++++++++++------------ 6 files changed, 79 insertions(+), 34 deletions(-) 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/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/sqlite.factor b/extra/db/sqlite/sqlite.factor index b8ef5c7b17..1b594d6fa4 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,13 +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 - [ sqlite3_reset drop ] keep sqlite-finalize ; + [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ; M: sqlite-result-set dispose ( result-set -- ) f swap set-result-set-handle ; @@ -47,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 ; @@ -90,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 ; @@ -126,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 -- ) @@ -176,6 +190,7 @@ M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } + ! { +nonnative-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 8e347490e4..2dbf6d1008 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,18 +190,16 @@ 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 - : test-repeated-insert [ ] [ person ensure-table ] unit-test [ ] [ person1 get insert-tuple ] unit-test [ person1 get insert-tuple ] must-fail ; +[ 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 - [ assigned-person-schema test-repeated-insert ] test-sqlite [ assigned-person-schema test-repeated-insert ] test-postgresql 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..532c097957 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,32 @@ 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+ ; + +! +native-id+ +assigned-id+ +random-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 +48,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 +74,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 ; From 7f11c9fe3a26e8326118b7ad670a30c151b59588 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Mar 2008 03:27:41 -0500 Subject: [PATCH 21/38] Fix delegate --- extra/delegate/delegate.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 9eabfae95c..67b8a39320 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -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 ; From 9d2d1c53475533c90351f1275b4f278e8c3b965b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Mar 2008 03:28:07 -0500 Subject: [PATCH 22/38] Fix serialize --- extra/serialize/serialize.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 65464d4e32..86fadf55bf 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -6,14 +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 -combinators.cleave new-slots accessors locals prettyprint -compiler.units sequences.private tuples.private ; +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 From d4be6ea98c6d3feb56f28dfc362ab8fd865f2ac7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Mar 2008 04:31:13 -0500 Subject: [PATCH 23/38] Working on HTTP server --- extra/http/http-tests.factor | 4 +- extra/http/server/actions/actions.factor | 17 ++-- extra/http/server/auth/auth.factor | 19 ++++- extra/http/server/auth/login/login.factor | 34 +++++--- .../auth/providers/assoc/assoc-tests.factor | 6 +- .../server/auth/providers/db/db-tests.factor | 20 +++-- .../server/auth/providers/providers.factor | 11 +-- extra/http/server/callbacks/callbacks.factor | 15 +++- extra/http/server/server.factor | 27 +++--- .../server/sessions/sessions-tests.factor | 41 +++++++-- extra/http/server/sessions/sessions.factor | 7 +- .../http/server/sessions/storage/db/db.factor | 14 +--- extra/openssl/openssl-tests.factor | 38 ++++----- extra/reports/noise/noise.factor | 83 ++++++++++++++----- extra/tools/walker/walker.factor | 24 +++++- 15 files changed, 239 insertions(+), 121 deletions(-) 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/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/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 230eef523e..f4b10a7d81 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -1,7 +1,7 @@ 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 ; +generic locals.private math.statistics ; IN: reports.noise : badness ( word -- n ) @@ -12,9 +12,9 @@ IN: reports.noise { 2apply 1 } { 2curry 1 } { 2drop 1 } - { 2dup 2 } - { 2keep 2 } - { 2nip 3 } + { 2dup 1 } + { 2keep 1 } + { 2nip 2 } { 2over 4 } { 2slip 2 } { 2swap 3 } @@ -33,11 +33,19 @@ IN: reports.noise { 4dup 3 } { 4slip 4 } { compose 1/2 } - { curry 1/2 } + { curry 1/3 } { dip 1 } { dipd 2 } - { drop 1/2 } - { dup 1/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 } @@ -62,11 +70,11 @@ IN: reports.noise { swap 1 } { swapd 3 } { tuck 2 } - { tuckd 3 } - { with 1 } + { tuckd 4 } + { with 1/2 } { with* 2 } - { r> 1/2 } - { >r 1/2 } + { r> 1 } + { >r 1 } { bi 1/2 } { tri 1 } @@ -93,14 +101,30 @@ M: lambda noise lambda-body noise ; M: object noise drop { 0 0 } ; -M: quotation noise [ noise ] map vsum { 1/3 0 } v+ ; +M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ; -M: array noise [ noise ] map vsum { 1/3 0 } 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 15 max / 100 * >integer ; + 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 ) @@ -110,20 +134,41 @@ M: word word-noise-factor M: lambda-word word-noise-factor "lambda" word-prop quot-noise-factor ; -: noisy-words ( -- alist ) - all-words [ +: flatten-generics ( words -- words' ) + [ dup generic? [ methods values ] [ 1array ] if - ] map concat [ dup word-noise-factor ] { } map>assoc + ] map concat ; + +: noisy-words ( -- alist ) + all-words flatten-generics + [ dup word-noise-factor ] { } map>assoc sort-values reverse ; -: noisy-words. ( alist -- ) +: 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 40 head noisy-words. ; + "NOISY WORDS:" print + noisy-words 80 head noise. + nl + "NOISY VOCABS:" print + noisy-vocabs 80 head noise. ; MAIN: noise-report diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index e86cee0c47..a2011d518c 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -24,7 +24,11 @@ SYMBOL: walking-thread : break ( -- ) continuation callstack over set-continuation-call - get-walker-thread send-synchronous { +USE: prettyprint USE: io.streams.c + "BREAK" show + get-walker-thread dup unparse-short show "SS" show send-synchronous +USE: prettyprint USE: io.streams.c + unparse-short show { { [ dup continuation? ] [ (continue) ] } { [ dup quotation? ] [ call ] } { [ dup not ] [ "Single stepping abandoned" throw ] } @@ -146,10 +150,18 @@ SYMBOL: +detached+ walker-status tget set-model ; : unassociate-thread ( -- ) - walker-thread walking-thread tget thread-variables delete-at - [ ] walking-thread tget set-thread-exit-handler ; + walker-thread walking-thread tget thread-variables at self eq? [ + walker-thread walking-thread tget thread-variables delete-at + [ ] walking-thread tget set-thread-exit-handler + ] [ +USE: io + global [ "OOPS" print flush ] bind + ] if ; + +: xshow self unparse-short append show ; : detach-msg ( -- ) + "DETACH" xshow +detached+ set-status unassociate-thread ; @@ -195,6 +207,7 @@ SYMBOL: +detached+ : walker-suspended ( continuation -- continuation' ) +suspended+ set-status [ status +suspended+ eq? ] [ + "SUSPENDED" xshow dup walker-history tget push dup walker-continuation tget set-model [ @@ -222,6 +235,7 @@ SYMBOL: +detached+ : walker-loop ( -- ) +running+ set-status [ status +detached+ eq? not ] [ + "RUNNING" xshow [ { { detach [ detach-msg f ] } @@ -241,7 +255,9 @@ SYMBOL: +detached+ [ walker-suspended ] } case ] handle-synchronous - ] [ ] while ; + ] [ ] while USE: dlists USE: concurrency.mailboxes + "EXIT" xshow + my-mailbox mailbox-data dlist-empty? [ "Crap" print flush ] unless ; : associate-thread ( walker -- ) walker-thread tset From 7bd91f68c9c8d04d9ef8df01ea7948e5a63e22a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 17 Mar 2008 05:08:47 -0500 Subject: [PATCH 24/38] Fix walker --- extra/tools/walker/walker.factor | 24 ++++-------------------- 1 file changed, 4 insertions(+), 20 deletions(-) diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index a2011d518c..e86cee0c47 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -24,11 +24,7 @@ SYMBOL: walking-thread : break ( -- ) continuation callstack over set-continuation-call -USE: prettyprint USE: io.streams.c - "BREAK" show - get-walker-thread dup unparse-short show "SS" show send-synchronous -USE: prettyprint USE: io.streams.c - unparse-short show { + get-walker-thread send-synchronous { { [ dup continuation? ] [ (continue) ] } { [ dup quotation? ] [ call ] } { [ dup not ] [ "Single stepping abandoned" throw ] } @@ -150,18 +146,10 @@ SYMBOL: +detached+ walker-status tget set-model ; : unassociate-thread ( -- ) - walker-thread walking-thread tget thread-variables at self eq? [ - walker-thread walking-thread tget thread-variables delete-at - [ ] walking-thread tget set-thread-exit-handler - ] [ -USE: io - global [ "OOPS" print flush ] bind - ] if ; - -: xshow self unparse-short append show ; + walker-thread walking-thread tget thread-variables delete-at + [ ] walking-thread tget set-thread-exit-handler ; : detach-msg ( -- ) - "DETACH" xshow +detached+ set-status unassociate-thread ; @@ -207,7 +195,6 @@ USE: io : walker-suspended ( continuation -- continuation' ) +suspended+ set-status [ status +suspended+ eq? ] [ - "SUSPENDED" xshow dup walker-history tget push dup walker-continuation tget set-model [ @@ -235,7 +222,6 @@ USE: io : walker-loop ( -- ) +running+ set-status [ status +detached+ eq? not ] [ - "RUNNING" xshow [ { { detach [ detach-msg f ] } @@ -255,9 +241,7 @@ USE: io [ walker-suspended ] } case ] handle-synchronous - ] [ ] while USE: dlists USE: concurrency.mailboxes - "EXIT" xshow - my-mailbox mailbox-data dlist-empty? [ "Crap" print flush ] unless ; + ] [ ] while ; : associate-thread ( walker -- ) walker-thread tset From 86221d57f362b344bf4dcab9c69e7e4ae28d1873 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 17 Mar 2008 09:03:24 -0500 Subject: [PATCH 25/38] fix cairo-demo my commit did more than fix a using..oops --- extra/cairo-demo/cairo-demo.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) 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 ; From 880a3a2af41ebbec3274eccf3c840e25457de3b8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 17 Mar 2008 14:14:04 -0500 Subject: [PATCH 26/38] before major refactoring --- extra/db/sqlite/lib/lib.factor | 1 + extra/db/sqlite/sqlite.factor | 2 ++ extra/db/tuples/tuples-tests.factor | 42 ++++++++++++++++++++--------- extra/db/types/types.factor | 2 -- 4 files changed, 33 insertions(+), 14 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 0e512ad018..f81d7de4b8 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -121,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 ] } diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 1b594d6fa4..bca904279b 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -190,6 +190,7 @@ 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" } @@ -209,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 2dbf6d1008..6b61981119 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -196,13 +196,6 @@ TUPLE: annotation n paste-id summary author mode contents ; [ ] [ person1 get insert-tuple ] unit-test [ person1 get insert-tuple ] must-fail ; -[ 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 -[ assigned-person-schema test-repeated-insert ] test-sqlite -[ assigned-person-schema test-repeated-insert ] test-postgresql - TUPLE: serialize-me id data ; : test-serialize ( -- ) @@ -247,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/types/types.factor b/extra/db/types/types.factor index 532c097957..a0414f334d 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -15,14 +15,12 @@ HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; - 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+ ; -! +native-id+ +assigned-id+ +random-assigned-id+ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ +foreign-id+ +has-many+ ; From 296a20767fae2ac3417cb2aff28315252f8173ed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 01:26:09 -0500 Subject: [PATCH 27/38] Fix a race condition --- extra/tools/walker/debug/debug.factor | 20 +++---- extra/tools/walker/walker.factor | 75 ++++++++++++--------------- extra/ui/tools/walker/walker.factor | 41 +++++++++------ 3 files changed, 69 insertions(+), 67 deletions(-) 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/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 From 6e7556242b32497456f3e44478452d916d16eeb9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 01:26:30 -0500 Subject: [PATCH 28/38] Comment out compilation unit stuff for now --- extra/serialize/serialize.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 86fadf55bf..36d5e40b77 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -316,10 +316,10 @@ SYMBOL: deserialized deserialize* [ "End of stream" throw ] unless ; : deserialize ( -- obj ) - [ - V{ } clone deserialized - [ (deserialize) ] with-variable - ] with-compilation-unit ; + ! [ + V{ } clone deserialized + [ (deserialize) ] with-variable ; + ! ] with-compilation-unit ; : serialize ( obj -- ) H{ } clone serialized [ (serialize) ] with-variable ; From 65c74d8404bd6bcd61fb0c29d911b39c2c813d15 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 02:37:31 -0500 Subject: [PATCH 29/38] Fix macosx/ppc bootstrap --- core/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index c955817ab9..cf31c16662 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -292,7 +292,7 @@ M: no-word summary create-method f set-word dup save-location ; : CREATE-METHOD ( -- method ) - scan-word scan-word create-method-in ; + scan-word bootstrap-word scan-word create-method-in ; TUPLE: staging-violation word ; From 4b2368e99f77bd10566ec5c3dabfc770f708a87e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 03:27:14 -0500 Subject: [PATCH 30/38] Fix io.unix.launcher unit test --- extra/io/unix/launcher/launcher-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/io/unix/launcher/launcher-tests.factor 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 From f31c521c47d3274e50dce37bab663a4501015b84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 17:46:25 -0500 Subject: [PATCH 31/38] Assorted bug fixes --- core/alien/alien-tests.factor | 10 +++++++--- core/classes/classes-tests.factor | 2 ++ core/inference/class/class-tests.factor | 4 +++- core/parser/parser-tests.factor | 4 +++- core/parser/parser.factor | 10 +++++++++- extra/fry/fry-docs.factor | 2 +- extra/help/stylesheet/stylesheet.factor | 1 + vm/alien.c | 6 +++--- 8 files changed, 29 insertions(+), 10 deletions(-) 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/classes/classes-tests.factor b/core/classes/classes-tests.factor index dbc1bcace2..7d43ee905a 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -28,6 +28,8 @@ TUPLE: second-one ; UNION: both first-one union-class ; [ t ] [ both tuple classes-intersect? ] unit-test +[ null ] [ vector virtual-sequence class-and ] unit-test +[ f ] [ vector virtual-sequence classes-intersect? ] unit-test [ t ] [ \ fixnum \ integer class< ] unit-test [ t ] [ \ fixnum \ fixnum class< ] unit-test diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 17197db667..e7fcbfcb08 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -294,4 +294,6 @@ cell-bits 32 = [ \ >= inlined? ] unit-test - +[ t ] [ + [ { vector } declare nth-unsafe ] \ nth-unsafe inlined? +] unit-test diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a69e28ab97..050bd735c0 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 [ @@ -447,3 +447,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 cf31c16662..fd93479283 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -478,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/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/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/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 */ From 290883f0e4e33ed138fc6cb42b8dddbb0a4670fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 18:02:24 -0500 Subject: [PATCH 32/38] Fix DLL" --- core/alien/syntax/syntax.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From cb4974aa344083dd04ac0345f4837ddc9bc66762 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 18:17:25 -0500 Subject: [PATCH 33/38] Fix fs-events issue --- extra/core-foundation/fsevents/fsevents.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) 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 From 4ec88d6bc688aefa3735ebedddc7158b92b043d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 20:24:29 -0500 Subject: [PATCH 34/38] Fix tests typo --- core/inference/class/class-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index e7fcbfcb08..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 From 23dd1f33105746ad63c76d8b954fa0663bc4591b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 20:24:39 -0500 Subject: [PATCH 35/38] Fix usage typo --- core/io/streams/c/c-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 core/io/streams/c/c-docs.factor 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" From da7f10804afc99d03aeda9341de0df3e688d0b79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 20:27:09 -0500 Subject: [PATCH 36/38] Refactor vocab loader --- core/vocabs/loader/loader-tests.factor | 9 ++++ core/vocabs/loader/loader.factor | 59 ++++++++++++++------------ core/vocabs/vocabs.factor | 20 +++++---- extra/bootstrap/help/help.factor | 7 ++- extra/help/markup/markup.factor | 3 +- extra/tools/vocabs/vocabs.factor | 8 ++-- 6 files changed, 60 insertions(+), 46 deletions(-) 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/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/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/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 % From 993a647ccc8237a99c5258a489737a0c673e705f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 21:43:29 -0500 Subject: [PATCH 37/38] Parser fixes --- core/generic/generic-tests.factor | 28 ++++++++++++ core/generic/generic.factor | 25 +++++------ core/parser/parser-tests.factor | 52 ++++++++++++++--------- core/prettyprint/prettyprint-tests.factor | 12 ++++++ core/prettyprint/prettyprint.factor | 6 +-- core/words/words.factor | 5 +++ 6 files changed, 93 insertions(+), 35 deletions(-) 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 ad31831e94..8fe5e4921a 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -104,20 +104,25 @@ M: method-spec definition 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 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 [ @@ -149,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/parser/parser-tests.factor b/core/parser/parser-tests.factor index a69e28ab97..3095f23be1 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -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= ] 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/words/words.factor b/core/words/words.factor index 73b877fdbb..a36cca00ac 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -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 ; From d04eb777ff0dfc4f1f3d91db4d6adc8a1aef147d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 18 Mar 2008 21:45:04 -0500 Subject: [PATCH 38/38] Update bootstrap code for loader changes --- core/bootstrap/primitives.factor | 6 +----- core/bootstrap/syntax.factor | 4 +--- 2 files changed, 2 insertions(+), 8 deletions(-) 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