Changeset 7276 in project for chicken/branches/release/posixunix.scm


Ignore:
Timestamp:
01/05/08 20:17:50 (13 years ago)
Author:
felix winkelmann
Message:

merged trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/release/posixunix.scm

    r6376 r7276  
    3939  (disable-interrupts)
    4040  (usual-integrations)
    41   (hide ##sys#stat group-member _get-groups _ensure-groups posix-error)
     41  (hide ##sys#stat group-member _get-groups _ensure-groups posix-error
     42        ##sys#terminal-check)
    4243  (foreign-declare #<<EOF
    4344#include <signal.h>
     
    5657#include <sys/utsname.h>
    5758#include <sys/stat.h>
     59#include <sys/ioctl.h>
    5860#include <fcntl.h>
    5961#include <dirent.h>
    6062#include <pwd.h>
    61 
    62 #ifdef ECOS
    63 #include <cyg/posix/signal.h>
    64 #endif
    6563
    6664#ifdef HAVE_GRP_H
     
    121119static C_TLS struct flock C_flock;
    122120static C_TLS DIR *temphandle;
    123 #ifndef ECOS
    124121static C_TLS struct passwd *C_user;
    125122#ifdef HAVE_GRP_H
    126123static C_TLS struct group *C_group;
    127 #else
    128 struct C_fake_group {
    129   int gr_gid;
    130   int gr_mem[ 1 ];
    131   char *gr_name;
    132   char *gr_passwd;
    133 };
    134 static C_TLS struct C_fake_group *C_group;
    135 #endif
    136124static C_TLS int C_pipefds[ 2 ];
    137125#endif
     
    162150#define C_set_file_ptr(port, ptr)  (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)
    163151
    164 #ifndef ECOS
    165152#define C_fork              fork
    166153#define C_waitpid(id, o)    C_fix(waitpid(C_unfix(id), &C_wait_status, C_unfix(o)))
     
    195182#define C_truncate(f, n)    C_fix(truncate((char *)C_data_pointer(f), C_num_to_int(n)))
    196183#define C_ftruncate(f, n)   C_fix(ftruncate(C_unfix(f), C_num_to_int(n)))
    197 #endif
    198184#define C_uname             C_fix(uname(&C_utsname))
    199185#define C_fdopen(a, n, fd, m) C_mpointer(a, fdopen(C_unfix(fd), C_c_string(m)))
     
    371357#endif
    372358
    373 #ifndef ECOS
    374359static gid_t *C_groups = NULL;
    375360
     
    377362#define C_set_gid(n, id)  (C_groups[ C_unfix(n) ] = C_unfix(id), C_SCHEME_UNDEFINED)
    378363#define C_set_groups(n)   C_fix(setgroups(C_unfix(n), C_groups))
    379 #endif
     364
     365static int get_tty_size(int p, int *rows, int *cols)
     366{
     367 struct winsize tty_size;
     368 int r;
     369
     370 memset(&tty_size, 0, sizeof tty_size);
     371
     372 r = ioctl(p, TIOCGWINSZ, &tty_size);
     373 if (r == 0) {
     374    *rows = tty_size.ws_row;
     375    *cols = tty_size.ws_col;
     376 }
     377 return r;
     378}
     379
    380380EOF
    381381) )
     
    508508(define-foreign-variable _s_isuid int "S_ISUID")
    509509(define-foreign-variable _s_isgid int "S_ISGID")
    510 (cond-expand
    511  [ecos]
    512  [else
    513   (define-foreign-variable _s_isvtx int "S_ISVTX")])
     510(define-foreign-variable _s_isvtx int "S_ISVTX")
    514511
    515512(define perm/irusr _s_irusr)
     
    582579        n) ) ) )
    583580
    584 (cond-expand
    585  [ecos]
    586  [else
    587   (define file-mkstemp
    588     (lambda (template)
    589       (##sys#check-string template 'file-mkstemp)
    590       (let* ([buf (##sys#make-c-string template)]
    591              [fd (##core#inline "C_mkstemp" buf)]
    592              [path-length (##sys#size buf)])
    593         (when (eq? -1 fd)
    594           (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template) )
    595         (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) ) ] )
     581(define file-mkstemp
     582  (lambda (template)
     583    (##sys#check-string template 'file-mkstemp)
     584    (let* ([buf (##sys#make-c-string template)]
     585           [fd (##core#inline "C_mkstemp" buf)]
     586           [path-length (##sys#size buf)])
     587      (when (eq? -1 fd)
     588        (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template) )
     589      (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )
    596590
    597591
     
    667661(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
    668662(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")
    669 (define-foreign-variable _stat_st_size unsigned-int "C_statbuf.st_size")
     663(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")
    670664(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
    671665(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
     
    676670(define-foreign-variable _stat_st_rdev unsigned-int "C_statbuf.st_rdev")
    677671(define-foreign-variable _stat_st_blksize unsigned-int "C_statbuf.st_blksize")
    678 (define-foreign-variable _stat_st_blocks unsigned-int "C_statbuf.st_rdev")
     672(define-foreign-variable _stat_st_blocks unsigned-int "C_statbuf.st_blocks")
    679673
    680674(define (##sys#stat file link loc)
     
    682676                 [(string? file)
    683677                  (let ([path (##sys#make-c-string (##sys#expand-home-path file))])
    684                     (cond-expand
    685                      [ecos
    686                       (##core#inline "C_stat" path)]
    687                      [else
    688                       (if link
    689                           (##core#inline "C_lstat" path)
    690                           (##core#inline "C_stat" path) ) ] )  ) ]
     678                    (if link
     679                        (##core#inline "C_lstat" path)
     680                        (##core#inline "C_stat" path) ) ) ]
    691681                 [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
    692682    (when (fx< r 0)
     
    814804;;; Pipes:
    815805
    816 (cond-expand
    817  [ecos]
    818  [else
    819 
    820   (let ()
    821     (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
    822     (define (badmode m) (##sys#error "illegal input/output mode specifier" m))
    823     (define (check loc cmd inp r)
    824       (if (##sys#null-pointer? r)
    825           (posix-error #:file-error loc "cannot open pipe" cmd)
    826           (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
    827             (##core#inline "C_set_file_ptr" port r)
    828             port) ) )
    829     (set! open-input-pipe
    830       (lambda (cmd . m)
    831         (##sys#check-string cmd 'open-input-pipe)
    832         (let ([m (mode m)])
    833           (check
    834            'open-input-pipe
    835            cmd #t
    836            (case m
    837              ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
    838              ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
    839              (else (badmode m)) ) ) ) ) )
    840     (set! open-output-pipe
    841       (lambda (cmd . m)
    842         (##sys#check-string cmd 'open-output-pipe)
    843         (let ((m (mode m)))
    844           (check
    845            'open-output-pipe
    846            cmd #f
    847            (case m
    848              ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd)))
    849              ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd)))
    850              (else (badmode m)) ) ) ) ) )
    851     (set! close-input-pipe
    852       (lambda (port)
    853         (##sys#check-port port 'close-input-pipe)
    854         (let ((r (##core#inline "close_pipe" port)))
    855           (when (eq? -1 r) (posix-error #:file-error 'close-input/output-pipe "error while closing pipe" port))
    856           r) ) )
    857     (set! close-output-pipe close-input-pipe) )
    858 
    859   (let ([open-input-pipe open-input-pipe]
    860         [open-output-pipe open-output-pipe]
    861         [close-input-pipe close-input-pipe]
    862         [close-output-pipe close-output-pipe] )
    863     (set! call-with-input-pipe
    864       (lambda (cmd proc . mode)
    865         (let ([p (apply open-input-pipe cmd mode)])
    866           (##sys#call-with-values
    867            (lambda () (proc p))
    868            (lambda results
    869              (close-input-pipe p)
    870              (apply values results) ) ) ) ) )
    871     (set! call-with-output-pipe
    872       (lambda (cmd proc . mode)
    873         (let ([p (apply open-output-pipe cmd mode)])
    874           (##sys#call-with-values
    875            (lambda () (proc p))
    876            (lambda results
    877              (close-output-pipe p)
    878              (apply values results) ) ) ) ) )
    879     (set! with-input-from-pipe
    880       (lambda (cmd thunk . mode)
    881         (let ([old ##sys#standard-input]
    882               [p (apply open-input-pipe cmd mode)] )
    883           (set! ##sys#standard-input p)
    884           (##sys#call-with-values thunk
    885                                   (lambda results
    886                                     (close-input-pipe p)
    887                                     (set! ##sys#standard-input old)
    888                                     (apply values results) ) ) ) ) )
    889     (set! with-output-to-pipe
    890       (lambda (cmd thunk . mode)
    891         (let ([old ##sys#standard-output]
    892               [p (apply open-output-pipe cmd mode)] )
    893           (set! ##sys#standard-output p)
    894           (##sys#call-with-values thunk
    895                                   (lambda results
    896                                     (close-output-pipe p)
    897                                     (set! ##sys#standard-output old)
    898                                     (apply values results) ) ) ) ) ) )
    899 
    900   (define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
    901   (define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
    902 
    903   (define create-pipe
    904     (lambda ()
    905       (when (fx< (##core#inline "C_pipe" #f) 0)
    906         (posix-error #:file-error 'create-pipe "cannot create pipe") )
    907       (values _pipefd0 _pipefd1) ) ) ] )
     806(let ()
     807  (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
     808  (define (badmode m) (##sys#error "illegal input/output mode specifier" m))
     809  (define (check loc cmd inp r)
     810    (if (##sys#null-pointer? r)
     811        (posix-error #:file-error loc "cannot open pipe" cmd)
     812        (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
     813          (##core#inline "C_set_file_ptr" port r)
     814          port) ) )
     815  (set! open-input-pipe
     816    (lambda (cmd . m)
     817      (##sys#check-string cmd 'open-input-pipe)
     818      (let ([m (mode m)])
     819        (check
     820         'open-input-pipe
     821         cmd #t
     822         (case m
     823           ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
     824           ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
     825           (else (badmode m)) ) ) ) ) )
     826  (set! open-output-pipe
     827    (lambda (cmd . m)
     828      (##sys#check-string cmd 'open-output-pipe)
     829      (let ((m (mode m)))
     830        (check
     831         'open-output-pipe
     832         cmd #f
     833         (case m
     834           ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd)))
     835           ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd)))
     836           (else (badmode m)) ) ) ) ) )
     837  (set! close-input-pipe
     838    (lambda (port)
     839      (##sys#check-port port 'close-input-pipe)
     840      (let ((r (##core#inline "close_pipe" port)))
     841        (when (eq? -1 r) (posix-error #:file-error 'close-input/output-pipe "error while closing pipe" port))
     842        r) ) )
     843  (set! close-output-pipe close-input-pipe) )
     844
     845(let ([open-input-pipe open-input-pipe]
     846      [open-output-pipe open-output-pipe]
     847      [close-input-pipe close-input-pipe]
     848      [close-output-pipe close-output-pipe] )
     849  (set! call-with-input-pipe
     850    (lambda (cmd proc . mode)
     851      (let ([p (apply open-input-pipe cmd mode)])
     852        (##sys#call-with-values
     853         (lambda () (proc p))
     854         (lambda results
     855           (close-input-pipe p)
     856           (apply values results) ) ) ) ) )
     857  (set! call-with-output-pipe
     858    (lambda (cmd proc . mode)
     859      (let ([p (apply open-output-pipe cmd mode)])
     860        (##sys#call-with-values
     861         (lambda () (proc p))
     862         (lambda results
     863           (close-output-pipe p)
     864           (apply values results) ) ) ) ) )
     865  (set! with-input-from-pipe
     866    (lambda (cmd thunk . mode)
     867      (let ([old ##sys#standard-input]
     868            [p (apply open-input-pipe cmd mode)] )
     869        (set! ##sys#standard-input p)
     870        (##sys#call-with-values thunk
     871                                (lambda results
     872                                  (close-input-pipe p)
     873                                  (set! ##sys#standard-input old)
     874                                  (apply values results) ) ) ) ) )
     875  (set! with-output-to-pipe
     876    (lambda (cmd thunk . mode)
     877      (let ([old ##sys#standard-output]
     878            [p (apply open-output-pipe cmd mode)] )
     879        (set! ##sys#standard-output p)
     880        (##sys#call-with-values thunk
     881                                (lambda results
     882                                  (close-output-pipe p)
     883                                  (set! ##sys#standard-output old)
     884                                  (apply values results) ) ) ) ) ) )
     885
     886(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
     887(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
     888
     889(define create-pipe
     890  (lambda ()
     891    (when (fx< (##core#inline "C_pipe" #f) 0)
     892      (posix-error #:file-error 'create-pipe "cannot create pipe") )
     893    (values _pipefd0 _pipefd1) ) )
    908894
    909895
     
    925911(define-foreign-variable _sigusr1 int "SIGUSR1")
    926912(define-foreign-variable _sigusr2 int "SIGUSR2")
    927 (cond-expand
    928  [ecos]
    929  [else
    930   (define-foreign-variable _sigvtalrm int "SIGVTALRM")
    931   (define-foreign-variable _sigprof int "SIGPROF")
    932   (define-foreign-variable _sigio int "SIGIO")
    933   (define-foreign-variable _sigurg int "SIGURG")
    934   (define-foreign-variable _sigchld int "SIGCHLD")
    935   (define-foreign-variable _sigcont int "SIGCONT")
    936   (define-foreign-variable _sigstop int "SIGSTOP")
    937   (define-foreign-variable _sigtstp int "SIGTSTP")
    938   (define-foreign-variable _sigxcpu int "SIGXCPU")
    939   (define-foreign-variable _sigxfsz int "SIGXFSZ")
    940   (define-foreign-variable _sigwinch int "SIGWINCH") ] )
     913(define-foreign-variable _sigvtalrm int "SIGVTALRM")
     914(define-foreign-variable _sigprof int "SIGPROF")
     915(define-foreign-variable _sigio int "SIGIO")
     916(define-foreign-variable _sigurg int "SIGURG")
     917(define-foreign-variable _sigchld int "SIGCHLD")
     918(define-foreign-variable _sigcont int "SIGCONT")
     919(define-foreign-variable _sigstop int "SIGSTOP")
     920(define-foreign-variable _sigtstp int "SIGTSTP")
     921(define-foreign-variable _sigxcpu int "SIGXCPU")
     922(define-foreign-variable _sigxfsz int "SIGXFSZ")
     923(define-foreign-variable _sigwinch int "SIGWINCH")
    941924
    942925(define signal/term _sigterm)
     
    10381021;;; Getting system-, group- and user-information:
    10391022
    1040 (cond-expand
    1041  [ecos]
    1042  [else
    1043 
    1044   (define-foreign-variable _uname int "C_uname")
    1045   (define-foreign-variable _uname-sysname nonnull-c-string "C_utsname.sysname")
    1046   (define-foreign-variable _uname-nodename nonnull-c-string "C_utsname.nodename")
    1047   (define-foreign-variable _uname-release nonnull-c-string "C_utsname.release")
    1048   (define-foreign-variable _uname-version nonnull-c-string "C_utsname.version")
    1049   (define-foreign-variable _uname-machine nonnull-c-string "C_utsname.machine")
    1050 
    1051   (define system-information
    1052     (lambda ()
    1053       (when (fx< _uname 0)
    1054         (##sys#update-errno)
    1055         (##sys#error 'system-information "cannot retrieve system information") )
    1056       (list _uname-sysname
    1057             _uname-nodename
    1058             _uname-release
    1059             _uname-version
    1060             _uname-machine) ) )
    1061 
    1062   (define set-user-id!                  ; DEPRECATED
    1063     (lambda (id)
    1064       (when (fx< (##core#inline "C_setuid" id) 0)
    1065         (##sys#update-errno)
    1066         (##sys#error 'set-user-id! "cannot set user ID" id) ) ) )
    1067 
    1068   (define current-user-id
    1069     (getter-with-setter
    1070      (foreign-lambda int "C_getuid")
    1071      set-user-id!) )
    1072 
    1073   (define current-effective-user-id
    1074     (getter-with-setter
    1075      (foreign-lambda int "C_geteuid")
    1076      (lambda (id)
    1077       (when (fx< (##core#inline "C_seteuid" id) 0)
    1078         (##sys#update-errno)
    1079         (##sys#error
     1023(define-foreign-variable _uname int "C_uname")
     1024(define-foreign-variable _uname-sysname nonnull-c-string "C_utsname.sysname")
     1025(define-foreign-variable _uname-nodename nonnull-c-string "C_utsname.nodename")
     1026(define-foreign-variable _uname-release nonnull-c-string "C_utsname.release")
     1027(define-foreign-variable _uname-version nonnull-c-string "C_utsname.version")
     1028(define-foreign-variable _uname-machine nonnull-c-string "C_utsname.machine")
     1029
     1030(define system-information
     1031  (lambda ()
     1032    (when (fx< _uname 0)
     1033      (##sys#update-errno)
     1034      (##sys#error 'system-information "cannot retrieve system information") )
     1035    (list _uname-sysname
     1036          _uname-nodename
     1037          _uname-release
     1038          _uname-version
     1039          _uname-machine) ) )
     1040
     1041(define set-user-id!                  ; DEPRECATED
     1042  (lambda (id)
     1043    (when (fx< (##core#inline "C_setuid" id) 0)
     1044      (##sys#update-errno)
     1045      (##sys#error 'set-user-id! "cannot set user ID" id) ) ) )
     1046
     1047(define current-user-id
     1048  (getter-with-setter
     1049   (foreign-lambda int "C_getuid")
     1050   set-user-id!) )
     1051
     1052(define current-effective-user-id
     1053  (getter-with-setter
     1054   (foreign-lambda int "C_geteuid")
     1055   (lambda (id)
     1056    (when (fx< (##core#inline "C_seteuid" id) 0)
     1057      (##sys#update-errno)
     1058      (##sys#error
    10801059         'effective-user-id!-setter "cannot set effective user ID" id) ) ) ) )
    10811060
    1082   (define set-group-id!                 ; DEPRECATED
    1083     (lambda (id)
    1084       (when (fx< (##core#inline "C_setgid" id) 0)
    1085         (##sys#update-errno)
    1086         (##sys#error 'set-user-id! "cannot set group ID" id) ) ) )
    1087 
    1088   (define current-group-id
    1089     (getter-with-setter
    1090      (foreign-lambda int "C_getgid")
    1091      set-group-id!) )
    1092 
    1093   (define current-effective-group-id
    1094     (getter-with-setter
    1095      (foreign-lambda int "C_getegid")
    1096      (lambda (id)
    1097       (when (fx< (##core#inline "C_setegid" id) 0)
    1098         (##sys#update-errno)
    1099         (##sys#error
     1061(define set-group-id!                 ; DEPRECATED
     1062  (lambda (id)
     1063    (when (fx< (##core#inline "C_setgid" id) 0)
     1064      (##sys#update-errno)
     1065      (##sys#error 'set-user-id! "cannot set group ID" id) ) ) )
     1066
     1067(define current-group-id
     1068  (getter-with-setter
     1069   (foreign-lambda int "C_getgid")
     1070   set-group-id!) )
     1071
     1072(define current-effective-group-id
     1073  (getter-with-setter
     1074   (foreign-lambda int "C_getegid")
     1075   (lambda (id)
     1076    (when (fx< (##core#inline "C_setegid" id) 0)
     1077      (##sys#update-errno)
     1078      (##sys#error
    11001079         'effective-group-id!-setter "cannot set effective group ID" id) ) ) ) )
    11011080
    1102   (define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")
    1103   (define-foreign-variable _user-passwd nonnull-c-string "C_user->pw_passwd")
    1104   (define-foreign-variable _user-uid int "C_user->pw_uid")
    1105   (define-foreign-variable _user-gid int "C_user->pw_gid")
    1106   (define-foreign-variable _user-gecos nonnull-c-string "C_user->pw_gecos")
    1107   (define-foreign-variable _user-dir c-string "C_user->pw_dir")
    1108   (define-foreign-variable _user-shell c-string "C_user->pw_shell")
    1109 
    1110   (define (user-information user #!optional as-vector)
    1111     (let ([r (if (fixnum? user)
    1112                  (##core#inline "C_getpwuid" user)
    1113                  (begin
    1114                    (##sys#check-string user 'user-information)
    1115                    (##core#inline "C_getpwnam" (##sys#make-c-string user)) ) ) ] )
    1116       (and r
    1117            ((if as-vector vector list)
    1118             _user-name
    1119             _user-passwd
    1120             _user-uid
    1121             _user-gid
    1122             _user-gecos
    1123             _user-dir
    1124             _user-shell) ) ) )
    1125 
    1126   (define (current-user-name)
    1127     (list-ref (user-information (current-user-id)) 0) )
    1128 
    1129   (define (current-effective-user-name)
    1130     (list-ref (user-information (current-effective-user-id)) 0) )
    1131 
    1132   (define-foreign-variable _group-name nonnull-c-string "C_group->gr_name")
    1133   (define-foreign-variable _group-passwd nonnull-c-string "C_group->gr_passwd")
    1134   (define-foreign-variable _group-gid int "C_group->gr_gid")
    1135 
    1136   (define group-member
    1137     (foreign-lambda* c-string ([int i])
    1138       "return(C_group->gr_mem[ i ]);") )
    1139 
    1140   (define (group-information group #!optional as-vector)
    1141     (let ([r (if (fixnum? group)
    1142                  (##core#inline "C_getgrgid" group)
    1143                  (begin
    1144                    (##sys#check-string group 'group-information)
    1145                    (##core#inline "C_getgrnam" (##sys#make-c-string group)) ) ) ] )
    1146       (and r
    1147            ((if as-vector vector list)
    1148             _group-name
    1149             _group-passwd
    1150             _group-gid
    1151             (let loop ([i 0])
    1152               (let ([n (group-member i)])
    1153                 (if n
    1154                     (cons n (loop (fx+ i 1)))
    1155                     '() ) ) ) ) ) ) )
    1156 
    1157   (define _get-groups
    1158     (foreign-lambda* int ([int n])
    1159       "return(getgroups(n, C_groups));") )
    1160 
    1161   (define _ensure-groups
    1162     (foreign-lambda* bool ([int n])
    1163       "if(C_groups != NULL) C_free(C_groups);"
    1164       "C_groups = (gid_t *)C_malloc(sizeof(gid_t) * n);"
    1165       "if(C_groups == NULL) return(0);"
    1166       "else return(1);") )
    1167 
    1168   (define (get-groups)
    1169     (let ([n (foreign-value "getgroups(0, C_groups)" int)])
    1170       (when (fx< n 0)
    1171         (##sys#update-errno)
    1172         (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
    1173       (unless (_ensure-groups n)
    1174         (##sys#error 'get-groups "out of memory") )
    1175       (when (fx< (_get-groups n) 0)
    1176         (##sys#update-errno)
    1177         (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
    1178       (let loop ([i 0])
    1179         (if (fx>= i n)
    1180             '()
    1181             (cons (##core#inline "C_get_gid" i) (loop (fx+ i 1))) ) ) ) )
    1182 
    1183   (define (set-groups! lst0)
    1184     (unless (_ensure-groups (length lst0))
    1185       (##sys#error 'set-groups! "out of memory") )
    1186     (do ([lst lst0 (##sys#slot lst 1)]
    1187          [i 0 (fx+ i 1)] )
    1188         ((null? lst)
    1189          (when (fx< (##core#inline "C_set_groups" i) 0)
    1190          (##sys#update-errno)
    1191          (##sys#error 'set-groups! "cannot set supplementary group ids" lst0) ) )
    1192       (let ([n (##sys#slot lst 0)])
    1193         (##sys#check-exact n 'set-groups!)
    1194         (##core#inline "C_set_gid" i n) ) ) )
    1195 
    1196   (define initialize-groups
    1197     (let ([init (foreign-lambda int "initgroups" c-string int)])
    1198       (lambda (user id)
    1199         (##sys#check-string user 'initialize-groups)
    1200         (##sys#check-exact id 'initialize-groups)
    1201         (when (fx< (init user id) 0)
    1202         (##sys#update-errno)
    1203         (##sys#error 'initialize-groups "cannot initialize supplementary group ids" user id) ) ) ) ) ] )
     1081(define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")
     1082(define-foreign-variable _user-passwd nonnull-c-string "C_user->pw_passwd")
     1083(define-foreign-variable _user-uid int "C_user->pw_uid")
     1084(define-foreign-variable _user-gid int "C_user->pw_gid")
     1085(define-foreign-variable _user-gecos nonnull-c-string "C_user->pw_gecos")
     1086(define-foreign-variable _user-dir c-string "C_user->pw_dir")
     1087(define-foreign-variable _user-shell c-string "C_user->pw_shell")
     1088
     1089(define (user-information user #!optional as-vector)
     1090  (let ([r (if (fixnum? user)
     1091               (##core#inline "C_getpwuid" user)
     1092               (begin
     1093                 (##sys#check-string user 'user-information)
     1094                 (##core#inline "C_getpwnam" (##sys#make-c-string user)) ) ) ] )
     1095    (and r
     1096         ((if as-vector vector list)
     1097          _user-name
     1098          _user-passwd
     1099          _user-uid
     1100          _user-gid
     1101          _user-gecos
     1102          _user-dir
     1103          _user-shell) ) ) )
     1104
     1105(define (current-user-name)
     1106  (list-ref (user-information (current-user-id)) 0) )
     1107
     1108(define (current-effective-user-name)
     1109  (list-ref (user-information (current-effective-user-id)) 0) )
     1110
     1111(define-foreign-variable _group-name nonnull-c-string "C_group->gr_name")
     1112(define-foreign-variable _group-passwd nonnull-c-string "C_group->gr_passwd")
     1113(define-foreign-variable _group-gid int "C_group->gr_gid")
     1114
     1115(define group-member
     1116  (foreign-lambda* c-string ([int i])
     1117    "return(C_group->gr_mem[ i ]);") )
     1118
     1119(define (group-information group #!optional as-vector)
     1120  (let ([r (if (fixnum? group)
     1121               (##core#inline "C_getgrgid" group)
     1122               (begin
     1123                 (##sys#check-string group 'group-information)
     1124                 (##core#inline "C_getgrnam" (##sys#make-c-string group)) ) ) ] )
     1125    (and r
     1126         ((if as-vector vector list)
     1127          _group-name
     1128          _group-passwd
     1129          _group-gid
     1130          (let loop ([i 0])
     1131            (let ([n (group-member i)])
     1132              (if n
     1133                  (cons n (loop (fx+ i 1)))
     1134                  '() ) ) ) ) ) ) )
     1135
     1136(define _get-groups
     1137  (foreign-lambda* int ([int n])
     1138    "return(getgroups(n, C_groups));") )
     1139
     1140(define _ensure-groups
     1141  (foreign-lambda* bool ([int n])
     1142    "if(C_groups != NULL) C_free(C_groups);"
     1143    "C_groups = (gid_t *)C_malloc(sizeof(gid_t) * n);"
     1144    "if(C_groups == NULL) return(0);"
     1145    "else return(1);") )
     1146
     1147(define (get-groups)
     1148  (let ([n (foreign-value "getgroups(0, C_groups)" int)])
     1149    (when (fx< n 0)
     1150      (##sys#update-errno)
     1151      (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
     1152    (unless (_ensure-groups n)
     1153      (##sys#error 'get-groups "out of memory") )
     1154    (when (fx< (_get-groups n) 0)
     1155      (##sys#update-errno)
     1156      (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
     1157    (let loop ([i 0])
     1158      (if (fx>= i n)
     1159          '()
     1160          (cons (##core#inline "C_get_gid" i) (loop (fx+ i 1))) ) ) ) )
     1161
     1162(define (set-groups! lst0)
     1163  (unless (_ensure-groups (length lst0))
     1164    (##sys#error 'set-groups! "out of memory") )
     1165  (do ([lst lst0 (##sys#slot lst 1)]
     1166       [i 0 (fx+ i 1)] )
     1167      ((null? lst)
     1168       (when (fx< (##core#inline "C_set_groups" i) 0)
     1169       (##sys#update-errno)
     1170       (##sys#error 'set-groups! "cannot set supplementary group ids" lst0) ) )
     1171    (let ([n (##sys#slot lst 0)])
     1172      (##sys#check-exact n 'set-groups!)
     1173      (##core#inline "C_set_gid" i n) ) ) )
     1174
     1175(define initialize-groups
     1176  (let ([init (foreign-lambda int "initgroups" c-string int)])
     1177    (lambda (user id)
     1178      (##sys#check-string user 'initialize-groups)
     1179      (##sys#check-exact id 'initialize-groups)
     1180      (when (fx< (init user id) 0)
     1181      (##sys#update-errno)
     1182      (##sys#error 'initialize-groups "cannot initialize supplementary group ids" user id) ) ) ) )
    12041183
    12051184
     
    12131192(define-foreign-variable _eintr int "EINTR")
    12141193(define-foreign-variable _eio int "EIO")
    1215 (cond-expand
    1216  [ecos]
    1217  [else
    1218   (define-foreign-variable _efault int "EFAULT")
    1219   (define-foreign-variable _echild int "ECHILD")
    1220   (define-foreign-variable _enoexec int "ENOEXEC")])
     1194(define-foreign-variable _efault int "EFAULT")
     1195(define-foreign-variable _echild int "ECHILD")
     1196(define-foreign-variable _enoexec int "ENOEXEC")
    12211197(define-foreign-variable _ebadf int "EBADF")
    12221198(define-foreign-variable _enomem int "ENOMEM")
     
    12761252(define errno/xdev 0)
    12771253
    1278 (cond-expand
    1279  [ecos]
    1280  [else
    1281 
    1282   ;;; Permissions and owners:
    1283 
    1284   (define change-file-mode
    1285     (lambda (fname m)
    1286       (##sys#check-string fname 'change-file-mode)
    1287       (##sys#check-exact m 'change-file-mode)
    1288       (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
    1289         (posix-error #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
    1290 
    1291   (define change-file-owner
    1292     (lambda (fn uid gid)
    1293       (##sys#check-string fn 'change-file-owner)
    1294       (##sys#check-exact uid 'change-file-owner)
    1295       (##sys#check-exact gid 'change-file-owner)
    1296       (when (fx< (##core#inline "C_chown" (##sys#make-c-string (##sys#expand-home-path fn)) uid gid) 0)
    1297         (posix-error #:file-error 'change-file-owner "cannot change file owner" fn uid gid) ) ) )
    1298 
    1299   (define-foreign-variable _r_ok int "R_OK")
    1300   (define-foreign-variable _w_ok int "W_OK")
    1301   (define-foreign-variable _x_ok int "X_OK")
    1302 
    1303   (let ()
    1304     (define (check filename acc loc)
    1305       (##sys#check-string filename loc)
    1306       (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
    1307         (unless r (##sys#update-errno))
    1308         r) )
    1309     (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
    1310     (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
    1311     (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )
    1312 
    1313   (define (create-session)
    1314     (let ([a (##core#inline "C_setsid" #f)])
    1315       (when (fx< a 0)
    1316         (##sys#update-errno)
    1317         (##sys#error 'create-session "cannot create session") )
    1318       a) )
    1319 
    1320   (define (set-process-group-id! pid pgid) ; DEPRECATED
    1321     (##sys#check-exact pid 'set-process-group-id!)
    1322     (##sys#check-exact pgid 'set-process-group-id!)
    1323     (when (fx< (##core#inline "C_setpgid" pid pgid) 0)
     1254;;; Permissions and owners:
     1255
     1256(define change-file-mode
     1257  (lambda (fname m)
     1258    (##sys#check-string fname 'change-file-mode)
     1259    (##sys#check-exact m 'change-file-mode)
     1260    (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
     1261      (posix-error #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
     1262
     1263(define change-file-owner
     1264  (lambda (fn uid gid)
     1265    (##sys#check-string fn 'change-file-owner)
     1266    (##sys#check-exact uid 'change-file-owner)
     1267    (##sys#check-exact gid 'change-file-owner)
     1268    (when (fx< (##core#inline "C_chown" (##sys#make-c-string (##sys#expand-home-path fn)) uid gid) 0)
     1269      (posix-error #:file-error 'change-file-owner "cannot change file owner" fn uid gid) ) ) )
     1270
     1271(define-foreign-variable _r_ok int "R_OK")
     1272(define-foreign-variable _w_ok int "W_OK")
     1273(define-foreign-variable _x_ok int "X_OK")
     1274
     1275(let ()
     1276  (define (check filename acc loc)
     1277    (##sys#check-string filename loc)
     1278    (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
     1279      (unless r (##sys#update-errno))
     1280      r) )
     1281  (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
     1282  (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
     1283  (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )
     1284
     1285(define (create-session)
     1286  (let ([a (##core#inline "C_setsid" #f)])
     1287    (when (fx< a 0)
    13241288      (##sys#update-errno)
    1325       (##sys#error 'set-process-group-id! "cannot set process group ID" pid pgid) ) )
    1326 
    1327   (define process-group-id
    1328     (getter-with-setter
    1329      (lambda (pid)
    1330        (##sys#check-exact pid 'process-group-id)
    1331        (let ([a (##core#inline "C_getpgid" pid)])
    1332          (when (fx< a 0)
    1333            (##sys#update-errno)
    1334            (##sys#error 'process-group-id "cannot retrieve process group ID" pid) )
    1335       a) )
    1336      set-process-group-id!) )
    1337 
    1338   ;;; Hard and symbolic links:
    1339 
    1340   (define create-symbolic-link
     1289      (##sys#error 'create-session "cannot create session") )
     1290    a) )
     1291
     1292(define (set-process-group-id! pid pgid) ; DEPRECATED
     1293  (##sys#check-exact pid 'set-process-group-id!)
     1294  (##sys#check-exact pgid 'set-process-group-id!)
     1295  (when (fx< (##core#inline "C_setpgid" pid pgid) 0)
     1296    (##sys#update-errno)
     1297    (##sys#error 'set-process-group-id! "cannot set process group ID" pid pgid) ) )
     1298
     1299(define process-group-id
     1300  (getter-with-setter
     1301   (lambda (pid)
     1302     (##sys#check-exact pid 'process-group-id)
     1303     (let ([a (##core#inline "C_getpgid" pid)])
     1304       (when (fx< a 0)
     1305         (##sys#update-errno)
     1306         (##sys#error 'process-group-id "cannot retrieve process group ID" pid) )
     1307    a) )
     1308   set-process-group-id!) )
     1309
     1310;;; Hard and symbolic links:
     1311
     1312(define create-symbolic-link
     1313  (lambda (old new)
     1314    (##sys#check-string old 'create-symbolic-link)
     1315    (##sys#check-string new 'create-symbolic-link)
     1316    (when (fx< (##core#inline
     1317              "C_symlink"
     1318              (##sys#make-c-string (##sys#expand-home-path old))
     1319              (##sys#make-c-string (##sys#expand-home-path new)) )
     1320             0)
     1321      (posix-error #:file-error 'create-symbol-link "cannot create symbolic link" old new) ) ) )
     1322
     1323(define-foreign-variable _filename_max int "FILENAME_MAX")
     1324
     1325(define read-symbolic-link
     1326  (let ([substring substring]
     1327      [buf (make-string (fx+ _filename_max 1))] )
     1328    (lambda (fname)
     1329      (##sys#check-string fname 'read-symbolic-link)
     1330      (let ([len (##core#inline "C_readlink" (##sys#make-c-string (##sys#expand-home-path fname)) buf)])
     1331      (when (fx< len 0)
     1332        (posix-error #:file-error 'read-symbolic-link "cannot read symbolic link" fname) )
     1333      (substring buf 0 len) ) ) ) )
     1334
     1335(define file-link
     1336  (let ([link (foreign-lambda int "link" c-string c-string)])
    13411337    (lambda (old new)
    1342       (##sys#check-string old 'create-symbolic-link)
    1343       (##sys#check-string new 'create-symbolic-link)
    1344       (when (fx< (##core#inline
    1345                 "C_symlink"
    1346                 (##sys#make-c-string (##sys#expand-home-path old))
    1347                 (##sys#make-c-string (##sys#expand-home-path new)) )
    1348                0)
    1349         (posix-error #:file-error 'create-symbol-link "cannot create symbolic link" old new) ) ) )
    1350 
    1351   (define-foreign-variable _filename_max int "FILENAME_MAX")
    1352 
    1353   (define read-symbolic-link
    1354     (let ([substring substring]
    1355         [buf (make-string (fx+ _filename_max 1))] )
    1356       (lambda (fname)
    1357         (##sys#check-string fname 'read-symbolic-link)
    1358         (let ([len (##core#inline "C_readlink" (##sys#make-c-string (##sys#expand-home-path fname)) buf)])
    1359         (when (fx< len 0)
    1360           (posix-error #:file-error 'read-symbolic-link "cannot read symbolic link" fname) )
    1361         (substring buf 0 len) ) ) ) )
    1362 
    1363   (define file-link
    1364     (let ([link (foreign-lambda int "link" c-string c-string)])
    1365       (lambda (old new)
    1366         (##sys#check-string old 'file-link)
    1367         (##sys#check-string new 'file-link)
    1368         (when (fx< (link old new) 0)
    1369         (posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) ) ] )
     1338      (##sys#check-string old 'file-link)
     1339      (##sys#check-string new 'file-link)
     1340      (when (fx< (link old new) 0)
     1341      (posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) )
    13701342
    13711343
     
    16001572;;; Other file operations:
    16011573
    1602 (cond-expand
    1603  [ecos]
    1604  [else
    1605   (define file-truncate
    1606     (lambda (fname off)
    1607       (##sys#check-number off 'file-truncate)
    1608       (when (fx< (cond [(string? fname) (##core#inline "C_truncate" (##sys#make-c-string (##sys#expand-home-path fname)) off)]
    1609                        [(fixnum? fname) (##core#inline "C_ftruncate" fname off)]
    1610                        [else (##sys#error 'file-truncate "invalid file" fname)] )
    1611                  0)
    1612             (posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) ) ] )
     1574(define file-truncate
     1575  (lambda (fname off)
     1576    (##sys#check-number off 'file-truncate)
     1577    (when (fx< (cond [(string? fname) (##core#inline "C_truncate" (##sys#make-c-string (##sys#expand-home-path fname)) off)]
     1578                     [(fixnum? fname) (##core#inline "C_ftruncate" fname off)]
     1579                     [else (##sys#error 'file-truncate "invalid file" fname)] )
     1580               0)
     1581      (posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) )
    16131582
    16141583
     
    16581627
    16591628
    1660 (cond-expand
    1661  [ecos]
    1662  [else
    1663 
    16641629;;; FIFOs:
    16651630
    1666   (define create-fifo
    1667     (lambda (fname . mode)
    1668       (##sys#check-string fname 'create-fifo)
    1669       (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])
    1670         (##sys#check-exact mode 'create-fifo)
    1671         (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string (##sys#expand-home-path fname)) mode) 0)
    1672         (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )
    1673 
    1674   (define fifo?
    1675     (lambda (filename)
    1676       (##sys#check-string filename 'fifo?)
    1677       (let ([v (##sys#file-info (##sys#expand-home-path filename))])
    1678         (if v
    1679             (fx= 3 (##sys#slot v 4))
    1680             (posix-error #:file-error 'fifo? "file does not exist" filename) ) ) ) )
     1631(define create-fifo
     1632  (lambda (fname . mode)
     1633    (##sys#check-string fname 'create-fifo)
     1634    (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])
     1635      (##sys#check-exact mode 'create-fifo)
     1636      (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string (##sys#expand-home-path fname)) mode) 0)
     1637      (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )
     1638
     1639(define fifo?
     1640  (lambda (filename)
     1641    (##sys#check-string filename 'fifo?)
     1642    (let ([v (##sys#file-info (##sys#expand-home-path filename))])
     1643      (if v
     1644          (fx= 3 (##sys#slot v 4))
     1645          (posix-error #:file-error 'fifo? "file does not exist" filename) ) ) ) )
    16811646
    16821647;;; Environment access:
    16831648
    1684   (define setenv
    1685     (lambda (var val)
    1686       (##sys#check-string var 'setenv)
    1687       (##sys#check-string val 'setenv)
    1688       (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
    1689       (##core#undefined) ) )
    1690 
    1691   (define (unsetenv var)
    1692     (##sys#check-string var 'unsetenv)
    1693     (##core#inline "C_putenv" (##sys#make-c-string var))
    1694     (##core#undefined) )
    1695 
    1696   (define current-environment
    1697     (let ([get (foreign-lambda c-string "C_getenventry" int)])
    1698       (lambda ()
    1699         (let loop ([i 0])
    1700           (let ([entry (get i)])
    1701             (if entry
    1702                 (let scan ([j 0])
    1703                   (if (char=? #\= (##core#inline "C_subchar" entry j))
    1704                       (cons (cons (##sys#substring entry 0 j)
    1705                                   (##sys#substring entry (fx+ j 1) (##sys#size entry)))
    1706                             (loop (fx+ i 1)))
    1707                       (scan (fx+ j 1)) ) )
    1708                 '() ) ) ) ) ) ) ] )
     1649(define setenv
     1650  (lambda (var val)
     1651    (##sys#check-string var 'setenv)
     1652    (##sys#check-string val 'setenv)
     1653    (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
     1654    (##core#undefined) ) )
     1655
     1656(define (unsetenv var)
     1657  (##sys#check-string var 'unsetenv)
     1658  (##core#inline "C_putenv" (##sys#make-c-string var))
     1659  (##core#undefined) )
     1660
     1661(define current-environment
     1662  (let ([get (foreign-lambda c-string "C_getenventry" int)])
     1663    (lambda ()
     1664      (let loop ([i 0])
     1665        (let ([entry (get i)])
     1666          (if entry
     1667              (let scan ([j 0])
     1668                (if (char=? #\= (##core#inline "C_subchar" entry j))
     1669                    (cons (cons (##sys#substring entry 0 j)
     1670                                (##sys#substring entry (fx+ j 1) (##sys#size entry)))
     1671                          (loop (fx+ i 1)))
     1672                    (scan (fx+ j 1)) ) )
     1673              '() ) ) ) ) ) )
    17091674
    17101675;;; Memory mapped I/O:
    1711 (cond-expand
    1712  [ecos]
    1713  [else
    1714 
    1715   (define-foreign-variable _prot_read int "PROT_READ")
    1716   (define-foreign-variable _prot_write int "PROT_WRITE")
    1717   (define-foreign-variable _prot_exec int "PROT_EXEC")
    1718   (define-foreign-variable _prot_none int "PROT_NONE")
    1719 
    1720   (define prot/read _prot_read)
    1721   (define prot/write _prot_write)
    1722   (define prot/exec _prot_exec)
    1723   (define prot/none _prot_none)
    1724 
    1725   (define-foreign-variable _map_fixed int "MAP_FIXED")
    1726   (define-foreign-variable _map_shared int "MAP_SHARED")
    1727   (define-foreign-variable _map_private int "MAP_PRIVATE")
    1728   (define-foreign-variable _map_anonymous int "MAP_ANON")
    1729   (define-foreign-variable _map_file int "MAP_FILE")
    1730 
    1731   (define map/fixed _map_fixed)
    1732   (define map/shared _map_shared)
    1733   (define map/private _map_private)
    1734   (define map/anonymous _map_anonymous)
    1735   (define map/file _map_file)
    1736 
    1737   (define map-file-to-memory
    1738     (let ([mmap (foreign-lambda c-pointer "mmap" c-pointer integer int int int integer)] )
    1739       (lambda (addr len prot flag fd . off)
    1740         (let ([addr (if (not addr) (##sys#null-pointer) addr)]
    1741               [off (if (pair? off) (car off) 0)] )
    1742           (unless (and (##core#inline "C_blockp" addr) (##core#inline "C_specialp" addr))
    1743                   (##sys#signal-hook #:type-error 'map-file-to-memory "bad argument type - not a foreign pointer" addr) )
    1744           (let ([addr2 (mmap addr len prot flag fd off)])
    1745             (when (eq? -1 (##sys#pointer->address addr2))
    1746                   (posix-error #:file-error 'map-file-to-memory "cannot map file to memory" addr len prot flag fd off) )
    1747             (##sys#make-structure 'mmap addr2 len) ) ) ) ) )
    1748 
    1749   (define unmap-file-from-memory
    1750     (let ([munmap (foreign-lambda int "munmap" c-pointer integer)] )
    1751       (lambda (mmap . len)
    1752         (##sys#check-structure mmap 'mmap 'unmap-file-from-memory)
    1753         (let ([len (if (pair? len) (car len) (##sys#slot mmap 2))])
    1754           (unless (eq? 0 (munmap (##sys#slot mmap 1) len))
    1755                   (posix-error #:file-error 'unmap-file-from-memory "cannot unmap file from memory" mmap len) ) ) ) ) )
    1756 
    1757   (define (memory-mapped-file-pointer mmap)
    1758     (##sys#check-structure mmap 'mmap 'memory-mapped-file-pointer)
    1759     (##sys#slot mmap 1) )
    1760 
    1761   (define (memory-mapped-file? x)
    1762     (##sys#structure? x 'mmap) )])
     1676
     1677(define-foreign-variable _prot_read int "PROT_READ")
     1678(define-foreign-variable _prot_write int "PROT_WRITE")
     1679(define-foreign-variable _prot_exec int "PROT_EXEC")
     1680(define-foreign-variable _prot_none int "PROT_NONE")
     1681
     1682(define prot/read _prot_read)
     1683(define prot/write _prot_write)
     1684(define prot/exec _prot_exec)
     1685(define prot/none _prot_none)
     1686
     1687(define-foreign-variable _map_fixed int "MAP_FIXED")
     1688(define-foreign-variable _map_shared int "MAP_SHARED")
     1689(define-foreign-variable _map_private int "MAP_PRIVATE")
     1690(define-foreign-variable _map_anonymous int "MAP_ANON")
     1691(define-foreign-variable _map_file int "MAP_FILE")
     1692
     1693(define map/fixed _map_fixed)
     1694(define map/shared _map_shared)
     1695(define map/private _map_private)
     1696(define map/anonymous _map_anonymous)
     1697(define map/file _map_file)
     1698
     1699(define map-file-to-memory
     1700  (let ([mmap (foreign-lambda c-pointer "mmap" c-pointer integer int int int integer)] )
     1701    (lambda (addr len prot flag fd . off)
     1702      (let ([addr (if (not addr) (##sys#null-pointer) addr)]
     1703            [off (if (pair? off) (car off) 0)] )
     1704        (unless (and (##core#inline "C_blockp" addr) (##core#inline "C_specialp" addr))
     1705                (##sys#signal-hook #:type-error 'map-file-to-memory "bad argument type - not a foreign pointer" addr) )
     1706        (let ([addr2 (mmap addr len prot flag fd off)])
     1707          (when (eq? -1 (##sys#pointer->address addr2))
     1708                (posix-error #:file-error 'map-file-to-memory "cannot map file to memory" addr len prot flag fd off) )
     1709          (##sys#make-structure 'mmap addr2 len) ) ) ) ) )
     1710
     1711(define unmap-file-from-memory
     1712  (let ([munmap (foreign-lambda int "munmap" c-pointer integer)] )
     1713    (lambda (mmap . len)
     1714      (##sys#check-structure mmap 'mmap 'unmap-file-from-memory)
     1715      (let ([len (if (pair? len) (car len) (##sys#slot mmap 2))])
     1716        (unless (eq? 0 (munmap (##sys#slot mmap 1) len))
     1717                (posix-error #:file-error 'unmap-file-from-memory "cannot unmap file from memory" mmap len) ) ) ) ) )
     1718
     1719(define (memory-mapped-file-pointer mmap)
     1720  (##sys#check-structure mmap 'mmap 'memory-mapped-file-pointer)
     1721  (##sys#slot mmap 1) )
     1722
     1723(define (memory-mapped-file? x)
     1724  (##sys#structure? x 'mmap) )
    17631725
    17641726;;; Time related things:
     
    18441806          (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
    18451807
    1846 (cond-expand
    1847  [ecos]
    1848  [else
    1849   (define (terminal-port? port)
    1850     (##sys#check-port port 'terminal-port?)
    1851     (let ([fp (##sys#peek-unsigned-integer port 0)])
    1852       (and (not (eq? fp 0)) (##core#inline "C_tty_portp" port) ) ) )
    1853 
    1854   (define terminal-name
    1855     (let ([ttyname (foreign-lambda nonnull-c-string "ttyname" int)] )
    1856       (lambda (port)
    1857         (##sys#check-port port 'terminal-name)
    1858         (unless (and (eq? 'stream (##sys#slot port 7))
    1859                      (##core#inline "C_tty_portp" port) )
    1860         (##sys#error 'terminal-name "port is not connected to a terminal" port) )
    1861         (ttyname (##core#inline "C_C_fileno" port) ) ) ) )
    1862 
    1863   (define get-host-name
    1864     (let ([getit
    1865          (foreign-lambda* c-string ()
    1866            "if(gethostname(C_hostbuf, 256) == -1) return(NULL);"
    1867            "else return(C_hostbuf);") ] )
    1868       (lambda ()
    1869         (let ([host (getit)])
    1870           (unless host
    1871             (posix-error #:error 'get-host-name "cannot retrieve host-name") )
    1872           host) ) ) ) ] )
     1808(define (terminal-port? port)
     1809  (##sys#check-port port 'terminal-port?)
     1810  (let ([fp (##sys#peek-unsigned-integer port 0)])
     1811    (and (not (eq? fp 0)) (##core#inline "C_tty_portp" port) ) ) )
     1812
     1813(define (##sys#terminal-check caller port)
     1814  (##sys#check-port port caller)
     1815  (unless (and (eq? 'stream (##sys#slot port 7))
     1816               (##core#inline "C_tty_portp" port))
     1817          (##sys#error caller "port is not connected to a terminal" port)))
     1818
     1819(define terminal-name
     1820  (let ([ttyname (foreign-lambda nonnull-c-string "ttyname" int)] )
     1821    (lambda (port)
     1822      (##sys#terminal-check 'terminal-name port)
     1823      (ttyname (##core#inline "C_C_fileno" port) ) ) ) )
     1824
     1825(define terminal-size
     1826  (let ((ttysize (foreign-lambda int "get_tty_size" int
     1827                                 (nonnull-c-pointer int)
     1828                                 (nonnull-c-pointer int))))
     1829    (lambda (port)
     1830      (##sys#terminal-check 'terminal-size port)
     1831      (let-location ((columns int)
     1832                     (rows int))
     1833                    (if (fx= 0
     1834                             (ttysize (##core#inline "C_C_fileno" port)
     1835                                      (location columns)
     1836                                      (location rows)))
     1837                        (values columns rows)
     1838                        (posix-error #:error 'terminal-size
     1839                                     "Unable to get size of terminal" port))))))
     1840 
     1841(define get-host-name
     1842  (let ([getit
     1843       (foreign-lambda* c-string ()
     1844         "if(gethostname(C_hostbuf, 256) == -1) return(NULL);"
     1845         "else return(C_hostbuf);") ] )
     1846    (lambda ()
     1847      (let ([host (getit)])
     1848        (unless host
     1849          (posix-error #:error 'get-host-name "cannot retrieve host-name") )
     1850        host) ) ) )
    18731851
    18741852
     
    19011879;;; Process handling:
    19021880
    1903 (cond-expand [ecos]
    1904              [else
    1905   (define process-fork
    1906     (let ([fork (foreign-lambda int "C_fork")])
    1907       (lambda thunk
    1908         (let ([pid (fork)])
    1909         (cond [(fx= -1 pid) (posix-error #:process-error 'process-fork "cannot create child process")]
    1910               [(and (pair? thunk) (fx= pid 0))
    1911                ((car thunk))
    1912                ((foreign-lambda void "_exit" int) 0) ]
    1913               [else pid] ) ) ) ) )
    1914 
    1915   (define process-execute
    1916     (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
    1917           [freeargs (foreign-lambda void "C_free_exec_args")]
    1918           [setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
    1919           [freeenv (foreign-lambda void "C_free_exec_env")]
    1920           [pathname-strip-directory pathname-strip-directory] )
    1921       (lambda (filename #!optional (arglist '()) envlist)
    1922         (##sys#check-string filename 'process-execute)
    1923         (##sys#check-list arglist 'process-execute)
    1924         (let ([s (pathname-strip-directory filename)])
    1925           (setarg 0 s (##sys#size s)) )
    1926         (do ([al arglist (cdr al)]
    1927              [i 1 (fx+ i 1)] )
    1928             ((null? al)
    1929              (setarg i #f 0)
    1930              (when envlist
    1931                (##sys#check-list envlist 'process-execute)
    1932                (do ([el envlist (cdr el)]
    1933                     [i 0 (fx+ i 1)] )
    1934                    ((null? el) (setenv i #f 0))
    1935                  (let ([s (car el)])
    1936                    (##sys#check-string s 'process-execute)
    1937                    (setenv i s (##sys#size s)) ) ) )
    1938              (let* ([prg (##sys#make-c-string (##sys#expand-home-path filename))]
    1939                     [r (if envlist
    1940                            (##core#inline "C_execve" prg)
    1941                            (##core#inline "C_execvp" prg) )] )
    1942                (when (fx= r -1)
    1943                  (freeargs)
    1944                  (freeenv)
    1945                  (posix-error #:process-error 'process-execute "cannot execute process" filename) ) ) )
    1946           (let ([s (car al)])
    1947             (##sys#check-string s 'process-execute)
    1948             (setarg i s (##sys#size s)) ) ) ) ) )
    1949 
    1950   (define-foreign-variable _wnohang int "WNOHANG")
    1951   (define-foreign-variable _wait-status int "C_wait_status")
    1952 
    1953   (define (##sys#process-wait pid nohang)
    1954     (let* ([res (##core#inline "C_waitpid" pid (if nohang _wnohang 0))]
    1955            [norm (##core#inline "C_WIFEXITED" _wait-status)] )
    1956       (values
    1957         res
    1958         norm
    1959         (cond [norm (##core#inline "C_WEXITSTATUS" _wait-status)]
    1960               [(##core#inline "C_WIFSIGNALED" _wait-status)
    1961                 (##core#inline "C_WTERMSIG" _wait-status)]
    1962               [else (##core#inline "C_WSTOPSIG" _wait-status)] ) ) ) )
    1963 
    1964   (define process-wait
    1965     (lambda args
    1966       (let-optionals* args ([pid #f] [nohang #f])
    1967         (let ([pid (or pid -1)])
    1968           (##sys#check-exact pid 'process-wait)
    1969           (receive [epid enorm ecode] (##sys#process-wait pid nohang)
    1970             (if (fx= epid -1)
    1971                 (posix-error #:process-error 'process-wait "waiting for child process failed" pid)
    1972                 (values epid enorm ecode) ) ) ) ) ) )
    1973 
    1974   (define current-process-id (foreign-lambda int "C_getpid"))
    1975   (define parent-process-id (foreign-lambda int "C_getppid"))
    1976 
    1977   (define sleep (foreign-lambda int "C_sleep" int))
    1978 
    1979   (define process-signal
    1980     (lambda (id . sig)
    1981       (let ([sig (if (pair? sig) (car sig) _sigterm)])
    1982         (##sys#check-exact id 'process-signal)
    1983         (##sys#check-exact sig 'process-signal)
    1984         (let ([r (##core#inline "C_kill" id sig)])
    1985         (when (fx= r -1) (posix-error #:process-error 'process-signal "could not send signal to process" id sig) ) ) ) ) )
    1986 
    1987   (define (##sys#shell-command)
    1988     (or (getenv "SHELL") "/bin/sh") )
    1989 
    1990   (define (##sys#shell-command-arguments cmdlin)
    1991     (list "-c" cmdlin) )
    1992 
    1993   (define process-run
    1994     (let ([process-fork process-fork]
    1995           [process-execute process-execute]
    1996           [getenv getenv] )
    1997       (lambda (f . args)
    1998         (let ([args (if (pair? args) (car args) #f)]
    1999               [pid (process-fork)] )
    2000           (cond [(not (eq? pid 0)) pid]
    2001                 [args (process-execute f args)]
    2002                 [else
    2003                  (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) ) )
    2004 
    2005   ;;; Run subprocess connected with pipes:
    2006 
    2007   ;; ##sys#process
    2008   ; loc            caller procedure symbol
    2009   ; cmd            pathname or commandline
    2010   ; args           string-list or '()
    2011   ; env            string-list or #f
    2012   ; stdoutf        #f then share, or #t then create
    2013   ; stdinf         #f then share, or #t then create
    2014   ; stderrf        #f then share, or #t then create
    2015   ;
    2016   ; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
    2017   ; where stdin-input-port?, etc. is a port or #f, indicating no port created.
    2018 
    2019   (define-constant DEFAULT-INPUT-BUFFER-SIZE 256)
    2020   (define-constant DEFAULT-OUTPUT-BUFFER-SIZE 0)
    2021 
    2022   ;FIXME process-execute, process-fork don't show parent caller
    2023 
    2024   (define ##sys#process
     1881(define process-fork
     1882  (let ([fork (foreign-lambda int "C_fork")])
     1883    (lambda thunk
     1884      (let ([pid (fork)])
     1885      (cond [(fx= -1 pid) (posix-error #:process-error 'process-fork "cannot create child process")]
     1886            [(and (pair? thunk) (fx= pid 0))
     1887             ((car thunk))
     1888             ((foreign-lambda void "_exit" int) 0) ]
     1889            [else pid] ) ) ) ) )
     1890
     1891(define process-execute
     1892  (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
     1893        [freeargs (foreign-lambda void "C_free_exec_args")]
     1894        [setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
     1895        [freeenv (foreign-lambda void "C_free_exec_env")]
     1896        [pathname-strip-directory pathname-strip-directory] )
     1897    (lambda (filename #!optional (arglist '()) envlist)
     1898      (##sys#check-string filename 'process-execute)
     1899      (##sys#check-list arglist 'process-execute)
     1900      (let ([s (pathname-strip-directory filename)])
     1901        (setarg 0 s (##sys#size s)) )
     1902      (do ([al arglist (cdr al)]
     1903           [i 1 (fx+ i 1)] )
     1904          ((null? al)
     1905           (setarg i #f 0)
     1906           (when envlist
     1907             (##sys#check-list envlist 'process-execute)
     1908             (do ([el envlist (cdr el)]
     1909                  [i 0 (fx+ i 1)] )
     1910                 ((null? el) (setenv i #f 0))
     1911               (let ([s (car el)])
     1912                 (##sys#check-string s 'process-execute)
     1913                 (setenv i s (##sys#size s)) ) ) )
     1914           (let* ([prg (##sys#make-c-string (##sys#expand-home-path filename))]
     1915                  [r (if envlist
     1916                         (##core#inline "C_execve" prg)
     1917                         (##core#inline "C_execvp" prg) )] )
     1918             (when (fx= r -1)
     1919               (freeargs)
     1920               (freeenv)
     1921               (posix-error #:process-error 'process-execute "cannot execute process" filename) ) ) )
     1922        (let ([s (car al)])
     1923          (##sys#check-string s 'process-execute)
     1924          (setarg i s (##sys#size s)) ) ) ) ) )
     1925
     1926(define-foreign-variable _wnohang int "WNOHANG")
     1927(define-foreign-variable _wait-status int "C_wait_status")
     1928
     1929(define (##sys#process-wait pid nohang)
     1930  (let* ([res (##core#inline "C_waitpid" pid (if nohang _wnohang 0))]
     1931         [norm (##core#inline "C_WIFEXITED" _wait-status)] )
     1932    (values
     1933      res
     1934      norm
     1935      (cond [norm (##core#inline "C_WEXITSTATUS" _wait-status)]
     1936            [(##core#inline "C_WIFSIGNALED" _wait-status)
     1937              (##core#inline "C_WTERMSIG" _wait-status)]
     1938            [else (##core#inline "C_WSTOPSIG" _wait-status)] ) ) ) )
     1939
     1940(define process-wait
     1941  (lambda args
     1942    (let-optionals* args ([pid #f] [nohang #f])
     1943      (let ([pid (or pid -1)])
     1944        (##sys#check-exact pid 'process-wait)
     1945        (receive [epid enorm ecode] (##sys#process-wait pid nohang)
     1946          (if (fx= epid -1)
     1947              (posix-error #:process-error 'process-wait "waiting for child process failed" pid)
     1948              (values epid enorm ecode) ) ) ) ) ) )
     1949
     1950(define current-process-id (foreign-lambda int "C_getpid"))
     1951(define parent-process-id (foreign-lambda int "C_getppid"))
     1952
     1953(define sleep (foreign-lambda int "C_sleep" int))
     1954
     1955(define process-signal
     1956  (lambda (id . sig)
     1957    (let ([sig (if (pair? sig) (car sig) _sigterm)])
     1958      (##sys#check-exact id 'process-signal)
     1959      (##sys#check-exact sig 'process-signal)
     1960      (let ([r (##core#inline "C_kill" id sig)])
     1961      (when (fx= r -1) (posix-error #:process-error 'process-signal "could not send signal to process" id sig) ) ) ) ) )
     1962
     1963(define (##sys#shell-command)
     1964  (or (getenv "SHELL") "/bin/sh") )
     1965
     1966(define (##sys#shell-command-arguments cmdlin)
     1967  (list "-c" cmdlin) )
     1968
     1969(define process-run
     1970  (let ([process-fork process-fork]
     1971        [process-execute process-execute]
     1972        [getenv getenv] )
     1973    (lambda (f . args)
     1974      (let ([args (if (pair? args) (car args) #f)]
     1975            [pid (process-fork)] )
     1976        (cond [(not (eq? pid 0)) pid]
     1977              [args (process-execute f args)]
     1978              [else
     1979               (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) ) )
     1980
     1981;;; Run subprocess connected with pipes:
     1982
     1983;; ##sys#process
     1984; loc            caller procedure symbol
     1985; cmd            pathname or commandline
     1986; args           string-list or '()
     1987; env            string-list or #f
     1988; stdoutf        #f then share, or #t then create
     1989; stdinf         #f then share, or #t then create
     1990; stderrf        #f then share, or #t then create
     1991;
     1992; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
     1993; where stdin-input-port?, etc. is a port or #f, indicating no port created.
     1994
     1995(define-constant DEFAULT-INPUT-BUFFER-SIZE 256)
     1996(define-constant DEFAULT-OUTPUT-BUFFER-SIZE 0)
     1997
     1998;FIXME process-execute, process-fork don't show parent caller
     1999
     2000(define ##sys#process
     2001  (let (
     2002      [create-pipe create-pipe]
     2003      [process-wait process-wait]
     2004      [process-fork process-fork]
     2005      [process-execute process-execute]
     2006      [duplicate-fileno duplicate-fileno]
     2007      [file-close file-close]
     2008      [replace-fd
     2009        (lambda (loc fd stdfd)
     2010          (unless (fx= stdfd fd)
     2011            (duplicate-fileno fd stdfd)
     2012            (file-close fd) ) )] )
    20252013    (let (
    2026         [create-pipe create-pipe]
    2027         [process-wait process-wait]
    2028         [process-fork process-fork]
    2029         [process-execute process-execute]
    2030         [duplicate-fileno duplicate-fileno]
    2031         [file-close file-close]
    2032         [replace-fd
    2033           (lambda (loc fd stdfd)
    2034             (unless (fx= stdfd fd)
    2035               (duplicate-fileno fd stdfd)
    2036               (file-close fd) ) )] )
     2014        [make-on-close
     2015          (lambda (loc pid clsvec idx idxa idxb)
     2016            (lambda ()
     2017              (vector-set! clsvec idx #t)
     2018              (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb))
     2019                (receive [_ flg cod] (process-wait pid)
     2020                  (unless flg
     2021                    (##sys#signal-hook #:process-error loc
     2022                      "abnormal process exit" pid cod)) ) ) ) )]
     2023        [needed-pipe
     2024          (lambda (loc port)
     2025            (and port
     2026                 (receive [i o] (create-pipe) (cons i o))) )]
     2027        [connect-parent
     2028          (lambda (loc pipe port fd)
     2029            (and port
     2030                 (let ([usefd (car pipe)] [clsfd (cdr pipe)])
     2031                   (file-close clsfd)
     2032                   usefd) ) )]
     2033        [connect-child
     2034          (lambda (loc pipe port stdfd)
     2035            (when port
     2036              (let ([usefd (car pipe)] [clsfd (cdr pipe)])
     2037                (file-close clsfd)
     2038                (replace-fd loc usefd stdfd)) ) )] )
    20372039      (let (
    2038           [make-on-close
    2039             (lambda (loc pid clsvec idx idxa idxb)
    2040               (lambda ()
    2041                 (vector-set! clsvec idx #t)
    2042                 (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb))
    2043                   (receive [_ flg cod] (process-wait pid)
    2044                     (unless flg
    2045                       (##sys#signal-hook #:process-error loc
    2046                         "abnormal process exit" pid cod)) ) ) ) )]
    2047           [needed-pipe
    2048             (lambda (loc port)
    2049               (and port
    2050                    (receive [i o] (create-pipe) (cons i o))) )]
    2051           [connect-parent
    2052             (lambda (loc pipe port fd)
    2053               (and port
    2054                    (let ([usefd (car pipe)] [clsfd (cdr pipe)])
    2055                      (file-close clsfd)
    2056                      usefd) ) )]
    2057           [connect-child
    2058             (lambda (loc pipe port stdfd)
    2059               (when port
    2060                 (let ([usefd (car pipe)] [clsfd (cdr pipe)])
    2061                   (file-close clsfd)
    2062                   (replace-fd loc usefd stdfd)) ) )] )
    2063         (let (
    2064             [spawn
    2065               (let ([swapped-ends
    2066                       (lambda (pipe)
    2067                         (and pipe
    2068                              (cons (cdr pipe) (car pipe)) ) )])
    2069                 (lambda (loc cmd args env stdoutf stdinf stderrf)
    2070                   (let ([ipipe (needed-pipe loc stdinf)]
    2071                         [opipe (needed-pipe loc stdoutf)]
    2072                         [epipe (needed-pipe loc stderrf)])
    2073                     (values
    2074                       ipipe (swapped-ends opipe) epipe
    2075                       (process-fork
    2076                         (lambda ()
    2077                           (connect-child loc opipe stdinf fileno/stdin)
    2078                           (connect-child loc (swapped-ends ipipe) stdoutf fileno/stdout)
    2079                           (connect-child loc (swapped-ends epipe) stderrf fileno/stderr)
    2080                           (process-execute cmd args env)))) ) ) )]
    2081             [input-port
    2082               (lambda (loc pid cmd pipe stdf stdfd on-close)
    2083                 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
    2084                   (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close) ) )]
    2085             [output-port
    2086               (lambda (loc pid cmd pipe stdf stdfd on-close)
    2087                 (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
    2088                   (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close) ) )] )
    2089           (lambda (loc cmd args env stdoutf stdinf stderrf)
    2090             (receive [inpipe outpipe errpipe pid]
    2091                        (spawn loc cmd args env stdoutf stdinf stderrf)
    2092               ;When shared assume already "closed", since only created ports
    2093               ;should be explicitly closed, and when one is closed we want
    2094               ;to wait.
    2095               (let ([clsvec (vector (not stdinf) (not stdoutf) (not stderrf))])
    2096                 (values
    2097                   (input-port loc pid cmd inpipe stdinf fileno/stdin
    2098                     (make-on-close loc pid clsvec 0 1 2))
    2099                   (output-port loc pid cmd outpipe stdoutf fileno/stdout
    2100                     (make-on-close loc pid clsvec 1 0 2))
    2101                   pid
    2102                   (input-port loc pid cmd errpipe stderrf fileno/stderr
    2103                     (make-on-close loc pid clsvec 2 0 1)) ) ) ) ) ) ) ) )
    2104 
    2105   ;;; Run subprocess connected with pipes:
    2106 
    2107   (define process)
    2108   (define process*)
    2109   (let ([%process
    2110           (lambda (loc err? cmd args env)
    2111             (let ([chkstrlst
    2112                    (lambda (lst)
    2113                      (##sys#check-list lst loc)
    2114                      (for-each (cut ##sys#check-string <> loc) lst) )])
    2115               (##sys#check-string cmd loc)
    2116               (if args
    2117                   (chkstrlst args)
    2118                   (begin
    2119                     (set! args (##sys#shell-command-arguments cmd))
    2120                     (set! cmd (##sys#shell-command)) ) )
    2121               (when env (chkstrlst env))
    2122               (receive [in out pid err] (##sys#process loc cmd args env #t #t err?)
    2123                 (if err?
    2124                     (values in out pid err)
    2125                     (values in out pid) ) ) ) )] )
    2126     (set! process
    2127       (lambda (cmd #!optional args env)
    2128         (%process 'process #f cmd args env) ))
    2129     (set! process*
    2130       (lambda (cmd #!optional args env)
    2131         (%process 'process* #t cmd args env) )) ) ] )
     2040          [spawn
     2041            (let ([swapped-ends
     2042                    (lambda (pipe)
     2043                      (and pipe
     2044                           (cons (cdr pipe) (car pipe)) ) )])
     2045              (lambda (loc cmd args env stdoutf stdinf stderrf)
     2046                (let ([ipipe (needed-pipe loc stdinf)]
     2047                      [opipe (needed-pipe loc stdoutf)]
     2048                      [epipe (needed-pipe loc stderrf)])
     2049                  (values
     2050                    ipipe (swapped-ends opipe) epipe
     2051                    (process-fork
     2052                      (lambda ()
     2053                        (connect-child loc opipe stdinf fileno/stdin)
     2054                        (connect-child loc (swapped-ends ipipe) stdoutf fileno/stdout)
     2055                        (connect-child loc (swapped-ends epipe) stderrf fileno/stderr)
     2056                        (process-execute cmd args env)))) ) ) )]
     2057          [input-port
     2058            (lambda (loc pid cmd pipe stdf stdfd on-close)
     2059              (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
     2060                (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close) ) )]
     2061          [output-port
     2062            (lambda (loc pid cmd pipe stdf stdfd on-close)
     2063              (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
     2064                (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close) ) )] )
     2065        (lambda (loc cmd args env stdoutf stdinf stderrf)
     2066          (receive [inpipe outpipe errpipe pid]
     2067                     (spawn loc cmd args env stdoutf stdinf stderrf)
     2068            ;When shared assume already "closed", since only created ports
     2069            ;should be explicitly closed, and when one is closed we want
     2070            ;to wait.
     2071            (let ([clsvec (vector (not stdinf) (not stdoutf) (not stderrf))])
     2072              (values
     2073                (input-port loc pid cmd inpipe stdinf fileno/stdin
     2074                  (make-on-close loc pid clsvec 0 1 2))
     2075                (output-port loc pid cmd outpipe stdoutf fileno/stdout
     2076                  (make-on-close loc pid clsvec 1 0 2))
     2077                pid
     2078                (input-port loc pid cmd errpipe stderrf fileno/stderr
     2079                  (make-on-close loc pid clsvec 2 0 1)) ) ) ) ) ) ) ) )
     2080
     2081;;; Run subprocess connected with pipes:
     2082
     2083(define process)
     2084(define process*)
     2085(let ([%process
     2086        (lambda (loc err? cmd args env)
     2087          (let ([chkstrlst
     2088                 (lambda (lst)
     2089                   (##sys#check-list lst loc)
     2090                   (for-each (cut ##sys#check-string <> loc) lst) )])
     2091            (##sys#check-string cmd loc)
     2092            (if args
     2093                (chkstrlst args)
     2094                (begin
     2095                  (set! args (##sys#shell-command-arguments cmd))
     2096                  (set! cmd (##sys#shell-command)) ) )
     2097            (when env (chkstrlst env))
     2098            (receive [in out pid err] (##sys#process loc cmd args env #t #t err?)
     2099              (if err?
     2100                  (values in out pid err)
     2101                  (values in out pid) ) ) ) )] )
     2102  (set! process
     2103    (lambda (cmd #!optional args env)
     2104      (%process 'process #f cmd args env) ))
     2105  (set! process*
     2106    (lambda (cmd #!optional args env)
     2107      (%process 'process* #t cmd args env) )) )
    21322108
    21332109;;; Find matching files:
     
    21352111(define find-files
    21362112  (let ([glob glob]
    2137         [string-match string-match]
    2138         [make-pathname make-pathname]
    2139         [directory? directory?] )
     2113        [string-match string-match]
     2114        [make-pathname make-pathname]
     2115        [directory? directory?] )
    21402116    (lambda (dir pred . action-id-limit)
    2141       (let-optionals action-id-limit
    2142           ([action (lambda (x y) (cons x y))] ; we want cons inlined
    2143            [id '()]
    2144            [limit #f] )
    2145         (##sys#check-string dir 'find-files)
    2146         (let* ([depth 0]
    2147                [lproc
    2148                 (cond [(not limit) (lambda _ #t)]
    2149                       [(fixnum? limit) (lambda _ (fx< depth limit))]
    2150                       [else limit] ) ]
    2151                [pproc
    2152                 (if (or (string? pred) (regexp? pred))
    2153                     (lambda (x) (string-match pred x))
    2154                     pred) ] )
    2155           (let loop ([fs (glob (make-pathname dir "*"))]
    2156                      [r id] )
    2157             (if (null? fs)
    2158                 r
    2159                 (let ([f (##sys#slot fs 0)]
    2160                       [rest (##sys#slot fs 1)] )
    2161                   (cond [(directory? f)
    2162                          (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
    2163                                [(lproc f)
    2164                                 (loop rest
    2165                                       (fluid-let ([depth (fx+ depth 1)])
    2166                                         (loop (glob (make-pathname f "*")) r) ) ) ]
    2167                                [else (loop rest r)] ) ]
    2168                         [(pproc f) (loop rest (action f r))]
    2169                         [else (loop rest r)] ) ) ) ) ) ) ) ) )
    2170 
    2171 
    2172 (cond-expand
    2173  [ecos]
    2174  [else
    2175 
    2176   ;;; chroot:
    2177 
    2178   (define set-root-directory!
    2179     (let ([chroot (foreign-lambda int "chroot" c-string)])
    2180       (lambda (dir)
    2181         (##sys#check-string dir 'set-root-directory!)
    2182         (when (fx< (chroot dir) 0)
    2183         (posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) ) ] )
     2117      (let-optionals
     2118          action-id-limit
     2119          ([action (lambda (x y) (cons x y))] ; we want cons inlined
     2120           [id '()]
     2121           [limit #f] )
     2122        (##sys#check-string dir 'find-files)
     2123        (let* ([depth 0]
     2124               [lproc
     2125                (cond [(not limit) (lambda _ #t)]
     2126                      [(fixnum? limit) (lambda _ (fx< depth limit))]
     2127                      [else limit] ) ]
     2128               [pproc
     2129                (if (or (string? pred) (regexp? pred))
     2130                    (lambda (x) (string-match pred x))
     2131                    pred) ] )
     2132          (let loop ([fs (glob (make-pathname dir "*"))]
     2133                     [r id] )
     2134            (if (null? fs)
     2135                r
     2136                (let ([f (##sys#slot fs 0)]
     2137                      [rest (##sys#slot fs 1)] )
     2138                  (cond [(directory? f)
     2139                         (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
     2140                               [(lproc f)
     2141                                (loop rest
     2142                                      (fluid-let ([depth (fx+ depth 1)])
     2143                                        (loop (glob (make-pathname f "*"))
     2144                                              (if (pproc f) (action f r) r)) ) ) ]
     2145                               [else (loop rest (if (pproc f) (action f r) r))] ) ]
     2146                        [(pproc f) (loop rest (action f r))]
     2147                        [else (loop rest r)] ) ) ) ) ) ) ) ) )
     2148
     2149
     2150;;; chroot:
     2151
     2152(define set-root-directory!
     2153  (let ([chroot (foreign-lambda int "chroot" c-string)])
     2154    (lambda (dir)
     2155      (##sys#check-string dir 'set-root-directory!)
     2156      (when (fx< (chroot dir) 0)
     2157        (posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )
Note: See TracChangeset for help on using the changeset viewer.