posixwin.scm

Scheme跨平台编译器

;;; Using file-descriptors:

(define-foreign-variable _stdin_fileno int "0")
(define-foreign-variable _stdout_fileno int "1")
(define-foreign-variable _stderr_fileno int "2")

(define fileno/stdin _stdin_fileno)
(define fileno/stdout _stdout_fileno)
(define fileno/stderr _stderr_fileno)

(let ()
  (define (mode inp m)
    (##sys#make-c-string
     (cond [(pair? m)
	    (let ([m (car m)])
	      (case m
		[(###append) (if (not inp) "a" (##sys#error "invalid mode for input file" m))]
		[else (##sys#error "invalid mode argument" m)] ) ) ]
	   [inp "r"]
	   [else "w"] ) ) )
  (define (check fd inp r)
    (##sys#update-errno)
    (if (##sys#null-pointer? r)
	(##sys#signal-hook #:file-error "cannot open file" fd)
	(let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 'stream)])
	  (##core#inline "C_set_file_ptr" port r)
	  port) ) )
  (set! open-input-file*
    (lambda (fd . m)
      (##sys#check-exact fd 'open-input-file*)
      (check fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m))) ) )
  (set! open-output-file*
    (lambda (fd . m)
      (##sys#check-exact fd 'open-output-file*)
      (check fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m)) ) ) ) )

(define port->fileno
  (lambda (port)
    (##sys#check-port port 'port->fileno)
    (if (not (zero? (##sys#peek-unsigned-integer port 0)))
	(let ([fd (##core#inline "C_C_fileno" port)])
	  (when (fx< fd 0)
	    (##sys#update-errno)
	    (##sys#signal-hook #:file-error 'port->fileno "cannot access file-descriptor of port" port) )
	  fd)
	(##sys#signal-hook #:type-error 'port->fileno "port has no attached file" port) ) ) )

(define duplicate-fileno
  (lambda (old . new)
    (##sys#check-exact old duplicate-fileno)
    (let ([fd (if (null? new)
		  (##core#inline "C_dup" old)
		  (let ([n (car new)])
		    (##sys#check-exact n 'duplicate-fileno)
		    (##core#inline "C_dup2" old n) ) ) ] )
      (when (fx< fd 0)
	(##sys#update-errno)
	(##sys#signal-hook #:file-error 'duplicate-fileno "cannot duplicate file descriptor" old) )
      fd) ) )

;;; Environment access:

(define setenv
  (lambda (var val)
    (##sys#check-string var 'setenv)
    (##sys#check-string val 'setenv)
    (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
    (##core#undefined) ) )

(define (unsetenv var)
  (##sys#check-string var 'unsetenv)
  (##core#inline "C_putenv" (##sys#make-c-string var))
  (##core#undefined) )

(define current-environment
  (let ([get (foreign-lambda c-string "C_getenventry" int)]
	[substring substring] )
    (lambda ()
      (let loop ([i 0])
	(let ([entry (get i)])
	  (if entry
	      (let scan ([j 0])
		(if (char=? #\= (##core#inline "C_subchar" entry j))
		    (cons (cons (substring entry 0 j) (substring entry (fx+ j 1) (##sys#size entry))) (loop (fx+ i 1)))
		    (scan (fx+ j 1)) ) )
	      '() ) ) ) ) ) )

;;; Time related things:

(define (seconds->local-time secs)
  (##sys#check-number secs 'seconds->local-time)
  (##sys#decode-seconds secs #f) )

(define (seconds->utc-time secs)
  (##sys#check-number secs 'seconds->utc-time)
  (##sys#decode-seconds secs #t) )

(define seconds->string
  (let ([ctime (foreign-lambda c-string "C_ctime" integer)])
    (lambda (secs)
      (let ([str (ctime secs)])
        (if str
            (##sys#substring str 0 (fx- (##sys#size str) 1))
            (##sys#error 'seconds->string "cannot convert seconds to string" secs) ) ) ) ) )

(define time->string
  (let ([asctime (foreign-lambda c-string "C_asctime" scheme-object)]
        [strftime (foreign-lambda c-string "C_strftime" scheme-object scheme-object)])
    (lambda (tm #!optional fmt)
      (##sys#check-vector tm 'time->string)
      (when (fx< (##sys#size tm) 10) (##sys#error 'time->string "time vector too short" tm))
      (if fmt
          (begin
            (##sys#check-string fmt 'time->string)
            (or (strftime tm (##sys#make-c-string fmt))
                (##sys#error 'time->string "time formatting overflows buffer" tm)) )
          (let ([str (asctime tm)])
            (if str
                (##sys#substring str 0 (fx- (##sys#size str) 1))
                (##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )

(define (local-time->seconds tm)
  (##sys#check-vector tm 'local-time->seconds)
  (when (fx< (##sys#size tm) 10) (##sys#error 'local-time->seconds "time vector too short" tm))
  (if (##core#inline "C_mktime" tm)
      (##sys#cons-flonum)
      (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm) ) )

(define local-timezone-abbreviation
  (foreign-lambda* c-string ()
   "char *z = (daylight ? _tzname[1] : _tzname[0]);"
   "return(z);") )

;;; Other things:

(define _exit
  (let ([ex0 (foreign-lambda void "_exit" int)])
    (lambda code
      (ex0 (if (pair? code) (car code) 0)) ) ) )

(define-foreign-variable _iofbf int "_IOFBF")
(define-foreign-variable _iolbf int "_IOLBF")
(define-foreign-variable _ionbf int "_IONBF")
(define-foreign-variable _bufsiz int "BUFSIZ")

(define set-buffering-mode!
    (lambda (port mode . size)
      (##sys#check-port port 'set-buffering-mode!)
      (let ([size (if (pair? size) (car size) _bufsiz)]
	    [mode (case mode
		    [(###full) _iofbf]
		    [(###line) _iolbf]
		    [(###none) _ionbf]
		    [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
	(##sys#check-exact size 'set-buffering-mode!)
	(when (fx< (if (eq? 'stream (##sys#slot port 7))
		       (##core#inline "C_setvbuf" port mode size)
		       -1)
		   0)
	  (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )

;;; Filename globbing:

(define glob
  (let ([regexp regexp]
	[make-anchored-pattern make-anchored-pattern]
	[string-match string-match]
	[glob->regexp glob->regexp]
	[directory directory]
	[make-pathname make-pathname]
	[decompose-pathname decompose-pathname] )
    (lambda paths
      (let conc-loop ([paths paths])
	(if (null? paths)
	    '()
	    (let ([path (car paths)])
	      (let-values ([(dir fil ext) (decompose-pathname path)])
		(let* ([fnpatt (glob->regexp (make-pathname #f (or fil "*") ext))]
		       [patt (make-anchored-pattern fnpatt)]
		       [rx (regexp patt)])
		  (let loop ([fns (directory (or dir ".") #t)])
		    (cond [(null? fns) (conc-loop (cdr paths))]
			  [(string-match rx (car fns))
			   => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) ]
			  [else (loop (cdr fns))] ) ) ) ) ) ) ) ) ) )


;;; Process handling:

(define-foreign-variable _p_overlay int "P_OVERLAY")
(define-foreign-variable _p_wait int "P_WAIT")
(define-foreign-variable _p_nowait int "P_NOWAIT")
(define-foreign-variable _p_nowaito int "P_NOWAITO")
(define-foreign-variable _p_detach int "P_DETACH")

(define spawn/overlay _p_overlay)
(define spawn/wait _p_wait)
(define spawn/nowait _p_nowait)
(define spawn/nowaito _p_nowaito)
(define spawn/detach _p_detach)

; Windows uses a commandline style for process arguments. Thus any
; arguments with embedded whitespace will parse incorrectly. Must
; string-quote such arguments.
(define $quote-args-list
  (let ([char-whitespace? char-whitespace?]
	[string-length string-length]
	[string-ref string-ref]
	[string-append string-append])
    (lambda (lst exactf)
      (if exactf
	lst
	(let ([needs-quoting?
		; This is essentially (string-any char-whitespace? s) but we don't
		; want a SRFI-13 dependency. (Do we?)
		(lambda (s)
		  (let ([len (string-length s)])
		    (let loop ([i 0])
		      (cond
			[(fx= i len) #f]
			[(char-whitespace? (string-ref s i)) #t]
			[else (loop (fx+ i 1))]))))])
	    (let loop ([ilst lst] [olst '()])
	      (if (null? ilst)
		(reverse olst)
		(let ([str (car ilst)])
		  (loop
		    (cdr ilst)
		    (cons
		      (if (needs-quoting? str) (string-append "\"" str "\"") str)
		      olst)) ) ) ) ) ) ) ) )

(define $exec-setup
  (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
	[setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
	[pathname-strip-directory pathname-strip-directory]
	[build-exec-argvec
	  (lambda (loc lst argvec-setter idx)
	    (if lst
	      (begin
		(##sys#check-list lst loc)
		(do ([l lst (cdr l)]
		     [i idx (fx+ i 1)] )
		    ((null? l) (argvec-setter i #f 0))
		  (let ([s (car l)])
		    (##sys#check-string s loc)
		    (argvec-setter i s (##sys#size s)) ) ) )
	      (argvec-setter idx #f 0) ) )])
    (lambda (loc filename arglst envlst exactf)
      (##sys#check-string filename loc)
      (let ([s (pathname-strip-directory filename)])
	(setarg 0 s (##sys#size s)) )
      (build-exec-argvec loc ($quote-args-list arglst exactf) setarg 1)
      (build-exec-argvec loc envlst setenv 0)
      (##core#inline "C_flushall")
      (##sys#make-c-string (##sys#expand-home-path filename)) ) ) )

(define ($exec-teardown loc msg filename res)
  (##sys#update-errno)
  (##core#inline "C_free_exec_args")
  (##core#inline "C_free_exec_env")
  (if (fx= res -1)
      (##sys#error loc msg filename)
      res ) )

(define (process-execute filename #!optional arglst envlst exactf)
  (let ([prg ($exec-setup 'process-execute filename arglst envlst exactf)])
    ($exec-teardown 'process-execute "cannot execute process" filename
      (if envlst (##core#inline "C_execve" prg) (##core#inline "C_execvp" prg))) ) )

(define (process-spawn mode filename #!optional arglst envlst exactf)
  (let ([prg ($exec-setup 'process-spawn filename arglst envlst exactf)])
    ($exec-teardown 'process-spawn "cannot spawn process" filename
      (if envlst (##core#inline "C_spawnvpe" mode prg) (##core#inline "C_spawnvp" mode prg))) ) )

(define current-process-id (foreign-lambda int "C_getpid"))

(define-foreign-variable _shlcmd c-string "C_shlcmd")

(define (##sys#shell-command)
  (or (getenv "COMSPEC")
      (if (##core#inline "C_get_shlcmd")
	  _shlcmd
	  (begin
	    (##sys#update-errno)
	    (##sys#error '##sys#shell-command "cannot retrieve system directory") ) ) ) )

(define (##sys#shell-command-arguments cmdlin)
  (list "/c" cmdlin) )

(define process-run
  (let ([process-spawn process-spawn]
	[getenv getenv] )
    (lambda (f . args)
      (let ([args (if (pair? args) (car args) #f)])
	(if args
	    (process-spawn spawn/nowait f args)
	    (process-spawn spawn/nowait (##sys#shell-command) (##sys#shell-command-arguments f)) ) ) ) ) )

;;; Run subprocess connected with pipes:
(define-foreign-variable _rdbuf char "C_rdbuf")
(define-foreign-variable _wr0 int "C_wr0_")
(define-foreign-variable _rd1 int "C_rd1_")

(define close-handle
  (foreign-lambda int "close_handle" bool))

; from original by Mejedi
;; ##sys#process
; loc		 caller procedure symbol
; cmd		 pathname or commandline
; args		 string-list or '()
; env		 string-list or #f (currently ignored)
; stdoutf	 #f then share, or #t then create
; stdinf	 #f then share, or #t then create
; stderrf	 #f then share, or #t then create
;
; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
; where stdin-input-port?, etc. is a port or #f, indicating no port created.

(define ##sys#process
  (let ([c-process
	  (foreign-lambda bool "C_process" c-string c-string c-pointer
	    (pointer int) (pointer int) (pointer int) (pointer int) int)])
    ; The environment list must be sorted & include current directory
    ; information for the system drives. i.e !C:=...
    ; For now any environment is ignored.
    (lambda (loc cmd args env stdoutf stdinf stderrf #!optional exactf)
      (let ([cmdlin (string-intersperse ($quote-args-list (cons cmd args) exactf))])
	(let-location ([handle int -1]
		       [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
	  (let ([res
		  (c-process cmd cmdlin #f
		    (location handle)
		    (location stdin_fd) (location stdout_fd) (location stderr_fd)
		    (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])
	    (if res
	      (values
		(and stdoutf (open-input-file* stdout_fd)) ;Parent stdin
		(and stdinf (open-output-file* stdin_fd))  ;Parent stdout
		handle
		(and stderrf (open-input-file* stderr_fd)))
	      (begin
		(##sys#update-errno)
		(##sys#signal-hook #:process-error loc "cannot execute process" cmdlin))) ) ) ) ) ) )

#;(define process (void))
#;(define process* (void))
(let ([%process
	(lambda (loc err? cmd args env exactf)
	  (let ([chkstrlst
		 (lambda (lst)
		   (##sys#check-list lst loc)
		   (for-each (cut ##sys#check-string <> loc) lst) )])
	    (##sys#check-string cmd loc)
	    (if args
	      (chkstrlst args)
	      (begin
		(set! exactf #t)
		(set! args (##sys#shell-command-arguments cmd))
		(set! cmd (##sys#shell-command)) ) )
	    (when env (chkstrlst env))
	    (receive [in out pid err] (##sys#process loc cmd args env #t #t err? exactf)
	      (if err?
		(values in out pid err)
		(values in out pid) ) ) ) )] )
  (set! process
    (lambda (cmd #!optional args env exactf)
      (%process 'process #f cmd args env exactf) ))
  (set! process*
    (lambda (cmd #!optional args env exactf)
      (%process 'process* #t cmd args env exactf) )) )

(define-foreign-variable _exstatus int "C_exstatus")

(define (##sys#process-wait pid nohang)
  (if (##core#inline "C_process_wait" pid nohang)
    (values pid #t _exstatus)
    (values -1 #f #f) ) )

(define process-wait
  (lambda (pid . args)
    (let-optionals* args ([nohang #f])
      (##sys#check-exact pid 'process-wait)
      (receive [epid enorm ecode] (##sys#process-wait pid nohang)
	(if (fx= epid -1)
	  (begin
	    (##sys#update-errno)
	    (##sys#signal-hook #:process-error 'process-wait "waiting for child process failed" pid) )
	  (values epid enorm ecode) ) ) ) ) )

(define sleep
  (lambda (t)
    (##core#inline "C_sleep" t)
    0) )

(define-foreign-variable _hostname c-string "C_hostname")
(define-foreign-variable _osver c-string "C_osver")
(define-