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

odbc: replace >r/>r with dip and locals

char-rename
Alexander Iljin 2016-10-30 00:02:29 +03:00 committed by John Benediktsson
parent 32bb390d4f
commit 7269e834e6
1 changed files with 28 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
unmaintained/odbc/odbc.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel alien alien.strings alien.syntax USING: accessors kernel alien alien.strings alien.syntax
combinators alien.c-types strings sequences namespaces make combinators alien.c-types strings sequences namespaces make
words math threads io.encodings.ascii ; words math threads io.encodings.ascii locals ;
IN: odbc IN: odbc
<< "odbc" "odbc32.dll" stdcall add-library >> << "odbc" "odbc32.dll" stdcall add-library >>
@ -157,7 +157,7 @@ FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNu
] keep ; ] keep ;
: odbc-connect ( env dsn -- dbc ) : odbc-connect ( env dsn -- dbc )
>r alloc-dbc-handle dup r> [ alloc-dbc-handle dup ] dip
f swap dup length 1024 temp-string 0 short <ref> SQL-DRIVER-NOPROMPT f swap dup length 1024 temp-string 0 short <ref> SQL-DRIVER-NOPROMPT
SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ; SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;
@ -165,7 +165,7 @@ FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNu
SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ; SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ;
: odbc-prepare ( dbc string -- statement ) : odbc-prepare ( dbc string -- statement )
>r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ; [ alloc-stmt-handle dup ] dip dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;
: odbc-free-statement ( statement -- ) : odbc-free-statement ( statement -- )
SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ; SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;
@ -187,24 +187,24 @@ TUPLE: column nullable digits size type name number ;
C: <column> column C: <column> column
: odbc-describe-column ( statement n -- column ) :: odbc-describe-column ( statement columnNumber -- column )
dup >r 1024 :> bufferLen
1024 CHAR: space <string> ascii string>alien dup >r bufferLen CHAR: space <string> ascii string>alien :> columnName
1024 0 short <ref> :> nameLengthPtr
0 short <ref> 0 short <ref> :> dataTypePtr
0 short <ref> dup >r 0 uint <ref> :> columnSizePtr
0 uint <ref> dup >r 0 short <ref> :> decimalDigitsPtr
0 short <ref> dup >r 0 short <ref> :> nullablePtr
0 short <ref> dup >r statement columnNumber columnName bufferLen nameLengthPtr
dataTypePtr columnSizePtr decimalDigitsPtr nullablePtr
SQLDescribeCol succeeded? [ SQLDescribeCol succeeded? [
r> short deref nullablePtr short deref
r> short deref decimalDigitsPtr short deref
r> uint deref columnSizePtr uint deref
r> short deref convert-sql-type dataTypePtr short deref convert-sql-type
r> ascii alien>string columnName ascii alien>string
r> <column> columnNumber <column>
] [ ] [
r> drop r> drop r> drop r> drop r> drop r> drop
"odbc-describe-column failed" throw "odbc-describe-column failed" throw
] if ; ] if ;
@ -230,15 +230,16 @@ TUPLE: field value column ;
C: <field> field C: <field> field
: odbc-get-field ( statement column -- field ) :: odbc-get-field ( statement column! -- field )
dup column? [ dupd odbc-describe-column ] unless dup >r number>> column column? [ statement column odbc-describe-column column! ] unless
SQL-C-DEFAULT 8192 :> bufferLen
8192 CHAR: space <string> ascii string>alien dup >r bufferLen CHAR: space <string> ascii string>alien :> targetValuePtr
8192
f SQLGetData succeeded? [ statement column number>> SQL-C-DEFAULT
r> r> [ dereference-type-pointer ] keep <field> targetValuePtr bufferLen f SQLGetData succeeded? [
targetValuePtr column [ dereference-type-pointer ] keep <field>
] [ ] [
r> drop r> [ column [
"SQLGetData Failed for Column: " % "SQLGetData Failed for Column: " %
dup name>> % dup name>> %
" of type: " % dup type>> name>> % " of type: " % dup type>> name>> %