scsh-0.6/scsh/syscalls.scm

;;; POSIX system-call Scheme binding.
;;; Copyright (c) 1993 by Olin Shivers.

;;; Scheme48 implementation.

;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?

(foreign-init-name "syscalls")

(foreign-source
  "#include <sys/signal.h>"
  "#include <sys/types.h>"
  "#include <sys/times.h>"
  "#include <sys/time.h>"
  "#include <fcntl.h>		/* for O_RDWR */" ; ???
  "#include <sys/stat.h>"
  "#include <netdb.h>"
  "#include <pwd.h>"
  "#include <unistd.h>"
  ""
  "/* Make sure foreign-function stubs interface to the C funs correctly: */"
  "#include \"dirstuff1.h\""
;  "#include \"fdports1.h\"" JMG 
  "#include \"select1.h\""
  "#include \"syscalls1.h\""
  "#include \"userinfo1.h\""
  ""
  "extern int errno;"
  ""
  "#define errno_on_zero_or_false(x) ((x) ? S48_FALSE : s48_enter_fixnum(errno))"
  "#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)"
  "#define False_on_zero(x) ((x) ? s48_enter_fixnum(x) : S48_FALSE)" ; Not a function.
  "" "")

;;; Macro for converting syscalls that return error codes to ones that
;;; raise exceptions on errors.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; DEFINE-ERRNO-SYSCALL defines an error-signalling syscall procedure from 
;;; one that returns an error code as its first return value -- #f for win,
;;; errno for lose. If the error code is ERRNO/INTR (interrupted syscall),
;;; we try again.
;;;
;;; (define-errno-syscall (SYSCALL ARGS) SYSCALL/ERRNO . RET-VALS) ==>
;;; 
;;; (define (SYSCALL . ARGS)
;;;   (receive (err . RET-VALS) (SYSCALL/ERRNO . ARGS)
;;;     (cond ((not err) (values . RET-VALS))		; Win
;;;           ((= err errno/intr) (SYSCALL . ARGS))	; Retry
;;;           (else (errno-error err SYSCALL . ARGS))))); Lose

(define-syntax define-errno-syscall
  (syntax-rules ()
    ((define-errno-syscall (syscall arg ...) syscall/errno
       ret-val ...)
     (define (syscall arg ...)
       (receive (err ret-val ...) (syscall/errno arg ...)
         (cond ((not err) (values ret-val ...))			; Win
	       ((= err errno/intr) 
		(syscall arg ...))		; Retry
	       (else (errno-error err syscall arg ...))))))	; Lose

    ;;; This case handles rest args
    ((define-errno-syscall (syscall . args) syscall/errno
       ret-val ...)
     (define (syscall . args)
       (receive (err ret-val ...) (apply syscall/errno args)
         (cond ((not err) (values ret-val ...))			; Win
	       ((= err errno/intr) 
		(apply syscall args))	; Retry
	       (else (apply errno-error err syscall args)))))))); Lose

;;; By the way, it would be better to insert a (LET LP () ...) for the
;;; the errno/intr retries, instead of calling the top-level definition
;;; (because in Scheme you have to allow for the fact that top-level
;;; defns can be re-defined, so the compiler can't just turn it into a
;;; jump), but the brain-dead S48 byte-compiler will cons a closure for
;;; the LP loop, which means that little syscalls like read-char can cons
;;; like crazy. So I'm doing it this way. Ech.


;;; Process
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; we can't algin env here, because exec-path/env calls
;; %%exec/errno directly  F*&% *P
(define-stubless-foreign %%exec/errno (prog argv env) "scheme_exec")

(define (%%exec prog argv env)
  (errno-error (%%exec/errno prog argv env) %exec prog argv env)) ; cute.

(define (%exec prog arg-list env)
  (let ((argv (mapv! stringify (list->vector arg-list)))
	(prog (stringify prog))
	(env (if (eq? env #t) #t (alist->env-vec env))))
    (%%exec prog argv env)))


(define-stubless-foreign exit/errno ; errno -- misnomer.
  (status) "scsh_exit")

(define-stubless-foreign %exit/errno ; errno -- misnomer
  (status) "scsh__exit")

(define (%exit . maybe-status)
  (%exit/errno (:optional maybe-status 0))
  (error "Yikes! %exit returned."))


(define-stubless-foreign %%fork () "scsh_fork")

;;; Posix waitpid(2) call.
(define-stubless-foreign %wait-pid/errno-list (pid options)
  "wait_pid")

(define (%wait-pid/errno pid options)
  (apply values (%wait-pid/errno-list pid options)))

;;; Miscellaneous process state
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Working directory

(define-stubless-foreign %chdir (directory) "scsh_chdir")

;;; These calls change/reveal the process working directory
;;; 

(define (process-chdir . maybe-dir)
  (let ((dir (:optional maybe-dir (home-dir))))
    (%chdir (ensure-file-name-is-nondirectory dir))))

;; TODO: we get an error if cwd does not exist on startup
(define-stubless-foreign process-cwd () "scheme_cwd")

;;; GID

(define-stubless-foreign user-gid  () "scsh_getgid")

(define-stubless-foreign user-effective-gid () "scsh_getegid")

(define-stubless-foreign set-gid (gid) "scsh_setgid")

(define-stubless-foreign set-effective-gid (gid) "scsh_setegid")

(define-stubless-foreign user-supplementary-gids () "get_groups")

;;; UID
(define-stubless-foreign user-uid  () "scsh_getuid")

(define-stubless-foreign user-effective-uid () "scsh_geteuid")

(define-stubless-foreign set-uid (uid) "scsh_setuid")

(define-stubless-foreign set-effective-uid (uid) "scsh_seteuid")

(import-lambda-definition %user-login-name () "my_username")
 
(define (user-login-name)
  (or (%user-login-name)
      (error "Cannot get your name")))

;;; PID

(define-foreign pid (getpid) pid_t)
(define-foreign parent-pid (getppid) pid_t)


;;; Process groups and session ids
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-foreign process-group (getpgrp) pid_t)
(define-foreign %set-process-group/errno
  (setpgid (pid_t pid) (pid_t groupid))
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (%set-process-group pid pgrp)
  %set-process-group/errno)


(define (set-process-group arg1 . maybe-arg2)
  (receive (pid pgrp) (if (null? maybe-arg2)
			  (values (pid) arg1)
			  (values arg1 (car maybe-arg2)))
	   (%set-process-group pid pgrp)))


(define-foreign become-session-leader/errno (setsid)
  (multi-rep (to-scheme pid_t errno_or_false)
	     pid_t))

(define-errno-syscall (become-session-leader) become-session-leader/errno
  sid)


;;; UMASK

(define-foreign set-umask (umask (mode_t mask)) no-declare ; integer on SunOS
  mode_t)

(define (umask)
  (let ((m (set-umask 0)))
    (set-umask m)
    m))


;;; PROCESS TIMES

;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.


(define-foreign process-times/errno (process_times)
  (to-scheme integer errno_or_false)
  clock_t	; user   cpu time
  clock_t	; system cpu time
  clock_t	; user   cpu time for me and all my descendants.
  clock_t)	; system cpu time for me and all my descendants.

(define-errno-syscall (process-times) process-times/errno
  utime stime cutime cstime)

(define-foreign cpu-ticks/sec (cpu_clock_ticks_per_sec) integer)

;;; File system
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Useful little utility for generic ops that work on filenames, fd's or
;;; ports.

(define (generic-file-op thing fd-op fname-op)
  (if (string? thing) (fname-op thing)
      (call/fdes thing fd-op)))


(define-foreign set-file-mode/errno
  (chmod (string path) (mode_t mode)) no-declare ; integer on SunOS
  (to-scheme fixnum errno_or_false))

; IBM's AIX include files declare fchmod(char*, mode_t).
; Amazing, but true. So we must prevent this def-foreign from issuing
; the conflicting, correct declaration. Hence the NO-DECLARE.

(define-foreign set-fdes-mode/errno
  (fchmod (fixnum fd) (mode_t mode)) ; integer on SunOS
  no-declare ; Workaround for AIX bug.
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (set-file-mode thing mode)
  (lambda (thing mode)
    (generic-file-op thing
		     (lambda (fd)    (set-fdes-mode/errno fd    mode))
		     (lambda (fname) (set-file-mode/errno fname mode)))))


;;; NO-DECLARE: gcc unistd.h bogusness.
(define-foreign set-file-uid&gid/errno
  (chown (string path) (uid_t uid) (gid_t gid)) no-declare
  (to-scheme fixnum errno_or_false))

(define-foreign set-fdes-uid&gid/errno
  (fchown (fixnum fd) (uid_t uid) (gid_t gid))
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (set-file-owner thing uid)
  (lambda (thing uid)
    (generic-file-op thing
		     (lambda (fd)    (set-fdes-uid&gid/errno fd    uid -1))
		     (lambda (fname) (set-file-uid&gid/errno fname uid -1)))))

(define-errno-syscall (set-file-group thing gid)
  (lambda (thing gid)
    (generic-file-op thing
		     (lambda (fd)    (set-fdes-uid&gid/errno fd    -1 gid))
		     (lambda (fname) (set-file-uid&gid/errno fname -1 gid)))))


;;; Uses real uid and gid, not effective. I don't use this anywhere.

(define-foreign %file-ruid-access-not?
  (access (string path)
	  (integer perms))
  bool)

;(define (file-access? path perms)
;  (not (%file-access-not? path perms)))
;
;(define (file-executable? fname)
;  (file-access? fname 1))
;
;(define (file-writable? fname)
;  (file-access? fname 2))
;
;(define (file-readable? fname)
;  (file-access? fname 4))


(define-foreign create-hard-link/errno
  (link (string original-name) (string new-name))
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (create-hard-link original-name new-name)
  create-hard-link/errno)


(define-foreign create-fifo/errno (mkfifo (string path) (mode_t mode))
  no-declare ; integer on SunOS
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (create-fifo path mode) create-fifo/errno)


(define-foreign create-directory/errno
  (mkdir (string path) (mode_t mode)) no-declare ; integer on SunOS.
  (to-scheme fixnum errno_or_false))

(define (create-directory path . maybe-mode)
  (let ((mode (:optional maybe-mode #o777))
	(fname (ensure-file-name-is-nondirectory path)))
    (cond ((create-directory/errno fname mode) =>
           (lambda (err)
	     (if err (errno-error err create-directory path mode)))))))

(define-stubless-foreign read-symlink (path) "scm_readlink")

(define-foreign %rename-file/errno
  (rename (string old-name) (string new-name))
  (to-scheme fixnum errno_or_false))
  
(define-errno-syscall (%rename-file old-name new-name)
  %rename-file/errno)


(define-foreign delete-directory/errno
  (rmdir (string path))
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (delete-directory path) delete-directory/errno)


(define-foreign %utime/errno (scm_utime (string path)
					(time_t ac) 
					(time_t m))  
  (to-scheme fixnum errno_or_false))

(define-foreign %utime-now/errno (scm_utime_now (string path))
  (to-scheme fixnum errno_or_false))
					

;;; (SET-FILE-TIMES/ERRNO path [access-time mod-time])

(define (set-file-times/errno path . maybe-times)
  (if (pair? maybe-times)
      (let* ((access-time (real->exact-integer (car maybe-times)))
	     (mod-time (if (pair? (cddr maybe-times))
			   (error "Too many arguments to set-file-times/errno"
				  (cons path maybe-times))
			   (real->exact-integer (cadr maybe-times)))))
	(%utime/errno path access-time 
		           mod-time ))
      (%utime-now/errno path)))

(define-errno-syscall (set-file-times . args) set-file-times/errno)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STAT

(define-stubless-foreign stat-file (path data chase?) "scheme_stat")

(define-stubless-foreign stat-fdes (fd data) "scheme_fstat")

(define-record file-info
  type
  device
  inode
  mode
  nlinks
  uid
  gid
  size
  atime
  mtime
  ctime
  )


;;; Should be redone to return multiple-values.
(define (%file-info fd/port/fname chase?)
  (let ((ans-vec (make-vector 11))
	(file-type (lambda (type-code)
		     (vector-ref '#(block-special char-special directory fifo
						  regular socket symlink)
				 type-code))))
    (generic-file-op fd/port/fname
		     (lambda (fd)
		       (stat-fdes fd ans-vec))
		     (lambda (fname)
		       (stat-file fname ans-vec chase?)))
    (make-file-info (file-type (vector-ref ans-vec 0))
		    (vector-ref ans-vec 1)
		    (vector-ref ans-vec 2)
		    (vector-ref ans-vec 3)
		    (vector-ref ans-vec 4)
		    (vector-ref ans-vec 5)
		    (vector-ref ans-vec 6)
		    (vector-ref ans-vec 7)
		    (vector-ref ans-vec 8)
		    (vector-ref ans-vec 9)
		    (vector-ref ans-vec 10))))
						      
		
(define (file-info fd/port/fname . maybe-chase?)
 (with-cwd-aligned
   (let ((chase? (:optional maybe-chase? #t)))
     (%file-info fd/port/fname chase?))))


(define file-attributes
  (deprecated-proc file-info "file-attributes" "Use file-info instead."))


;;; "no-declare" as there is no agreement among the OS's as to whether or not
;;; the OLD-NAME arg is "const". It *should* be const.

(define-foreign create-symlink/errno
  (symlink (string old-name) (string new-name))	no-declare
  (to-scheme fixnum errno_or_false))
  
;(define-errno-syscall (create-symlink old-name new-name)
;  create-symlink/errno)


;;; "no-declare" as there is no agreement among the OS's as to whether or not
;;; the PATH arg is "const". It *should* be const.

(define-foreign truncate-file/errno
  (truncate (string path) (off_t length)) 	no-declare
  (to-scheme fixnum errno_or_false))

(define-foreign truncate-fdes/errno
  (ftruncate (fixnum fd) (off_t length))   no-declare ; Indigo bogosity.
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (truncate-file path length)
  (lambda (thing length)
    (generic-file-op thing
		     (lambda (fd)    (truncate-fdes/errno fd    length))
		     (lambda (fname) (truncate-file/errno fname length)))))


(define-foreign delete-file/errno
  (unlink (string path))
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (delete-file path) delete-file/errno)


(define-foreign sync-file/errno (fsync (fixnum fd))
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (sync-file fd/port)
  (lambda (fd/port)
    (if (output-port? fd/port) (force-output fd/port))
    (sleazy-call/fdes fd/port sync-file/errno)))


;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
(define-foreign sync-file-system (sync) no-declare ; Linux sux - says int
  ignore)


;;; I/O
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-foreign %close-fdes/errno (close (fixnum fd))
  (to-scheme fixnum "errno_or_false"))

(define (%close-fdes fd)
  (let lp ()
    (let ((errno (%close-fdes/errno fd)))
      (cond ((not errno) 	  #t)	; Successful close.
	    ((= errno errno/badf) #f)	; File descriptor already closed.
	    ((= errno errno/intr) (lp))	; Retry.
	    (else
	     (errno-error errno %close-fdes fd))))))	; You lose.

(define-foreign %dup/errno
  (dup (fixnum fd))
  (multi-rep (to-scheme fixnum errno_or_false)
	     fixnum))

(define-errno-syscall (%dup fd) %dup/errno
   new-fd)

(define-foreign %dup2/errno
  (dup2 (fixnum fd-from) (fixnum fd-to))
  (multi-rep (to-scheme fixnum errno_or_false)
	     fixnum))

(define-errno-syscall (%dup2 fd-from fd-to) %dup2/errno 
   new-fd)


(define-foreign %fd-seek/errno
  (lseek (fixnum fd) (off_t offset) (fixnum whence))
  (multi-rep (to-scheme off_t errno_or_false)
	     off_t))



(define seek/set 0)			;Unix codes for "whence"
(define seek/delta 1)
(define seek/end 2)

(define (seek fd/port offset . maybe-whence)
  (let ((whence (:optional maybe-whence seek/set))
	(fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
    (receive (err cursor) (%fd-seek/errno fd offset whence)
	     (if err (errno-error err seek fd offset whence) cursor))))

(define (tell fd/port)
  (let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
    (receive (err offset) (%fd-seek/errno fd 0 seek/delta)
	     (if err (errno-error err tell fd/port) offset))))

(define-foreign %char-ready-fdes?/errno
  (char_ready_fdes (fixnum fd))
  desc) ; errno, #t, or #f

(define (%char-ready-fdes? fd)
  (let ((retval (%char-ready-fdes?/errno fd)))
    (if (integer? retval) (errno-error retval %char-ready-fdes? fd)
	retval)))


(define-foreign %open/errno
  (open (string path)
	(fixnum flags)
	(mode_t mode))	; integer on SunOS
  no-declare ; NOTE
  (multi-rep (to-scheme fixnum errno_or_false)
             fixnum))

(define-errno-syscall (%open path flags mode) %open/errno
   fd)

(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
    (with-cwd-aligned
     (%open path flags (:optional maybe-mode #o666))))


(define-stubless-foreign pipe-fdes () "scheme_pipe")

(define (pipe)
  (apply (lambda (r-fd w-fd)
	   (let ((r (fdes->inport  r-fd))
		 (w (fdes->outport w-fd)))
	     (release-port-handle r)
	     (release-port-handle w)
	     (values r w)))
	 (pipe-fdes)))

(define-foreign %read-fdes-char
  (read_fdes_char (fixnum fd))
  desc) ; Char or errno or #f (eof).

(define (read-fdes-char fd)
  (let ((c (%read-fdes-char fd)))
    (if (integer? c) (errno-error c read-fdes-char fd) c)))


(define-foreign write-fdes-char/errno (write_fdes_char (char char) (fixnum fd))
  (to-scheme fixnum errno_or_false))

(define-errno-syscall (write-fdes-char char fd) write-fdes-char/errno)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read and write

(define-foreign read-fdes-substring!/errno
  (read_fdes_substring (string-desc buf)
		       (size_t start)
		       (size_t end)
		       (fixnum fd))
  (multi-rep (to-scheme ssize_t errno_or_false)
	     ssize_t))

(define-foreign write-fdes-substring/errno
  (write_fdes_substring (string-desc buf)
			(size_t start)
			(size_t end)
			(fixnum fd))
  (multi-rep (to-scheme ssize_t errno_or_false)
	     ssize_t))


;;; Signals (rather incomplete)
;;; ---------------------------

(define-stubless-foreign signal-pid (pid signal) "scsh_kill")

(define (signal-process proc signal)
  (signal-pid (cond ((proc? proc)    (proc:pid proc))
		    ((integer? proc) proc)
		    (else (error "Illegal proc passed to signal-process" proc)))
	      signal))

(define (signal-process-group proc-group signal)
  (signal-pid (- (cond ((proc? proc-group)    (proc:pid proc-group))
		       ((integer? proc-group) proc-group)
		       (else (error "Illegal proc passed to signal-process-group"
                                    proc-group))))
              signal))
(define (itimer sec)
  ((structure-ref scsh-events schedule-timer-interrupt!) (* sec 1000)))
;;; SunOS, not POSIX:
;;; (define-foreign signal-process-group/errno
;;;   (killpg (integer proc-group) (integer signal))
;;;   (to-scheme integer errno_or_false))
;;; 
;;; (define-errno-syscall (signal-process-group proc-group signal)
;;;   signal-process-group/errno)

(define-foreign pause-until-interrupt (pause) no-declare ignore)

;;; now in low-interrupt: (define-foreign itimer (alarm (uint_t secs)) uint_t)

;;; User info
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-record user-info
  name uid gid home-dir shell

  ;; Make user-info records print like #{user-info shivers}.
  ((disclose ui)
   (list "user-info" (user-info:name ui))))


(import-lambda-definition 
 %uid->user-info 
 (uid user-info-record)
 "user_info_uid")

(import-lambda-definition 
 %name->user-info 
 (name user-info-record)
 "user_info_name")

(define (uid->user-info uid)
  (let ((empty-user-info (make-user-info #f uid #f #f #f)))
    (if (%uid->user-info uid empty-user-info)
	empty-user-info
	(error "Cannot get user's information" uid->user-info uid)))) 


(define (name->user-info name)
  (let ((empty-user-info (make-user-info name #f #f #f #f)))
    (if (%name->user-info name empty-user-info)
	empty-user-info
	(error "Cannot get user's information" name->user-info name))))

(define (user-info uid/name)
  ((cond ((string?  uid/name) name->user-info)
	 ((integer? uid/name) uid->user-info)
	 (else (error "user-info arg must be string or integer" uid/name)))
   uid/name))

;;; Derived functions

(define (->uid uid/name)
  (user-info:uid (user-info uid/name)))

(define (->username uid/name)
  (user-info:name (user-info uid/name)))

(define (%homedir uid/name)
  (user-info:home-dir (user-info uid/name)))


;;; Group info
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-record group-info
  name gid members

  ;; Make group-info records print like #{group-info wheel}.
  ((disclose gi) (list "group-info" (group-info:name gi))))

(import-lambda-definition 
 %gid->group-info 
 (gid group-info-record)
 "group_info_gid")

(import-lambda-definition 
 %name->group-info 
 (name group-info-record)
 "group_info_name")

(define (gid->group-info  gid)
  (let ((empty-group-info (make-group-info #f gid #f)))
    (if (%gid->group-info gid empty-group-info)
	empty-group-info
	(error "Cannot get group's information for gid" gid))))
							
(define (name->group-info name)
  (let ((empty-group-info (make-group-info name #f #f)))
    (if (%name->group-info name empty-group-info)
	empty-group-info
	(error "Cannot get group's information for name" name))))

(define (group-info gid/name)
  ((cond ((string?  gid/name) name->group-info)
	 ((integer? gid/name) gid->group-info)
	 (else (error "group-info arg must be string or integer" gid/name)))
   gid/name))

;;; Derived functions

(define (->gid name)
  (group-info:gid (group-info name)))

(define (->groupname gid)
  (group-info:name (group-info gid)))

;;; Directory stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-foreign %open-dir (open_dir (string dir-name))
  (to-scheme integer "False_on_zero")	; Win: #f, lose: errno
  (C char**)				; Vector of strings
  fixnum)				; Length of strings

;;; Takes a null-terminated C vector of strings -- filenames.
;;; Sorts them in place by the Unix filename order: ., .., dotfiles, others.

(define-foreign %sort-file-vector
  (scm_sort_filevec ((C "const char** ~a") cvec)
		    (fixnum    veclen))
  ignore)

(define (directory-files . args)
  (with-cwd-aligned
   (let-optionals args ((dir       ".")
			(dotfiles? #f))
    (check-arg string? dir directory-files)
    (receive (err cvec numfiles)
	     (%open-dir (ensure-file-name-is-nondirectory dir))
      (if err (errno-error err directory-files dir dotfiles?))
      (%sort-file-vector cvec numfiles)
      (let ((files (vector->list (C-string-vec->Scheme&free cvec numfiles))))
	(if dotfiles? files
	    (filter (lambda (f) (not (char=? (string-ref f 0) #\.)))
		    files)))))))

;;; I do this one in C, I'm not sure why:
;;; It is used by MATCH-FILES.
;;; 99/7: No one is using this function, so I'm commenting it out.
;;; Later, we could tune up the globber or regexp file-matcher to use
;;; it (but should shift it into the rx directory). But I should also go
;;; to a file-at-a-time cursor model for directory fetching. -Olin

;(define-foreign %filter-C-strings!
;  (filter_stringvec (string pattern) ((C "char const ** ~a") cvec))
;  static-string	; error message -- #f if no error.
;  integer)	; number of files that pass the filter.


;(define (match-files regexp . maybe-dir)
;  (let ((dir (:optional maybe-dir ".")))
;    (check-arg string? dir match-files)
;    (receive (err cvec numfiles)
;	     (%open-dir (ensure-file-name-is-nondirectory dir))
;      (if err (errno-error err match-files regexp dir))
;      (receive (err numfiles) (%filter-C-strings! regexp cvec)
;	(if err (error err match-files))
;	(%sort-file-vector cvec numfiles)
;	(let ((files (C-string-vec->Scheme&free cvec numfiles)))
;	  (vector->list files))))))


;;; Environment manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; (var . val) / "var=val" rep conversion:

 

(define (split-env-string var=val)
  (let ((i (string-index var=val #\=)))
    (if i (values (substring var=val 0 i)
		  (substring var=val (+ i 1) (string-length var=val)))
	(error "No \"=\" in environment string" var=val))))

(define (env-list->alist env-list)
  (map (lambda (var=val)
	 (call-with-values (lambda () (split-env-string var=val))
			   cons))
       env-list))

(define (alist->env-vec alist)
  (list->vector (map (lambda (var.val)
		       (string-append (car var.val) "="
				      (let ((val (cdr var.val)))
					(if (string? val) val
					    (string-join val ":")))))
		     alist)))

;;; ENV->ALIST

(define-foreign %load-env (scm_envvec)
  desc)

(define (env->list)
  (%load-env))

(define (environ-env->alist) 
  (env-list->alist (env->list)))


	   
;;; ALIST->ENV

(define-foreign %install-env/errno 
  (install_env (vector-desc env-vec))
  (to-scheme integer errno_or_false))

(define-errno-syscall (%install-env env-vec) %install-env/errno)

;;; assumes aligned env
(define (envvec-alist->env alist)
  (%install-env (alist->env-vec alist)))

;;; create new env for thread
(define-foreign %create-env/errno 
  (create_env (vector-desc env-vec))
  (to-scheme integer errno_or_false)
  desc)

(define-errno-syscall (%create-env env-vec) 
  %create-env/errno 
  bvec)

(define (alist->envvec alist)
  (%create-env (alist->env-vec alist)))

(define-foreign %align-env
  (align_env (desc))
  ignore)

(define-foreign %free-env
  (free_envvec (desc))
  desc)
;;; GETENV, SETENV
;;; they all assume an aligned env


(define-foreign %envvec-setenv (envvec_setenv (desc name) (desc entry))
  desc)

(define (envvec-setenv name value)
  (%envvec-setenv name (string-append name "=" value)))

(define-foreign envvec-getenv (getenv (string var))
  static-string)

(foreign-source
 "#define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) : S48_FALSE)"
 "" "")

(define-foreign envvec-delete-env (delete_env (desc var))
  desc)


;;; Fd-ports
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-stubless-foreign %set-cloexec (fd val) "set_cloexec")

;;; Some of fcntl()
;;;;;;;;;;;;;;;;;;;

(define-stubless-foreign %fcntl-read (fd command) "fcntl_read")
(define-stubless-foreign %fcntl-write (fd command val) "fcntl_write")

;;; fcntl()'s F_GETFD and F_SETFD.  Note that the SLEAZY- prefix on the
;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour
;;; of these procedures. Straight CALL/FDES modifies unrevealed file
;;; descriptors by clearing their CLOEXEC bit when it reveals them -- so it
;;; would interfere with the reading and writing of that bit!

(define (fdes-flags fd/port)
  (sleazy-call/fdes fd/port
    (lambda (fd) (%fcntl-read fd fcntl/get-fdes-flags))))

(define (set-fdes-flags fd/port flags)
  (sleazy-call/fdes fd/port
    (lambda (fd) (%fcntl-write fd fcntl/set-fdes-flags flags))))

;;; fcntl()'s F_GETFL and F_SETFL.
;;; Get: Returns open flags + get-status flags (below)
;;; Set: append, sync, async, nbio, nonblocking, no-delay

(define (fdes-status fd/port)
  (sleazy-call/fdes fd/port
    (lambda (fd) (%fcntl-read fd fcntl/get-status-flags))))

(define (set-fdes-status fd/port flags)
  (sleazy-call/fdes fd/port
    (lambda (fd) (%fcntl-write fd fcntl/set-status-flags flags))))

;;; Miscellaneous
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; usleep(3): Try to sleep for USECS microseconds.
;;; sleep(3):  Try to sleep for SECS seconds.

; De-released -- not POSIX and not on SGI systems.
; (define-foreign usleep (usleep (integer usecs)) integer)

(define (sleep secs) (sleep-until (+ secs (time))))

(define (sleep-until when)
  (let* ((when (floor when))	; Painful to do real->int in Scheme.
	 (when (if (exact? when) when (inexact->exact when))))
    (let lp ()
      (or (%sleep-until when) (lp)))))

;;; JMG: I don't know whether time_t or long is correct...
(define-foreign %sleep-until (sleep_until (time_t secs))
  desc)

(define-stubless-foreign %gethostname () "scm_gethostname")

(define system-name %gethostname)

(define-foreign errno-msg (errno_msg (integer i))
  static-string)

(define-stubless-foreign %crypt (key salt) "scm_crypt")

(define (crypt key salt)
  (let* ((allowed-char-set  (rx (| alpha digit "." "/")))
	 (salt-regexp  (rx (: ,allowed-char-set ,allowed-char-set))))
    (if (not (= (string-length salt) 2)) (error "salt must have length 2"))
    (if (not (regexp-search? salt-regexp salt))
	(error "illegal char in salt " salt))
    (if (> (string-length key) 8) (error "key too long "  (string-length key)))
    (%crypt key salt)))