Merge branch 'master' of git://factorcode.org/git/factor

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 <c-object> } " or " { $link malloc-object } "."
+"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
 $nl
 "Arrays of C unions can be created by calling " { $link <c-array> } " 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: } "." ;

core/generator/fixup/fixup-docs.factor

@@ -1,5 +1,6 @@
-USING: help.syntax help.markup generator.fixup math kernel
+USING: help.syntax help.markup math kernel
-words strings alien byte-array ;
+words strings alien ;
+IN: generator.fixup
 
 HELP: frame-required
 { $values { "n" "a non-negative integer" } }

extra/db/tuples/tuples-tests.factor

@@ -436,8 +436,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
@@ -446,7 +451,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
 

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

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
+SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
-SYMBOL: NOTICE
-SYMBOL: WARNING
-SYMBOL: ERROR
-SYMBOL: CRITICAL
 
-: log-levels
+: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
-    { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
 
 : send-to-log-server ( array string -- )
     prefix "log-server" get send ;
 
 SYMBOL: log-service
 
-: check-log-message
+: check-log-message ( msg word level -- msg word level )
-    pick string?
+    3dup [ string? ] [ word? ] [ word? ] tri* and and
-    pick word?
+    [ "Bad parameters to log-message" throw ] unless ; inline
-    pick word? and and
-    [ "Bad parameters to log-message" throw ] unless ;
 
 : 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
+        [ [ ndup ] keep narray stack>message ] 2dip log-message
-        r> r> 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 )
+: stack-balancer ( effect -- quot )
-    >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
+    [ in>> length [ ndrop ] curry ]
-    swap effect-out length f <repetition> append >quotation ;
+    [ out>> length f <repetition> >quotation ]
+    bi append ;
 
 : error-logging-quot ( quot word -- quot' )
-    [ [ log-error ] curry ] keep
+    dup stack-effect stack-balancer
-    [ stack-effect ] keep stack-balancer compose
+    '[ , [ , log-error @ ] recover ] ;
-    [ recover ] 2curry ;
 
 : 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
+    CREATE-WORD dup scan-word
-    dup scan-word
+    '[ 1array stack>message , , log-message ]
-    [ >r >r 1array stack>message r> r> log-message ] 2curry
     define ; parsing