From 155f24df4fb21c117424783d9c440df17505298b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 18:16:40 -0500 Subject: [PATCH 1/4] Fix circularity --- core/generator/fixup/fixup-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index 58bc32397f..64d733ef8c 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -1,5 +1,6 @@ -USING: help.syntax help.markup generator.fixup math kernel -words strings alien byte-array ; +USING: help.syntax help.markup math kernel +words strings alien ; +IN: generator.fixup HELP: frame-required { $values { "n" "a non-negative integer" } } From 07fffb2811896172290a0b73bd6d3919d3b1c16d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 18:16:51 -0500 Subject: [PATCH 2/4] Clean up logging and fix error logging --- extra/logging/logging-tests.factor | 24 +++++++++++++ extra/logging/logging.factor | 55 +++++++++++++----------------- 2 files changed, 47 insertions(+), 32 deletions(-) create mode 100644 extra/logging/logging-tests.factor diff --git a/extra/logging/logging-tests.factor b/extra/logging/logging-tests.factor new file mode 100644 index 0000000000..796c8769fc --- /dev/null +++ b/extra/logging/logging-tests.factor @@ -0,0 +1,24 @@ +IN: logging.tests +USING: tools.test logging math ; + +: input-logging-test ( a b -- c ) + ; + +\ input-logging-test NOTICE add-input-logging + +: output-logging-test ( a b -- c ) + ; + +\ output-logging-test DEBUG add-output-logging + +: error-logging-test ( a b -- c ) / ; + +\ error-logging-test ERROR add-error-logging + +"logging-test" [ + [ 4 ] [ 1 3 input-logging-test ] unit-test + + [ 4 ] [ 1 3 output-logging-test ] unit-test + + [ 4/3 ] [ 4 3 error-logging-test ] unit-test + + [ f ] [ 1 0 error-logging-test ] unit-test +] with-logging diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index f54ab05bbd..df03bf320b 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -4,33 +4,26 @@ USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects arrays.lib parser strings -combinators.lib quotations ; +combinators.lib quotations fry symbols accessors ; IN: logging -SYMBOL: DEBUG -SYMBOL: NOTICE -SYMBOL: WARNING -SYMBOL: ERROR -SYMBOL: CRITICAL +SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; -: log-levels - { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; +: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; : send-to-log-server ( array string -- ) prefix "log-server" get send ; SYMBOL: log-service -: check-log-message - pick string? - pick word? - pick word? and and - [ "Bad parameters to log-message" throw ] unless ; +: check-log-message ( msg word level -- msg word level ) + 3dup [ string? ] [ word? ] [ word? ] tri* and and + [ "Bad parameters to log-message" throw ] unless ; inline : log-message ( msg word level -- ) check-log-message log-service get dup [ - >r >r >r string-lines r> word-name r> word-name r> + [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip 4array "log-message" send-to-log-server ] [ 4drop @@ -69,7 +62,7 @@ SYMBOL: log-service PRIVATE> : (define-logging) ( word level quot -- ) - >r >r dup r> r> 2curry annotate ; + [ dup ] 2dip 2curry annotate ; : call-logging-quot ( quot word level -- quot' ) "called" -rot [ log-message ] 3curry prepose ; @@ -79,31 +72,30 @@ PRIVATE> : log-stack ( n word level -- ) log-service get [ - >r >r [ ndup ] keep narray stack>message - r> r> log-message + [ [ ndup ] keep narray stack>message ] 2dip log-message ] [ 3drop ] if ; inline -: input# stack-effect effect-in length ; +: input# stack-effect in>> length ; : input-logging-quot ( quot word level -- quot' ) - over input# -rot [ log-stack ] 3curry prepose ; + rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ; : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; -: output# stack-effect effect-out length ; +: output# stack-effect out>> length ; : output-logging-quot ( quot word level -- quot' ) - over output# -rot [ log-stack ] 3curry compose ; + [ [ output# ] keep ] dip '[ @ , , , log-stack ] ; : add-output-logging ( word level -- ) [ output-logging-quot ] (define-logging) ; : (log-error) ( object word level -- ) log-service get [ - >r >r [ print-error ] with-string-writer r> r> log-message + [ [ print-error ] with-string-writer ] 2dip log-message ] [ 2drop rethrow ] if ; @@ -112,22 +104,21 @@ PRIVATE> : log-critical ( error word -- ) CRITICAL (log-error) ; -: stack-balancer ( effect word -- quot ) - >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry - swap effect-out length f append >quotation ; +: stack-balancer ( effect -- quot ) + [ in>> length [ ndrop ] curry ] + [ out>> length f >quotation ] + bi append ; : error-logging-quot ( quot word -- quot' ) - [ [ log-error ] curry ] keep - [ stack-effect ] keep stack-balancer compose - [ recover ] 2curry ; + dup stack-effect stack-balancer + '[ , [ , log-error @ ] recover ] ; : add-error-logging ( word level -- ) - [ over >r input-logging-quot r> error-logging-quot ] + [ [ input-logging-quot ] 2keep drop error-logging-quot ] (define-logging) ; : LOG: #! Syntax: name level - CREATE-WORD - dup scan-word - [ >r >r 1array stack>message r> r> log-message ] 2curry + CREATE-WORD dup scan-word + '[ 1array stack>message , , log-message ] define ; parsing From 8036c4af79a604552b4e2a152e143272c39cdc7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:02:19 -0500 Subject: [PATCH 3/4] Fix typo --- core/alien/structs/structs-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index e7e576293f..baf0b40707 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -91,6 +91,6 @@ $nl ARTICLE: "c-unions" "C unions" "A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values." { $subsection POSTPONE: C-UNION: } -"C structure objects can be allocated by calling " { $link } " or " { $link malloc-object } "." +"C union objects can be allocated by calling " { $link } " or " { $link malloc-object } "." $nl "Arrays of C unions can be created by calling " { $link } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ; From f3085d9f8e43043617bc9c164ef9bfe214627015 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:05:55 -0500 Subject: [PATCH 4/4] Add another failing test --- extra/db/tuples/tuples-tests.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index fa213efb2f..5ab52899da 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -429,8 +429,13 @@ subbclass "SUBCLASS" { { "b" "B" TEXT } } define-persistent +TUPLE: fubbclass < subbclass ; + +fubbclass "FUBCLASS" { } define-persistent + : test-db-inheritance ( -- ) [ ] [ subbclass ensure-table ] unit-test + [ ] [ fubbclass ensure-table ] unit-test [ ] [ subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set @@ -439,7 +444,11 @@ subbclass "SUBCLASS" { [ t "hi" 5 ] [ subbclass new "id" get >>id select-tuple [ subbclass? ] [ b>> ] [ a>> ] tri - ] unit-test ; + ] unit-test + + [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test + + [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ; [ test-db-inheritance ] test-sqlite