posixwin.scm

Scheme跨平台编译器

    (##sys#check-string name 'change-directory)
    (unless (zero? (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
      (##sys#update-errno)
      (##sys#signal-hook #:file-error 'change-directory "cannot change current directory" name) ) ) )

(define delete-directory
  (lambda (name)
    (##sys#check-string name 'delete-directory)
    (unless (zero? (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
      (##sys#update-errno)
      (##sys#signal-hook #:file-error 'delete-directory "cannot delete directory" name) ) ) )

(define directory
  (let ([string-append string-append]
	[make-string make-string]
	[string string])
    (lambda (#!optional (spec (current-directory)) show-dotfiles?)
      (##sys#check-string spec 'directory)
      (let ([buffer (make-string 256)]
	    [handle (##sys#make-pointer)]
	    [entry (##sys#make-pointer)] )
	(##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec)) handle)
	(if (##sys#null-pointer? handle)
	    (begin
	      (##sys#update-errno)
	      (##sys#signal-hook #:file-error 'directory "cannot open directory" spec) )
	    (let loop ()
	      (##core#inline "C_readdir" handle entry)
	      (if (##sys#null-pointer? entry)
		  (begin
		    (##core#inline "C_closedir" handle)
		    '() )
		  (let* ([flen (##core#inline "C_foundfile" entry buffer)]
			 [file (##sys#substring buffer 0 flen)]
			 [char1 (string-ref file 0)]
			 [char2 (and (> flen 1) (string-ref file 1))] )
		    (if (and (eq? char1 #\.)
			     (or (not char2)
				 (and (eq? char2 #\.) (eq? flen 2))
				 (not show-dotfiles?) ) )
			(loop)
			(cons file (loop)) ) ) ) ) ) ) ) ) )

(define (directory? fname)
  (##sys#check-string fname 'directory?)
  (let ((info (##sys#file-info
		(##sys#platform-fixup-pathname (##sys#expand-home-path fname)))))
    (and info (fx= 1 (##sys#slot info 4))) ) )

(define current-directory
  (let ([make-string make-string])
    (lambda (#!optional dir)
      (if dir
	  (change-directory dir)
	  (let* ([buffer (make-string 256)]
		 [len (##core#inline "C_curdir" buffer)] )
	    (##sys#update-errno)
	    (if len
		(##sys#substring buffer 0 len)
		(##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )


(define canonical-path
    (let ((null?      null?)
          (char=?     char=?)
          (string=?   string=?)
          (alpha?     char-alphabetic?)
          (sref       string-ref)
          (ssplit     (cut string-split <> "/\\"))
          (sappend    string-append)
          (isperse    (cut string-intersperse <> "\\"))
          (sep?       (lambda (c) (or (char=? #\/ c) (char=? #\\ c))))
          (user       current-user-name)
          (cwd        (let ((cw   current-directory))
                          (lambda ()
                              (condition-case (cw)
                                  (var ()    "c:\\"))))))
        (lambda (path)
            (##sys#check-string path 'canonical-path)
            (let ((p   (cond ((fx= 0 (##sys#size path))
                                 (sappend (cwd) "\\"))
                             ((and (fx< (##sys#size path) 3)
                                   (sep? (sref path 0)))
                                 (sappend
                                     (##sys#substring (cwd) 0 2)
                                     path))
                             ((fx= 1 (##sys#size path))
                                 (sappend (cwd) "\\" path))
                             ((and (char=? #\~ (sref path 0))
                                   (sep? (sref path 1)))
                                 (sappend
                                     (##sys#substring (cwd) 0 3)
                                     "Documents and Settings\\"
                                     (user)
                                     (##sys#substring path 1
                                         (##sys#size path))))
                             ((fx= 2 (##sys#size path))
                                 (sappend (cwd) "\\" path))
                             ((and (alpha? (sref path 0))
                                   (char=? #\: (sref path 1))
                                   (sep? (sref path 2)))
                                 path)
                             ((and (char=? #\/ (sref path 0))
                                   (alpha? (sref path 1))
                                   (char=? #\: (sref path 2)))
                                 (sappend
                                     (##sys#substring path 1 3)
                                     "\\"
                                     (##sys#substring path 3
                                         (##sys#size path))))
                             ((sep? (sref path 0))
                                 (sappend
                                     (##sys#substring (cwd) 0 2)
                                     path))
                             (else
                                 (sappend (cwd) "\\" path)))))
                (let loop ((l   (ssplit (##sys#substring p 3 (##sys#size p))))
                           (r   '()))
                    (if (null? l)
                        (if (null? r)
                            (##sys#substring p 0 3)
                            (if (sep? (sref p (- (##sys#size p) 1)))
                                (sappend
                                    (##sys#substring p 0 3)
                                    (isperse (reverse (cons "" r))))
                                (sappend
                                    (##sys#substring p 0 3)
                                    (isperse (reverse r)))))
                        (loop
                            (cdr l)
                            (if (string=? ".." (car l))
                                (cdr r)
                                (if (string=? "." (car l))
                                    r
                                    (cons (car l) r))))))))))
                           

;;; Pipes:

(let ()
  (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
  (define (badmode m) (##sys#error "illegal input/output mode specifier" m))
  (define (check cmd inp r)
    (##sys#update-errno)
    (if (##sys#null-pointer? r)
	(##sys#signal-hook #:file-error "cannot open pipe" cmd)
	(let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
	  (##core#inline "C_set_file_ptr" port r)
	  port) ) )
  (set! open-input-pipe
    (lambda (cmd . m)
      (##sys#check-string cmd 'open-input-pipe)
      (let ([m (mode m)])
	(check
	 cmd #t
	 (case m
	   ((###text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
	   ((###binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
	   (else (badmode m)) ) ) ) ) )
  (set! open-output-pipe
    (lambda (cmd . m)
      (##sys#check-string cmd 'open-output-pipe)
      (let ((m (mode m)))
	(check
	 cmd #f
	 (case m
	   ((###text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd)))
	   ((###binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd)))
	   (else (badmode m)) ) ) ) ) )
  (set! close-input-pipe
    (lambda (port)
      (##sys#check-port port 'close-input-pipe)
      (let ((r (##core#inline "close_pipe" port)))
	(##sys#update-errno)
	(when (eq? -1 r) (##sys#signal-hook #:file-error 'close-input-pipe "error while closing pipe" port)) ) ) )
  (set! close-output-pipe close-input-pipe) )

(let ([open-input-pipe open-input-pipe]
      [open-output-pipe open-output-pipe]
      [close-input-pipe close-input-pipe]
      [close-output-pipe close-output-pipe] )
  (set! call-with-input-pipe
    (lambda (cmd proc . mode)
      (let ([p (apply open-input-pipe cmd mode)])
	(##sys#call-with-values
	 (lambda () (proc p))
	 (lambda results
	   (close-input-pipe p)
	   (apply values results) ) ) ) ) )
  (set! call-with-output-pipe
    (lambda (cmd proc . mode)
      (let ([p (apply open-output-pipe cmd mode)])
	(##sys#call-with-values
	 (lambda () (proc p))
	 (lambda results
	   (close-output-pipe p)
	   (apply values results) ) ) ) ) )
  (set! with-input-from-pipe
    (lambda (cmd thunk . mode)
      (let ([old ##sys#standard-input]
	    [p (apply open-input-pipe cmd mode)] )
	(set! ##sys#standard-input p)
	(##sys#call-with-values thunk
	  (lambda results
	    (close-input-pipe p)
	    (set! ##sys#standard-input old)
	    (apply values results) ) ) ) ) )
  (set! with-output-to-pipe
    (lambda (cmd thunk . mode)
      (let ([old ##sys#standard-output]
	    [p (apply open-output-pipe cmd mode)] )
	(set! ##sys#standard-output p)
	(##sys#call-with-values thunk
	  (lambda results
	    (close-output-pipe p)
	    (set! ##sys#standard-output old)
	    (apply values results) ) ) ) ) ) )


;;; Pipe primitive:

(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")

(define create-pipe
    (lambda (#!optional (mode (fxior open/binary open/noinherit)))
      (when (fx< (##core#inline "C_pipe" #f mode) 0)
	(##sys#update-errno)
	(##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
      (values _pipefd0 _pipefd1) ) )

;;; Signal processing:

(define-foreign-variable _nsig int "NSIG")
(define-foreign-variable _sigterm int "SIGTERM")
(define-foreign-variable _sigint int "SIGINT")
(define-foreign-variable _sigfpe int "SIGFPE")
(define-foreign-variable _sigill int "SIGILL")
(define-foreign-variable _sigsegv int "SIGSEGV")
(define-foreign-variable _sigabrt int "SIGABRT")
(define-foreign-variable _sigbreak int "SIGBREAK")

(define signal/term _sigterm)
(define signal/int _sigint)
(define signal/fpe _sigfpe)
(define signal/ill _sigill)
(define signal/segv _sigsegv)
(define signal/abrt _sigabrt)
(define signal/break _sigbreak)
(define signal/alrm 0)
(define signal/chld 0)
(define signal/cont 0)
(define signal/hup 0)
(define signal/io 0)
(define signal/kill 0)
(define signal/pipe 0)
(define signal/prof 0)
(define signal/quit 0)
(define signal/stop 0)
(define signal/trap 0)
(define signal/tstp 0)
(define signal/urg 0)
(define signal/usr1 0)
(define signal/usr2 0)
(define signal/vtalrm 0)
(define signal/winch 0)
(define signal/xcpu 0)
(define signal/xfsz 0)

(define signals-list
  (list
    signal/term signal/int signal/fpe signal/ill
    signal/segv signal/abrt signal/break))

(let ([oldhook ##sys#interrupt-hook]
      [sigvector (make-vector 256 #f)] )
  (set! signal-handler
    (lambda (sig)
      (##sys#check-exact sig 'signal-handler)
      (##sys#slot sigvector sig) ) )
  (set! set-signal-handler!
    (lambda (sig proc)
      (##sys#check-exact sig 'set-signal-handler!)
      (##core#inline "C_establish_signal_handler" sig (and proc sig))
      (vector-set! sigvector sig proc) ) )
  (set! ##sys#interrupt-hook
    (lambda (reason state)
      (let ([h (##sys#slot sigvector reason)])
	(if h
	    (begin
	      (h reason)
	      (##sys#context-switch state) )
	    (oldhook reason state) ) ) ) ) )

;;; More errno codes:

(define-foreign-variable _errno int "errno")

(define-foreign-variable _eperm int "EPERM")
(define-foreign-variable _enoent int "ENOENT")
(define-foreign-variable _esrch int "ESRCH")
(define-foreign-variable _eintr int "EINTR")
(define-foreign-variable _eio int "EIO")
(define-foreign-variable _enoexec int "ENOEXEC")
(define-foreign-variable _ebadf int "EBADF")
(define-foreign-variable _echild int "ECHILD")
(define-foreign-variable _enomem int "ENOMEM")
(define-foreign-variable _eacces int "EACCES")
(define-foreign-variable _efault int "EFAULT")
(define-foreign-variable _ebusy int "EBUSY")
(define-foreign-variable _eexist int "EEXIST")
(define-foreign-variable _enotdir int "ENOTDIR")
(define-foreign-variable _eisdir int "EISDIR")
(define-foreign-variable _einval int "EINVAL")
(define-foreign-variable _emfile int "EMFILE")
(define-foreign-variable _enospc int "ENOSPC")
(define-foreign-variable _espipe int "ESPIPE")
(define-foreign-variable _epipe int "EPIPE")
(define-foreign-variable _eagain int "EAGAIN")
(define-foreign-variable _erofs int "EROFS")
(define-foreign-variable _enxio int "ENXIO")
(define-foreign-variable _e2big int "E2BIG")
(define-foreign-variable _exdev int "EXDEV")
(define-foreign-variable _enodev int "ENODEV")
(define-foreign-variable _enfile int "ENFILE")
(define-foreign-variable _enotty int "ENOTTY")
(define-foreign-variable _efbig int "EFBIG")
(define-foreign-variable _emlink int "EMLINK")
(define-foreign-variable _edom int "EDOM")
(define-foreign-variable _erange int "ERANGE")
(define-foreign-variable _edeadlk int "EDEADLK")
(define-foreign-variable _enametoolong int "ENAMETOOLONG")
(define-foreign-variable _enolck int "ENOLCK")
(define-foreign-variable _enosys int "ENOSYS")
(define-foreign-variable _enotempty int "ENOTEMPTY")
(define-foreign-variable _eilseq int "EILSEQ")

(define errno/perm _eperm)
(define errno/noent _enoent)
(define errno/srch _esrch)
(define errno/intr _eintr)
(define errno/io _eio)
(define errno/noexec _enoexec)
(define errno/badf _ebadf)
(define errno/child _echild)
(define errno/nomem _enomem)
(define errno/acces _eacces)
(define errno/fault _efault)
(define errno/busy _ebusy)
(define errno/exist _eexist)
(define errno/notdir _enotdir)
(define errno/isdir _eisdir)
(define errno/inval _einval)
(define errno/mfile _emfile)
(define errno/nospc _enospc)
(define errno/spipe _espipe)
(define errno/pipe _epipe)
(define errno/again _eagain)
(define errno/rofs _erofs)
(define errno/nxio _enxio)
(define errno/2big _e2big)
(define errno/xdev _exdev)
(define errno/nodev _enodev)
(define errno/nfile _enfile)
(define errno/notty _enotty)
(define errno/fbig _efbig)
(define errno/mlink _emlink)
(define errno/dom _edom)
(define errno/range _erange)
(define errno/deadlk _edeadlk)
(define errno/nametoolong _enametoolong)
(define errno/nolck _enolck)
(define errno/nosys _enosys)
(define errno/notempty _enotempty)
(define errno/ilseq _eilseq)

;;; Permissions and owners:

(define change-file-mode
  (lambda (fname m)
    (##sys#check-string fname 'change-file-mode)
    (##sys#check-exact m 'change-file-mode)
    (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
      (##sys#update-errno)
      (##sys#signal-hook #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )

(define-foreign-variable _r_ok int "2")
(define-foreign-variable _w_ok int "4")
(define-foreign-variable _x_ok int "2")

(let ()
  (define (check filename acc loc)
    (##sys#check-string filename loc)
    (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
      (unless r (##sys#update-errno))
      r) )
  (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
  (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
  (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )

(define-foreign-variable _filename_max int "FILENAME_MAX")