Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Since we're using constructor arguments in the define-foreign-type, t…

…here's no need for a separate define-make-type* macro, so inline it into define-make-types*/datatypes. Also, group all the macrology together to make it easier to understand at a glance
  • Loading branch information...
commit d8fec3dec2d9f56440f057de954461d292be1b4b 1 parent 2cce1c2
Peter Bex authored
Showing with 47 additions and 58 deletions.
  1. +47 −58 freetds.scm
View
105 freetds.scm
@@ -78,27 +78,6 @@ with the FreeTDS egg. If not, see <http://www.gnu.org/licenses/>.
;;;; Custom types and FreeTDS<->Scheme type conversion
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define-syntax define-type-maker
- (syntax-rules ()
- ((_ type constructor)
- (define (constructor #!optional (length 1))
- (let ((type* ((foreign-lambda* (c-pointer type) ((int l))
- "C_return(malloc(l*(sizeof(" type "))));")
- length)))
- (when (null-pointer? type*)
- (error 'constructor
- (format "could not allocate ~a ~a(s)" length type)))
- (set-finalizer! type* (foreign-lambda* void (((c-pointer type) t))
- "C_free(t);"))
- type*)))))
-
- (define-syntax define-make-type*
- (er-macro-transformer
- (lambda (expression rename compare)
- (let* ((type (symbol->string (cadr expression)))
- (constructor (string->symbol (sprintf "make-~a*" type))))
- `(define-type-maker ,type ,constructor)))))
-
(define-foreign-record-type
(CS_DATAFMT CS_DATAFMT)
(constructor: make-CS_DATAFMT*)
@@ -147,40 +126,6 @@ with the FreeTDS egg. If not, see <http://www.gnu.org/licenses/>.
;; 33 = CS_MAX_NUMLEN
(CS_CHAR (array 33) numeric-array))
- (define-for-syntax datatypes
- '(CS_BINARY
- CS_LONGBINARY
- CS_VARBINARY
- CS_BIT
- CS_CHAR
- CS_LONGCHAR
- CS_VARCHAR
- CS_DATETIME
- CS_DATETIME4
- CS_TINYINT
- CS_SMALLINT
- CS_INT
- CS_BIGINT
- CS_DECIMAL
- CS_NUMERIC
- CS_FLOAT
- CS_REAL
- CS_MONEY
- CS_MONEY4
- CS_TEXT
- CS_IMAGE))
-
- (define-syntax define-make-types*/datatypes
- (er-macro-transformer
- (lambda (expression rename compare)
- (let ((%define-make-type* (rename 'define-make-type*))
- (%begin (rename 'begin)))
- (cons
- %begin
- (map (lambda (type)
- `(,%define-make-type* ,type))
- datatypes))))))
-
(define (char-null? char)
(char=? char #\nul))
@@ -368,6 +313,29 @@ with the FreeTDS egg. If not, see <http://www.gnu.org/licenses/>.
(CS_CHAR*->string text* length))
(define translate-CS_IMAGE* translate-CS_TEXT*)
+ (define-for-syntax datatypes
+ '(CS_BINARY
+ CS_LONGBINARY
+ CS_VARBINARY
+ CS_BIT
+ CS_CHAR
+ CS_LONGCHAR
+ CS_VARCHAR
+ CS_DATETIME
+ CS_DATETIME4
+ CS_TINYINT
+ CS_SMALLINT
+ CS_INT
+ CS_BIGINT
+ CS_DECIMAL
+ CS_NUMERIC
+ CS_FLOAT
+ CS_REAL
+ CS_MONEY
+ CS_MONEY4
+ CS_TEXT
+ CS_IMAGE))
+
(define-for-syntax (datatype->integer datatype)
`(foreign-value ,(format "~a_TYPE" datatype) CS_INT))
@@ -380,6 +348,29 @@ with the FreeTDS egg. If not, see <http://www.gnu.org/licenses/>.
(define-for-syntax (datatype->translate-type* datatype)
(string->symbol (format "translate-~a*" datatype)))
+ (define-syntax define-type-maker
+ (syntax-rules ()
+ ((_ type constructor)
+ (define (constructor #!optional (length 1))
+ (let ((type* ((foreign-lambda* (c-pointer type) ((int l))
+ "C_return(malloc(l*(sizeof(" type "))));")
+ length)))
+ (when (null-pointer? type*)
+ (error 'constructor
+ (format "could not allocate ~a ~a(s)" length type)))
+ (set-finalizer! type* (foreign-lambda* void (((c-pointer type) t))
+ "C_free(t);"))
+ type*)))))
+
+ (define-syntax define-make-types*/datatypes
+ (er-macro-transformer
+ (lambda (expression rename compare)
+ `(begin . ,(map (lambda (type)
+ (let ((type-string (symbol->string type))
+ (constructor (datatype->make-type* type)))
+ `(define-type-maker ,type-string ,constructor)))
+ datatypes)))))
+
(define-syntax define-datatype->make-type*/datatypes
(er-macro-transformer
(lambda (expression rename compare)
@@ -886,9 +877,7 @@ with the FreeTDS egg. If not, see <http://www.gnu.org/licenses/>.
(error-on-non-success
#f
(lambda ()
- ((foreign-lambda CS_RETCODE
- "ct_cmd_drop"
- (c-pointer "CS_COMMAND"))
+ ((foreign-lambda CS_RETCODE "ct_cmd_drop" (c-pointer "CS_COMMAND"))
command*))
'ct_cmd_drop
"failed to drop command"))
Please sign in to comment.
Something went wrong with that request. Please try again.