~ chicken-core (chicken-5) 7a22bcfe35edd6d841ba9eed7594cc5818f7084e
commit 7a22bcfe35edd6d841ba9eed7594cc5818f7084e
Author: felix <felix@y.(none)>
AuthorDate: Tue Aug 24 00:52:45 2010 +0200
Commit: felix <felix@y.(none)>
CommitDate: Tue Aug 24 00:52:45 2010 +0200
removed more shadowing bindings and did some cleanups
diff --git a/data-structures.scm b/data-structures.scm
index acdf47b8..3b54967f 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -180,20 +180,19 @@ EOF
(cons head (loop tail rest)) ) ) ] ) ) )
(define chop
- (let ([reverse reverse])
- (lambda (lst n)
- (##sys#check-exact n 'chop)
- (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))
- (let ([len (length lst)])
- (let loop ([lst lst] [i len])
- (cond [(null? lst) '()]
- [(fx< i n) (list lst)]
- [else
- (do ([hd '() (cons (##sys#slot tl 0) hd)]
- [tl lst (##sys#slot tl 1)]
- [c n (fx- c 1)] )
- ((fx= c 0)
- (cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) ) )
+ (lambda (lst n)
+ (##sys#check-exact n 'chop)
+ (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))
+ (let ([len (length lst)])
+ (let loop ([lst lst] [i len])
+ (cond [(null? lst) '()]
+ [(fx< i n) (list lst)]
+ [else
+ (do ([hd '() (cons (##sys#slot tl 0) hd)]
+ [tl lst (##sys#slot tl 1)]
+ [c n (fx- c 1)] )
+ ((fx= c 0)
+ (cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) )
(define (join lsts . lst)
(let ([lst (if (pair? lst) (car lst) '())])
@@ -304,22 +303,19 @@ EOF
;;; Anything->string conversion:
(define ->string
- (let ([display display]
- [string string])
- (lambda (x)
- (cond [(string? x) x]
- [(symbol? x) (symbol->string x)]
- [(char? x) (string x)]
- [(number? x) (##sys#number->string x)]
- [else
- (let ([o (open-output-string)])
- (display x o)
- (get-output-string o) ) ] ) ) ) )
+ (lambda (x)
+ (cond [(string? x) x]
+ [(symbol? x) (symbol->string x)]
+ [(char? x) (string x)]
+ [(number? x) (##sys#number->string x)]
+ [else
+ (let ([o (open-output-string)])
+ (display x o)
+ (get-output-string o) ) ] ) ) )
(define conc
- (let ([string-append string-append])
- (lambda args
- (apply string-append (map ->string args)) ) ) )
+ (lambda args
+ (apply string-append (map ->string args)) ) )
;;; Search one string inside another:
@@ -478,55 +474,53 @@ EOF
;;; Translate elements of a string:
(define string-translate
- (let ([make-string make-string]
- [list->string list->string] )
- (lambda (str from . to)
-
- (define (instring s)
- (let ([len (##sys#size s)])
- (lambda (c)
- (let loop ([i 0])
- (cond [(fx>= i len) #f]
- [(eq? c (##core#inline "C_subchar" s i)) i]
- [else (loop (fx+ i 1))] ) ) ) ) )
-
- (let* ([from
- (cond [(char? from) (lambda (c) (eq? c from))]
- [(pair? from) (instring (list->string from))]
- [else
- (##sys#check-string from 'string-translate)
- (instring from) ] ) ]
- [to
- (and (pair? to)
- (let ([tx (##sys#slot to 0)])
- (cond [(char? tx) tx]
- [(pair? tx) (list->string tx)]
- [else
- (##sys#check-string tx 'string-translate)
- tx] ) ) ) ]
- [tlen (and (string? to) (##sys#size to))] )
- (##sys#check-string str 'string-translate)
- (let* ([slen (##sys#size str)]
- [str2 (make-string slen)] )
- (let loop ([i 0] [j 0])
- (if (fx>= i slen)
- (if (fx< j i)
- (##sys#substring str2 0 j)
- str2)
- (let* ([ci (##core#inline "C_subchar" str i)]
- [found (from ci)] )
- (cond [(not found)
- (##core#inline "C_setsubchar" str2 j ci)
- (loop (fx+ i 1) (fx+ j 1)) ]
- [(not to) (loop (fx+ i 1) j)]
- [(char? to)
- (##core#inline "C_setsubchar" str2 j to)
- (loop (fx+ i 1) (fx+ j 1)) ]
- [(fx>= found tlen)
- (##sys#error 'string-translate "invalid translation destination" i to) ]
- [else
- (##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
- (loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) ) )
+ (lambda (str from . to)
+
+ (define (instring s)
+ (let ([len (##sys#size s)])
+ (lambda (c)
+ (let loop ([i 0])
+ (cond [(fx>= i len) #f]
+ [(eq? c (##core#inline "C_subchar" s i)) i]
+ [else (loop (fx+ i 1))] ) ) ) ) )
+
+ (let* ([from
+ (cond [(char? from) (lambda (c) (eq? c from))]
+ [(pair? from) (instring (list->string from))]
+ [else
+ (##sys#check-string from 'string-translate)
+ (instring from) ] ) ]
+ [to
+ (and (pair? to)
+ (let ([tx (##sys#slot to 0)])
+ (cond [(char? tx) tx]
+ [(pair? tx) (list->string tx)]
+ [else
+ (##sys#check-string tx 'string-translate)
+ tx] ) ) ) ]
+ [tlen (and (string? to) (##sys#size to))] )
+ (##sys#check-string str 'string-translate)
+ (let* ([slen (##sys#size str)]
+ [str2 (make-string slen)] )
+ (let loop ([i 0] [j 0])
+ (if (fx>= i slen)
+ (if (fx< j i)
+ (##sys#substring str2 0 j)
+ str2)
+ (let* ([ci (##core#inline "C_subchar" str i)]
+ [found (from ci)] )
+ (cond [(not found)
+ (##core#inline "C_setsubchar" str2 j ci)
+ (loop (fx+ i 1) (fx+ j 1)) ]
+ [(not to) (loop (fx+ i 1) j)]
+ [(char? to)
+ (##core#inline "C_setsubchar" str2 j to)
+ (loop (fx+ i 1) (fx+ j 1)) ]
+ [(fx>= found tlen)
+ (##sys#error 'string-translate "invalid translation destination" i to) ]
+ [else
+ (##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
+ (loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) )
(define (string-translate* str smap)
(##sys#check-string str 'string-translate*)
@@ -788,21 +782,20 @@ EOF
;;; Binary search:
(define binary-search
- (let ([list->vector list->vector])
- (lambda (vec proc)
- (if (pair? vec)
- (set! vec (list->vector vec))
- (##sys#check-vector vec 'binary-search) )
- (let ([len (##sys#size vec)])
- (and (fx> len 0)
- (let loop ([ps 0]
- [pe len] )
- (let ([p (fx+ ps (##core#inline "C_fixnum_shift_right" (fx- pe ps) 1))])
- (let* ([x (##sys#slot vec p)]
- [r (proc x)] )
- (cond [(fx= r 0) p]
- [(fx< r 0) (and (not (fx= pe p)) (loop ps p))]
- [else (and (not (fx= ps p)) (loop p pe))] ) ) ) ) ) ) ) ) )
+ (lambda (vec proc)
+ (if (pair? vec)
+ (set! vec (list->vector vec))
+ (##sys#check-vector vec 'binary-search) )
+ (let ([len (##sys#size vec)])
+ (and (fx> len 0)
+ (let loop ([ps 0]
+ [pe len] )
+ (let ([p (fx+ ps (##core#inline "C_fixnum_shift_right" (fx- pe ps) 1))])
+ (let* ([x (##sys#slot vec p)]
+ [r (proc x)] )
+ (cond [(fx= r 0) p]
+ [(fx< r 0) (and (not (fx= pe p)) (loop ps p))]
+ [else (and (not (fx= ps p)) (loop p pe))] ) ) ) ) ) ) ) )
diff --git a/expand.scm b/expand.scm
index 625ad701..56319d8e 100644
--- a/expand.scm
+++ b/expand.scm
@@ -434,127 +434,126 @@
; This code is disgustingly complex.
(define ##sys#canonicalize-body
- (let ([reverse reverse])
- (lambda (body #!optional (se (##sys#current-environment)) cs?)
- (define (fini vars vals mvars mvals body)
- (if (and (null? vars) (null? mvars))
- (let loop ([body2 body] [exps '()])
- (if (not (pair? body2))
- (cons
- '##core#begin
- body) ; no more defines, otherwise we would have called `expand'
- (let ([x (car body2)])
- (if (and (pair? x)
- (let ((d (car x)))
- (and (symbol? d)
- (or (eq? (or (lookup d se) d) 'define)
- (eq? (or (lookup d se) d) 'define-values)))) )
- (cons
- '##core#begin
- (##sys#append (reverse exps) (list (expand body2))))
- (loop (cdr body2) (cons x exps)) ) ) ) )
- (let* ((vars (reverse vars))
- (result
- `(##core#let
- ,(##sys#map
- (lambda (v) (##sys#list v (##sys#list '##core#undefined)))
- (apply ##sys#append vars mvars) )
- ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
- ,@(map (lambda (vs x)
- (let ([tmps (##sys#map gensym vs)])
- `(##sys#call-with-values
- (##core#lambda () ,x)
- (##core#lambda
- ,tmps
- ,@(map (lambda (v t)
- `(##core#set! ,v ,t))
- vs tmps) ) ) ) )
- (reverse mvars)
- (reverse mvals) )
- ,@body) ) )
- (dd `(BODY: ,result))
- result)))
- (define (fini/syntax vars vals mvars mvals body)
- (fini
- vars vals mvars mvals
- (let loop ((body body) (defs '()) (done #f))
- (cond (done `((##core#letrec-syntax
- ,(map cdr (reverse defs)) ,@body) ))
- ((not (pair? body)) (loop body defs #t))
- ((and (list? (car body))
- (>= 3 (length (car body)))
- (symbol? (caar body))
- (eq? 'define-syntax (or (lookup (caar body) se) (caar body))))
- (let ((def (car body)))
- (loop
- (cdr body)
- (cons (cond ((pair? (cadr def))
- `(define-syntax ; (the first element is actually ignored)
- ,(caadr def)
- (##core#lambda ,(cdadr def) ,@(cddr def))))
- ;; insufficient, if introduced by different expansions, but
- ;; better than nothing:
- ((eq? (car def) (cadr def))
- (##sys#defjam-error def))
- (else def))
- defs)
- #f)))
- (else (loop body defs #t))))))
- (define (expand body)
- (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
- (if (not (pair? body))
- (fini vars vals mvars mvals body)
- (let* ((x (car body))
- (rest (cdr body))
- (exp1 (and (pair? x) (car x)))
- (head (and exp1
- (symbol? exp1)
- (or (lookup exp1 se) exp1))))
- (cond [(not (symbol? head)) (fini vars vals mvars mvals body)]
- [(eq? 'define (or (lookup head se) head))
- (##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)
- (let loop2 ([x x])
- (let ([head (cadr x)])
- (cond [(not (pair? head))
- (##sys#check-syntax 'define x '(_ variable . #(_ 0)) #f se)
- (when (eq? (car x) head) ; see above
- (##sys#defjam-error x))
- (loop rest (cons head vars)
- (cons (if (pair? (cddr x))
- (caddr x)
- '(##core#undefined) )
- vals)
- mvars mvals) ]
- [(pair? (car head))
- (##sys#check-syntax
- 'define x '(_ (_ . lambda-list) . #(_ 1)) #f se)
- (loop2
- (##sys#expand-curried-define head (cddr x) se)) ]
- [else
- (##sys#check-syntax
- 'define x
- '(_ (variable . lambda-list) . #(_ 1)) #f se)
- (loop rest
- (cons (car head) vars)
- (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
- mvars mvals) ] ) ) ) ]
- ((eq? 'define-syntax (or (lookup head se) head))
- (##sys#check-syntax 'define-syntax x '(_ _ . #(_ 1)) se)
- (fini/syntax vars vals mvars mvals body) )
- [(eq? 'define-values (or (lookup head se) head))
- ;;XXX check for any of the variables being `define-values' (?)
- (##sys#check-syntax 'define-values x '(_ #(_ 0) _) #f se)
- (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
- [(eq? '##core#begin head)
- (loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
- ((or (memq head vars) (memq head mvars))
- (fini vars vals mvars mvals body))
- [else
- (let ([x2 (##sys#expand-0 x se cs?)])
- (if (eq? x x2)
- (fini vars vals mvars mvals body)
- (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
- (expand body) ) ) )
+ (lambda (body #!optional (se (##sys#current-environment)) cs?)
+ (define (fini vars vals mvars mvals body)
+ (if (and (null? vars) (null? mvars))
+ (let loop ([body2 body] [exps '()])
+ (if (not (pair? body2))
+ (cons
+ '##core#begin
+ body) ; no more defines, otherwise we would have called `expand'
+ (let ([x (car body2)])
+ (if (and (pair? x)
+ (let ((d (car x)))
+ (and (symbol? d)
+ (or (eq? (or (lookup d se) d) 'define)
+ (eq? (or (lookup d se) d) 'define-values)))) )
+ (cons
+ '##core#begin
+ (##sys#append (reverse exps) (list (expand body2))))
+ (loop (cdr body2) (cons x exps)) ) ) ) )
+ (let* ((vars (reverse vars))
+ (result
+ `(##core#let
+ ,(##sys#map
+ (lambda (v) (##sys#list v (##sys#list '##core#undefined)))
+ (apply ##sys#append vars mvars) )
+ ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
+ ,@(map (lambda (vs x)
+ (let ([tmps (##sys#map gensym vs)])
+ `(##sys#call-with-values
+ (##core#lambda () ,x)
+ (##core#lambda
+ ,tmps
+ ,@(map (lambda (v t)
+ `(##core#set! ,v ,t))
+ vs tmps) ) ) ) )
+ (reverse mvars)
+ (reverse mvals) )
+ ,@body) ) )
+ (dd `(BODY: ,result))
+ result)))
+ (define (fini/syntax vars vals mvars mvals body)
+ (fini
+ vars vals mvars mvals
+ (let loop ((body body) (defs '()) (done #f))
+ (cond (done `((##core#letrec-syntax
+ ,(map cdr (reverse defs)) ,@body) ))
+ ((not (pair? body)) (loop body defs #t))
+ ((and (list? (car body))
+ (>= 3 (length (car body)))
+ (symbol? (caar body))
+ (eq? 'define-syntax (or (lookup (caar body) se) (caar body))))
+ (let ((def (car body)))
+ (loop
+ (cdr body)
+ (cons (cond ((pair? (cadr def))
+ `(define-syntax ; (the first element is actually ignored)
+ ,(caadr def)
+ (##core#lambda ,(cdadr def) ,@(cddr def))))
+ ;; insufficient, if introduced by different expansions, but
+ ;; better than nothing:
+ ((eq? (car def) (cadr def))
+ (##sys#defjam-error def))
+ (else def))
+ defs)
+ #f)))
+ (else (loop body defs #t))))))
+ (define (expand body)
+ (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
+ (if (not (pair? body))
+ (fini vars vals mvars mvals body)
+ (let* ((x (car body))
+ (rest (cdr body))
+ (exp1 (and (pair? x) (car x)))
+ (head (and exp1
+ (symbol? exp1)
+ (or (lookup exp1 se) exp1))))
+ (cond [(not (symbol? head)) (fini vars vals mvars mvals body)]
+ [(eq? 'define (or (lookup head se) head))
+ (##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)
+ (let loop2 ([x x])
+ (let ([head (cadr x)])
+ (cond [(not (pair? head))
+ (##sys#check-syntax 'define x '(_ variable . #(_ 0)) #f se)
+ (when (eq? (car x) head) ; see above
+ (##sys#defjam-error x))
+ (loop rest (cons head vars)
+ (cons (if (pair? (cddr x))
+ (caddr x)
+ '(##core#undefined) )
+ vals)
+ mvars mvals) ]
+ [(pair? (car head))
+ (##sys#check-syntax
+ 'define x '(_ (_ . lambda-list) . #(_ 1)) #f se)
+ (loop2
+ (##sys#expand-curried-define head (cddr x) se)) ]
+ [else
+ (##sys#check-syntax
+ 'define x
+ '(_ (variable . lambda-list) . #(_ 1)) #f se)
+ (loop rest
+ (cons (car head) vars)
+ (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
+ mvars mvals) ] ) ) ) ]
+ ((eq? 'define-syntax (or (lookup head se) head))
+ (##sys#check-syntax 'define-syntax x '(_ _ . #(_ 1)) se)
+ (fini/syntax vars vals mvars mvals body) )
+ [(eq? 'define-values (or (lookup head se) head))
+ ;;XXX check for any of the variables being `define-values' (?)
+ (##sys#check-syntax 'define-values x '(_ #(_ 0) _) #f se)
+ (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
+ [(eq? '##core#begin head)
+ (loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
+ ((or (memq head vars) (memq head mvars))
+ (fini vars vals mvars mvals body))
+ [else
+ (let ([x2 (##sys#expand-0 x se cs?)])
+ (if (eq? x x2)
+ (fini vars vals mvars mvals body)
+ (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
+ (expand body) ) )
;;; A simple expression matcher
@@ -668,85 +667,83 @@
(define-constant +default-argument-count-limit+ 99999)
(define ##sys#check-syntax
- (let ([string-append string-append]
- [symbol->string symbol->string] )
- (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
-
- (define (test x pred msg)
- (unless (pred x) (err msg)) )
-
- (define (err msg)
- (let* ([sexp ##sys#syntax-error-culprit]
- [ln (get-line-number sexp)] )
- (##sys#syntax-error-hook
- (if ln
- (string-append "(" ln ") in `" (symbol->string id) "' - " msg)
- (string-append "in `" (symbol->string id) "' - " msg) )
- exp) ) )
-
- (define (lambda-list? x)
- (or (##sys#extended-lambda-list? x)
- (let loop ((x x))
- (cond ((null? x))
- ((symbol? x) (not (keyword? x)))
- ((pair? x)
- (let ((s (car x)))
- (and (symbol? s) (not (keyword? s))
- (loop (cdr x)) ) ) )
- (else #f) ) ) ) )
-
- (define (proper-list? x)
- (let loop ((x x))
- (cond ((eq? x '()))
- ((pair? x) (loop (cdr x)))
- (else #f) ) ) )
-
- (when culprit (set! ##sys#syntax-error-culprit culprit))
- (let walk ((x exp) (p pat))
- (cond ((vector? p)
- (let* ((p2 (vector-ref p 0))
- (vlen (##sys#size p))
- (min (if (fx> vlen 1)
- (vector-ref p 1)
- 0) )
- (max (cond ((eq? vlen 1) 1)
- ((fx> vlen 2) (vector-ref p 2))
- (else +default-argument-count-limit+) ) ) )
- (do ((x x (cdr x))
- (n 0 (fx+ n 1)) )
- ((eq? x '())
- (if (fx< n min)
- (err "not enough arguments") ) )
- (cond ((fx>= n max)
- (err "too many arguments") )
- ((not (pair? x))
- (err "not a proper list") )
- (else (walk (car x) p2) ) ) ) ) )
- ((##sys#immediate? p)
- (if (not (eq? p x)) (err "unexpected object")) )
- ((symbol? p)
- (case p
- ((_) #t)
- ((pair) (test x pair? "pair expected"))
- ((variable) (test x symbol? "identifier expected"))
- ((symbol) (test x symbol? "symbol expected"))
- ((list) (test x proper-list? "proper list expected"))
- ((number) (test x number? "number expected"))
- ((string) (test x string? "string expected"))
- ((lambda-list) (test x lambda-list? "lambda-list expected"))
- (else
- (test
- x
- (lambda (y)
- (let ((y2 (and (symbol? y) (lookup y se))))
- (eq? (if (symbol? y2) y2 y) p)))
- "missing keyword")) ) )
- ((not (pair? p))
- (err "incomplete form") )
- ((not (pair? x)) (err "pair expected"))
- (else
- (walk (car x) (car p))
- (walk (cdr x) (cdr p)) ) ) ) ) ) )
+ (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
+
+ (define (test x pred msg)
+ (unless (pred x) (err msg)) )
+
+ (define (err msg)
+ (let* ([sexp ##sys#syntax-error-culprit]
+ [ln (get-line-number sexp)] )
+ (##sys#syntax-error-hook
+ (if ln
+ (string-append "(" ln ") in `" (symbol->string id) "' - " msg)
+ (string-append "in `" (symbol->string id) "' - " msg) )
+ exp) ) )
+
+ (define (lambda-list? x)
+ (or (##sys#extended-lambda-list? x)
+ (let loop ((x x))
+ (cond ((null? x))
+ ((symbol? x) (not (keyword? x)))
+ ((pair? x)
+ (let ((s (car x)))
+ (and (symbol? s) (not (keyword? s))
+ (loop (cdr x)) ) ) )
+ (else #f) ) ) ) )
+
+ (define (proper-list? x)
+ (let loop ((x x))
+ (cond ((eq? x '()))
+ ((pair? x) (loop (cdr x)))
+ (else #f) ) ) )
+
+ (when culprit (set! ##sys#syntax-error-culprit culprit))
+ (let walk ((x exp) (p pat))
+ (cond ((vector? p)
+ (let* ((p2 (vector-ref p 0))
+ (vlen (##sys#size p))
+ (min (if (fx> vlen 1)
+ (vector-ref p 1)
+ 0) )
+ (max (cond ((eq? vlen 1) 1)
+ ((fx> vlen 2) (vector-ref p 2))
+ (else +default-argument-count-limit+) ) ) )
+ (do ((x x (cdr x))
+ (n 0 (fx+ n 1)) )
+ ((eq? x '())
+ (if (fx< n min)
+ (err "not enough arguments") ) )
+ (cond ((fx>= n max)
+ (err "too many arguments") )
+ ((not (pair? x))
+ (err "not a proper list") )
+ (else (walk (car x) p2) ) ) ) ) )
+ ((##sys#immediate? p)
+ (if (not (eq? p x)) (err "unexpected object")) )
+ ((symbol? p)
+ (case p
+ ((_) #t)
+ ((pair) (test x pair? "pair expected"))
+ ((variable) (test x symbol? "identifier expected"))
+ ((symbol) (test x symbol? "symbol expected"))
+ ((list) (test x proper-list? "proper list expected"))
+ ((number) (test x number? "number expected"))
+ ((string) (test x string? "string expected"))
+ ((lambda-list) (test x lambda-list? "lambda-list expected"))
+ (else
+ (test
+ x
+ (lambda (y)
+ (let ((y2 (and (symbol? y) (lookup y se))))
+ (eq? (if (symbol? y2) y2 y) p)))
+ "missing keyword")) ) )
+ ((not (pair? p))
+ (err "incomplete form") )
+ ((not (pair? x)) (err "pair expected"))
+ (else
+ (walk (car x) (car p))
+ (walk (cdr x) (cdr p)) ) ) ) ) )
;;; explicit-renaming transformer
diff --git a/extras.scm b/extras.scm
index 42afea27..dcbfcca8 100644
--- a/extras.scm
+++ b/extras.scm
@@ -80,7 +80,7 @@
;;; Line I/O:
(define read-line
- (let ([make-string make-string])
+ (let ()
(define (fixup str len)
(##sys#substring
str 0
@@ -120,26 +120,24 @@
(loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )
(define read-lines
- (let ((call-with-input-file call-with-input-file)
- (reverse reverse) )
- (lambda port-and-max
- (let* ((port (if (pair? port-and-max) (##sys#slot port-and-max 0) ##sys#standard-input))
- (rest (and (pair? port-and-max) (##sys#slot port-and-max 1)))
- (max (if (pair? rest) (##sys#slot rest 0) #f)) )
- (define (doread port)
- (let loop ((lns '())
- (n (or max 1000000000)) ) ; this is silly
- (if (eq? n 0)
- (reverse lns)
- (let ((ln (read-line port)))
- (if (eof-object? ln)
- (reverse lns)
- (loop (cons ln lns) (fx- n 1)) ) ) ) ) )
- (if (string? port)
- (call-with-input-file port doread)
- (begin
- (##sys#check-port port 'read-lines)
- (doread port) ) ) ) ) ) )
+ (lambda port-and-max
+ (let* ((port (if (pair? port-and-max) (##sys#slot port-and-max 0) ##sys#standard-input))
+ (rest (and (pair? port-and-max) (##sys#slot port-and-max 1)))
+ (max (if (pair? rest) (##sys#slot rest 0) #f)) )
+ (define (doread port)
+ (let loop ((lns '())
+ (n (or max 1000000000)) ) ; this is silly
+ (if (eq? n 0)
+ (reverse lns)
+ (let ((ln (read-line port)))
+ (if (eof-object? ln)
+ (reverse lns)
+ (loop (cons ln lns) (fx- n 1)) ) ) ) ) )
+ (if (string? port)
+ (call-with-input-file port doread)
+ (begin
+ (##sys#check-port port 'read-lines)
+ (doread port) ) ) ) ) )
;;; Extended I/O
@@ -222,29 +220,26 @@
(get-output-string out) ) ) ) ) ) ) )
(define write-string
- (let ([display display])
- (lambda (s . more)
- (##sys#check-string s 'write-string)
- (let-optionals more ([n #f] [port ##sys#standard-output])
- (##sys#check-port port 'write-string)
- (when n (##sys#check-exact n 'write-string))
- (display
- (if (and n (fx< n (##sys#size s)))
- (##sys#substring s 0 n)
- s)
- port) ) ) ) )
+ (lambda (s . more)
+ (##sys#check-string s 'write-string)
+ (let-optionals more ([n #f] [port ##sys#standard-output])
+ (##sys#check-port port 'write-string)
+ (when n (##sys#check-exact n 'write-string))
+ (display
+ (if (and n (fx< n (##sys#size s)))
+ (##sys#substring s 0 n)
+ s)
+ port) ) ) )
(define write-line
- (let ((display display)
- (newline newline) )
- (lambda (str . port)
- (let ((p (if (##core#inline "C_eqp" port '())
- ##sys#standard-output
- (##sys#slot port 0) ) ) )
- (##sys#check-port p 'write-line)
- (##sys#check-string str 'write-line)
- (display str p)
- (newline p) ) ) ) )
+ (lambda (str . port)
+ (let ((p (if (##core#inline "C_eqp" port '())
+ ##sys#standard-output
+ (##sys#slot port 0) ) ) )
+ (##sys#check-port p 'write-line)
+ (##sys#check-string str 'write-line)
+ (display str p)
+ (newline p) ) ) )
;;; Binary I/O
@@ -559,14 +554,11 @@
;;; Write simple formatted output:
(define fprintf0
- (let ((write write)
- (newline newline)
- (display display) )
- (lambda (loc port msg args)
- (when port (##sys#check-port port loc))
- (let ((out (if (and port (##sys#tty-port? port))
- port
- (open-output-string))))
+ (lambda (loc port msg args)
+ (when port (##sys#check-port port loc))
+ (let ((out (if (and port (##sys#tty-port? port))
+ port
+ (open-output-string))))
(let rec ([msg msg] [args args])
(##sys#check-string msg loc)
(let ((index 0)
@@ -612,7 +604,7 @@
(loop) ) ) ) ) )
(cond ((not port) (get-output-string out))
((not (eq? out port))
- (##sys#print (get-output-string out) #f port) ) ) ) ) ) )
+ (##sys#print (get-output-string out) #f port) ) ) ) ) )
(define (fprintf port fstr . args)
(fprintf0 'fprintf port fstr args) )
diff --git a/files.scm b/files.scm
index b3b14876..20a8d1c6 100644
--- a/files.scm
+++ b/files.scm
@@ -68,47 +68,33 @@ EOF
;;; file-copy and file-move : they do what you'd think.
(define (file-copy origfile newfile #!optional (clobber #f) (blocksize 1024))
- (##sys#check-string origfile 'file-copy)
- (##sys#check-string newfile 'file-copy)
- (##sys#check-number blocksize 'file-copy)
- (or (and (integer? blocksize) (> blocksize 0))
- (##sys#error (string-append
- "invalid blocksize given: not a positive integer - "
- (number->string blocksize))))
- (or (file-exists? origfile)
- (##sys#error (string-append "origfile does not exist - " origfile)))
- (and (file-exists? newfile)
- (or clobber
- (##sys#error (string-append
- "newfile exists but clobber is false - "
- newfile))))
- (let* ((i (condition-case (open-input-file origfile)
- (val ()
- (##sys#error (string-append
- "could not open origfile for read - "
- origfile)))))
- (o (condition-case (open-output-file newfile)
- (val ()
- (##sys#error (string-append
- "could not open newfile for write - "
- newfile)))))
- (s (make-string blocksize)))
- (let loop ((d (read-string! blocksize s i))
- (l 0))
- (if (fx= 0 d)
- (begin
- (close-input-port i)
- (close-output-port o)
- l)
- (begin
- (condition-case (write-string s d o)
- (val ()
- (close-input-port i)
- (close-output-port o)
- (##sys#error (string-append
- "error writing file starting at "
- (number->string l)))))
- (loop (read-string! blocksize s i) (fx+ d l)))))))
+ (##sys#check-string origfile 'file-copy)
+ (##sys#check-string newfile 'file-copy)
+ (##sys#check-number blocksize 'file-copy)
+ (or (and (integer? blocksize) (> blocksize 0))
+ (##sys#error (string-append
+ "invalid blocksize given: not a positive integer - "
+ (number->string blocksize))))
+ (or (file-exists? origfile)
+ (##sys#error (string-append "origfile does not exist - " origfile)))
+ (and (file-exists? newfile)
+ (or clobber
+ (##sys#error (string-append
+ "newfile exists but clobber is false - "
+ newfile))))
+ (let* ((i (open-input-file origfile))
+ (o (open-output-file newfile))
+ (s (make-string blocksize)))
+ (let loop ((d (read-string! blocksize s i))
+ (l 0))
+ (if (fx= 0 d)
+ (begin
+ (close-input-port i)
+ (close-output-port o)
+ l)
+ (begin
+ (write-string s d o)
+ (loop (read-string! blocksize s i) (fx+ d l)))))))
(define (file-move origfile newfile #!optional (clobber #f) (blocksize 1024))
(##sys#check-string origfile 'file-move)
@@ -125,16 +111,8 @@ EOF
(##sys#error (string-append
"newfile exists but clobber is false - "
newfile))))
- (let* ((i (condition-case (open-input-file origfile)
- (val ()
- (##sys#error (string-append
- "could not open origfile for read - "
- origfile)))))
- (o (condition-case (open-output-file newfile)
- (val ()
- (##sys#error (string-append
- "could not open newfile for write - "
- newfile)))))
+ (let* ((i (open-input-file origfile))
+ (o (open-output-file newfile))
(s (make-string blocksize)))
(let loop ((d (read-string! blocksize s i))
(l 0))
@@ -142,20 +120,10 @@ EOF
(begin
(close-input-port i)
(close-output-port o)
- (condition-case (delete-file origfile)
- (val ()
- (##sys#error (string-append
- "could not remove origfile - "
- origfile))))
+ (delete-file origfile)
l)
(begin
- (condition-case (write-string s d o)
- (val ()
- (close-input-port i)
- (close-output-port o)
- (##sys#error (string-append
- "error writing file starting at "
- (number->string l)))))
+ (write-string s d o)
(loop (read-string! blocksize s i) (fx+ d l)))))))
;;; Pathname operations:
@@ -199,8 +167,7 @@ EOF
(define make-pathname)
(define make-absolute-pathname)
-(let ([string-append string-append]
- [def-pds "/"] )
+(let ([def-pds "/"] )
(define (conc-dirs dirs pds)
(##sys#check-list dirs 'make-pathname)
@@ -322,8 +289,7 @@ EOF
(define create-temporary-file)
(define create-temporary-directory)
-(let ((call-with-output-file call-with-output-file)
- (temp #f)
+(let ((temp #f)
(temp-prefix "temp"))
(define (tempdir)
(or temp
@@ -370,9 +336,7 @@ EOF
;;; normalize pathname for a particular platform
(define normalize-pathname
- (let ((reverse reverse)
- (display display)
- (bldplt (if (memq (build-platform) '(msvc mingw32)) 'windows 'unix)) )
+ (let ((bldplt (if (memq (build-platform) '(msvc mingw32)) 'windows 'unix)) )
(define (addpart part parts)
(cond ((string=? "." part) parts)
((string=? ".." part) (if (null? parts) '("..") (cdr parts)))
diff --git a/library.scm b/library.scm
index 4d01b802..2ae17447 100644
--- a/library.scm
+++ b/library.scm
@@ -1494,49 +1494,47 @@ EOF
(define for-each)
(define map)
-(let ([car car]
- [cdr cdr] )
- (letrec ((mapsafe
- (lambda (p lsts start loc)
- (if (eq? lsts '())
- lsts
- (let ((item (##sys#slot lsts 0)))
- (cond ((eq? item '())
- (check lsts start loc))
- ((pair? item)
- (cons (p item) (mapsafe p (##sys#slot lsts 1) #f loc)) )
- (else (##sys#error-not-a-proper-list item loc)) ) ) ) ) )
- (check
- (lambda (lsts start loc)
- (if (or (not start)
- (let loop ((lsts lsts))
- (and (not (eq? lsts '()))
- (not (eq? (##sys#slot lsts 0) '()))
- (loop (##sys#slot lsts 1)) ) ) )
- (##sys#error loc "lists are not of same length" lsts) ) ) ) )
-
- (set! for-each
- (lambda (fn lst1 . lsts)
- (if (null? lsts)
- (##sys#for-each fn lst1)
- (let loop ((all (cons lst1 lsts)))
- (let ((first (##sys#slot all 0)))
- (cond ((pair? first)
- (apply fn (mapsafe car all #t 'for-each))
- (loop (mapsafe cdr all #t 'for-each)) )
- (else (check all #t 'for-each)) ) ) ) ) ) )
-
- (set! map
- (lambda (fn lst1 . lsts)
- (if (null? lsts)
- (##sys#map fn lst1)
- (let loop ((all (cons lst1 lsts)))
- (let ((first (##sys#slot all 0)))
- (cond ((pair? first)
- (cons (apply fn (mapsafe car all #t 'map))
- (loop (mapsafe cdr all #t 'map)) ) )
- (else (check (##core#inline "C_i_cdr" all) #t 'map)
- '() ) ) ) ) ) ) ) ) )
+(letrec ((mapsafe
+ (lambda (p lsts start loc)
+ (if (eq? lsts '())
+ lsts
+ (let ((item (##sys#slot lsts 0)))
+ (cond ((eq? item '())
+ (check lsts start loc))
+ ((pair? item)
+ (cons (p item) (mapsafe p (##sys#slot lsts 1) #f loc)) )
+ (else (##sys#error-not-a-proper-list item loc)) ) ) ) ) )
+ (check
+ (lambda (lsts start loc)
+ (if (or (not start)
+ (let loop ((lsts lsts))
+ (and (not (eq? lsts '()))
+ (not (eq? (##sys#slot lsts 0) '()))
+ (loop (##sys#slot lsts 1)) ) ) )
+ (##sys#error loc "lists are not of same length" lsts) ) ) ) )
+
+ (set! for-each
+ (lambda (fn lst1 . lsts)
+ (if (null? lsts)
+ (##sys#for-each fn lst1)
+ (let loop ((all (cons lst1 lsts)))
+ (let ((first (##sys#slot all 0)))
+ (cond ((pair? first)
+ (apply fn (mapsafe (lambda (x) (car x)) all #t 'for-each)) ; ensure inlining
+ (loop (mapsafe (lambda (x) (cdr x)) all #t 'for-each)) )
+ (else (check all #t 'for-each)) ) ) ) ) ) )
+
+ (set! map
+ (lambda (fn lst1 . lsts)
+ (if (null? lsts)
+ (##sys#map fn lst1)
+ (let loop ((all (cons lst1 lsts)))
+ (let ((first (##sys#slot all 0)))
+ (cond ((pair? first)
+ (cons (apply fn (mapsafe (lambda (x) (car x)) all #t 'map))
+ (loop (mapsafe (lambda (x) (cdr x)) all #t 'map)) ) )
+ (else (check (##core#inline "C_i_cdr" all) #t 'map)
+ '() ) ) ) ) ) ) ) )
;;; dynamic-wind:
@@ -1607,10 +1605,9 @@ EOF
(##sys#continuation-graft k thunk) ) )
(define continuation-return
- (let ([continuation-graft continuation-graft])
- (lambda (k . vals)
- (##sys#check-structure k 'continuation 'continuation-return)
- (continuation-graft k (lambda () (apply values vals))) ) ) )
+ (lambda (k . vals)
+ (##sys#check-structure k 'continuation 'continuation-return)
+ (continuation-graft k (lambda () (apply values vals))) ) )
;;; Ports:
@@ -2110,9 +2107,7 @@ EOF
(define ##sys#read
(let ([reverse reverse]
- [list? list?]
[string-append string-append]
- [string string]
[kwprefix (string (integer->char 0))])
(lambda (port infohandler)
(let ([csp (case-sensitive)]
@@ -3291,8 +3286,6 @@ EOF
+build-tag+))
+build-version+) )
-(define ##sys#pathname-directory-separator #\/) ; DEPRECATED
-
;;; Feature identifiers:
diff --git a/lolevel.scm b/lolevel.scm
index ae414886..5e6309e3 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -403,14 +403,13 @@ EOF
(##sys#slot d 1) ) ) )
(define set-procedure-data!
- (let ((extend-procedure extend-procedure))
- (lambda (proc x)
- (let ((p2 (extend-procedure proc x)))
- (if (eq? p2 proc)
- proc
- (##sys#signal-hook
- #:type-error 'set-procedure-data!
- "bad argument type - not an extended procedure" proc) ) ) ) ) )
+ (lambda (proc x)
+ (let ((p2 (extend-procedure proc x)))
+ (if (eq? p2 proc)
+ proc
+ (##sys#signal-hook
+ #:type-error 'set-procedure-data!
+ "bad argument type - not an extended procedure" proc) ) ) ) )
;;; Accessors for arbitrary vector-like block objects:
diff --git a/ports.scm b/ports.scm
index 88e9fe46..03825bf6 100644
--- a/ports.scm
+++ b/ports.scm
@@ -52,13 +52,12 @@
(loop) ) ) ) )
(define port-map
- (let ((reverse reverse))
- (lambda (fn thunk)
- (let loop ((xs '()))
- (let ((x (thunk)))
- (if (eof-object? x)
- (reverse xs)
- (loop (cons (fn x) xs))))))))
+ (lambda (fn thunk)
+ (let loop ((xs '()))
+ (let ((x (thunk)))
+ (if (eof-object? x)
+ (reverse xs)
+ (loop (cons (fn x) xs)))))))
(define (port-fold fn acc thunk)
(let loop ((acc acc))
@@ -104,7 +103,7 @@
(loop (fx+ n 1))))))))
(define copy-port
- (let ((read-char read-char)
+ (let ((read-char read-char) ; shadow here
(write-char write-char))
(lambda (src dest #!optional (read read-char) (write write-char))
;; does not check port args intentionally
@@ -249,25 +248,24 @@
port) ) )
(define make-output-port
- (let ([string string])
- (lambda (write close #!optional flush)
- (let* ((class
- (vector
- #f ; read-char
- #f ; peek-char
- (lambda (p c) ; write-char
- (write (string c)) )
- (lambda (p s) ; write-string
- (write s) )
- (lambda (p) ; close
- (close)
- (##sys#setislot p 8 #t) )
- (lambda (p) ; flush-output
- (when flush (flush)) )
- #f ; char-ready?
- #f ; read-string!
- #f) ) ; read-line
- (data (vector #f))
- (port (##sys#make-port #f class "(custom)" 'custom)) )
- (##sys#set-port-data! port data)
- port) ) ) )
+ (lambda (write close #!optional flush)
+ (let* ((class
+ (vector
+ #f ; read-char
+ #f ; peek-char
+ (lambda (p c) ; write-char
+ (write (string c)) )
+ (lambda (p s) ; write-string
+ (write s) )
+ (lambda (p) ; close
+ (close)
+ (##sys#setislot p 8 #t) )
+ (lambda (p) ; flush-output
+ (when flush (flush)) )
+ #f ; char-ready?
+ #f ; read-string!
+ #f) ) ; read-line
+ (data (vector #f))
+ (port (##sys#make-port #f class "(custom)" 'custom)) )
+ (##sys#set-port-data! port data)
+ port) ) )
diff --git a/posix-common.scm b/posix-common.scm
index f4b771f5..0b7694d6 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -180,17 +180,18 @@ EOF
;;; Set or get current directory:
(define current-directory
- (let ((make-string make-string))
- (lambda (#!optional dir)
- (if dir
- (change-directory dir)
- (let* ((buffer (make-string 1024))
- (len (##core#inline "C_curdir" buffer)) )
- #+(or unix cygwin)
- (##sys#update-errno)
- (if len
- (##sys#substring buffer 0 len)
- (##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
+ (lambda (#!optional dir)
+ (if dir
+ (change-directory dir)
+ (let* ((buffer (make-string 1024))
+ (len (##core#inline "C_curdir" buffer)) )
+ #+(or unix cygwin)
+ (##sys#update-errno)
+ (if len
+ (##sys#substring buffer 0 len)
+ (##sys#signal-hook
+ #:file-error
+ 'current-directory "cannot retrieve current directory") ) ) ) ) )
(define delete-directory
(lambda (name)
@@ -201,33 +202,32 @@ EOF
name)))
(define directory
- (let ([make-string make-string])
- (lambda (#!optional (spec (current-directory)) show-dotfiles?)
- (##sys#check-string spec 'directory)
- (let ([buffer (make-string 256)]
- [handle (##sys#make-pointer)]
- [entry (##sys#make-pointer)] )
- (##core#inline
- "C_opendir"
- (##sys#make-c-string (##sys#expand-home-path spec) 'directory) handle)
- (if (##sys#null-pointer? handle)
- (posix-error #:file-error 'directory "cannot open directory" spec)
- (let loop ()
- (##core#inline "C_readdir" handle entry)
- (if (##sys#null-pointer? entry)
- (begin
- (##core#inline "C_closedir" handle)
- '() )
- (let* ([flen (##core#inline "C_foundfile" entry buffer)]
- [file (##sys#substring buffer 0 flen)]
- [char1 (string-ref file 0)]
- [char2 (and (fx> flen 1) (string-ref file 1))] )
- (if (and (eq? #\. char1)
- (or (not char2)
- (and (eq? #\. char2) (eq? 2 flen))
- (not show-dotfiles?) ) )
- (loop)
- (cons file (loop)) ) ) ) ) ) ) ) ) )
+ (lambda (#!optional (spec (current-directory)) show-dotfiles?)
+ (##sys#check-string spec 'directory)
+ (let ([buffer (make-string 256)]
+ [handle (##sys#make-pointer)]
+ [entry (##sys#make-pointer)] )
+ (##core#inline
+ "C_opendir"
+ (##sys#make-c-string (##sys#expand-home-path spec) 'directory) handle)
+ (if (##sys#null-pointer? handle)
+ (posix-error #:file-error 'directory "cannot open directory" spec)
+ (let loop ()
+ (##core#inline "C_readdir" handle entry)
+ (if (##sys#null-pointer? entry)
+ (begin
+ (##core#inline "C_closedir" handle)
+ '() )
+ (let* ([flen (##core#inline "C_foundfile" entry buffer)]
+ [file (##sys#substring buffer 0 flen)]
+ [char1 (string-ref file 0)]
+ [char2 (and (fx> flen 1) (string-ref file 1))] )
+ (if (and (eq? #\. char1)
+ (or (not char2)
+ (and (eq? #\. char2) (eq? 2 flen))
+ (not show-dotfiles?) ) )
+ (loop)
+ (cons file (loop)) ) ) ) ) ) ) ) )
;;; Filename globbing:
diff --git a/posixunix.scm b/posixunix.scm
index 2260c671..0a5a7387 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -604,17 +604,16 @@ EOF
(posix-error #:file-error 'file-close "cannot close file" fd) ) ) )
(define file-read
- (let ([make-string make-string] )
- (lambda (fd size . buffer)
- (##sys#check-exact fd 'file-read)
- (##sys#check-exact size 'file-read)
- (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
- (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
- (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
- (let ([n (##core#inline "C_read" fd buf size)])
- (when (eq? -1 n)
- (posix-error #:file-error 'file-read "cannot read from file" fd size) )
- (list buf n) ) ) ) ) )
+ (lambda (fd size . buffer)
+ (##sys#check-exact fd 'file-read)
+ (##sys#check-exact size 'file-read)
+ (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
+ (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
+ (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
+ (let ([n (##core#inline "C_read" fd buf size)])
+ (when (eq? -1 n)
+ (posix-error #:file-error 'file-read "cannot read from file" fd size) )
+ (list buf n) ) ) ) )
(define file-write
(lambda (fd buffer . size)
@@ -708,20 +707,20 @@ EOF
(define seek/cur _seek_cur)
(define set-file-position!
- (lambda (port pos . whence)
- (let ((whence (if (pair? whence) (car whence) _seek_set)))
- (##sys#check-exact pos 'set-file-position!)
- (##sys#check-exact whence 'set-file-position!)
- (when (negative? pos)
- (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
- (unless (cond ((port? port)
- (and (eq? (##sys#slot port 7) 'stream)
- (##core#inline "C_fseek" port pos whence) ) )
- ((fixnum? port)
- (##core#inline "C_lseek" port pos whence))
- (else
- (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )
- (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
+ (lambda (port pos . whence)
+ (let ((whence (if (pair? whence) (car whence) _seek_set)))
+ (##sys#check-exact pos 'set-file-position!)
+ (##sys#check-exact whence 'set-file-position!)
+ (when (negative? pos)
+ (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
+ (unless (cond ((port? port)
+ (and (eq? (##sys#slot port 7) 'stream)
+ (##core#inline "C_fseek" port pos whence) ) )
+ ((fixnum? port)
+ (##core#inline "C_lseek" port pos whence))
+ (else
+ (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )
+ (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
(define file-position
(getter-with-setter
@@ -1289,8 +1288,7 @@ EOF
(define-foreign-variable _filename_max int "FILENAME_MAX")
(define read-symbolic-link
- (let ([substring substring]
- [buf (make-string (fx+ _filename_max 1))] )
+ (let ([buf (make-string (fx+ _filename_max 1))] )
(lambda (fname #!optional canonicalize)
(##sys#check-string fname 'read-symbolic-link)
(let ([len (##core#inline "C_do_readlink" (##sys#make-c-string (##sys#expand-home-path fname) 'read-symbolic-link) buf)])
@@ -1536,8 +1534,7 @@ EOF
(make-output-port
(lambda (str) ; write-string
(store str) )
- (lambda () ; close
- ; Do nothing when closed already
+ (lambda () ; close - do nothing when closed already
(unless (##sys#slot this-port 8)
(when (fx< (##core#inline "C_close" fd) 0)
(posix-error #:file-error loc "cannot close" fd nam) )
@@ -1790,20 +1787,20 @@ EOF
(define-foreign-variable _bufsiz int "BUFSIZ")
(define set-buffering-mode!
- (lambda (port mode . size)
- (##sys#check-port port 'set-buffering-mode!)
- (let ([size (if (pair? size) (car size) _bufsiz)]
- [mode (case mode
- [(###full) _iofbf]
- [(###line) _iolbf]
- [(###none) _ionbf]
- [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
- (##sys#check-exact size 'set-buffering-mode!)
- (when (fx< (if (eq? 'stream (##sys#slot port 7))
- (##core#inline "C_setvbuf" port mode size)
- -1)
- 0)
- (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
+ (lambda (port mode . size)
+ (##sys#check-port port 'set-buffering-mode!)
+ (let ([size (if (pair? size) (car size) _bufsiz)]
+ [mode (case mode
+ [(###full) _iofbf]
+ [(###line) _iolbf]
+ [(###none) _ionbf]
+ [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
+ (##sys#check-exact size 'set-buffering-mode!)
+ (when (fx< (if (eq? 'stream (##sys#slot port 7))
+ (##core#inline "C_setvbuf" port mode size)
+ -1)
+ 0)
+ (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
(define (terminal-port? port)
(##sys#check-port port 'terminal-port?)
@@ -1840,9 +1837,9 @@ EOF
(define get-host-name
(let ([getit
- (foreign-lambda* c-string ()
- "if(gethostname(C_hostbuf, 256) == -1) C_return(NULL);"
- "else C_return(C_hostbuf);") ] )
+ (foreign-lambda* c-string ()
+ "if(gethostname(C_hostbuf, 256) == -1) C_return(NULL);"
+ "else C_return(C_hostbuf);") ] )
(lambda ()
(let ([host (getit)])
(unless host
@@ -2047,6 +2044,7 @@ EOF
(define process)
(define process*)
+
(let ([%process
(lambda (loc err? cmd args env)
(let ([chkstrlst
diff --git a/posixwin.scm b/posixwin.scm
index db4dc9f0..11006c4c 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -986,18 +986,17 @@ EOF
(##sys#signal-hook #:file-error 'file-close "cannot close file" fd) ) ) )
(define file-read
- (let ([make-string make-string] )
- (lambda (fd size . buffer)
- (##sys#check-exact fd 'file-read)
- (##sys#check-exact size 'file-read)
- (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
- (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
- (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
- (let ([n (##core#inline "C_read" fd buf size)])
- (when (eq? -1 n)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'file-read "cannot read from file" fd size) )
- (list buf n) ) ) ) ) )
+ (lambda (fd size . buffer)
+ (##sys#check-exact fd 'file-read)
+ (##sys#check-exact size 'file-read)
+ (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
+ (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
+ (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
+ (let ([n (##core#inline "C_read" fd buf size)])
+ (when (eq? -1 n)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'file-read "cannot read from file" fd size) )
+ (list buf n) ) ) ) )
(define file-write
(lambda (fd buffer . size)
@@ -1013,16 +1012,15 @@ EOF
n) ) ) )
(define file-mkstemp
- (let ([string-length string-length])
- (lambda (template)
- (##sys#check-string template 'file-mkstemp)
- (let* ([buf (##sys#make-c-string template 'file-mkstemp)]
- [fd (##core#inline "C_mkstemp" buf)]
- [path-length (string-length buf)])
- (when (eq? -1 fd)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'file-mkstemp "cannot create temporary file" template) )
- (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) ) )
+ (lambda (template)
+ (##sys#check-string template 'file-mkstemp)
+ (let* ([buf (##sys#make-c-string template 'file-mkstemp)]
+ [fd (##core#inline "C_mkstemp" buf)]
+ [path-length (string-length buf)])
+ (when (eq? -1 fd)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'file-mkstemp "cannot create temporary file" template) )
+ (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )
;;; File attribute access:
@@ -1092,15 +1090,15 @@ EOF
"cannot create directory" name)))
(define-inline (create-directory-check name)
- (if (file-exists? name)
- (let ((i (##sys#file-info name)))
- (and i
- (fx= 1 (##sys#slot i 4))))
- #f))
+ (if (file-exists? name)
+ (let ((i (##sys#file-info name)))
+ (and i
+ (fx= 1 (##sys#slot i 4))))
+ #f))
(define-inline (create-directory-helper-silent name)
- (unless (create-directory-check name)
- (create-directory-helper name)))
+ (unless (create-directory-check name)
+ (create-directory-helper name)))
(define-inline (create-directory-helper-parents name)
(let* ((l (string-split name "/\\"))
@@ -1171,46 +1169,47 @@ EOF
(when (eq? -1 r) (##sys#signal-hook #:file-error 'close-input-pipe "error while closing pipe" port)) ) ) )
(set! close-output-pipe close-input-pipe) )
-(let ([open-input-pipe open-input-pipe]
- [open-output-pipe open-output-pipe]
- [close-input-pipe close-input-pipe]
- [close-output-pipe close-output-pipe] )
- (set! call-with-input-pipe
- (lambda (cmd proc . mode)
- (let ([p (apply open-input-pipe cmd mode)])
- (##sys#call-with-values
- (lambda () (proc p))
- (lambda results
- (close-input-pipe p)
- (apply values results) ) ) ) ) )
- (set! call-with-output-pipe
- (lambda (cmd proc . mode)
- (let ([p (apply open-output-pipe cmd mode)])
- (##sys#call-with-values
- (lambda () (proc p))
- (lambda results
- (close-output-pipe p)
- (apply values results) ) ) ) ) )
- (set! with-input-from-pipe
- (lambda (cmd thunk . mode)
- (let ([old ##sys#standard-input]
- [p (apply open-input-pipe cmd mode)] )
- (set! ##sys#standard-input p)
- (##sys#call-with-values thunk
- (lambda results
- (close-input-pipe p)
- (set! ##sys#standard-input old)
- (apply values results) ) ) ) ) )
- (set! with-output-to-pipe
- (lambda (cmd thunk . mode)
- (let ([old ##sys#standard-output]
- [p (apply open-output-pipe cmd mode)] )
- (set! ##sys#standard-output p)
- (##sys#call-with-values thunk
- (lambda results
- (close-output-pipe p)
- (set! ##sys#standard-output old)
- (apply values results) ) ) ) ) ) )
+(define call-with-input-pipe
+ (lambda (cmd proc . mode)
+ (let ([p (apply open-input-pipe cmd mode)])
+ (##sys#call-with-values
+ (lambda () (proc p))
+ (lambda results
+ (close-input-pipe p)
+ (apply values results) ) ) ) ) )
+
+(define call-with-output-pipe
+ (lambda (cmd proc . mode)
+ (let ([p (apply open-output-pipe cmd mode)])
+ (##sys#call-with-values
+ (lambda () (proc p))
+ (lambda results
+ (close-output-pipe p)
+ (apply values results) ) ) ) ) )
+
+(define with-input-from-pipe
+ (lambda (cmd thunk . mode)
+ (let ([old ##sys#standard-input]
+ [p (apply open-input-pipe cmd mode)] )
+ (set! ##sys#standard-input p)
+ (##sys#call-with-values
+ thunk
+ (lambda results
+ (close-input-pipe p)
+ (set! ##sys#standard-input old)
+ (apply values results) ) ) ) ) )
+
+(define with-output-to-pipe
+ (lambda (cmd thunk . mode)
+ (let ([old ##sys#standard-output]
+ [p (apply open-output-pipe cmd mode)] )
+ (set! ##sys#standard-output p)
+ (##sys#call-with-values
+ thunk
+ (lambda results
+ (close-output-pipe p)
+ (set! ##sys#standard-output old)
+ (apply values results) ) ) ) ) )
;;; Pipe primitive:
@@ -1219,11 +1218,11 @@ EOF
(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
(define create-pipe
- (lambda (#!optional (mode (fxior open/binary open/noinherit)))
- (when (fx< (##core#inline "C_pipe" #f mode) 0)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
- (values _pipefd0 _pipefd1) ) )
+ (lambda (#!optional (mode (fxior open/binary open/noinherit)))
+ (when (fx< (##core#inline "C_pipe" #f mode) 0)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
+ (values _pipefd0 _pipefd1) ) )
;;; Signal processing:
@@ -1473,8 +1472,7 @@ EOF
(##core#undefined) )
(define get-environment-variables
- (let ([get (foreign-lambda c-string "C_getenventry" int)]
- [substring substring] )
+ (let ([get (foreign-lambda c-string "C_getenventry" int)])
(lambda ()
(let loop ([i 0])
(let ([entry (get i)])
@@ -1559,20 +1557,20 @@ EOF
(define-foreign-variable _bufsiz int "BUFSIZ")
(define set-buffering-mode!
- (lambda (port mode . size)
- (##sys#check-port port 'set-buffering-mode!)
- (let ([size (if (pair? size) (car size) _bufsiz)]
- [mode (case mode
- [(###full) _iofbf]
- [(###line) _iolbf]
- [(###none) _ionbf]
- [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
- (##sys#check-exact size 'set-buffering-mode!)
- (when (fx< (if (eq? 'stream (##sys#slot port 7))
- (##core#inline "C_setvbuf" port mode size)
- -1)
- 0)
- (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
+ (lambda (port mode . size)
+ (##sys#check-port port 'set-buffering-mode!)
+ (let ([size (if (pair? size) (car size) _bufsiz)]
+ [mode (case mode
+ [(###full) _iofbf]
+ [(###line) _iolbf]
+ [(###none) _ionbf]
+ [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
+ (##sys#check-exact size 'set-buffering-mode!)
+ (when (fx< (if (eq? 'stream (##sys#slot port 7))
+ (##core#inline "C_setvbuf" port mode size)
+ -1)
+ 0)
+ (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
;;; Process handling:
@@ -1592,32 +1590,28 @@ EOF
; arguments with embedded whitespace will parse incorrectly. Must
; string-quote such arguments.
(define $quote-args-list
- (let ([char-whitespace? char-whitespace?]
- [string-length string-length]
- [string-ref string-ref]
- [string-append string-append])
- (lambda (lst exactf)
- (if exactf
+ (lambda (lst exactf)
+ (if exactf
lst
(let ([needs-quoting?
- ; This is essentially (string-any char-whitespace? s) but we don't
- ; want a SRFI-13 dependency. (Do we?)
- (lambda (s)
- (let ([len (string-length s)])
- (let loop ([i 0])
- (cond
- [(fx= i len) #f]
- [(char-whitespace? (string-ref s i)) #t]
- [else (loop (fx+ i 1))]))))])
- (let loop ([ilst lst] [olst '()])
- (if (null? ilst)
+ ; This is essentially (string-any char-whitespace? s) but we don't
+ ; want a SRFI-13 dependency. (Do we?)
+ (lambda (s)
+ (let ([len (string-length s)])
+ (let loop ([i 0])
+ (cond
+ [(fx= i len) #f]
+ [(char-whitespace? (string-ref s i)) #t]
+ [else (loop (fx+ i 1))]))))])
+ (let loop ([ilst lst] [olst '()])
+ (if (null? ilst)
(reverse olst)
(let ([str (car ilst)])
(loop
- (cdr ilst)
- (cons
- (if (needs-quoting? str) (string-append "\"" str "\"") str)
- olst)) ) ) ) ) ) ) ) )
+ (cdr ilst)
+ (cons
+ (if (needs-quoting? str) (string-append "\"" str "\"") str)
+ olst)) ) ) ) ) ) ) )
(define $exec-setup
(let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
@@ -1729,6 +1723,7 @@ EOF
(define process)
(define process*)
+
(let ([%process
(lambda (loc err? cmd args env exactf)
(let ([chkstrlst
diff --git a/regex.scm b/regex.scm
index 526e65ad..9b8912e0 100644
--- a/regex.scm
+++ b/regex.scm
@@ -168,193 +168,178 @@
;;; Split string into fields:
(define string-split-fields
- (let ([reverse reverse]
- [substring substring]
- [string-search-positions string-search-positions] )
- (lambda (rx str . mode-and-start)
- (##sys#check-string str 'string-split-fields)
- (let* ([argc (length mode-and-start)]
- [len (##sys#size str)]
- [mode (if (fx> argc 0) (car mode-and-start) #t)]
- [start (if (fx> argc 1) (cadr mode-and-start) 0)]
- [fini (case mode
- [(#:suffix)
- (lambda (ms start)
- (if (fx< start len)
- (##sys#error 'string-split-fields
- "record does not end with suffix" str rx)
- (reverse ms) ) ) ]
- [(#:infix)
- (lambda (ms start)
- (if (fx>= start len)
- (reverse (cons "" ms))
- (reverse (cons (substring str start len) ms)) ) ) ]
- [else (lambda (ms start) (reverse ms)) ] ) ]
- [fetch (case mode
- [(#:infix #:suffix) (lambda (start from to) (substring str start from))]
- [else (lambda (start from to) (substring str from to))] ) ] )
- (let loop ([ms '()] [start start])
- (let ([m (string-search-positions rx str start)])
- (if m
- (let* ([mp (car m)]
- [from (car mp)]
- [to (cadr mp)] )
- (if (fx= from to)
- (if (fx= to len)
- (fini ms start)
- (loop (cons (fetch start (fx+ from 1) (fx+ to 2)) ms) (fx+ to 1)) )
- (loop (cons (fetch start from to) ms) to) ) )
- (fini ms start) ) ) ) ) ) ) )
+ (lambda (rx str . mode-and-start)
+ (##sys#check-string str 'string-split-fields)
+ (let* ([argc (length mode-and-start)]
+ [len (##sys#size str)]
+ [mode (if (fx> argc 0) (car mode-and-start) #t)]
+ [start (if (fx> argc 1) (cadr mode-and-start) 0)]
+ [fini (case mode
+ [(#:suffix)
+ (lambda (ms start)
+ (if (fx< start len)
+ (##sys#error 'string-split-fields
+ "record does not end with suffix" str rx)
+ (reverse ms) ) ) ]
+ [(#:infix)
+ (lambda (ms start)
+ (if (fx>= start len)
+ (reverse (cons "" ms))
+ (reverse (cons (substring str start len) ms)) ) ) ]
+ [else (lambda (ms start) (reverse ms)) ] ) ]
+ [fetch (case mode
+ [(#:infix #:suffix) (lambda (start from to) (substring str start from))]
+ [else (lambda (start from to) (substring str from to))] ) ] )
+ (let loop ([ms '()] [start start])
+ (let ([m (string-search-positions rx str start)])
+ (if m
+ (let* ([mp (car m)]
+ [from (car mp)]
+ [to (cadr mp)] )
+ (if (fx= from to)
+ (if (fx= to len)
+ (fini ms start)
+ (loop (cons (fetch start (fx+ from 1) (fx+ to 2)) ms) (fx+ to 1)) )
+ (loop (cons (fetch start from to) ms) to) ) )
+ (fini ms start) ) ) ) ) ) )
;;; Substitute matching strings:
(define string-substitute
- (let ([substring substring]
- [reverse reverse]
- [make-string make-string]
- [string-search-positions string-search-positions] )
- (lambda (rx subst string . flag)
- (##sys#check-string subst 'string-substitute)
- (##sys#check-string string 'string-substitute)
- (let* ([which (if (pair? flag) (car flag) 1)]
- [substlen (##sys#size subst)]
- (strlen (##sys#size string))
- [substlen-1 (fx- substlen 1)]
- [result '()]
- [total 0] )
- (define (push x)
- (set! result (cons x result))
- (set! total (fx+ total (##sys#size x))) )
- (define (substitute matches)
- (let loop ([start 0] [index 0])
- (if (fx>= index substlen-1)
- (push (if (fx= start 0) subst (substring subst start substlen)))
- (let ([c (##core#inline "C_subchar" subst index)]
- [index+1 (fx+ index 1)] )
- (if (char=? c #\\)
- (let ([c2 (##core#inline "C_subchar" subst index+1)])
- (if (and (not (char=? #\\ c2)) (char-numeric? c2))
- (let ([mi (list-ref matches (fx- (char->integer c2) 48))])
- (push (substring subst start index))
- (push (substring string (car mi) (cadr mi)))
- (loop (fx+ index 2) index+1) )
- (loop start (fx+ index+1 1)) ) )
- (loop start index+1) ) ) ) ) )
- (let loop ([index 0] [count 1])
- (let ((matches (and (fx< index strlen)
- (string-search-positions rx string index))))
- (cond [matches
- (let* ([range (car matches)]
- [upto (cadr range)] )
- (cond ((fx= 0 (fx- (cadr range) (car range)))
- (##sys#error
- 'string-substitute "empty substitution match"
- rx) )
- ((or (not (fixnum? which)) (fx= count which))
- (push (substring string index (car range)))
- (substitute matches)
- (loop upto #f) )
- (else
- (push (substring string index upto))
- (loop upto (fx+ count 1)) ) ) ) ]
- [else
- (push (substring string index (##sys#size string)))
- (##sys#fragments->string total (reverse result)) ] ) ) ) ) ) ) )
+ (lambda (rx subst string . flag)
+ (##sys#check-string subst 'string-substitute)
+ (##sys#check-string string 'string-substitute)
+ (let* ([which (if (pair? flag) (car flag) 1)]
+ [substlen (##sys#size subst)]
+ (strlen (##sys#size string))
+ [substlen-1 (fx- substlen 1)]
+ [result '()]
+ [total 0] )
+ (define (push x)
+ (set! result (cons x result))
+ (set! total (fx+ total (##sys#size x))) )
+ (define (substitute matches)
+ (let loop ([start 0] [index 0])
+ (if (fx>= index substlen-1)
+ (push (if (fx= start 0) subst (substring subst start substlen)))
+ (let ([c (##core#inline "C_subchar" subst index)]
+ [index+1 (fx+ index 1)] )
+ (if (char=? c #\\)
+ (let ([c2 (##core#inline "C_subchar" subst index+1)])
+ (if (and (not (char=? #\\ c2)) (char-numeric? c2))
+ (let ([mi (list-ref matches (fx- (char->integer c2) 48))])
+ (push (substring subst start index))
+ (push (substring string (car mi) (cadr mi)))
+ (loop (fx+ index 2) index+1) )
+ (loop start (fx+ index+1 1)) ) )
+ (loop start index+1) ) ) ) ) )
+ (let loop ([index 0] [count 1])
+ (let ((matches (and (fx< index strlen)
+ (string-search-positions rx string index))))
+ (cond [matches
+ (let* ([range (car matches)]
+ [upto (cadr range)] )
+ (cond ((fx= 0 (fx- (cadr range) (car range)))
+ (##sys#error
+ 'string-substitute "empty substitution match"
+ rx) )
+ ((or (not (fixnum? which)) (fx= count which))
+ (push (substring string index (car range)))
+ (substitute matches)
+ (loop upto #f) )
+ (else
+ (push (substring string index upto))
+ (loop upto (fx+ count 1)) ) ) ) ]
+ [else
+ (push (substring string index (##sys#size string)))
+ (##sys#fragments->string total (reverse result)) ] ) ) ) ) ) )
(define string-substitute*
- (let ([string-substitute string-substitute])
- (lambda (str smap . mode)
- (##sys#check-string str 'string-substitute*)
- (##sys#check-list smap 'string-substitute*)
- (let ((mode (and (pair? mode) (car mode))))
- (let loop ((str str) (smap smap))
- (if (null? smap)
- str
- (let ((sm (car smap)))
- (loop (string-substitute (car sm) (cdr sm) str mode)
- (cdr smap) ) ) ) ) ) ) ) )
+ (lambda (str smap . mode)
+ (##sys#check-string str 'string-substitute*)
+ (##sys#check-list smap 'string-substitute*)
+ (let ((mode (and (pair? mode) (car mode))))
+ (let loop ((str str) (smap smap))
+ (if (null? smap)
+ str
+ (let ((sm (car smap)))
+ (loop (string-substitute (car sm) (cdr sm) str mode)
+ (cdr smap) ) ) ) ) ) ) )
;;; Glob support:
(define glob->regexp
- (let ((list->string list->string)
- (string->list string->list)
- (regexp regexp))
- (lambda (s #!optional sre?)
- (##sys#check-string s 'glob->regexp)
- (let ((sre
- (cons
- ':
- (let loop ((cs (string->list s)) (dir #t))
- (if (null? cs)
- '()
- (let ((c (car cs))
- (rest (cdr cs)) )
- (cond ((char=? c #\*)
- (if dir
- `((or (: (~ ("./\\"))
- (* (~ ("/\\"))))
- (* (~ ("./\\"))))
- ,@(loop rest #f))
- `((* (~ ("/\\"))) ,@(loop rest #f))))
- ((char=? c #\?) (cons 'any (loop rest #f)))
- ((char=? c #\[)
- (let loop2 ((rest rest) (s '()))
- (cond ((not (pair? rest))
- (error 'glob->regexp "unexpected end of character class" s))
- ((char=? #\] (car rest))
- `((or ,@s) ,@(loop (cdr rest) #f)))
- ((and (pair? (cdr rest))
- (pair? (cddr rest))
- (char=? #\- (cadr rest)) )
- (loop2 (cdddr rest) (cons `(/ ,(car rest) ,(caddr rest)) s)))
- ((and (pair? (cdr rest))
- (char=? #\- (car rest)))
- (loop2 (cddr rest)
- (cons `(~ ,(cadr rest)) s)))
- (else
- (loop2 (cdr rest) (cons (car rest) s))))))
- (else (cons c (loop rest (memq c '(#\\ #\/))))))))))))
- (if sre? sre (regexp sre))))))
+ (lambda (s #!optional sre?)
+ (##sys#check-string s 'glob->regexp)
+ (let ((sre
+ (cons
+ ':
+ (let loop ((cs (string->list s)) (dir #t))
+ (if (null? cs)
+ '()
+ (let ((c (car cs))
+ (rest (cdr cs)) )
+ (cond ((char=? c #\*)
+ (if dir
+ `((or (: (~ ("./\\"))
+ (* (~ ("/\\"))))
+ (* (~ ("./\\"))))
+ ,@(loop rest #f))
+ `((* (~ ("/\\"))) ,@(loop rest #f))))
+ ((char=? c #\?) (cons 'any (loop rest #f)))
+ ((char=? c #\[)
+ (let loop2 ((rest rest) (s '()))
+ (cond ((not (pair? rest))
+ (error 'glob->regexp "unexpected end of character class" s))
+ ((char=? #\] (car rest))
+ `((or ,@s) ,@(loop (cdr rest) #f)))
+ ((and (pair? (cdr rest))
+ (pair? (cddr rest))
+ (char=? #\- (cadr rest)) )
+ (loop2 (cdddr rest) (cons `(/ ,(car rest) ,(caddr rest)) s)))
+ ((and (pair? (cdr rest))
+ (char=? #\- (car rest)))
+ (loop2 (cddr rest)
+ (cons `(~ ,(cadr rest)) s)))
+ (else
+ (loop2 (cdr rest) (cons (car rest) s))))))
+ (else (cons c (loop rest (memq c '(#\\ #\/))))))))))))
+ (if sre? sre (regexp sre)))))
;;; Grep-like function on list:
(define grep
- (let ((string-search string-search)
- (regexp regexp))
- (lambda (rx lst #!optional (acc (lambda (x) x)))
- (##sys#check-list lst 'grep)
- (##sys#check-closure acc 'grep)
- (let ((rx (regexp rx)))
- (let loop ((lst lst))
- (if (null? lst)
- '()
- (let ((x (##sys#slot lst 0))
- (r (##sys#slot lst 1)) )
- (if (string-search rx (acc x))
- (cons x (loop r))
- (loop r) ) ) ) ) ) ) ) )
+ (lambda (rx lst #!optional (acc (lambda (x) x)))
+ (##sys#check-list lst 'grep)
+ (##sys#check-closure acc 'grep)
+ (let ((rx (regexp rx)))
+ (let loop ((lst lst))
+ (if (null? lst)
+ '()
+ (let ((x (##sys#slot lst 0))
+ (r (##sys#slot lst 1)) )
+ (if (string-search rx (acc x))
+ (cons x (loop r))
+ (loop r) ) ) ) ) ) ) )
;;; Escape regular expression (suggested by Peter Bex):
(define regexp-escape
- (let ([open-output-string open-output-string]
- [get-output-string get-output-string] )
- (lambda (str)
- (##sys#check-string str 'regexp-escape)
- (let ([out (open-output-string)]
- [len (##sys#size str)] )
- (let loop ([i 0])
- (cond [(fx>= i len) (get-output-string out)]
- [(memq (##core#inline "C_subchar" str i)
- '(#\. #\\ #\? #\* #\+ #\^ #\$ #\( #\) #\[ #\] #\| #\{ #\}))
- (##sys#write-char-0 #\\ out)
- (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
- (loop (fx+ i 1)) ]
- [else
- (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
- (loop (fx+ i 1)) ] ) ) ) ) ) )
+ (lambda (str)
+ (##sys#check-string str 'regexp-escape)
+ (let ([out (open-output-string)]
+ [len (##sys#size str)] )
+ (let loop ([i 0])
+ (cond [(fx>= i len) (get-output-string out)]
+ [(memq (##core#inline "C_subchar" str i)
+ '(#\. #\\ #\? #\* #\+ #\^ #\$ #\( #\) #\[ #\] #\| #\{ #\}))
+ (##sys#write-char-0 #\\ out)
+ (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
+ (loop (fx+ i 1)) ]
+ [else
+ (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
+ (loop (fx+ i 1)) ] ) ) ) ) )
diff --git a/tcp.scm b/tcp.scm
index 96299349..11761d9e 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -322,8 +322,7 @@ EOF
(set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) )
(define ##net#io-ports
- (let ((tbs tcp-buffer-size)
- (make-string make-string) )
+ (let ((tbs tcp-buffer-size))
(lambda (fd)
(unless (##net#make-nonblocking fd)
(##sys#update-errno)
@@ -431,7 +430,7 @@ EOF
(set! bufindex next)
(cond ((eq? pos2 limit) ; no line-terminator, hit limit
(if str (##sys#string-append str dest) dest))
- ((eq? pos2 next) ; no line-terminator, hit buflen
+ ((eq? pos2 next) ; no line-terminator, hit buflen
(read-input)
(if (fx>= bufindex buflen)
(or str "")
Trap