~ chicken-core (master) /posix-common.scm
Trap1;;;; posix-common.scm - common code for UNIX and Windows versions of the posix unit2;3; Copyright (c) 2010-2022, The CHICKEN Team4; All rights reserved.5;6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following7; conditions are met:8;9; Redistributions of source code must retain the above copyright notice, this list of conditions and the following10; disclaimer.11; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following12; disclaimer in the documentation and/or other materials provided with the distribution.13; Neither the name of the author nor the names of its contributors may be used to endorse or promote14; products derived from this software without specific prior written permission.15;16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE24; POSSIBILITY OF SUCH DAMAGE.252627(declare28 (foreign-declare #<<EOF2930#include <signal.h>3132static int C_not_implemented(void);33int C_not_implemented() { return -1; }3435#if defined(_WIN32) && !defined(__CYGWIN__)36static struct _stat64i32 C_statbuf;37#define C_fstat _fstat64i3238#else39static struct stat C_statbuf;40#define C_fstat fstat41#endif4243#define C_stat_type (C_statbuf.st_mode & S_IFMT)44#define C_stat_perm (C_statbuf.st_mode & ~S_IFMT)4546#define C_u_i_stat(fn) C_fix(C_stat(C_OS_FILENAME(fn, 0), &C_statbuf))47#define C_u_i_fstat(fd) C_fix(C_fstat(C_unfix(fd), &C_statbuf))4849#ifndef S_IFSOCK50# define S_IFSOCK 014000051#endif5253#ifndef S_IRUSR54# define S_IRUSR S_IREAD55#endif56#ifndef S_IWUSR57# define S_IWUSR S_IWRITE58#endif59#ifndef S_IXUSR60# define S_IXUSR S_IEXEC61#endif6263#ifndef S_IRGRP64# define S_IRGRP S_IREAD65#endif66#ifndef S_IWGRP67# define S_IWGRP S_IWRITE68#endif69#ifndef S_IXGRP70# define S_IXGRP S_IEXEC71#endif7273#ifndef S_IROTH74# define S_IROTH S_IREAD75#endif76#ifndef S_IWOTH77# define S_IWOTH S_IWRITE78#endif79#ifndef S_IXOTH80# define S_IXOTH S_IEXEC81#endif8283#define cpy_tmvec_to_tmstc08(ptm, v) \84 ((ptm)->tm_sec = C_unfix(C_block_item((v), 0)), \85 (ptm)->tm_min = C_unfix(C_block_item((v), 1)), \86 (ptm)->tm_hour = C_unfix(C_block_item((v), 2)), \87 (ptm)->tm_mday = C_unfix(C_block_item((v), 3)), \88 (ptm)->tm_mon = C_unfix(C_block_item((v), 4)), \89 (ptm)->tm_year = C_unfix(C_block_item((v), 5)), \90 (ptm)->tm_wday = C_unfix(C_block_item((v), 6)), \91 (ptm)->tm_yday = C_unfix(C_block_item((v), 7)), \92 (ptm)->tm_isdst = (C_block_item((v), 8) != C_SCHEME_FALSE))9394#define cpy_tmvec_to_tmstc9(ptm, v) \95 (((struct tm *)ptm)->tm_gmtoff = -C_unfix(C_block_item((v), 9)))9697#define C_tm_set_08(v, tm) cpy_tmvec_to_tmstc08( (tm), (v) )98#define C_tm_set_9(v, tm) cpy_tmvec_to_tmstc9( (tm), (v) )99100static struct tm *101C_tm_set( C_word v, void *tm )102{103 C_tm_set_08( v, (struct tm *)tm );104#if defined(C_GNU_ENV) && !defined(__CYGWIN__) && !defined(__uClinux__)105 C_tm_set_9( v, (struct tm *)tm );106#endif107 return tm;108}109110#define TIME_STRING_MAXLENGTH 255111static char C_time_string [TIME_STRING_MAXLENGTH + 1];112#undef TIME_STRING_MAXLENGTH113114#define C_strftime(v, f, tm) \115 (strftime(C_time_string, sizeof(C_time_string), C_c_string(f), C_tm_set((v), (tm))) ? C_time_string : NULL)116#define C_a_mktime(ptr, c, v, tm) C_int64_to_num(ptr, mktime(C_tm_set((v), C_data_pointer(tm))))117#define C_asctime(v, tm) (asctime(C_tm_set((v), (tm))))118119#define C_fdopen(a, n, fd, m) C_mpointer(a, fdopen(C_unfix(fd), C_c_string(m)))120#define C_dup(x) C_fix(dup(C_unfix(x)))121#define C_dup2(x, y) C_fix(dup2(C_unfix(x), C_unfix(y)))122123#define C_set_file_ptr(port, ptr) (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)124125/* It is assumed that 'int' is-a 'long' */126#define C_ftell(a, n, p) C_int64_to_num(a, ftell(C_port_file(p)))127#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int64(n), C_unfix(w)))128#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_num_to_int64(o), C_unfix(w)))129130EOF131))132133(include "common-declarations.scm")134135(import (only (scheme base) port?))136137(define-syntax define-unimplemented138 (syntax-rules ()139 ((_ ?name)140 (define (?name . _)141 (error '?name (##core#immutable '"this function is not available on this platform")) ) ) ) )142143(define-syntax set!-unimplemented144 (syntax-rules ()145 ((_ ?name)146 (set! ?name147 (lambda _148 (error '?name (##core#immutable '"this function is not available on this platform"))) ) ) ) )149150151;;; Error codes:152153(define-foreign-variable _errno int "errno")154155(define-foreign-variable _eperm int "EPERM")156(define-foreign-variable _enoent int "ENOENT")157(define-foreign-variable _esrch int "ESRCH")158(define-foreign-variable _eintr int "EINTR")159(define-foreign-variable _eio int "EIO")160(define-foreign-variable _enoexec int "ENOEXEC")161(define-foreign-variable _ebadf int "EBADF")162(define-foreign-variable _echild int "ECHILD")163(define-foreign-variable _enomem int "ENOMEM")164(define-foreign-variable _eacces int "EACCES")165(define-foreign-variable _efault int "EFAULT")166(define-foreign-variable _ebusy int "EBUSY")167(define-foreign-variable _eexist int "EEXIST")168(define-foreign-variable _enotdir int "ENOTDIR")169(define-foreign-variable _eisdir int "EISDIR")170(define-foreign-variable _einval int "EINVAL")171(define-foreign-variable _emfile int "EMFILE")172(define-foreign-variable _enospc int "ENOSPC")173(define-foreign-variable _espipe int "ESPIPE")174(define-foreign-variable _epipe int "EPIPE")175(define-foreign-variable _eagain int "EAGAIN")176(define-foreign-variable _erofs int "EROFS")177(define-foreign-variable _enxio int "ENXIO")178(define-foreign-variable _e2big int "E2BIG")179(define-foreign-variable _exdev int "EXDEV")180(define-foreign-variable _enodev int "ENODEV")181(define-foreign-variable _enfile int "ENFILE")182(define-foreign-variable _enotty int "ENOTTY")183(define-foreign-variable _efbig int "EFBIG")184(define-foreign-variable _emlink int "EMLINK")185(define-foreign-variable _edom int "EDOM")186(define-foreign-variable _erange int "ERANGE")187(define-foreign-variable _edeadlk int "EDEADLK")188(define-foreign-variable _enametoolong int "ENAMETOOLONG")189(define-foreign-variable _enolck int "ENOLCK")190(define-foreign-variable _enosys int "ENOSYS")191(define-foreign-variable _enotempty int "ENOTEMPTY")192(define-foreign-variable _eilseq int "EILSEQ")193(define-foreign-variable _ewouldblock int "EWOULDBLOCK")194195196;;; File properties197198(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")199(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")200(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")201(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")202(define-foreign-variable _stat_st_mtime integer64 "C_statbuf.st_mtime")203(define-foreign-variable _stat_st_atime integer64 "C_statbuf.st_atime")204(define-foreign-variable _stat_st_ctime integer64 "C_statbuf.st_ctime")205(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")206(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")207(define-foreign-variable _stat_st_dev unsigned-int "C_statbuf.st_dev")208(define-foreign-variable _stat_st_rdev unsigned-int "C_statbuf.st_rdev")209210(define-syntax stat-mode211 (er-macro-transformer212 (lambda (x r c)213 ;; no need to rename here214 (let* ((mode (cadr x))215 (name (symbol->string mode)))216 `(##core#begin217 (declare218 (foreign-declare219 ,(string-append "#ifndef " name "\n"220 "#define " name " S_IFREG\n"221 "#endif\n")))222 (define-foreign-variable ,mode unsigned-int))))))223224(stat-mode S_IFLNK)225(stat-mode S_IFREG)226(stat-mode S_IFDIR)227(stat-mode S_IFCHR)228(stat-mode S_IFBLK)229(stat-mode S_IFSOCK)230(stat-mode S_IFIFO)231232(define (stat file link err loc)233 (let ((r (cond ((fixnum? file) (##core#inline "C_u_i_fstat" file))234 ((port? file) (##core#inline "C_u_i_fstat" (chicken.file.posix#port->fileno file)))235 ((string? file)236 (let ((path (##sys#make-c-string file loc)))237 (if link238 (##core#inline "C_u_i_lstat" path)239 (##core#inline "C_u_i_stat" path))))240 (else241 (##sys#signal-hook242 #:type-error loc "bad argument type - not a fixnum, port or string" file)) ) ) )243 (if (fx< r 0)244 (if err245 (##sys#posix-error #:file-error loc "cannot access file" file)246 #f)247 #t)))248249(set! chicken.file.posix#file-stat250 (lambda (f #!optional link)251 (stat f link #t 'file-stat)252 (vector _stat_st_ino _stat_st_mode _stat_st_nlink253 _stat_st_uid _stat_st_gid _stat_st_size254 _stat_st_atime _stat_st_ctime _stat_st_mtime255 _stat_st_dev _stat_st_rdev256 _stat_st_blksize _stat_st_blocks) ) )257258(set! chicken.file.posix#set-file-permissions!259 (lambda (f p)260 (##sys#check-fixnum p 'set-file-permissions!)261 (let ((r (cond ((fixnum? f) (##core#inline "C_fchmod" f p))262 ((port? f) (##core#inline "C_fchmod" (chicken.file.posix#port->fileno f) p))263 ((string? f)264 (##core#inline "C_chmod"265 (##sys#make-c-string f 'set-file-permissions!) p))266 (else267 (##sys#signal-hook268 #:type-error 'file-permissions269 "bad argument type - not a fixnum, port or string" f)) ) ) )270 (when (fx< r 0)271 (##sys#posix-error #:file-error 'set-file-permissions! "cannot change file permissions" f p) ) )))272273(set! chicken.file.posix#file-modification-time274 (lambda (f)275 (stat f #f #t 'file-modification-time)276 _stat_st_mtime))277(set! chicken.file.posix#file-access-time278 (lambda (f)279 (stat f #f #t 'file-access-time)280 _stat_st_atime))281(set! chicken.file.posix#file-change-time282 (lambda (f)283 (stat f #f #t 'file-change-time)284 _stat_st_ctime))285286(set! chicken.file.posix#set-file-times!287 (lambda (f . rest)288 (let-optionals* rest ((atime (current-seconds)) (mtime atime))289 (when atime (##sys#check-exact-integer atime 'set-file-times!))290 (when mtime (##sys#check-exact-integer mtime 'set-file-times!))291 (let ((r ((foreign-lambda int "set_file_mtime"292 scheme-object scheme-object scheme-object)293 f atime mtime)))294 (when (fx< r 0)295 (apply ##sys#posix-error296 #:file-error297 'set-file-times! "cannot set file times" f rest))))))298299(set! chicken.file.posix#file-size300 (lambda (f) (stat f #f #t 'file-size) _stat_st_size))301302(set! chicken.file.posix#set-file-owner!303 (lambda (f uid)304 (chown 'set-file-owner! f uid -1)))305306(set! chicken.file.posix#set-file-group!307 (lambda (f gid)308 (chown 'set-file-group! f -1 gid)))309310(set! chicken.file.posix#file-owner311 (getter-with-setter312 (lambda (f) (stat f #f #t 'file-owner) _stat_st_uid)313 chicken.file.posix#set-file-owner!314 "(chicken.file.posix#file-owner f)") )315316(set! chicken.file.posix#file-group317 (getter-with-setter318 (lambda (f) (stat f #f #t 'file-group) _stat_st_gid)319 chicken.file.posix#set-file-group!320 "(chicken.file.posix#file-group f)") )321322(set! chicken.file.posix#file-permissions323 (getter-with-setter324 (lambda (f)325 (stat f #f #t 'file-permissions)326 (foreign-value "C_stat_perm" unsigned-int))327 chicken.file.posix#set-file-permissions!328 "(chicken.file.posix#file-permissions f)"))329330(set! chicken.file.posix#file-type331 (lambda (file #!optional link (err #t))332 (and (stat file link err 'file-type)333 (let ((res (foreign-value "C_stat_type" unsigned-int)))334 (cond335 ((fx= res S_IFREG) 'regular-file)336 ((fx= res S_IFLNK) 'symbolic-link)337 ((fx= res S_IFDIR) 'directory)338 ((fx= res S_IFCHR) 'character-device)339 ((fx= res S_IFBLK) 'block-device)340 ((fx= res S_IFIFO) 'fifo)341 ((fx= res S_IFSOCK) 'socket)342 (else 'regular-file))))))343344(set! chicken.file.posix#regular-file?345 (lambda (file)346 (eq? 'regular-file (chicken.file.posix#file-type file #f #f))))347348(set! chicken.file.posix#symbolic-link?349 (lambda (file)350 (eq? 'symbolic-link (chicken.file.posix#file-type file #t #f))))351352(set! chicken.file.posix#block-device?353 (lambda (file)354 (eq? 'block-device (chicken.file.posix#file-type file #f #f))))355356(set! chicken.file.posix#character-device?357 (lambda (file)358 (eq? 'character-device (chicken.file.posix#file-type file #f #f))))359360(set! chicken.file.posix#fifo?361 (lambda (file)362 (eq? 'fifo (chicken.file.posix#file-type file #f #f))))363364(set! chicken.file.posix#socket?365 (lambda (file)366 (eq? 'socket (chicken.file.posix#file-type file #f #f))))367368(set! chicken.file.posix#directory?369 (lambda (file)370 (eq? 'directory (chicken.file.posix#file-type file #f #f))))371372373;;; File position access:374375(define-foreign-variable _seek_set int "SEEK_SET")376(define-foreign-variable _seek_cur int "SEEK_CUR")377(define-foreign-variable _seek_end int "SEEK_END")378379(set! chicken.file.posix#seek/set _seek_set)380(set! chicken.file.posix#seek/end _seek_end)381(set! chicken.file.posix#seek/cur _seek_cur)382383(set! chicken.file.posix#set-file-position!384 (lambda (port pos . whence)385 (let ((whence (if (pair? whence) (car whence) _seek_set)))386 (##sys#check-fixnum pos 'set-file-position!)387 (##sys#check-fixnum whence 'set-file-position!)388 (unless (cond ((port? port)389 (and-let* ((stream (eq? (##sys#slot port 7) 'stream))390 (res (##core#inline "C_fseek" port pos whence)))391 (##sys#setislot port 6 #f) ;; Reset EOF status392 res))393 ((fixnum? port)394 (##core#inline "C_lseek" port pos whence))395 (else396 (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )397 (##sys#posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )398399(set! chicken.file.posix#file-position400 (getter-with-setter401 (lambda (port)402 (let ((pos (cond ((port? port)403 (if (eq? (##sys#slot port 7) 'stream)404 (##core#inline_allocate ("C_ftell" 7) port)405 -1) )406 ((fixnum? port)407 (##core#inline "C_lseek" port 0 _seek_cur) )408 (else409 (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )410 (when (< pos 0)411 (##sys#posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )412 pos) )413 chicken.file.posix#set-file-position! ; doesn't accept WHENCE414 "(chicken.file.posix#file-position port)"))415416417;;; Using file-descriptors:418419(define-foreign-variable _stdin_fileno int "STDIN_FILENO")420(define-foreign-variable _stdout_fileno int "STDOUT_FILENO")421(define-foreign-variable _stderr_fileno int "STDERR_FILENO")422423(set! chicken.file.posix#fileno/stdin _stdin_fileno)424(set! chicken.file.posix#fileno/stdout _stdout_fileno)425(set! chicken.file.posix#fileno/stderr _stderr_fileno)426427(define-foreign-variable _o_rdonly int "O_RDONLY")428(define-foreign-variable _o_wronly int "O_WRONLY")429(define-foreign-variable _o_rdwr int "O_RDWR")430(define-foreign-variable _o_creat int "O_CREAT")431(define-foreign-variable _o_append int "O_APPEND")432(define-foreign-variable _o_excl int "O_EXCL")433(define-foreign-variable _o_trunc int "O_TRUNC")434(define-foreign-variable _o_binary int "O_BINARY")435(define-foreign-variable _o_text int "O_TEXT")436437(set! chicken.file.posix#open/rdonly _o_rdonly)438(set! chicken.file.posix#open/wronly _o_wronly)439(set! chicken.file.posix#open/rdwr _o_rdwr)440(set! chicken.file.posix#open/read _o_rdonly)441(set! chicken.file.posix#open/write _o_wronly)442(set! chicken.file.posix#open/creat _o_creat)443(set! chicken.file.posix#open/append _o_append)444(set! chicken.file.posix#open/excl _o_excl)445(set! chicken.file.posix#open/trunc _o_trunc)446(set! chicken.file.posix#open/binary _o_binary)447(set! chicken.file.posix#open/text _o_text)448449;; open/noinherit is platform-specific450451(define-foreign-variable _s_irusr int "S_IRUSR")452(define-foreign-variable _s_iwusr int "S_IWUSR")453(define-foreign-variable _s_ixusr int "S_IXUSR")454(define-foreign-variable _s_irgrp int "S_IRGRP")455(define-foreign-variable _s_iwgrp int "S_IWGRP")456(define-foreign-variable _s_ixgrp int "S_IXGRP")457(define-foreign-variable _s_iroth int "S_IROTH")458(define-foreign-variable _s_iwoth int "S_IWOTH")459(define-foreign-variable _s_ixoth int "S_IXOTH")460(define-foreign-variable _s_irwxu int "S_IRUSR | S_IWUSR | S_IXUSR")461(define-foreign-variable _s_irwxg int "S_IRGRP | S_IWGRP | S_IXGRP")462(define-foreign-variable _s_irwxo int "S_IROTH | S_IWOTH | S_IXOTH")463464(set! chicken.file.posix#perm/irusr _s_irusr)465(set! chicken.file.posix#perm/iwusr _s_iwusr)466(set! chicken.file.posix#perm/ixusr _s_ixusr)467(set! chicken.file.posix#perm/irgrp _s_irgrp)468(set! chicken.file.posix#perm/iwgrp _s_iwgrp)469(set! chicken.file.posix#perm/ixgrp _s_ixgrp)470(set! chicken.file.posix#perm/iroth _s_iroth)471(set! chicken.file.posix#perm/iwoth _s_iwoth)472(set! chicken.file.posix#perm/ixoth _s_ixoth)473(set! chicken.file.posix#perm/irwxu _s_irwxu)474(set! chicken.file.posix#perm/irwxg _s_irwxg)475(set! chicken.file.posix#perm/irwxo _s_irwxo)476477;; perm/isvtx, perm/isuid and perm/isgid are platform-specific478479(let ()480 (define (mode inp m loc)481 (##sys#make-c-string482 (cond (m (case m483 ((#:append) (if (not inp) "a" (##sys#error "invalid mode for input file" m)))484 (else (##sys#error "invalid mode argument" m)) ) )485 (inp "r")486 (else "w") )487 loc) )488 (define (check loc fd inp r enc)489 (if (##sys#null-pointer? r)490 (##sys#posix-error #:file-error loc "cannot open file" fd)491 (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(fdport)" 'stream)))492 (##core#inline "C_set_file_ptr" port r)493 (##sys#setslot port 15 enc)494 port) ) )495 (set! chicken.file.posix#open-input-file*496 (lambda (fd #!optional m (enc 'utf-8))497 (##sys#check-fixnum fd 'open-input-file*)498 (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m 'open-input-file*)) enc)) )499 (set! chicken.file.posix#open-output-file*500 (lambda (fd #!optional m (enc 'utf-8))501 (##sys#check-fixnum fd 'open-output-file*)502 (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m 'open-output-file*)) enc) ) ) )503504(set! chicken.file.posix#port->fileno505 (lambda (port)506 (##sys#check-open-port port 'port->fileno)507 (cond ((eq? 'socket (##sys#slot port 7))508 ;; Extract socket-FD from the port's "data" object - this is identical509 ;; to "##sys#tcp-port->fileno" in the tcp unit (tcp.scm). We code it in510 ;; this low-level manner to avoid depend on code defined there.511 ;; Peter agrees with that. I think. Have a nice day.512 (##sys#slot (##sys#port-data port) 0) )513 ((not (zero? (##sys#peek-unsigned-integer port 0)))514 (let ([fd (##core#inline "C_port_fileno" port)])515 (when (fx< fd 0)516 (##sys#posix-error #:file-error 'port->fileno "cannot access file-descriptor of port" port) )517 fd) )518 (else (##sys#posix-error #:type-error 'port->fileno "port has no attached file" port)) ) ) )519520(set! chicken.file.posix#duplicate-fileno521 (lambda (old . new)522 (##sys#check-fixnum old 'duplicate-fileno)523 (let ([fd (if (null? new)524 (##core#inline "C_dup" old)525 (let ([n (car new)])526 (##sys#check-fixnum n 'duplicate-fileno)527 (##core#inline "C_dup2" old n) ) ) ] )528 (when (fx< fd 0)529 (##sys#posix-error #:file-error 'duplicate-fileno "cannot duplicate file-descriptor" old) )530 fd) ) )531532533;;; Access process ID:534535(set! chicken.process-context.posix#current-process-id536 (foreign-lambda int "C_getpid"))537538539;;; Set or get current directory by file descriptor:540541(set! chicken.process-context.posix#change-directory*542 (lambda (fd)543 (##sys#check-fixnum fd 'change-directory*)544 (unless (fx= 0 (##core#inline "C_fchdir" fd))545 (##sys#posix-error #:file-error 'change-directory* "cannot change current directory" fd))546 fd))547548(set! ##sys#change-directory-hook549 (let ((cd ##sys#change-directory-hook))550 (lambda (dir)551 ((if (fixnum? dir)552 chicken.process-context.posix#change-directory*553 cd) dir))))554555;;; umask556557(set! chicken.file.posix#file-creation-mode558 (getter-with-setter559 (lambda (#!optional um)560 (when um (##sys#check-fixnum um 'file-creation-mode))561 (let ((um2 (##core#inline "C_umask" (or um 0))))562 (unless um (##core#inline "C_umask" um2)) ; restore563 um2))564 (lambda (um)565 (##sys#check-fixnum um 'file-creation-mode)566 (##core#inline "C_umask" um))567 "(chicken.file.posix#file-creation-mode mode)"))568569570;;; Time related things:571572(define decode-seconds (##core#primitive "C_decode_seconds"))573574(define (check-time-vector loc tm)575 (##sys#check-vector tm loc)576 (when (fx< (##sys#size tm) 10)577 (##sys#error loc "time vector too short" tm) ) )578579(set! chicken.time.posix#seconds->local-time580 (lambda (#!optional (secs (current-seconds)))581 (##sys#check-exact-integer secs 'seconds->local-time)582 (decode-seconds secs #f) ))583584(set! chicken.time.posix#seconds->utc-time585 (lambda (#!optional (secs (current-seconds)))586 (##sys#check-exact-integer secs 'seconds->utc-time)587 (decode-seconds secs #t) ) )588589(set! chicken.time.posix#seconds->string590 (let ([ctime (foreign-lambda c-string "C_ctime" integer)])591 (lambda (#!optional (secs (current-seconds)))592 (##sys#check-exact-integer secs 'seconds->string)593 (let ([str (ctime secs)])594 (if str595 (##sys#substring str 0 (fx- (string-length str) 1))596 (##sys#error 'seconds->string "cannot convert seconds to string" secs) ) ) ) ) )597598(set! chicken.time.posix#local-time->seconds599 (let ((tm-size (foreign-value "sizeof(struct tm)" int)))600 (lambda (tm)601 (check-time-vector 'local-time->seconds tm)602 (let ((t (##core#inline_allocate ("C_a_mktime" 7) tm (##sys#make-bytevector tm-size 0))))603 (if (= -1 t)604 (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm)605 t)))))606607(set! chicken.time.posix#time->string608 (let ((asctime (foreign-lambda c-string "C_asctime" scheme-object scheme-pointer))609 (strftime (foreign-lambda c-string "C_strftime" scheme-object scheme-object scheme-pointer))610 (tm-size (foreign-value "sizeof(struct tm)" int)))611 (lambda (tm #!optional fmt)612 (check-time-vector 'time->string tm)613 (if fmt614 (begin615 (##sys#check-string fmt 'time->string)616 (or (strftime tm (##sys#make-c-string fmt 'time->string) (##sys#make-bytevector tm-size 0))617 (##sys#error 'time->string "time formatting overflows buffer" tm)) )618 (let ([str (asctime tm (##sys#make-bytevector tm-size 0))])619 (if str620 (##sys#substring str 0 (fx- (string-length str) 1))621 (##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )622623624;;; Signals625626(set! chicken.process.signal#set-signal-handler! ; DEPRECATED627 (lambda (sig proc)628 (##sys#check-fixnum sig 'set-signal-handler!)629 (##core#inline "C_establish_signal_handler" sig (and proc sig))630 (vector-set! ##sys#signal-vector sig proc) ) )631632(set! chicken.process.signal#signal-handler ; DEPRECATED633 (getter-with-setter634 (lambda (sig)635 (##sys#check-fixnum sig 'signal-handler)636 (##sys#slot ##sys#signal-vector sig) )637 chicken.process.signal#set-signal-handler!638 "(chicken.process.signal#signal-handler sig)"))639640(set! chicken.process.signal#make-signal-handler641 (lambda sigs642 (let ((q (##sys#make-event-queue)))643 (for-each644 (lambda (sig)645 (##sys#check-fixnum sig 'make-signal-handler)646 (##core#inline "C_establish_signal_handler" sig sig)647 (vector-set! ##sys#signal-vector sig648 (lambda (sig) (##sys#add-event-to-queue! q sig))))649 sigs)650 (lambda (#!optional wait)651 (if wait652 (##sys#wait-for-next-event q)653 (##sys#get-next-event q))))))654655(set! chicken.process.signal#signal-ignore656 (lambda (sig)657 (##sys#check-fixnum sig 'signal-ignore)658 (##core#inline "C_establish_signal_handler" sig #f)659 (vector-set! ##sys#signal-vector sig #f)))660661(set! chicken.process.signal#signal-default662 (lambda (sig)663 (##sys#check-fixnum sig 'signal-default)664 (##core#inline "C_establish_signal_handler" sig #t)665 (vector-set! ##sys#signal-vector sig #f)))666667668;;; Processes669670(define children '())671672(define-record process673 id returned-normally? input-port output-port error-port exit-status)674675(define (get-pid x #!optional default)676 (cond ((fixnum? x) x)677 ((process? x) (process-id x))678 (else default)))679680(define (register-pid pid)681 (let ((p (make-process pid #f #f #f #f #f)))682 (set! children (cons (cons pid p) children))683 p))684685(define (drop-child pid)686 (set! children687 (let rec ((cs children))688 (cond ((null? cs) '())689 ((eq? pid (caar cs)) (cdr cs))690 (else (rec (cdr cs)))))))691692(set! chicken.process#process? process?)693(set! chicken.process#process-id process-id)694(set! chicken.process#process-exit-status process-exit-status)695(set! chicken.process#process-returned-normally? process-returned-normally?)696(set! chicken.process#process-input-port process-input-port)697(set! chicken.process#process-output-port process-output-port)698(set! chicken.process#process-error-port process-error-port)699700(set! chicken.process#process-sleep701 (lambda (n)702 (##sys#check-fixnum n 'process-sleep)703 (##core#inline "C_i_process_sleep" n)))704705(set! chicken.process#process-wait706 (lambda args707 (let-optionals* args ((proc #f) (nohang #f))708 (if (and (process? proc) (process-exit-status proc))709 (values (process-id proc)710 (process-returned-normally? proc)711 (process-exit-status proc))712 (let ((pid (get-pid proc -1)))713 (##sys#check-fixnum pid 'process-wait)714 (receive (epid enorm ecode) (process-wait-impl pid nohang)715 (cond716 ((fx= epid -1)717 (##sys#posix-error #:process-error 'process-wait718 "waiting for child process failed" pid))719 ((fx= epid 0)720 (values 0 #f #f))721 (else722 (unless (process? proc)723 (let ((a (assq epid children)))724 (when a725 (set! proc (cdr a)))))726 (drop-child epid)727 (when (process? proc)728 (process-returned-normally?-set! proc enorm)729 (process-exit-status-set! proc ecode))730 (values epid enorm ecode))) ) )) ) ) )731732;; This can construct argv or envp for process-execute or process-run733(define list->c-string-buffer734 (lambda (string-list convert loc)735 (##sys#check-list string-list loc)736737 (let* ((string-count (##sys#length string-list))738 ;; NUL-terminated, so we must add one739 (buffer (make-pointer-vector (add1 string-count) #f)))740741 (handle-exceptions exn742 ;; Free to avoid memory leak, then reraise743 (begin (free-c-string-buffer buffer) (signal exn))744745 (do ((sl string-list (cdr sl))746 (i 0 (fx+ i 1)))747 ((or (null? sl) (fx= i string-count))) ; Should coincide748749 (##sys#check-string (car sl) loc)750 ;; This avoids embedded NULs and appends a NUL, so "cs" is751 ;; safe to copy and use as-is in the pointer-vector.752 (let* ((cs (##sys#make-c-string (convert (car sl)) loc))753 (csp (c-string->allocated-pointer cs)))754 (unless csp (error loc "Out of memory"))755 (pointer-vector-set! buffer i csp)))756757 buffer))))758759(define (free-c-string-buffer buffer-array)760 (let ((size (pointer-vector-length buffer-array)))761 (do ((i 0 (fx+ i 1)))762 ((fx= i size))763 (and-let* ((s (pointer-vector-ref buffer-array i)))764 (free s)))))765766;; Environments are represented as string->string association lists767(define (check-environment-list lst loc)768 (##sys#check-list lst loc)769 (for-each770 (lambda (p)771 (##sys#check-pair p loc)772 (##sys#check-string (car p) loc)773 (##sys#check-string (cdr p) loc))774 lst))775776(define call-with-exec-args777 (let ((nop (lambda (x) x)))778 (lambda (loc filename argconv arglist envlist proc)779 (let* ((args (cons filename arglist)) ; Add argv[0]780 (argbuf (list->c-string-buffer args argconv loc))781 (envbuf #f))782783 (handle-exceptions exn784 ;; Free to avoid memory leak, then reraise785 (begin (free-c-string-buffer argbuf)786 (when envbuf (free-c-string-buffer envbuf))787 (signal exn))788789 ;; Envlist is never converted, so we always use nop here790 (when envlist791 (check-environment-list envlist loc)792 (set! envbuf793 (list->c-string-buffer794 (map (lambda (p) (string-append (car p) "=" (cdr p))) envlist)795 nop loc)))796797 (proc (##sys#make-c-string filename loc) argbuf envbuf))))))798799;; Pipes:800801(define-foreign-variable _pipe_buf int "PIPE_BUF")802(set! chicken.process#pipe/buf _pipe_buf)803804(let ()805 (define (mode arg) (if (pair? arg) (##sys#slot arg 0) #:text))806 (define (badmode m) (##sys#error "illegal input/output mode specifier" m))807 (define (check loc cmd inp r)808 (if (##sys#null-pointer? r)809 (##sys#posix-error #:file-error loc "cannot open pipe" cmd)810 (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(pipe)" 'stream)))811 (##core#inline "C_set_file_ptr" port r)812 port) ) )813 (set! chicken.process#open-input-pipe814 (lambda (cmd . m)815 (##sys#check-string cmd 'open-input-pipe)816 (let ([m (mode m)])817 (check818 'open-input-pipe819 cmd #t820 (case m821 ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe)))822 ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd 'open-input-pipe)))823 (else (badmode m)) ) ) ) ) )824 (set! chicken.process#open-output-pipe825 (lambda (cmd . m)826 (##sys#check-string cmd 'open-output-pipe)827 (let ((m (mode m)))828 (check829 'open-output-pipe830 cmd #f831 (case m832 ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe)))833 ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd 'open-output-pipe)))834 (else (badmode m)) ) ) ) ) )835 (set! chicken.process#close-input-pipe836 (lambda (port)837 (##sys#check-input-port port #t 'close-input-pipe)838 (let ((r (##core#inline "close_pipe" port)))839 (when (eq? -1 r)840 (##sys#posix-error #:file-error 'close-input-pipe "error while closing pipe" port))841 r) ) )842 (set! chicken.process#close-output-pipe843 (lambda (port)844 (##sys#check-output-port port #t 'close-output-pipe)845 (let ((r (##core#inline "close_pipe" port)))846 (when (eq? -1 r)847 (##sys#posix-error #:file-error 'close-output-pipe "error while closing pipe" port))848 r) ) ))849850(set! chicken.process#with-input-from-pipe851 (lambda (cmd thunk . mode)852 (let ((p (apply chicken.process#open-input-pipe cmd mode)))853 (fluid-let ((##sys#standard-input p))854 (call-with-values thunk855 (lambda results856 (chicken.process#close-input-pipe p)857 (apply values results) ) ) ) ) ) )858859(set! chicken.process#call-with-output-pipe860 (lambda (cmd proc . mode)861 (let ((p (apply chicken.process#open-output-pipe cmd mode)))862 (call-with-values863 (lambda () (proc p))864 (lambda results865 (chicken.process#close-output-pipe p)866 (apply values results) ) ) ) ) )867868(set! chicken.process#call-with-input-pipe869 (lambda (cmd proc . mode)870 (let ([p (apply chicken.process#open-input-pipe cmd mode)])871 (call-with-values872 (lambda () (proc p))873 (lambda results874 (chicken.process#close-input-pipe p)875 (apply values results) ) ) ) ) )876877(set! chicken.process#with-output-to-pipe878 (lambda (cmd thunk . mode)879 (let ((p (apply chicken.process#open-output-pipe cmd mode)))880 (fluid-let ((##sys#standard-output p))881 (call-with-values thunk882 (lambda results883 (chicken.process#close-output-pipe p)884 (apply values results) ) ) ) ) ) )