Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 14:49:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Ports can be passed for fileno arguments. The fileno-nonblock return type

Browse source 
can be specified to automatically make the result non-blocking.
This commit is contained in:
Alex Shinn 2012-12-31 00:21:43 +09:00
parent 97ee1b7b65
commit 0a9dce93b0
1 changed files with 24 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

35
tools/chibi-ffi
View file

@ -505,7 +505,7 @@
((eq? base 'input-port) "sexp_iportp") ((eq? base 'input-port) "sexp_iportp")
((eq? base 'output-port) "sexp_oportp") ((eq? base 'output-port) "sexp_oportp")
((eq? base 'input-output-port) "sexp_ioportp") ((eq? base 'input-output-port) "sexp_ioportp")
((eq? base 'fileno) "sexp_filenop") ((memq base '(fileno fileno-nonblock)) "sexp_filenop")
(else #f)))) (else #f))))
(define (type-name type) (define (type-name type)
@ -531,7 +531,7 @@
((eq? base 'input-port) "SEXP_IPORT") ((eq? base 'input-port) "SEXP_IPORT")
((eq? base 'output-port) "SEXP_OPORT") ((eq? base 'output-port) "SEXP_OPORT")
((eq? base 'input-output-port) "SEXP_IPORT") ((eq? base 'input-output-port) "SEXP_IPORT")
((eq? base 'fileno) "SEXP_FILENO") ((memq base '(fileno fileno-nonblock)) "SEXP_FILENO")
((void-pointer-type? type) "SEXP_CPOINTER") ((void-pointer-type? type) "SEXP_CPOINTER")
((lookup-type base) ((lookup-type base)
;; (string-append "sexp_type_tag(" (type-id-name base) ")") ;; (string-append "sexp_type_tag(" (type-id-name base) ")")
@ -606,7 +606,7 @@
(cat "sexp_make_non_null_output_port(ctx, " val ", SEXP_FALSE)")) (cat "sexp_make_non_null_output_port(ctx, " val ", SEXP_FALSE)"))
((eq? 'input-output-port base) ((eq? 'input-output-port base)
(cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)")) (cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)"))
((eq? 'fileno base) ((memq base '(fileno fileno-nonblock))
(cat "sexp_make_fileno(ctx, sexp_make_fixnum(" val "), SEXP_FALSE)")) (cat "sexp_make_fileno(ctx, sexp_make_fixnum(" val "), SEXP_FALSE)"))
(else (else
(let ((ctype (lookup-type base)) (let ((ctype (lookup-type base))
@ -655,10 +655,11 @@
"(" val ")")) "(" val ")"))
((eq? base 'port-or-fileno) ((eq? base 'port-or-fileno)
(cat "(sexp_portp(" val ") ? sexp_port_fileno(" val ")" (cat "(sexp_portp(" val ") ? sexp_port_fileno(" val ")"
" : sexp_fileno_fd(" val "))")) " : sexp_filenop(" val ") ? sexp_fileno_fd(" val ")"
" : sexp_unbox_fixnum(" val "))"))
((port-type? base) ((port-type? base)
(cat "sexp_port_stream(" val ")")) (cat "sexp_port_stream(" val ")"))
((eq? base 'fileno) ((memq base '(fileno fileno-nonblock))
(cat "(sexp_filenop(" val ") ? sexp_fileno_fd(" val ")" (cat "(sexp_filenop(" val ") ? sexp_fileno_fd(" val ")"
" : sexp_unbox_fixnum(" val "))")) " : sexp_unbox_fixnum(" val "))"))
(else (else
@ -677,7 +678,7 @@
(define (base-type-c-name base) (define (base-type-c-name base)
(case base (case base
((string env-string non-null-string) (if *c++?* "string" "char*")) ((string env-string non-null-string) (if *c++?* "string" "char*"))
((fileno) "int") ((fileno fileno-nonblock) "int")
(else (string-replace (symbol->string base) #\- " ")))) (else (string-replace (symbol->string base) #\- " "))))
(define (type-struct-type type) (define (type-struct-type type)
@ -715,7 +716,7 @@
((eq? base 'env-string) ((eq? base 'env-string)
(cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg
")) && sexp_stringp(sexp_cdr(" arg ")))")) ")) && sexp_stringp(sexp_cdr(" arg ")))"))
((eq? base 'fileno) ((memq base '(fileno fileno-nonblock))
(cat "(sexp_filenop(" arg ") || sexp_fixnump(" arg "))")) (cat "(sexp_filenop(" arg ") || sexp_fixnump(" arg "))"))
((string-type? base) ((string-type? base)
(cat (cat
@ -758,13 +759,13 @@
" return sexp_xtype_exception(ctx, self, \"not a list of " " return sexp_xtype_exception(ctx, self, \"not a list of "
(type-name type) "s\", " arg ");\n"))) (type-name type) "s\", " arg ");\n")))
((eq? base-type 'port-or-fileno) ((eq? base-type 'port-or-fileno)
(cat " if (! (sexp_portp(" arg ") || sexp_filenop(" arg ")))\n" (cat " if (! (sexp_portp(" arg ") || sexp_filenop(" arg ") || sexp_fixnump(" arg ")))\n"
" return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n"))
((or (int-type? base-type) ((or (int-type? base-type)
(float-type? base-type) (float-type? base-type)
(string-type? base-type) (string-type? base-type)
(port-type? base-type) (port-type? base-type)
(eq? base-type 'fileno)) (memq base-type '(fileno fileno-nonblock)))
(cat (cat
" if (! " (lambda () (check-type arg type)) ")\n" " if (! " (lambda () (check-type arg type)) ")\n"
" return sexp_type_exception(ctx, self, " " return sexp_type_exception(ctx, self, "
@ -1047,11 +1048,22 @@
(define (write-result-adjustment result) (define (write-result-adjustment result)
(cond (cond
;; new port results are automatically made non-blocking
((memq (type-base result) '(input-port output-port input-output-port)) ((memq (type-base result) '(input-port output-port input-output-port))
(let ((res (string-append "res" (type-index-string result)))) (let ((res (string-append "res" (type-index-string result))))
(cat "#ifdef SEXP_USE_GREEN_THREADS\n" (cat "#ifdef SEXP_USE_GREEN_THREADS\n"
" if (sexp_portp(" res "))\n" " if (sexp_portp(" res "))\n"
" fcntl(fileno(sexp_port_stream(" res ")), F_SETFL, O_NONBLOCK);\n" " fcntl(fileno(sexp_port_stream(" res ")), F_SETFL, O_NONBLOCK "
" | fcntl(fileno(sexp_port_stream(" res ")), F_GETFL));\n"
"#endif\n")))
;; a file descriptor result can be automatically made non-blocking
;; by specifying a result type of fileno-nonblock
((memq (type-base result) '(fileno-nonblock))
(let ((res (string-append "res" (type-index-string result))))
(cat "#ifdef SEXP_USE_GREEN_THREADS\n"
" if (sexp_filenop(" res "))\n"
" fcntl(sexp_fileno_fd(" res "), F_SETFL, O_NONBLOCK "
" | fcntl(sexp_fileno_fd(" res "), F_GETFL));\n"
"#endif\n"))))) "#endif\n")))))
(define (write-result result . o) (define (write-result result . o)
@ -1661,7 +1673,8 @@
((and compile? (not (equal? "-" dest))) ((and compile? (not (equal? "-" dest)))
;; This has to use `eval' for bootstrapping, since we need ;; This has to use `eval' for bootstrapping, since we need
;; chibi-ffi to compile to (chibi process) module. ;; chibi-ffi to compile to (chibi process) module.
(let* ((so (string-append (strip-extension src) *shared-object-extension*)) (let* ((so (string-append (strip-extension src)
*shared-object-extension*))
(system (begin (eval '(import (chibi process))) (system (begin (eval '(import (chibi process)))
(eval 'system))) (eval 'system)))
(base-args (append (or cflags '()) (base-args (append (or cflags '())