Index: library.scm =================================================================== --- library.scm (revision 15090) +++ library.scm (working copy) @@ -1663,7 +1663,38 @@ (##sys#check-structure k 'continuation 'continuation-return) (continuation-graft k (lambda () (apply values vals))) ) ) ) +;;; Parameters: +(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size)) +(define ##sys#current-parameter-vector '#()) + +(define make-parameter + (let ([count 0]) + (lambda (init . guard) + (let* ([guard (if (pair? guard) (car guard) (lambda (x) x))] + [val (guard init)] + [i count] ) + (set! count (fx+ count 1)) + (when (fx>= i (##sys#size ##sys#default-parameter-vector)) + (set! ##sys#default-parameter-vector + (##sys#grow-vector ##sys#default-parameter-vector (fx+ i 1) (##core#undefined)) ) ) + (##sys#setslot ##sys#default-parameter-vector i val) + (lambda arg + (let ([n (##sys#size ##sys#current-parameter-vector)]) + (cond [(pair? arg) + (when (fx>= i n) + (set! ##sys#current-parameter-vector + (##sys#grow-vector ##sys#current-parameter-vector (fx+ i 1) ##sys#snafu) ) ) + (##sys#setslot ##sys#current-parameter-vector i (guard (##sys#slot arg 0))) + (##core#undefined) ] + [(fx>= i n) + (##sys#slot ##sys#default-parameter-vector i) ] + [else + (let ([val (##sys#slot ##sys#current-parameter-vector i)]) + (if (eq? val ##sys#snafu) + (##sys#slot ##sys#default-parameter-vector i) + val) ) ] ) ) ) ) ) ) ) + ;;; Ports: (define (port? x) (##core#inline "C_i_portp" x)) @@ -1844,30 +1875,45 @@ (define (##sys#pathname-resolution name thunk . _) (thunk (##sys#expand-home-path name)) ) -(define ##sys#expand-home-path +(define ##sys#tilde-expander + ;; expects single path component without the tilde; + ;; in other words, a username or an empty string (let ((getenv getenv)) - (lambda (path) - (let ((len (##sys#size path))) - (if (fx> len 0) - (case (##core#inline "C_subchar" path 0) - ((#\~) - (let ((rest (##sys#substring path 1 len))) - (if (and (fx> len 1) (char=? #\/ (##core#inline "C_subchar" path 1))) - (##sys#string-append (or (getenv "HOME") "") rest) - (##sys#string-append "/home/" rest) ) ) ) - ((#\$) - (let loop ((i 1)) - (if (fx>= i len) - path - (let ((c (##core#inline "C_subchar" path i))) - (if (or (eq? c #\/) (eq? c #\\)) - (##sys#string-append - (or (getenv (##sys#substring path 1 i)) "") - (##sys#substring path i len)) - (loop (fx+ i 1)) ) ) ) ) ) - (else path) ) - "") ) ) ) ) + (make-parameter + (lambda (str) + (if (fx= (##sys#size str) 0) + (or (getenv "HOME") "~") + (##sys#string-append "/home/" str)))))) +(define ##sys#expand-home-path + (lambda (path) + (let ((len (##sys#size path))) + (if (fx> len 0) + (case (##core#inline "C_subchar" path 0) + ((#\~) + (let loop ((sep 1)) + (cond ((fx> sep len) + ((##sys#tilde-expander) + (##sys#substring path 1 len))) + ((char=? #\/ (##core#inline "C_subchar" path sep)) + (##sys#string-append + ((##sys#tilde-expander) + (##sys#substring path 1 sep)) + (##sys#substring path sep len))) + (else (loop (fx+ sep 1)))))) + ((#\$) + (let loop ((i 1)) + (if (fx>= i len) + path + (let ((c (##core#inline "C_subchar" path i))) + (if (or (eq? c #\/) (eq? c #\\)) + (##sys#string-append + (or (getenv (##sys#substring path 1 i)) "") + (##sys#substring path i len)) + (loop (fx+ i 1)) ) ) ) ) ) + (else path) ) + "") ) ) ) + (define open-input-file) (define open-output-file) (define close-input-port) @@ -2034,40 +2080,6 @@ (##sys#string-append "cannot rename file - " strerror) old new) ) ) ) ) #:rename new) ) - -;;; Parameters: - -(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size)) -(define ##sys#current-parameter-vector '#()) - -(define make-parameter - (let ([count 0]) - (lambda (init . guard) - (let* ([guard (if (pair? guard) (car guard) (lambda (x) x))] - [val (guard init)] - [i count] ) - (set! count (fx+ count 1)) - (when (fx>= i (##sys#size ##sys#default-parameter-vector)) - (set! ##sys#default-parameter-vector - (##sys#grow-vector ##sys#default-parameter-vector (fx+ i 1) (##core#undefined)) ) ) - (##sys#setslot ##sys#default-parameter-vector i val) - (lambda arg - (let ([n (##sys#size ##sys#current-parameter-vector)]) - (cond [(pair? arg) - (when (fx>= i n) - (set! ##sys#current-parameter-vector - (##sys#grow-vector ##sys#current-parameter-vector (fx+ i 1) ##sys#snafu) ) ) - (##sys#setslot ##sys#current-parameter-vector i (guard (##sys#slot arg 0))) - (##core#undefined) ] - [(fx>= i n) - (##sys#slot ##sys#default-parameter-vector i) ] - [else - (let ([val (##sys#slot ##sys#current-parameter-vector i)]) - (if (eq? val ##sys#snafu) - (##sys#slot ##sys#default-parameter-vector i) - val) ) ] ) ) ) ) ) ) ) - - ;;; Input: (define (eof-object? x) (##core#inline "C_eofp" x)) Index: posixunix.scm =================================================================== --- posixunix.scm (revision 15090) +++ posixunix.scm (working copy) @@ -527,7 +527,19 @@ "if(select(fd + 1, &in, NULL, NULL, &tm) == -1) return(-1);" "else return(FD_ISSET(fd, &in) ? 1 : 0);" ) ) +;; Global parameter modifications: +(##sys#tilde-expander ; override library.scm tilde expansion + (lambda (str) + (if (fx= (##sys#size str) 0) + (or (getenv "HOME") + (let ((info (user-information (current-user-id)))) + (and info (list-ref info 5))) + "~") + (let ((info (user-information str))) + (or (and info (list-ref info 5)) + (##sys#string-append "~" str)))))) + ;;; Lo-level I/O: (define-foreign-variable _pipe_buf int "PIPE_BUF")