posixunix.scm

Scheme跨平台编译器

      tl += 3600;
    }
  tg = gmtime (&tl);
  tg->tm_isdst = 0;
  tb = mktime (tg);
  if (tb == -1)
    {
      tg->tm_hour--;
      tb = mktime (tg);
      if (tb == -1)
        return -1; /* can't deal with output from gmtime */
      tb += 3600;
    }
  return (tl - (tb - tl));
}
#endif

#define C_tm_set_08(v) \
        (memset(&C_tm, 0, sizeof(struct tm)), \
        C_tm.tm_sec = C_unfix(C_block_item(v, 0)), \
        C_tm.tm_min = C_unfix(C_block_item(v, 1)), \
        C_tm.tm_hour = C_unfix(C_block_item(v, 2)), \
        C_tm.tm_mday = C_unfix(C_block_item(v, 3)), \
        C_tm.tm_mon = C_unfix(C_block_item(v, 4)), \
        C_tm.tm_year = C_unfix(C_block_item(v, 5)), \
        C_tm.tm_wday = C_unfix(C_block_item(v, 6)), \
        C_tm.tm_yday = C_unfix(C_block_item(v, 7)), \
        C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE))

#define C_tm_set_9(v) \
        (C_tm.tm_gmtoff = C_unfix(C_block_item(v, 9)))

#define C_tm_get_08(v) \
        (C_set_block_item(v, 0, C_fix(C_tm.tm_sec)), \
        C_set_block_item(v, 1, C_fix(C_tm.tm_min)), \
        C_set_block_item(v, 2, C_fix(C_tm.tm_hour)), \
        C_set_block_item(v, 3, C_fix(C_tm.tm_mday)), \
        C_set_block_item(v, 4, C_fix(C_tm.tm_mon)), \
        C_set_block_item(v, 5, C_fix(C_tm.tm_year)), \
        C_set_block_item(v, 6, C_fix(C_tm.tm_wday)), \
        C_set_block_item(v, 7, C_fix(C_tm.tm_yday)), \
        C_set_block_item(v, 8, (C_tm.tm_isdst ? C_SCHEME_TRUE : C_SCHEME_FALSE)))

#define C_tm_get_9(v) \
        (C_set_block_item(v, 9, C_fix(C_tm.tm_gmtoff)))

#if !defined(C_GNU_ENV) || defined(__CYGWIN__) || defined(__uClinux__)

static struct tm *
C_tm_set (C_word v)
{
  C_tm_set_08 (v);
  return &C_tm;
}

static C_word
C_tm_get (C_word v)
{
  C_tm_get_08 (v);
  return v;
}

#else

static struct tm *
C_tm_set (C_word v)
{
  C_tm_set_08 (v);
  C_tm_set_9 (v);
  return &C_tm;
}

static C_word
C_tm_get (C_word v)
{
  C_tm_get_08 (v);
  C_tm_get_9 (v);
  return v;
}

#endif

#define C_asctime(v)    (asctime(C_tm_set(v)))
#define C_mktime(v)     ((C_temporary_flonum = mktime(C_tm_set(v))) != -1)
#define C_timegm(v)     ((C_temporary_flonum = timegm(C_tm_set(v))) != -1)

#define TIME_STRING_MAXLENGTH 255
static char C_time_string [TIME_STRING_MAXLENGTH + 1];
#undef TIME_STRING_MAXLENGTH

#define C_strftime(v, f) \
        (strftime(C_time_string, sizeof(C_time_string), C_c_string(f), C_tm_set(v)) ? C_time_string : NULL)

#define C_strptime(s, f, v) \
        (strptime(C_c_string(s), C_c_string(f), &C_tm) ? C_tm_get(v) : C_SCHEME_FALSE)

static gid_t *C_groups = NULL;

#define C_get_gid(n)      C_fix(C_groups[ C_unfix(n) ])
#define C_set_gid(n, id)  (C_groups[ C_unfix(n) ] = C_unfix(id), C_SCHEME_UNDEFINED)
#define C_set_groups(n)   C_fix(setgroups(C_unfix(n), C_groups))

#ifdef TIOCGWINSZ
static int get_tty_size(int p, int *rows, int *cols)
{
 struct winsize tty_size;
 int r;

 memset(&tty_size, 0, sizeof tty_size);

 r = ioctl(p, TIOCGWINSZ, &tty_size);
 if (r == 0) {
    *rows = tty_size.ws_row;
    *cols = tty_size.ws_col;
 }
 return r;
}
#else
static int get_tty_size(int p, int *rows, int *cols)
{
 *rows = *cols = 0;
 return -1;
}
#endif

EOF
) )

(cond-expand
 [paranoia]
 [else
  (declare
    (no-bound-checks)
    (no-procedure-checks-for-usual-bindings)
    (bound-to-procedure
     string-match glob->regexp regexp make-anchored-pattern
     ##sys#thread-yield! ##sys#make-string
     ##sys#make-port ##sys#file-info ##sys#update-errno ##sys#fudge ##sys#make-c-string ##sys#check-port
     ##sys#error ##sys#signal-hook ##sys#peek-unsigned-integer make-pathname glob directory?
     pathname-file process-fork file-close duplicate-fileno process-execute getenv
     make-string make-input-port make-output-port ##sys#thread-block-for-i/o create-pipe
     process-wait pathname-strip-directory ##sys#expand-home-path directory
     decompose-pathname ##sys#cons-flonum ##sys#decode-seconds ##sys#null-pointer ##sys#pointer->address
     ##sys#substring ##sys#context-switch close-input-pipe close-output-pipe change-directory
     current-directory ##sys#make-pointer port? ##sys#schedule ##sys#process
     ##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts
     make-nonblocking-input-port make-nonblocking-output-port 
     canonical-path) ) ] )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-structure . _) '(##core#undefined))
    (define-macro (##sys#check-range . _) '(##core#undefined))
    (define-macro (##sys#check-pair . _) '(##core#undefined))
    (define-macro (##sys#check-list . _) '(##core#undefined))
    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    (define-macro (##sys#check-string . _) '(##core#undefined))
    (define-macro (##sys#check-char . _) '(##core#undefined))
    (define-macro (##sys#check-exact . _) '(##core#undefined))
    (define-macro (##sys#check-port . _) '(##core#undefined))
    (define-macro (##sys#check-number . _) '(##core#undefined))
    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
 [else
  (declare (emit-exports "posix.exports")) ] )

(register-feature! 'posix)

(define posix-error
  (let ([strerror (foreign-lambda c-string "strerror" int)]
        [string-append string-append] )
    (lambda (type loc msg . args)
      (let ([rn (##sys#update-errno)])
        (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )

;; Faster versions of common operations

(define ##sys#posix-error posix-error)

(define ##sys#file-nonblocking!
  (foreign-lambda* bool ([int fd])
    "int val = fcntl(fd, F_GETFL, 0);"
    "if(val == -1) return(0);"
    "return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )

(define ##sys#file-select-one
  (foreign-lambda* int ([int fd])
    "fd_set in;"
    "struct timeval tm;"
    "FD_ZERO(&in);"
    "FD_SET(fd, &in);"
    "tm.tv_sec = tm.tv_usec = 0;"
    "if(select(fd + 1, &in, NULL, NULL, &tm) == -1) return(-1);"
    "else return(FD_ISSET(fd, &in) ? 1 : 0);" ) )


;;; Lo-level I/O:

(define-foreign-variable _pipe_buf int "PIPE_BUF")

(define pipe/buf _pipe_buf)

(define-foreign-variable _f_dupfd int "F_DUPFD")
(define-foreign-variable _f_getfd int "F_GETFD")
(define-foreign-variable _f_setfd int "F_SETFD")
(define-foreign-variable _f_getfl int "F_GETFL")
(define-foreign-variable _f_setfl int "F_SETFL")

(define fcntl/dupfd _f_dupfd)
(define fcntl/getfd _f_getfd)
(define fcntl/setfd _f_setfd)
(define fcntl/getfl _f_getfl)
(define fcntl/setfl _f_setfl)

(define-foreign-variable _o_rdonly int "O_RDONLY")
(define-foreign-variable _o_wronly int "O_WRONLY")
(define-foreign-variable _o_rdwr int "O_RDWR")
(define-foreign-variable _o_creat int "O_CREAT")
(define-foreign-variable _o_append int "O_APPEND")
(define-foreign-variable _o_excl int "O_EXCL")
(define-foreign-variable _o_noctty int "O_NOCTTY")
(define-foreign-variable _o_nonblock int "O_NONBLOCK")
(define-foreign-variable _o_trunc int "O_TRUNC")
(define-foreign-variable _o_fsync int "O_FSYNC")
(define-foreign-variable _o_binary int "O_BINARY")
(define-foreign-variable _o_text int "O_TEXT")

(define open/rdonly _o_rdonly)
(define open/wronly _o_wronly)
(define open/rdwr _o_rdwr)
(define open/read _o_rdonly)
(define open/write _o_wronly)
(define open/creat _o_creat)
(define open/append _o_append)
(define open/excl _o_excl)
(define open/noctty _o_noctty)
(define open/nonblock _o_nonblock)
(define open/trunc _o_trunc)
(define open/sync _o_fsync)
(define open/fsync _o_fsync)
(define open/binary _o_binary)
(define open/text _o_text)

(define-foreign-variable _s_irusr int "S_IRUSR")
(define-foreign-variable _s_iwusr int "S_IWUSR")
(define-foreign-variable _s_ixusr int "S_IXUSR")
(define-foreign-variable _s_irgrp int "S_IRGRP")
(define-foreign-variable _s_iwgrp int "S_IWGRP")
(define-foreign-variable _s_ixgrp int "S_IXGRP")
(define-foreign-variable _s_iroth int "S_IROTH")
(define-foreign-variable _s_iwoth int "S_IWOTH")
(define-foreign-variable _s_ixoth int "S_IXOTH")
(define-foreign-variable _s_irwxu int "S_IRWXU")
(define-foreign-variable _s_irwxg int "S_IRWXG")
(define-foreign-variable _s_irwxo int "S_IRWXO")
(define-foreign-variable _s_isuid int "S_ISUID")
(define-foreign-variable _s_isgid int "S_ISGID")
(define-foreign-variable _s_isvtx int "S_ISVTX")

(define perm/irusr _s_irusr)
(define perm/iwusr _s_iwusr)
(define perm/ixusr _s_ixusr)
(define perm/irgrp _s_irgrp)
(define perm/iwgrp _s_iwgrp)
(define perm/ixgrp _s_ixgrp)
(define perm/iroth _s_iroth)
(define perm/iwoth _s_iwoth)
(define perm/ixoth _s_ixoth)
(define perm/irwxu _s_irwxu)
(define perm/irwxg _s_irwxg)
(define perm/irwxo _s_irwxo)
(define perm/isvtx _s_isvtx)
(define perm/isuid _s_isuid)
(define perm/isgid _s_isgid)

(define file-control
  (let ([fcntl (foreign-lambda int fcntl int int long)])
    (lambda (fd cmd #!optional (arg 0))
      (##sys#check-exact fd 'file-control)
      (##sys#check-exact cmd 'file-control)
      (let ([res (fcntl fd cmd arg)])
        (if (fx= res -1)
            (posix-error #:file-error 'file-control "cannot control file" fd cmd)
            res ) ) ) ) )

(define file-open
  (let ([defmode (bitwise-ior _s_irwxu (bitwise-ior _s_irgrp _s_iroth))] )
    (lambda (filename flags . mode)
      (let ([mode (if (pair? mode) (car mode) defmode)])
        (##sys#check-string filename 'file-open)
        (##sys#check-exact flags 'file-open)
        (##sys#check-exact mode 'file-open)
        (let ([fd (##core#inline "C_open" (##sys#make-c-string (##sys#expand-home-path filename)) flags mode)])
          (when (eq? -1 fd)
            (posix-error #:file-error 'file-open "cannot open file" filename flags mode) )
          fd) ) ) ) )

(define file-close
  (lambda (fd)
    (##sys#check-exact fd 'file-close)
    (when (fx< (##core#inline "C_close" fd) 0)
      (posix-error #:file-error 'file-close "cannot close file" fd) ) ) )

(define file-read
  (let ([make-string make-string] )
    (lambda (fd size . buffer)
      (##sys#check-exact fd 'file-read)
      (##sys#check-exact size 'file-read)
      (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
        (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
          (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
        (let ([n (##core#inline "C_read" fd buf size)])
          (when (eq? -1 n)
            (posix-error #:file-error 'file-read "cannot read from file" fd size) )
          (list buf n) ) ) ) ) )

(define file-write
  (lambda (fd buffer . size)
    (##sys#check-exact fd 'file-write)
    (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
      (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
    (let ([size (if (pair? size) (car size) (##sys#size buffer))])
      (##sys#check-exact size 'file-write)
      (let ([n (##core#inline "C_write" fd buffer size)])
        (when (eq? -1 n)
          (posix-error #:file-error 'file-write "cannot write to file" fd size) )
        n) ) ) )

(define file-mkstemp
  (lambda (template)
    (##sys#check-string template 'file-mkstemp)
    (let* ([buf (##sys#make-c-string template)]
	   [fd (##core#inline "C_mkstemp" buf)]
	   [path-length (##sys#size buf)])
      (when (eq? -1 fd)
	(posix-error #:file-error 'file-mkstemp "cannot create temporary file" template) )
      (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )


;;; I/O multiplexing: