steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

update cond/case

db4
Doug Coleman 2008-04-11 12:56:48 -05:00
parent 2b78870033
commit acf6132389
15 changed files with 91 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
extra/koszul/koszul.factor
View File

@ -15,7 +15,7 @@ IN: koszul
{ [ dup number? ] [ { } associate ] }
{ [ dup array? ] [ 1 swap associate ] }
{ [ dup hashtable? ] [ ] }
{ [ t ] [ 1array >alt ] }
[ 1array >alt ]
} cond ;
: canonicalize
@ -31,10 +31,10 @@ SYMBOL: terms
! Printing elements
: num-alt. ( n -- str )
{
{ [ dup 1 = ] [ drop " + " ] }
{ [ dup -1 = ] [ drop " - " ] }
{ [ t ] [ number>string " + " prepend ] }
} cond ;
{ 1 [ " + " ] }
{ -1 [ " - " ] }
[ number>string " + " prepend ]
} case ;
: (alt.) ( basis n -- str )
over empty? [

2
extra/lazy-lists/lazy-lists.factor
View File

@ -321,7 +321,7 @@ M: sequence-cons nil? ( sequence-cons -- bool )
{
{ [ dup sequence? ] [ 0 swap seq>list ] }
{ [ dup list? ] [ ] }
{ [ t ] [ "Could not convert object to a list" throw ] }
[ "Could not convert object to a list" throw ]
} cond ;
TUPLE: lazy-concat car cdr ;

2
extra/logging/parser/parser.factor
View File

@ -66,7 +66,7 @@ MEMO: 'log-line' ( -- parser )
parse-log-line {
{ [ dup malformed? ] [ malformed-line ] }
{ [ dup multiline? ] [ add-multiline ] }
{ [ t ] [ , ] }
[ , ]
} cond
] each
] { } make ;

4
extra/logging/server/server.factor
View File

@ -40,10 +40,10 @@ SYMBOL: log-files
rot [ empty? not ] subset {
{ [ dup empty? ] [ 3drop ] }
{ [ dup length 1 = ] [ first -rot f (write-message) ] }
{ [ t ] [
[
[ first -rot f (write-message) ] 3keep
1 tail -rot [ t (write-message) ] 2curry each
] }
]
} cond ;
: (log-message) ( msg -- )

2
extra/match/match.factor
View File

@ -58,7 +58,7 @@ MACRO: match-cond ( assoc -- )
{ [ dup match-var? ] [ get ] }
{ [ dup sequence? ] [ [ replace-patterns ] map ] }
{ [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
{ [ t ] [ ] }
[ ]
} cond ;
: match-replace ( object pattern1 pattern2 -- result )

2
extra/math/functions/functions.factor
View File

@ -99,7 +99,7 @@ M: real absq sq ;
{ [ pick fp-nan? pick fp-nan? or ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ ~rel ] }
{ [ t ] [ ~abs ] }
[ ~abs ]
} cond ;
: power-of-2? ( n -- ? )

2
extra/math/miller-rabin/miller-rabin.factor
View File

@ -55,7 +55,7 @@ TUPLE: miller-rabin-bounds ;
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
{ [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] }
[ [ drop trials set t (miller-rabin) ] with-scope ]
} cond ;
: miller-rabin ( n -- ? ) 10 miller-rabin* ;

5
extra/math/primes/primes.factor
View File

@ -38,9 +38,8 @@ PRIVATE>
{ [ dup 2 < ] [ drop { } ] }
{ [ dup 1000003 < ]
[ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
{ [ t ]
[ primes-under-million 1000003 lprimes-from
rot [ <= ] curry lwhile list>array append ] }
[ primes-under-million 1000003 lprimes-from
rot [ <= ] curry lwhile list>array append ]
} cond ; foldable
: primes-between ( low high -- seq )

2
extra/multi-methods/multi-methods.factor
View File

@ -89,7 +89,7 @@ SYMBOL: total
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
{ [ 2dup class< ] [ -1 ] }
{ [ 2dup swap class< ] [ 1 ] }
{ [ t ] [ 0 ] }
[ 0 ]
} cond 2nip
] 2map [ zero? not ] find nip 0 or ;

88
extra/odbc/odbc.factor
View File

@ -88,38 +88,38 @@ SYMBOL: SQL-TYPE-UNKNOWN
: convert-sql-type ( number -- symbol )
{
{ [ dup 1 = ] [ drop SQL-CHAR ] }
{ [ dup 12 = ] [ drop SQL-VARCHAR ] }
{ [ dup -1 = ] [ drop SQL-LONGVARCHAR ] }
{ [ dup -8 = ] [ drop SQL-WCHAR ] }
{ [ dup -9 = ] [ drop SQL-WCHARVAR ] }
{ [ dup -10 = ] [ drop SQL-WLONGCHARVAR ] }
{ [ dup 3 = ] [ drop SQL-DECIMAL ] }
{ [ dup 5 = ] [ drop SQL-SMALLINT ] }
{ [ dup 2 = ] [ drop SQL-NUMERIC ] }
{ [ dup 4 = ] [ drop SQL-INTEGER ] }
{ [ dup 7 = ] [ drop SQL-REAL ] }
{ [ dup 6 = ] [ drop SQL-FLOAT ] }
{ [ dup 8 = ] [ drop SQL-DOUBLE ] }
{ [ dup -7 = ] [ drop SQL-BIT ] }
{ [ dup -6 = ] [ drop SQL-TINYINT ] }
{ [ dup -5 = ] [ drop SQL-BIGINT ] }
{ [ dup -2 = ] [ drop SQL-BINARY ] }
{ [ dup -3 = ] [ drop SQL-VARBINARY ] }
{ [ dup -4 = ] [ drop SQL-LONGVARBINARY ] }
{ [ dup 91 = ] [ drop SQL-TYPE-DATE ] }
{ [ dup 92 = ] [ drop SQL-TYPE-TIME ] }
{ [ dup 93 = ] [ drop SQL-TYPE-TIMESTAMP ] }
{ [ t ] [ drop SQL-TYPE-UNKNOWN ] }
} cond ;
{ 1 [ SQL-CHAR ] }
{ 12 [ SQL-VARCHAR ] }
{ -1 [ SQL-LONGVARCHAR ] }
{ -8 [ SQL-WCHAR ] }
{ -9 [ SQL-WCHARVAR ] }
{ -10 [ SQL-WLONGCHARVAR ] }
{ 3 [ SQL-DECIMAL ] }
{ 5 [ SQL-SMALLINT ] }
{ 2 [ SQL-NUMERIC ] }
{ 4 [ SQL-INTEGER ] }
{ 7 [ SQL-REAL ] }
{ 6 [ SQL-FLOAT ] }
{ 8 [ SQL-DOUBLE ] }
{ -7 [ SQL-BIT ] }
{ -6 [ SQL-TINYINT ] }
{ -5 [ SQL-BIGINT ] }
{ -2 [ SQL-BINARY ] }
{ -3 [ SQL-VARBINARY ] }
{ -4 [ SQL-LONGVARBINARY ] }
{ 91 [ SQL-TYPE-DATE ] }
{ 92 [ SQL-TYPE-TIME ] }
{ 93 [ SQL-TYPE-TIMESTAMP ] }
[ drop SQL-TYPE-UNKNOWN ]
} case ;
: succeeded? ( n -- bool )
#! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
{
{ [ dup SQL-SUCCESS = ] [ drop t ] }
{ [ dup SQL-SUCCESS-WITH-INFO = ] [ drop t ] }
{ [ t ] [ drop f ] }
} cond ;
{ \ SQL-SUCCESS [ t ] }
{ \ SQL-SUCCESS-WITH-INFO [ t ] }
[ drop f ]
} case ;
FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;
FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;
@ -213,21 +213,21 @@ C: <column> column
: dereference-type-pointer ( byte-array column -- object )
column-type {
{ [ dup SQL-CHAR = ] [ drop alien>char-string ] }
{ [ dup SQL-VARCHAR = ] [ drop alien>char-string ] }
{ [ dup SQL-LONGVARCHAR = ] [ drop alien>char-string ] }
{ [ dup SQL-WCHAR = ] [ drop alien>char-string ] }
{ [ dup SQL-WCHARVAR = ] [ drop alien>char-string ] }
{ [ dup SQL-WLONGCHARVAR = ] [ drop alien>char-string ] }
{ [ dup SQL-SMALLINT = ] [ drop *short ] }
{ [ dup SQL-INTEGER = ] [ drop *long ] }
{ [ dup SQL-REAL = ] [ drop *float ] }
{ [ dup SQL-FLOAT = ] [ drop *double ] }
{ [ dup SQL-DOUBLE = ] [ drop *double ] }
{ [ dup SQL-TINYINT = ] [ drop *char ] }
{ [ dup SQL-BIGINT = ] [ drop *longlong ] }
{ [ t ] [ nip [ "Unknown SQL Type: " % word-name % ] "" make ] }
} cond ;
{ SQL-CHAR [ alien>char-string ] }
{ SQL-VARCHAR [ alien>char-string ] }
{ SQL-LONGVARCHAR [ alien>char-string ] }
{ SQL-WCHAR [ alien>char-string ] }
{ SQL-WCHARVAR [ alien>char-string ] }
{ SQL-WLONGCHARVAR [ alien>char-string ] }
{ SQL-SMALLINT [ *short ] }
{ SQL-INTEGER [ *long ] }
{ SQL-REAL [ *float ] }
{ SQL-FLOAT [ *double ] }
{ SQL-DOUBLE [ *double ] }
{ SQL-TINYINT [ *char ] }
{ SQL-BIGINT [ *longlong ] }
[ nip [ "Unknown SQL Type: " % word-name % ] "" make ]
} case ;
TUPLE: field value column ;
@ -267,4 +267,4 @@ C: <field> field
dup odbc-execute
dup odbc-get-all-rows
swap odbc-free-statement
] keep odbc-disconnect ;
] keep odbc-disconnect ;

4
extra/ogg/player/player.factor
View File

@ -179,7 +179,7 @@ HINTS: yuv>rgb byte-array byte-array ;
num-audio-buffers-processed {
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
{ [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }
{ [ t ] [ fill-processed-audio-buffer t ] }
[ fill-processed-audio-buffer t ]
} cond ;
: start-audio ( player -- player bool )
@ -284,7 +284,7 @@ HINTS: yuv>rgb byte-array byte-array ;
decode-packet {
{ [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }
{ [ is-theora-packet? ] [ handle-initial-theora-header ] }
{ [ t ] [ handle-initial-unknown-header ] }
[ handle-initial-unknown-header ]
} cond t
] [
f

2
extra/opengl/gl/extensions/extensions.factor
View File

@ -7,7 +7,7 @@ ERROR: unknown-gl-platform ;
{ [ os windows? ] [ "opengl.gl.windows" ] }
{ [ os macosx? ] [ "opengl.gl.macosx" ] }
{ [ os unix? ] [ "opengl.gl.unix" ] }
{ [ t ] [ unknown-gl-platform ] }
[ unknown-gl-platform ]
} cond use+ >>
IN: opengl.gl.extensions

2
extra/optimizer/debugger/debugger.factor
View File

@ -149,7 +149,7 @@ SYMBOL: node-count
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
{ [ t ] [ words-called ] }
[ words-called ]
} cond 1 -rot get at+
] [
drop

40
extra/oracle/oracle.factor
View File

@ -35,20 +35,20 @@ C: <connection> connection
: check-result ( result -- )
{
{ [ dup OCI_SUCCESS = ] [ drop ] }
{ [ dup OCI_ERROR = ] [ err get get-oci-error ] }
{ [ dup OCI_INVALID_HANDLE = ] [ "invalid handle" throw ] }
{ [ t ] [ "operation failed" throw ] }
} cond ;
{ \ OCI_SUCCESS [ ] }
{ \ OCI_ERROR [ err get get-oci-error ] }
{ \ OCI_INVALID_HANDLE [ "invalid handle" throw ] }
[ "operation failed" throw ]
} case ;
: check-status ( status -- bool )
{
{ [ dup OCI_SUCCESS = ] [ drop t ] }
{ [ dup OCI_ERROR = ] [ err get get-oci-error ] }
{ [ dup OCI_INVALID_HANDLE = ] [ "invalid handle" throw ] }
{ [ dup OCI_NO_DATA = ] [ drop f ] }
{ [ t ] [ "operation failed" throw ] }
} cond ;
{ \ OCI_SUCCESS [ t ] }
{ \ OCI_ERROR [ err get get-oci-error ] }
{ \ OCI_INVALID_HANDLE [ "invalid handle" throw ] }
{ \ OCI_NO_DATA [ f ] }
[ "operation failed" throw ]
} case ;
! =========================================================
! Initialization and handle-allocation routines
@ -153,19 +153,19 @@ C: <connection> connection
>r stm get err get r> dup length swap malloc-char-string swap
OCI_NTV_SYNTAX OCI_DEFAULT OCIStmtPrepare check-result ;
: calculate-size ( type -- size object )
: calculate-size ( type -- size )
{
{ [ dup SQLT_INT = ] [ "int" heap-size ] }
{ [ dup SQLT_FLT = ] [ "float" heap-size ] }
{ [ dup SQLT_CHR = ] [ "char" heap-size ] }
{ [ dup SQLT_NUM = ] [ "int" heap-size 10 * ] }
{ [ dup SQLT_STR = ] [ 64 ] }
{ [ dup SQLT_ODT = ] [ 256 ] }
} cond ;
{ \ SQLT_INT [ "int" heap-size ] }
{ \ SQLT_FLT [ "float" heap-size ] }
{ \ SQLT_CHR [ "char" heap-size ] }
{ \ SQLT_NUM [ "int" heap-size 10 * ] }
{ \ SQLT_STR [ 64 ] }
{ \ SQLT_ODT [ 256 ] }
} case ;
: define-by-position ( position type -- )
>r >r stm get f <void*> err get
r> r> calculate-size swap >r [ "char" malloc-array dup buf set ] keep 1+
r> r> dup calculate-size >r [ "char" malloc-array dup buf set ] keep 1+
r> f f f OCI_DEFAULT OCIDefineByPos check-result ;
: execute-statement ( -- bool )

16
extra/porter-stemmer/porter-stemmer.factor
View File

@ -60,7 +60,7 @@ USING: kernel math parser sequences combinators splitting ;
{ [ 1 over consonant-end? not ] [ drop f ] }
{ [ 2 over consonant-end? ] [ drop f ] }
{ [ 3 over consonant-end? not ] [ drop f ] }
{ [ t ] [ "wxy" last-is? not ] }
[ "wxy" last-is? not ]
} cond ;
: r ( str oldsuffix newsuffix -- str )
@ -75,7 +75,7 @@ USING: kernel math parser sequences combinators splitting ;
{ [ "ies" ?tail ] [ "i" append ] }
{ [ dup "ss" tail? ] [ ] }
{ [ "s" ?tail ] [ ] }
{ [ t ] [ ] }
[ ]
} cond
] when ;
@ -114,11 +114,11 @@ USING: kernel math parser sequences combinators splitting ;
{
{ [ "ed" ?tail ] [ -ed ] }
{ [ "ing" ?tail ] [ -ing ] }
{ [ t ] [ f ] }
[ f ]
} cond
] [ -ed/ing ]
}
{ [ t ] [ ] }
[ ]
} cond ;
: step1c ( str -- newstr )
@ -149,7 +149,7 @@ USING: kernel math parser sequences combinators splitting ;
{ [ "iviti" ?tail ] [ "iviti" "ive" r ] }
{ [ "biliti" ?tail ] [ "biliti" "ble" r ] }
{ [ "logi" ?tail ] [ "logi" "log" r ] }
{ [ t ] [ ] }
[ ]
} cond ;
: step3 ( str -- newstr )
@ -161,7 +161,7 @@ USING: kernel math parser sequences combinators splitting ;
{ [ "ical" ?tail ] [ "ical" "ic" r ] }
{ [ "ful" ?tail ] [ "ful" "" r ] }
{ [ "ness" ?tail ] [ "ness" "" r ] }
{ [ t ] [ ] }
[ ]
} cond ;
: -ion ( str -- newstr )
@ -192,7 +192,7 @@ USING: kernel math parser sequences combinators splitting ;
{ [ "ous" ?tail ] [ ] }
{ [ "ive" ?tail ] [ ] }
{ [ "ize" ?tail ] [ ] }
{ [ t ] [ ] }
[ ]
} cond dup consonant-seq 1 > [ nip ] [ drop ] if ;
: remove-e? ( str -- ? )
@ -210,7 +210,7 @@ USING: kernel math parser sequences combinators splitting ;
{ [ dup peek CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ butlast ] }
{ [ t ] [ ] }
[ ]
} cond ;
: step5 ( str -- newstr ) remove-e ll->l ;