Skip to content

Commit

Permalink
incorporate code review comments
Browse files Browse the repository at this point in the history
  • Loading branch information
@shakdwipeea
shakdwipeea committed Nov 29, 2019
1 parent d4299f2 commit cd7b1d7
Show file tree
Hide file tree
Showing 2 changed files with 54 additions and 49 deletions.
101 changes: 52 additions & 49 deletions src/std/foreign.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -118,12 +118,12 @@
"struct " struct-str " *obj = (struct " struct-str "*) ptr;" "\n"
(apply string-append
(map (lambda (m)
(case (cdr m)
((char-string)
(let ((mem-name (symbol->string (car m))))
(string-append "if(obj->" mem-name ") "
"free(obj->" mem-name ");" "\n")))
(else "")))
(cond
((memq (cdr m) string-types)
(let ((mem-name (symbol->string (car m))))
(string-append "if(obj->" mem-name ") "
"free(obj->" mem-name ");" "\n")))
(else "")))
members))
"free(obj);" "\n"
"return ___FIX (___NO_ERR);" "\n"
Expand All @@ -136,51 +136,52 @@
(string-compat-types (if string-compat-required?
`((c-declare ,default-free-body)
(c-define-type ,shallow-ptr
(pointer ,struct (,struct-ptr) "ffi_free"))))))
`(begin
,@(append `((c-define-type ,struct (struct ,struct-str))
(c-define-type ,struct-ptr
(pointer ,struct (,struct-ptr) ,release-function))
(c-define-type ,borrowed-ptr (pointer ,struct (,struct-ptr))))
string-compat-types)
(pointer ,struct (,struct-ptr) "ffi_free")))
'())))
`(begin (c-define-type ,struct (struct ,struct-str))
(c-define-type ,struct-ptr
(pointer ,struct (,struct-ptr) ,release-function))
(c-define-type ,borrowed-ptr (pointer ,struct (,struct-ptr)))

,@string-compat-types

(define ,(string->symbol (string-append struct-str "-ptr?"))

(define ,(string->symbol (string-append struct-str "-ptr?"))
(lambda (obj)
(and (foreign? obj)
(equal? (foreign-tags obj) (quote (,struct-ptr))))))

;; getter and setters
,@(apply append
(map (lambda (m)
(let* ((member-name (symbol->string (car m)))
(member-type (cdr m))
(getter-name (string-append struct-str "-" member-name))
(setter-body (cond
((member member-type string-types)
(string-setter-body member-name))
(else
(string-append
"___arg1->" member-name " = ___arg2;" "\n"
"___return;" "\n")))))
`((define ,(string->symbol getter-name)
(c-lambda (,struct-ptr) ,member-type
,(string-append
"___return(___arg1->" member-name ");")))
(map (lambda (m)
(let* ((member-name (symbol->string (car m)))
(member-type (cdr m))
(getter-name (string-append struct-str "-" member-name))
(setter-body (cond
((member member-type string-types)
(string-setter-body member-name))
(else
(string-append
"___arg1->" member-name " = ___arg2;" "\n"
"___return;" "\n")))))
`((define ,(string->symbol getter-name)
(c-lambda (,struct-ptr) ,member-type
,(string-append
"___return(___arg1->" member-name ");")))

(define ,(string->symbol (string-append getter-name "-set!"))
(c-lambda (,struct-ptr ,member-type) void
,setter-body)))))
members))
(define ,(string->symbol (string-append getter-name "-set!"))
(c-lambda (,struct-ptr ,member-type) void
,setter-body)))))
members))

;; malloc
(define ,(string->symbol (string-append "malloc-" struct-str))
(c-lambda () ,struct-ptr
,(string-append
"struct " struct-str "* var = malloc(sizeof(struct " struct-str "));" "\n"
"memset(var, 0, sizeof(struct " struct-str "));"
"if (var == NULL)" "\n"
" ___return (NULL);" "\n"
"memset(var, 0, sizeof(struct " struct-str "));"
"___return(var);")))

(define ,(string->symbol (string-append "ptr->" struct-str))
Expand All @@ -192,9 +193,9 @@
(c-lambda (unsigned-int32) ,(if string-compat-required? shallow-ptr struct-ptr)
,(string-append
"struct " struct-str " *arr_var=malloc(___arg1*sizeof(struct " struct-str "));" "\n"
"memset(arr_var, 0, ___arg1*sizeof(struct " struct-str "));" "\n"
"if (arr_var == NULL)" "\n"
" ___return (NULL);" "\n"
"memset(arr_var, 0, ___arg1*sizeof(struct " struct-str "));" "\n"
"___return(arr_var);")))

;; ref array
Expand Down Expand Up @@ -248,22 +249,24 @@ END-C
(format-id name "~a-~a-set!" name field)))
fields))))

(syntax-case stx ()
((_ (exts ...) body ...)
(with-syntax (((id ...)
(let lp ((rest #'(exts ...))
(ids []))
(syntax-case rest (struct)
((id . rest)
(identifier? #'id)
(lp #'rest (cons #'id ids)))
(def (parse-externs exts)
(let lp ((rest exts)
(ids []))
(syntax-case rest (struct)
((id . rest)
(identifier? #'id)
(lp #'rest (cons #'id ids)))

(((struct name fields ...) . rest)
(lp (syntax rest)
(foldl cons ids (make-struct-ids #'name
#'(fields ...)))))
(((struct name fields ...) . rest)
(lp (syntax rest)
(foldl cons ids (make-struct-ids #'name
#'(fields ...)))))

(() ids)))))
(() ids))))

(syntax-case stx ()
((_ (exts ...) body ...)
(with-syntax (((id ...) (parse-externs (syntax (exts ...)))))
(if (module-context? (current-expander-context))
(let (ns (or (module-context-ns (current-expander-context))
(expander-context-id (current-expander-context))))
Expand Down
2 changes: 2 additions & 0 deletions src/std/run-tests.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
;; -*- Gerbil -*-

(import :std/test
:std/foreign-test
"build-config"
"generic-test"
"coroutine-test"
Expand Down Expand Up @@ -81,6 +82,7 @@
httpd-test
sasl-test
protobuf-test
foreign-test
(if config-enable-sqlite [sqlite-test] []) ...
(if config-enable-lmdb [lmdb-test] []) ...
(if config-enable-leveldb [leveldb-test] []) ...
Expand Down

0 comments on commit cd7b1d7

Please sign in to comment.