posixwin.scm

Scheme跨平台编译器

    const char modes[3] = "rww";
    HANDLE cur_process = GetCurrentProcess(), child_process = NULL;
    void* envblk = NULL;

    /****** create io handles & fds ***/

    for (i=0; i<3 && success; ++i)
    {
	if (f_share_io[i])
	{
	    success = DuplicateHandle(
		cur_process, standard_io_handles[i],
		cur_process, &child_io_handles[i],
		0, FALSE, DUPLICATE_SAME_ACCESS);
	}
	else
	{
	    HANDLE a, b;
	    success = CreatePipe(&a,&b,NULL,0);
	    if(success)
	    {
		HANDLE parent_end;
		if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }
		else		   { parent_end=a; child_io_handles[i]=b; }
		success = (io_fds[i] = _open_osfhandle((long)parent_end,0)) >= 0;
	    }
	}
    }

    /****** make handles inheritable */

    for (i=0; i<3 && success; ++i)
	success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);

#if 0 /* Requires a sorted list by key! */
    /****** create environment block if necessary ****/

    if (env && success)
    {
	char** p;
	int len = 0;

	for (p = env; *p; ++p) len += strlen(*p) + 1;

	if (envblk = C_malloc(len + 1))
	{
	    char* pb = (char*)envblk;
	    for (p = env; *p; ++p)
	    {
		strcpy(pb, *p);
		pb += strlen(*p) + 1;
	    }
	    *pb = '\0';
	}
	else
	    success = FALSE;
    }
#endif

    /****** finally spawn process ****/

    if (success)
    {
	PROCESS_INFORMATION pi;
	STARTUPINFO si;

	ZeroMemory(&pi,sizeof pi);
	ZeroMemory(&si,sizeof si);
	si.cb = sizeof si;
	si.dwFlags = STARTF_USESTDHANDLES;
	si.hStdInput = child_io_handles[0];
	si.hStdOutput = child_io_handles[1];
	si.hStdError = child_io_handles[2];

	/* FIXME passing 'app' param causes failure & possible stack corruption */
	success = CreateProcess(
	    NULL, (char*)cmdlin, NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);

	if (success)
	{
	    child_process=pi.hProcess;
	    CloseHandle(pi.hThread);
	}
	else
	    set_last_errno();
    }
    else
	set_last_errno();

    /****** cleanup & return *********/

    /* parent must close child end */
    for (i=0; i<3; ++i) CloseHandle(child_io_handles[i]);

    if (success)
    {
	*phandle = (int)child_process;
	*pstdin_fd = io_fds[0];
	*pstdout_fd = io_fds[1];
	*pstderr_fd = io_fds[2];
    }
    else
    {
	for (i=0; i<3; ++i) _close(io_fds[i]);
    }

    return success;
}
EOF
) )

(cond-expand
 [paranoia]
 [else
  (declare
    (no-bound-checks)
    (no-procedure-checks-for-usual-bindings)
    (bound-to-procedure
     ##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 ##sys#process
     ##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts) ) ] )

(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) ) ) ) )

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


;;; Lo-level I/O:

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

(define pipe/buf _pipe_buf)

(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_trunc int "O_TRUNC")
(define-foreign-variable _o_binary int "O_BINARY")
(define-foreign-variable _o_text int "O_TEXT")
(define-foreign-variable _o_noinherit int "O_NOINHERIT")

(define open/rdonly _o_rdonly)
(define open/wronly _o_wronly)
(define open/rdwr _o_rdwr)
(define open/read _o_rdwr)
(define open/write _o_wronly)
(define open/creat _o_creat)
(define open/append _o_append)
(define open/excl _o_excl)
(define open/trunc _o_trunc)
(define open/binary _o_binary)
(define open/text _o_text)
(define open/noinherit _o_noinherit)

(define-foreign-variable _s_irusr int "S_IREAD")
(define-foreign-variable _s_iwusr int "S_IWRITE")
(define-foreign-variable _s_ixusr int "S_IEXEC")
(define-foreign-variable _s_irgrp int "S_IREAD")
(define-foreign-variable _s_iwgrp int "S_IWRITE")
(define-foreign-variable _s_ixgrp int "S_IEXEC")
(define-foreign-variable _s_iroth int "S_IREAD")
(define-foreign-variable _s_iwoth int "S_IWRITE")
(define-foreign-variable _s_ixoth int "S_IEXEC")
(define-foreign-variable _s_irwxu int "S_IREAD | S_IWRITE | S_IEXEC")
(define-foreign-variable _s_irwxg int "S_IREAD | S_IWRITE | S_IEXEC")
(define-foreign-variable _s_irwxo int "S_IREAD | S_IWRITE | S_IEXEC")

(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 file-open
  (let ([defmode (bitwise-ior _s_irwxu (fxior _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)
	    (##sys#update-errno)
	    (##sys#signal-hook #: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)
      (##sys#update-errno)
      (##sys#signal-hook #: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)
	    (##sys#update-errno)
	    (##sys#signal-hook #: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)
	  (##sys#update-errno)
	  (##sys#signal-hook #:file-error 'file-write "cannot write to file" fd size) )
	n) ) ) )

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


;;; File attribute access:

(define-foreign-variable _seek_set int "SEEK_SET")
(define-foreign-variable _seek_cur int "SEEK_CUR")
(define-foreign-variable _seek_end int "SEEK_END")

(define seek/set _seek_set)
(define seek/end _seek_end)
(define seek/cur _seek_cur)

(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")
(define-foreign-variable _stat_st_size unsigned-int "C_statbuf.st_size")
(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")
(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")
(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")

(define (##sys#stat file)
  (let ([r (cond [(fixnum? file) (##core#inline "C_fstat" file)]
		 [(string? file) (##core#inline "C_stat" (##sys#make-c-string (##sys#expand-home-path file)))]
		 [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
    (when (fx< r 0)
      (##sys#update-errno)
      (##sys#signal-hook #:file-error "cannot access file" file) ) ) )

(define (file-stat f #!optional link)
  (##sys#stat f)
  (vector _stat_st_ino _stat_st_mode _stat_st_nlink
	  _stat_st_uid _stat_st_gid _stat_st_size
	  _stat_st_atime _stat_st_ctime _stat_st_mtime
	  0 0 0 0) )

(define (file-size f) (##sys#stat f) _stat_st_size)
(define (file-modification-time f) (##sys#stat f) _stat_st_mtime)
(define (file-access-time f) (##sys#stat f) _stat_st_atime)
(define (file-change-time f) (##sys#stat f) _stat_st_ctime)
(define (file-owner f) (##sys#stat f) _stat_st_uid)
(define (file-permissions f) (##sys#stat f) _stat_st_mode)

(define (regular-file? fname)
  (##sys#check-string fname 'regular-file?)
  (let ((info (##sys#file-info (##sys#expand-home-path fname))))
    (and info (fx= 0 (##sys#slot info 4))) ) )

(define (symbolic-link? fname)
  (##sys#check-string fname 'symbolic-link?)
  #f)

(let ((stat-type
         (lambda (name)
             (lambda (fname)
                 (##sys#check-string fname name)
                 #f))))
    (set! stat-regular? regular-file?)
    (set! stat-directory? (stat-type 'stat-directory?))
    (set! stat-char-device? (stat-type 'stat-char-device?))
    (set! stat-block-device? (stat-type 'stat-block-device?))
    (set! stat-fifo? (stat-type 'stat-fifo?))
    (set! stat-symlink? (stat-type 'stat-symlink?))
    (set! stat-socket? (stat-type 'stat-socket?)))

(define file-position
  (lambda (port)
    (let ([pos (cond [(port? port)
		      (if (eq? (##sys#slot port 7) 'stream)
			  (##core#inline "C_ftell" port)
			  -1) ]
		     [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
		     [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
      (when (fx< pos 0)
	(##sys#update-errno)
	(##sys#signal-hook #:file-error 'file-position "cannot retrieve file position of port" port) )
      pos) ) )

(define set-file-position!
  (lambda (port pos . whence)
    (let ([whence (if (pair? whence) (car whence) _seek_set)])
      (##sys#check-exact pos 'set-file-position!)
      (##sys#check-exact whence 'set-file-position!)
      (when (fx< pos 0) (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
      (unless (cond [(port? port)
		     (and (eq? (##sys#slot port 7) 'stream)
			  (##core#inline "C_fseek" port pos whence) ) ]
		    [(fixnum? port) (##core#inline "C_lseek" port pos whence)]
		    [else (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)] )
	(##sys#update-errno)
	(##sys#signal-hook #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )


;;; Directory stuff:

(define-inline (create-directory-helper name)
    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string name)))
            (##sys#update-errno)
            (##sys#signal-hook #:file-error 'create-directory
                               "cannot create directory" name)))

(define-inline (create-directory-check name)
    (if (file-exists? name)
        (let ((i   (##sys#file-info name)))
            (and i
                 (fx= 1 (##sys#slot i 4))))
        #f))

(define-inline (create-directory-helper-silent name)
    (unless (create-directory-check name)
            (create-directory-helper name)))

(define-inline (create-directory-helper-parents name)
    (let* ((l   (string-split name "\\"))
           (c   (car l)))
        (for-each
             (lambda (x)
                 (set! c (string-append c "\\" x))
                 (create-directory-helper-silent c))
             (cdr l))))

(define create-directory
  (lambda (name #!optional parents?)
    (##sys#check-string name 'create-directory)
    (if parents?
        (create-directory-helper-parents (canonical-path name))
        (create-directory-helper (canonical-path name)))))
;(define create-directory
;  (lambda (name)
;    (##sys#check-string name 'create-directory)
;    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string (##sys#expand-home-path name))))
;      (##sys#update-errno)
;      (##sys#signal-hook #:file-error 'create-directory "cannot create directory" name) ) ) )

(define change-directory
  (lambda (name)