~ chicken-core (chicken-5) 6c6b3d84a88f466c8775cf0fe52a028a2a41386d
commit 6c6b3d84a88f466c8775cf0fe52a028a2a41386d
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Aug 19 05:49:10 2010 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Aug 19 05:49:10 2010 -0400
removed shadowing bindings for non-standard procedures
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 088e1178..4fc2fcf8 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -149,8 +149,7 @@
(##sys#extend-macro-environment
'assert '()
(##sys#er-transformer
- (let ((string-append string-append)
- (get-line-number get-line-number))
+ (let ((string-append string-append))
(lambda (form r c)
(##sys#check-syntax 'assert form '#(_ 1))
(let* ((exp (cadr form))
diff --git a/data-structures.scm b/data-structures.scm
index 5404427d..acdf47b8 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -42,7 +42,7 @@ EOF
(define (identity x) x)
-(define (project n)
+(define (project n) ; DEPRECATED
(lambda args (list-ref args n)) )
(define (conjoin . preds)
@@ -224,7 +224,6 @@ EOF
[else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) )
(define shuffle
- ;; this should really shadow SORT! and RANDOM...
(lambda (l random)
(let ((len (length l)))
(map cdr
@@ -305,10 +304,8 @@ EOF
;;; Anything->string conversion:
(define ->string
- (let ([open-output-string open-output-string]
- [display display]
- [string string]
- [get-output-string get-output-string] )
+ (let ([display display]
+ [string string])
(lambda (x)
(cond [(string? x) x]
[(symbol? x) (symbol->string x)]
diff --git a/eval.scm b/eval.scm
index 0d8bb4fb..400b60e2 100644
--- a/eval.scm
+++ b/eval.scm
@@ -183,8 +183,6 @@
(define ##sys#compile-to-closure
(let ([write write]
[reverse reverse]
- [open-output-string open-output-string]
- [get-output-string get-output-string]
[with-input-from-file with-input-from-file]
[unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
[display display] )
@@ -850,12 +848,10 @@
[write write]
[display display]
[newline newline]
- (flush-output flush-output)
[eval eval]
[open-input-file open-input-file]
[close-input-port close-input-port]
[string-append string-append]
- [load-verbose load-verbose]
[topentry (##sys#make-c-string "C_toplevel")] )
(define (has-sep? str)
(let loop ([i (fx- (##sys#size str) 1)])
@@ -989,9 +985,7 @@
x) ) ) )
(define ##sys#load-library-0
- (let ([load-verbose load-verbose]
- [string-append string-append]
- [dynamic-load-libraries dynamic-load-libraries]
+ (let ([string-append string-append]
[display display] )
(lambda (uname lib)
(let ([id (##sys#->feature-id uname)])
@@ -1027,9 +1021,7 @@
(define load-library ##sys#load-library)
(define ##sys#include-forms-from-file
- (let ((load-verbose load-verbose)
- (print print)
- (with-input-from-file with-input-from-file)
+ (let ((with-input-from-file with-input-from-file)
(read read)
(reverse reverse))
(lambda (fname)
@@ -1095,8 +1087,7 @@
(define ##sys#setup-mode #f)
(define ##sys#find-extension
- (let ((file-exists? file-exists?)
- (string-append string-append) )
+ (let ((string-append string-append) )
(lambda (p inc?)
(let ((rp (##sys#repository-path)))
(define (check path)
@@ -1165,7 +1156,6 @@
(define ##sys#extension-information
(let ([with-input-from-file with-input-from-file]
- [file-exists? file-exists?]
[string-append string-append]
[read read] )
(lambda (id loc)
@@ -1497,10 +1487,7 @@
(let ((eval eval)
(read read)
(call-with-current-continuation call-with-current-continuation)
- (print-call-chain print-call-chain)
- (flush-output flush-output)
- (string-append string-append)
- (load-verbose load-verbose))
+ (string-append string-append))
(lambda ()
(define (write-err xs)
diff --git a/expand.scm b/expand.scm
index 895cec99..625ad701 100644
--- a/expand.scm
+++ b/expand.scm
@@ -325,8 +325,7 @@
[else (loop (cdr llist))] ) ) ) )
(define ##sys#expand-extended-lambda-list
- (let ([reverse reverse]
- [gensym gensym] )
+ (let ([reverse reverse])
(lambda (llist0 body errh se)
(define (err msg) (errh msg llist0))
(define (->keyword s) (string->keyword (##sys#slot s 1)))
@@ -435,8 +434,7 @@
; This code is disgustingly complex.
(define ##sys#canonicalize-body
- (let ([reverse reverse]
- [map map] )
+ (let ([reverse reverse])
(lambda (body #!optional (se (##sys#current-environment)) cs?)
(define (fini vars vals mvars mvals body)
(if (and (null? vars) (null? mvars))
@@ -603,55 +601,53 @@
(##sys#strip-syntax args)))
(define ##sys#syntax-error/context
- (let ((open-output-string open-output-string)
- (get-output-string get-output-string))
- (lambda (msg arg)
- (define (syntax-imports sym)
- (let loop ((defs (or (##sys#get (##sys#strip-syntax sym) '##core#db) '())))
- (cond ((null? defs) '())
- ((eq? 'syntax (caar defs))
- (cons (cadar defs) (loop (cdr defs))))
- (else (loop (cdr defs))))))
- (if (null? ##sys#syntax-context)
- (##sys#syntax-error-hook msg arg)
- (let ((out (open-output-string)))
- (define (outstr str)
- (##sys#print str #f out))
- (let loop ((cx ##sys#syntax-context))
- (cond ((null? cx) ; no unimported syntax found
- (outstr msg)
- (outstr ": ")
- (##sys#print arg #t out)
- (outstr "\ninside expression `(")
- (##sys#print (##sys#strip-syntax (car ##sys#syntax-context)) #t out)
- (outstr " ...)'"))
- (else
- (let* ((sym (##sys#strip-syntax (car cx)))
- (us (syntax-imports sym)))
- (cond ((pair? us)
- (outstr msg)
- (outstr ": ")
- (##sys#print arg #t out)
- (outstr "\n\n Perhaps you intended to use the syntax `(")
- (##sys#print sym #t out)
- (outstr " ...)' without importing it first.\n")
- (if (fx= 1 (length us))
- (outstr
- (string-append
- " Suggesting: `(import "
- (symbol->string (car us))
- ")'"))
- (outstr
- (string-append
- " Suggesting one of:\n"
- (let loop ((lst us))
- (if (null? lst)
- ""
- (string-append
- "\n (import " (symbol->string (car lst)) ")'"
- (loop (cdr lst)))))))))
- (else (loop (cdr cx))))))))
- (##sys#syntax-error-hook (get-output-string out)))))))
+ (lambda (msg arg)
+ (define (syntax-imports sym)
+ (let loop ((defs (or (##sys#get (##sys#strip-syntax sym) '##core#db) '())))
+ (cond ((null? defs) '())
+ ((eq? 'syntax (caar defs))
+ (cons (cadar defs) (loop (cdr defs))))
+ (else (loop (cdr defs))))))
+ (if (null? ##sys#syntax-context)
+ (##sys#syntax-error-hook msg arg)
+ (let ((out (open-output-string)))
+ (define (outstr str)
+ (##sys#print str #f out))
+ (let loop ((cx ##sys#syntax-context))
+ (cond ((null? cx) ; no unimported syntax found
+ (outstr msg)
+ (outstr ": ")
+ (##sys#print arg #t out)
+ (outstr "\ninside expression `(")
+ (##sys#print (##sys#strip-syntax (car ##sys#syntax-context)) #t out)
+ (outstr " ...)'"))
+ (else
+ (let* ((sym (##sys#strip-syntax (car cx)))
+ (us (syntax-imports sym)))
+ (cond ((pair? us)
+ (outstr msg)
+ (outstr ": ")
+ (##sys#print arg #t out)
+ (outstr "\n\n Perhaps you intended to use the syntax `(")
+ (##sys#print sym #t out)
+ (outstr " ...)' without importing it first.\n")
+ (if (fx= 1 (length us))
+ (outstr
+ (string-append
+ " Suggesting: `(import "
+ (symbol->string (car us))
+ ")'"))
+ (outstr
+ (string-append
+ " Suggesting one of:\n"
+ (let loop ((lst us))
+ (if (null? lst)
+ ""
+ (string-append
+ "\n (import " (symbol->string (car lst)) ")'"
+ (loop (cdr lst)))))))))
+ (else (loop (cdr cx))))))))
+ (##sys#syntax-error-hook (get-output-string out))))))
(define syntax-error ##sys#syntax-error-hook)
@@ -673,8 +669,6 @@
(define ##sys#check-syntax
(let ([string-append string-append]
- [keyword? keyword?]
- [get-line-number get-line-number]
[symbol->string symbol->string] )
(lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
diff --git a/extras.scm b/extras.scm
index 36450b78..42afea27 100644
--- a/extras.scm
+++ b/extras.scm
@@ -65,7 +65,7 @@
(define (randomize . n)
(let ((nn (if (null? n)
- (##sys#inexact->exact (fp/ (current-seconds) 1000))
+ (##sys#inexact->exact (fp/ (current-seconds) 1000.0)) ; wall clock time
(car n))))
(##sys#check-exact nn 'randomize)
(##core#inline "C_randomize" nn) ) )
@@ -120,8 +120,7 @@
(loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )
(define read-lines
- (let ((read-line read-line)
- (call-with-input-file call-with-input-file)
+ (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))
@@ -186,45 +185,41 @@
(define-constant read-string-buffer-size 2048)
(define ##sys#read-string/port
- (let ((open-output-string open-output-string)
- (get-output-string get-output-string) )
- (lambda (n p)
- (##sys#check-port p 'read-string)
- (cond (n (##sys#check-exact n 'read-string)
- (let* ((str (##sys#make-string n))
- (n2 (##sys#read-string! n str p 0)) )
- (if (eq? n n2)
- str
- (##sys#substring str 0 n2))))
- (else
- (let ([out (open-output-string)]
- (buf (make-string read-string-buffer-size)))
- (let loop ()
- (let ((n (##sys#read-string! read-string-buffer-size
- buf p 0)))
- (cond ((eq? n 0)
- (get-output-string out))
- (else
- (write-string buf n out)
- (loop)))))))))))
+ (lambda (n p)
+ (##sys#check-port p 'read-string)
+ (cond (n (##sys#check-exact n 'read-string)
+ (let* ((str (##sys#make-string n))
+ (n2 (##sys#read-string! n str p 0)) )
+ (if (eq? n n2)
+ str
+ (##sys#substring str 0 n2))))
+ (else
+ (let ([out (open-output-string)]
+ (buf (make-string read-string-buffer-size)))
+ (let loop ()
+ (let ((n (##sys#read-string! read-string-buffer-size
+ buf p 0)))
+ (cond ((eq? n 0)
+ (get-output-string out))
+ (else
+ (write-string buf n out)
+ (loop))))))))))
(define (read-string #!optional n (port ##sys#standard-input))
(##sys#read-string/port n port) )
(define read-token
- (let ([open-output-string open-output-string]
- [get-output-string get-output-string] )
- (lambda (pred . port)
- (let ([port (optional port ##sys#standard-input)])
- (##sys#check-port port 'read-token)
- (let ([out (open-output-string)])
- (let loop ()
- (let ([c (##sys#peek-char-0 port)])
- (if (and (not (eof-object? c)) (pred c))
- (begin
- (##sys#write-char-0 (##sys#read-char-0 port) out)
- (loop) )
- (get-output-string out) ) ) ) ) ) ) ) )
+ (lambda (pred . port)
+ (let ([port (optional port ##sys#standard-input)])
+ (##sys#check-port port 'read-token)
+ (let ([out (open-output-string)])
+ (let loop ()
+ (let ([c (##sys#peek-char-0 port)])
+ (if (and (not (eof-object? c)) (pred c))
+ (begin
+ (##sys#write-char-0 (##sys#read-char-0 port) out)
+ (loop) )
+ (get-output-string out) ) ) ) ) ) ) )
(define write-string
(let ([display display])
@@ -279,276 +274,274 @@
;
(define generic-write
- (let ([open-output-string open-output-string]
- [get-output-string get-output-string] )
- (lambda (obj display? width output)
-
- (define (read-macro? l)
- (define (length1? l) (and (pair? l) (null? (cdr l))))
- (let ((head (car l)) (tail (cdr l)))
- (case head
- ((quote quasiquote unquote unquote-splicing) (length1? tail))
- (else #f))))
-
- (define (read-macro-body l)
- (cadr l))
-
- (define (read-macro-prefix l)
- (let ((head (car l)) (tail (cdr l)))
- (case head
- ((quote) "'")
- ((quasiquote) "`")
- ((unquote) ",")
- ((unquote-splicing) ",@"))))
-
- (define (out str col)
- (and col (output str) (+ col (string-length str))))
-
- (define (wr obj col)
-
- (define (wr-expr expr col)
- (if (read-macro? expr)
- (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
- (wr-lst expr col)))
-
- (define (wr-lst l col)
- (if (pair? l)
- (let loop ((l (cdr l))
- (col (and col (wr (car l) (out "(" col)))))
- (cond ((not col) col)
- ((pair? l)
- (loop (cdr l) (wr (car l) (out " " col))))
- ((null? l) (out ")" col))
- (else (out ")" (wr l (out " . " col))))))
- (out "()" col)))
-
- (cond ((pair? obj) (wr-expr obj col))
- ((null? obj) (wr-lst obj col))
- ((eof-object? obj) (out "#!eof" col))
- ((vector? obj) (wr-lst (vector->list obj) (out "#" col)))
- ((boolean? obj) (out (if obj "#t" "#f") col))
- ((##sys#number? obj) (out (##sys#number->string obj) col))
- ((symbol? obj)
- (let ([s (open-output-string)])
- (##sys#print obj #t s)
- (out (get-output-string s) col) ) )
- ((procedure? obj) (out (##sys#procedure->string obj) col))
- ((string? obj) (if display?
- (out obj col)
- (let loop ((i 0) (j 0) (col (out "\"" col)))
- (if (and col (< j (string-length obj)))
- (let ((c (string-ref obj j)))
- (if (or (char=? c #\\)
- (char=? c #\"))
- (loop j
- (+ j 1)
- (out "\\"
- (out (##sys#substring obj i j)
- col)))
- (loop i (+ j 1) col)))
- (out "\""
- (out (##sys#substring obj i j) col))))))
- ((char? obj) (if display?
- (out (make-string 1 obj) col)
- (let ([code (char->integer obj)])
- (out "#\\" col)
- (cond [(char-name obj)
- => (lambda (cn)
- (out (##sys#slot cn 1) col) ) ]
- [(fx< code 32)
- (out "x" col)
- (out (number->string code 16) col) ]
- [(fx> code 255)
- (out (if (fx> code #xffff) "U" "u") col)
- (out (number->string code 16) col) ]
- [else (out (make-string 1 obj) col)] ) ) ) )
- ((eof-object? obj) (out "#<eof>" col))
- ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
- ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
- ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
- (out "#<unbound value>" col) )
- ((##sys#generic-structure? obj)
- (let ([o (open-output-string)])
- (##sys#user-print-hook obj #t o)
- (out (get-output-string o) col) ) )
- ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))
- ((##core#inline "C_bytevectorp" obj)
- (if (##core#inline "C_permanentp" obj)
- (out "#<static blob of size" col)
- (out "#<blob of size " col) )
- (out (number->string (##core#inline "C_block_size" obj)) col)
- (out ">" col) )
- ((##core#inline "C_lambdainfop" obj)
- (out "#<lambda info " col)
- (out (##sys#lambda-info->string obj) col)
- (out "#>" col) )
- (else (out "#<unprintable object>" col)) ) )
-
- (define (pp obj col)
-
- (define (spaces n col)
- (if (> n 0)
- (if (> n 7)
- (spaces (- n 8) (out " " col))
- (out (##sys#substring " " 0 n) col))
- col))
-
- (define (indent to col)
- (and col
- (if (< to col)
- (and (out (make-string 1 #\newline) col) (spaces to 0))
- (spaces (- to col) col))))
-
- (define (pr obj col extra pp-pair)
- (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
- (let ((result '())
- (left (max (+ (- (- width col) extra) 1) max-expr-width)))
- (generic-write obj display? #f
- (lambda (str)
- (set! result (cons str result))
- (set! left (- left (string-length str)))
- (> left 0)))
- (if (> left 0) ; all can be printed on one line
- (out (reverse-string-append result) col)
- (if (pair? obj)
- (pp-pair obj col extra)
- (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
- (wr obj col)))
-
- (define (pp-expr expr col extra)
- (if (read-macro? expr)
- (pr (read-macro-body expr)
- (out (read-macro-prefix expr) col)
- extra
- pp-expr)
- (let ((head (car expr)))
- (if (symbol? head)
- (let ((proc (style head)))
- (if proc
- (proc expr col extra)
- (if (> (string-length (##sys#symbol->qualified-string head))
- max-call-head-width)
- (pp-general expr col extra #f #f #f pp-expr)
- (pp-call expr col extra pp-expr))))
- (pp-list expr col extra pp-expr)))))
+ (lambda (obj display? width output)
+
+ (define (read-macro? l)
+ (define (length1? l) (and (pair? l) (null? (cdr l))))
+ (let ((head (car l)) (tail (cdr l)))
+ (case head
+ ((quote quasiquote unquote unquote-splicing) (length1? tail))
+ (else #f))))
+
+ (define (read-macro-body l)
+ (cadr l))
+
+ (define (read-macro-prefix l)
+ (let ((head (car l)) (tail (cdr l)))
+ (case head
+ ((quote) "'")
+ ((quasiquote) "`")
+ ((unquote) ",")
+ ((unquote-splicing) ",@"))))
+
+ (define (out str col)
+ (and col (output str) (+ col (string-length str))))
+
+ (define (wr obj col)
+
+ (define (wr-expr expr col)
+ (if (read-macro? expr)
+ (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
+ (wr-lst expr col)))
+
+ (define (wr-lst l col)
+ (if (pair? l)
+ (let loop ((l (cdr l))
+ (col (and col (wr (car l) (out "(" col)))))
+ (cond ((not col) col)
+ ((pair? l)
+ (loop (cdr l) (wr (car l) (out " " col))))
+ ((null? l) (out ")" col))
+ (else (out ")" (wr l (out " . " col))))))
+ (out "()" col)))
+
+ (cond ((pair? obj) (wr-expr obj col))
+ ((null? obj) (wr-lst obj col))
+ ((eof-object? obj) (out "#!eof" col))
+ ((vector? obj) (wr-lst (vector->list obj) (out "#" col)))
+ ((boolean? obj) (out (if obj "#t" "#f") col))
+ ((##sys#number? obj) (out (##sys#number->string obj) col))
+ ((symbol? obj)
+ (let ([s (open-output-string)])
+ (##sys#print obj #t s)
+ (out (get-output-string s) col) ) )
+ ((procedure? obj) (out (##sys#procedure->string obj) col))
+ ((string? obj) (if display?
+ (out obj col)
+ (let loop ((i 0) (j 0) (col (out "\"" col)))
+ (if (and col (< j (string-length obj)))
+ (let ((c (string-ref obj j)))
+ (if (or (char=? c #\\)
+ (char=? c #\"))
+ (loop j
+ (+ j 1)
+ (out "\\"
+ (out (##sys#substring obj i j)
+ col)))
+ (loop i (+ j 1) col)))
+ (out "\""
+ (out (##sys#substring obj i j) col))))))
+ ((char? obj) (if display?
+ (out (make-string 1 obj) col)
+ (let ([code (char->integer obj)])
+ (out "#\\" col)
+ (cond [(char-name obj)
+ => (lambda (cn)
+ (out (##sys#slot cn 1) col) ) ]
+ [(fx< code 32)
+ (out "x" col)
+ (out (number->string code 16) col) ]
+ [(fx> code 255)
+ (out (if (fx> code #xffff) "U" "u") col)
+ (out (number->string code 16) col) ]
+ [else (out (make-string 1 obj) col)] ) ) ) )
+ ((eof-object? obj) (out "#<eof>" col))
+ ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
+ ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
+ ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
+ (out "#<unbound value>" col) )
+ ((##sys#generic-structure? obj)
+ (let ([o (open-output-string)])
+ (##sys#user-print-hook obj #t o)
+ (out (get-output-string o) col) ) )
+ ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))
+ ((##core#inline "C_bytevectorp" obj)
+ (if (##core#inline "C_permanentp" obj)
+ (out "#<static blob of size" col)
+ (out "#<blob of size " col) )
+ (out (number->string (##core#inline "C_block_size" obj)) col)
+ (out ">" col) )
+ ((##core#inline "C_lambdainfop" obj)
+ (out "#<lambda info " col)
+ (out (##sys#lambda-info->string obj) col)
+ (out "#>" col) )
+ (else (out "#<unprintable object>" col)) ) )
+
+ (define (pp obj col)
+
+ (define (spaces n col)
+ (if (> n 0)
+ (if (> n 7)
+ (spaces (- n 8) (out " " col))
+ (out (##sys#substring " " 0 n) col))
+ col))
+
+ (define (indent to col)
+ (and col
+ (if (< to col)
+ (and (out (make-string 1 #\newline) col) (spaces to 0))
+ (spaces (- to col) col))))
+
+ (define (pr obj col extra pp-pair)
+ (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
+ (let ((result '())
+ (left (max (+ (- (- width col) extra) 1) max-expr-width)))
+ (generic-write obj display? #f
+ (lambda (str)
+ (set! result (cons str result))
+ (set! left (- left (string-length str)))
+ (> left 0)))
+ (if (> left 0) ; all can be printed on one line
+ (out (reverse-string-append result) col)
+ (if (pair? obj)
+ (pp-pair obj col extra)
+ (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
+ (wr obj col)))
+
+ (define (pp-expr expr col extra)
+ (if (read-macro? expr)
+ (pr (read-macro-body expr)
+ (out (read-macro-prefix expr) col)
+ extra
+ pp-expr)
+ (let ((head (car expr)))
+ (if (symbol? head)
+ (let ((proc (style head)))
+ (if proc
+ (proc expr col extra)
+ (if (> (string-length (##sys#symbol->qualified-string head))
+ max-call-head-width)
+ (pp-general expr col extra #f #f #f pp-expr)
+ (pp-call expr col extra pp-expr))))
+ (pp-list expr col extra pp-expr)))))
; (head item1
; item2
; item3)
- (define (pp-call expr col extra pp-item)
- (let ((col* (wr (car expr) (out "(" col))))
- (and col
- (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
+ (define (pp-call expr col extra pp-item)
+ (let ((col* (wr (car expr) (out "(" col))))
+ (and col
+ (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
; (item1
; item2
; item3)
- (define (pp-list l col extra pp-item)
- (let ((col (out "(" col)))
- (pp-down l col col extra pp-item)))
-
- (define (pp-down l col1 col2 extra pp-item)
- (let loop ((l l) (col col1))
- (and col
- (cond ((pair? l)
- (let ((rest (cdr l)))
- (let ((extra (if (null? rest) (+ extra 1) 0)))
- (loop rest
- (pr (car l) (indent col2 col) extra pp-item)))))
- ((null? l)
- (out ")" col))
- (else
- (out ")"
- (pr l
- (indent col2 (out "." (indent col2 col)))
- (+ extra 1)
- pp-item)))))))
-
- (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
-
- (define (tail1 rest col1 col2 col3)
- (if (and pp-1 (pair? rest))
- (let* ((val1 (car rest))
- (rest (cdr rest))
- (extra (if (null? rest) (+ extra 1) 0)))
- (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
- (tail2 rest col1 col2 col3)))
-
- (define (tail2 rest col1 col2 col3)
- (if (and pp-2 (pair? rest))
- (let* ((val1 (car rest))
- (rest (cdr rest))
- (extra (if (null? rest) (+ extra 1) 0)))
- (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
- (tail3 rest col1 col2)))
-
- (define (tail3 rest col1 col2)
- (pp-down rest col2 col1 extra pp-3))
-
- (let* ((head (car expr))
- (rest (cdr expr))
- (col* (wr head (out "(" col))))
- (if (and named? (pair? rest))
- (let* ((name (car rest))
- (rest (cdr rest))
- (col** (wr name (out " " col*))))
- (tail1 rest (+ col indent-general) col** (+ col** 1)))
- (tail1 rest (+ col indent-general) col* (+ col* 1)))))
-
- (define (pp-expr-list l col extra)
- (pp-list l col extra pp-expr))
-
- (define (pp-lambda expr col extra)
- (pp-general expr col extra #f pp-expr-list #f pp-expr))
-
- (define (pp-if expr col extra)
- (pp-general expr col extra #f pp-expr #f pp-expr))
-
- (define (pp-cond expr col extra)
- (pp-call expr col extra pp-expr-list))
-
- (define (pp-case expr col extra)
- (pp-general expr col extra #f pp-expr #f pp-expr-list))
-
- (define (pp-and expr col extra)
- (pp-call expr col extra pp-expr))
-
- (define (pp-let expr col extra)
- (let* ((rest (cdr expr))
- (named? (and (pair? rest) (symbol? (car rest)))))
- (pp-general expr col extra named? pp-expr-list #f pp-expr)))
-
- (define (pp-begin expr col extra)
- (pp-general expr col extra #f #f #f pp-expr))
-
- (define (pp-do expr col extra)
- (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
+ (define (pp-list l col extra pp-item)
+ (let ((col (out "(" col)))
+ (pp-down l col col extra pp-item)))
+
+ (define (pp-down l col1 col2 extra pp-item)
+ (let loop ((l l) (col col1))
+ (and col
+ (cond ((pair? l)
+ (let ((rest (cdr l)))
+ (let ((extra (if (null? rest) (+ extra 1) 0)))
+ (loop rest
+ (pr (car l) (indent col2 col) extra pp-item)))))
+ ((null? l)
+ (out ")" col))
+ (else
+ (out ")"
+ (pr l
+ (indent col2 (out "." (indent col2 col)))
+ (+ extra 1)
+ pp-item)))))))
+
+ (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
+
+ (define (tail1 rest col1 col2 col3)
+ (if (and pp-1 (pair? rest))
+ (let* ((val1 (car rest))
+ (rest (cdr rest))
+ (extra (if (null? rest) (+ extra 1) 0)))
+ (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
+ (tail2 rest col1 col2 col3)))
+
+ (define (tail2 rest col1 col2 col3)
+ (if (and pp-2 (pair? rest))
+ (let* ((val1 (car rest))
+ (rest (cdr rest))
+ (extra (if (null? rest) (+ extra 1) 0)))
+ (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
+ (tail3 rest col1 col2)))
+
+ (define (tail3 rest col1 col2)
+ (pp-down rest col2 col1 extra pp-3))
+
+ (let* ((head (car expr))
+ (rest (cdr expr))
+ (col* (wr head (out "(" col))))
+ (if (and named? (pair? rest))
+ (let* ((name (car rest))
+ (rest (cdr rest))
+ (col** (wr name (out " " col*))))
+ (tail1 rest (+ col indent-general) col** (+ col** 1)))
+ (tail1 rest (+ col indent-general) col* (+ col* 1)))))
+
+ (define (pp-expr-list l col extra)
+ (pp-list l col extra pp-expr))
+
+ (define (pp-lambda expr col extra)
+ (pp-general expr col extra #f pp-expr-list #f pp-expr))
+
+ (define (pp-if expr col extra)
+ (pp-general expr col extra #f pp-expr #f pp-expr))
+
+ (define (pp-cond expr col extra)
+ (pp-call expr col extra pp-expr-list))
+
+ (define (pp-case expr col extra)
+ (pp-general expr col extra #f pp-expr #f pp-expr-list))
+
+ (define (pp-and expr col extra)
+ (pp-call expr col extra pp-expr))
+
+ (define (pp-let expr col extra)
+ (let* ((rest (cdr expr))
+ (named? (and (pair? rest) (symbol? (car rest)))))
+ (pp-general expr col extra named? pp-expr-list #f pp-expr)))
+
+ (define (pp-begin expr col extra)
+ (pp-general expr col extra #f #f #f pp-expr))
+
+ (define (pp-do expr col extra)
+ (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
; define formatting style (change these to suit your style)
- (define indent-general 2)
+ (define indent-general 2)
- (define max-call-head-width 5)
+ (define max-call-head-width 5)
- (define max-expr-width 50)
+ (define max-expr-width 50)
- (define (style head)
- (case head
- ((lambda let* letrec define) pp-lambda)
- ((if set!) pp-if)
- ((cond) pp-cond)
- ((case) pp-case)
- ((and or) pp-and)
- ((let) pp-let)
- ((begin) pp-begin)
- ((do) pp-do)
- (else #f)))
+ (define (style head)
+ (case head
+ ((lambda let* letrec define) pp-lambda)
+ ((if set!) pp-if)
+ ((cond) pp-cond)
+ ((case) pp-case)
+ ((and or) pp-and)
+ ((let) pp-let)
+ ((begin) pp-begin)
+ ((do) pp-do)
+ (else #f)))
- (pr obj col 0 pp-expr))
+ (pr obj col 0 pp-expr))
- (if width
- (out (make-string 1 #\newline) (pp obj 0))
- (wr obj 0)))) )
+ (if width
+ (out (make-string 1 #\newline) (pp obj 0))
+ (wr obj 0))))
; (pretty-print obj port) pretty prints 'obj' on 'port'. The current
; output port is used if 'port' is not specified.
@@ -568,9 +561,7 @@
(define fprintf0
(let ((write write)
(newline newline)
- (display display)
- (open-output-string open-output-string)
- (get-output-string get-output-string))
+ (display display) )
(lambda (loc port msg args)
(when port (##sys#check-port port loc))
(let ((out (if (and port (##sys#tty-port? port))
@@ -633,17 +624,14 @@
(fprintf0 'sprintf #f fstr args) )
(define format
- (let ([fprintf fprintf]
- [sprintf sprintf]
- [printf printf] )
- (lambda (fmt-or-dst . args)
- (apply (cond [(not fmt-or-dst) sprintf]
- [(boolean? fmt-or-dst) printf]
- [(string? fmt-or-dst) (set! args (cons fmt-or-dst args)) sprintf]
- [(output-port? fmt-or-dst) (set! args (cons fmt-or-dst args)) fprintf]
- [else
- (##sys#error 'format "illegal destination" fmt-or-dst args)])
- args) ) ) )
+ (lambda (fmt-or-dst . args)
+ (apply (cond [(not fmt-or-dst) sprintf]
+ [(boolean? fmt-or-dst) printf]
+ [(string? fmt-or-dst) (set! args (cons fmt-or-dst args)) sprintf]
+ [(output-port? fmt-or-dst) (set! args (cons fmt-or-dst args)) fprintf]
+ [else
+ (##sys#error 'format "illegal destination" fmt-or-dst args)])
+ args) ) )
(register-feature! 'srfi-28)
diff --git a/files.scm b/files.scm
index 3e8b0d63..b3b14876 100644
--- a/files.scm
+++ b/files.scm
@@ -63,10 +63,8 @@ EOF
;;; Like `delete-file', but does nothing if the file doesn't exist:
(define delete-file*
- (let ([file-exists? file-exists?]
- [delete-file delete-file] )
- (lambda (file)
- (and (file-exists? file) (delete-file file)) ) ) )
+ (lambda (file)
+ (and (file-exists? file) (delete-file file)) ) )
;;; file-copy and file-move : they do what you'd think.
(define (file-copy origfile newfile #!optional (clobber #f) (blocksize 1024))
@@ -113,52 +111,52 @@ EOF
(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)
- (##sys#check-string newfile 'file-move)
- (##sys#check-number blocksize 'file-move)
- (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)
- (condition-case (delete-file origfile)
- (val ()
- (##sys#error (string-append
- "could not remove origfile - "
- 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)))))
- (loop (read-string! blocksize s i) (fx+ d l)))))))
+ (##sys#check-string origfile 'file-move)
+ (##sys#check-string newfile 'file-move)
+ (##sys#check-number blocksize 'file-move)
+ (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)
+ (condition-case (delete-file origfile)
+ (val ()
+ (##sys#error (string-append
+ "could not remove origfile - "
+ 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)))))
+ (loop (read-string! blocksize s i) (fx+ d l)))))))
;;; Pathname operations:
@@ -171,16 +169,15 @@ EOF
(define root-origin)
(define root-directory)
-(let ((string-match string-match))
- (if ##sys#windows-platform
- (let ((rx (regexp "([A-Za-z]:)?([\\/\\\\]).*")))
- (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
- (set! root-origin (lambda (rt) (and rt (cadr rt))))
- (set! root-directory (lambda (rt) (and rt (caddr rt)))) )
- (let ((rx (regexp "([\\/\\\\]).*")))
- (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
- (set! root-origin (lambda (rt) #f))
- (set! root-directory (lambda (rt) (and rt (cadr rt)))) ) ) )
+(if ##sys#windows-platform
+ (let ((rx (regexp "([A-Za-z]:)?([\\/\\\\]).*")))
+ (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
+ (set! root-origin (lambda (rt) (and rt (cadr rt))))
+ (set! root-directory (lambda (rt) (and rt (caddr rt)))) )
+ (let ((rx (regexp "([\\/\\\\]).*")))
+ (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
+ (set! root-origin (lambda (rt) #f))
+ (set! root-directory (lambda (rt) (and rt (cadr rt)))) ) )
(define (absolute-pathname? pn)
(##sys#check-string pn 'absolute-pathname?)
@@ -203,7 +200,6 @@ EOF
(define make-absolute-pathname)
(let ([string-append string-append]
- [absolute-pathname? absolute-pathname?]
[def-pds "/"] )
(define (conc-dirs dirs pds)
@@ -261,78 +257,67 @@ EOF
file ext def-pds) ) ) )
(define decompose-pathname
- (let ((string-match string-match))
- (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
- [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
- [rx1 (regexp patt1)]
- [rx2 (regexp patt2)]
- [strip-pds
- (lambda (dir)
- (and dir
- (if (member dir '("/" "\\"))
- dir
- (chop-pds dir #f) ) ) )] )
- (lambda (pn)
- (##sys#check-string pn 'decompose-pathname)
- (if (fx= 0 (##sys#size pn))
- (values #f #f #f)
- (let ([ms (string-match rx1 pn)])
- (if ms
- (values (strip-pds (cadr ms)) (caddr ms) (car (cddddr ms)))
- (let ([ms (string-match rx2 pn)])
- (if ms
- (values (strip-pds (cadr ms)) (caddr ms) #f)
- (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) ) )
-
-(define pathname-directory)
-(define pathname-file)
-(define pathname-extension)
-(define pathname-strip-directory)
-(define pathname-strip-extension)
-(define pathname-replace-directory)
-(define pathname-replace-file)
-(define pathname-replace-extension)
-(let ([decompose-pathname decompose-pathname])
-
- (set! pathname-directory
- (lambda (pn)
- (let-values ([(dir file ext) (decompose-pathname pn)])
- dir) ) )
-
- (set! pathname-file
- (lambda (pn)
- (let-values ([(dir file ext) (decompose-pathname pn)])
- file) ) )
-
- (set! pathname-extension
- (lambda (pn)
- (let-values ([(dir file ext) (decompose-pathname pn)])
- ext) ) )
-
- (set! pathname-strip-directory
+ (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
+ [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
+ [rx1 (regexp patt1)]
+ [rx2 (regexp patt2)]
+ [strip-pds
+ (lambda (dir)
+ (and dir
+ (if (member dir '("/" "\\"))
+ dir
+ (chop-pds dir #f) ) ) )] )
(lambda (pn)
- (let-values ([(dir file ext) (decompose-pathname pn)])
- (make-pathname #f file ext) ) ) )
-
- (set! pathname-strip-extension
- (lambda (pn)
- (let-values ([(dir file ext) (decompose-pathname pn)])
- (make-pathname dir file) ) ) )
-
- (set! pathname-replace-directory
- (lambda (pn dir)
- (let-values ([(_ file ext) (decompose-pathname pn)])
- (make-pathname dir file ext) ) ) )
-
- (set! pathname-replace-file
- (lambda (pn file)
- (let-values ([(dir _ ext) (decompose-pathname pn)])
- (make-pathname dir file ext) ) ) )
-
- (set! pathname-replace-extension
- (lambda (pn ext)
- (let-values ([(dir file _) (decompose-pathname pn)])
- (make-pathname dir file ext) ) ) ) )
+ (##sys#check-string pn 'decompose-pathname)
+ (if (fx= 0 (##sys#size pn))
+ (values #f #f #f)
+ (let ([ms (string-match rx1 pn)])
+ (if ms
+ (values (strip-pds (cadr ms)) (caddr ms) (car (cddddr ms)))
+ (let ([ms (string-match rx2 pn)])
+ (if ms
+ (values (strip-pds (cadr ms)) (caddr ms) #f)
+ (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) )
+
+(define pathname-directory
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ dir) ) )
+
+(define pathname-file
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ file) ) )
+
+(define pathname-extension
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ ext) ) )
+
+(define pathname-strip-directory
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ (make-pathname #f file ext) ) ) )
+
+(define pathname-strip-extension
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ (make-pathname dir file) ) ) )
+
+(define pathname-replace-directory
+ (lambda (pn dir)
+ (let-values ([(_ file ext) (decompose-pathname pn)])
+ (make-pathname dir file ext) ) ) )
+
+(define pathname-replace-file
+ (lambda (pn file)
+ (let-values ([(dir _ ext) (decompose-pathname pn)])
+ (make-pathname dir file ext) ) ) )
+
+(define pathname-replace-extension
+ (lambda (pn ext)
+ (let-values ([(dir file _) (decompose-pathname pn)])
+ (make-pathname dir file ext) ) ) )
(define create-temporary-file)
(define create-temporary-directory)
@@ -385,10 +370,7 @@ EOF
;;; normalize pathname for a particular platform
(define normalize-pathname
- (let ((open-output-string open-output-string)
- (get-output-string get-output-string)
- (get-environment-variable get-environment-variable)
- (reverse reverse)
+ (let ((reverse reverse)
(display display)
(bldplt (if (memq (build-platform) '(msvc mingw32)) 'windows 'unix)) )
(define (addpart part parts)
@@ -446,10 +428,9 @@ EOF
;; does arg check
(define split-directory
- (let ((string-split string-split) )
- (lambda (loc dir keep?)
- (##sys#check-string dir loc)
- (string-split dir "/\\" keep?) ) ) )
+ (lambda (loc dir keep?)
+ (##sys#check-string dir loc)
+ (string-split dir "/\\" keep?) ) )
;; Directory string or list only contains path-separators
;; and/or current-directory (".") names.
diff --git a/library.scm b/library.scm
index c4b99b0d..a6961e6f 100644
--- a/library.scm
+++ b/library.scm
@@ -1799,26 +1799,25 @@ EOF
(thunk (##sys#expand-home-path name)) )
(define ##sys#expand-home-path
- (let ((get-environment-variable get-environment-variable))
- (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)))
- (##sys#string-append (or (get-environment-variable "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 (get-environment-variable (##sys#substring path 1 i)) "")
- (##sys#substring path i len))
- (loop (fx+ i 1)) ) ) ) ) )
- (else path) )
- "") ) ) ) )
+ (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)))
+ (##sys#string-append (or (get-environment-variable "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 (get-environment-variable (##sys#substring path 1 i)) "")
+ (##sys#substring path i len))
+ (loop (fx+ i 1)) ) ) ) ) )
+ (else path) )
+ "") ) ) )
(define open-input-file)
(define open-output-file)
@@ -2114,19 +2113,13 @@ EOF
[list? list?]
[string-append string-append]
[string string]
- [char-name char-name]
- [csp case-sensitive]
- [ksp keyword-style]
- [psp parentheses-synonyms]
- [sep symbol-escape]
- [crt current-read-table]
[kwprefix (string (integer->char 0))])
(lambda (port infohandler)
- (let ([csp (csp)]
- [ksp (ksp)]
- [psp (psp)]
- [sep (sep)]
- [crt (crt)]
+ (let ([csp (case-sensitive)]
+ [ksp (keyword-style)]
+ [psp (parentheses-synonyms)]
+ [sep (symbol-escape)]
+ [crt (current-read-table)]
[rat-flag #f]
; set below - needs more state to make a decision
(terminating-characters '(#\, #\; #\( #\) #\' #\" #\[ #\] #\{ #\}))
@@ -2794,22 +2787,18 @@ EOF
(define ##sys#print-exit (make-parameter #f))
(define ##sys#print
- (let ([char-name char-name]
- [csp case-sensitive]
- [ksp keyword-style]
- [cpp current-print-length]
- [string-append string-append])
+ (let ([string-append string-append])
(lambda (x readable port)
(##sys#check-port-mode port #f)
- (let ([csp (csp)]
- [ksp (ksp)]
+ (let ([csp (case-sensitive)]
+ [ksp (keyword-style)]
[length-limit (print-length-limit)]
[special-characters '(#\( #\) #\, #\[ #\] #\{ #\} #\' #\" #\; #\ #\` #\|)] )
(define (outstr port str)
(if length-limit
(let* ((len (##sys#size str))
- (cpp0 (cpp))
+ (cpp0 (current-print-length))
(cpl (fx+ cpp0 len)) )
(if (fx>= cpl length-limit)
(cond ((fx> len 3)
@@ -2818,15 +2807,15 @@ EOF
(outstr0 port "...") ) )
(else (outstr0 port str)) )
(outstr0 port str) )
- (cpp cpl) )
+ (current-print-length cpl) )
(outstr0 port str) ) )
(define (outstr0 port str)
((##sys#slot (##sys#slot port 2) 3) port str) )
(define (outchr port chr)
- (let ((cpp0 (cpp)))
- (cpp (fx+ cpp0 1))
+ (let ((cpp0 (current-print-length)))
+ (current-print-length (fx+ cpp0 1))
(when (and length-limit (fx>= cpp0 length-limit))
(outstr0 port "...")
((##sys#print-exit) #t) )
@@ -3308,8 +3297,7 @@ EOF
;;; Feature identifiers:
(define ##sys#->feature-id
- (let ([string->keyword string->keyword]
- [keyword? keyword?] )
+ (let ()
(define (err . args)
(apply ##sys#signal-hook #:type-error "bad argument type - not a valid feature identifer" args) )
(define (prefix s)
@@ -3465,10 +3453,7 @@ EOF
(define ##sys#error-handler
(make-parameter
- (let ([string-append string-append]
- [open-output-string open-output-string]
- [get-output-string get-output-string]
- [print-call-chain print-call-chain] )
+ (let ([string-append string-append])
(lambda (msg . args)
(##sys#error-handler (lambda args (##core#inline "C_halt" "error in error")))
(cond ((##sys#fudge 4)
@@ -3528,14 +3513,13 @@ EOF
(define force-finalizers (make-parameter #t))
(define ##sys#cleanup-before-exit
- (let ([ffp force-finalizers])
- (lambda ()
- (when (##sys#fudge 37)
- (##sys#print "\n" #f ##sys#standard-error)
- (##sys#dump-heap-state))
- (when (##sys#fudge 13)
- (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-error) )
- (when (ffp) (##sys#force-finalizers)) ) ) )
+ (lambda ()
+ (when (##sys#fudge 37)
+ (##sys#print "\n" #f ##sys#standard-error)
+ (##sys#dump-heap-state))
+ (when (##sys#fudge 13)
+ (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-error) )
+ (when (force-finalizers) (##sys#force-finalizers)) ) )
(define (on-exit thunk)
(set! ##sys#cleanup-before-exit
@@ -3708,9 +3692,8 @@ EOF
[else (car err-def)] ) ) ) ) ) )
(define get-condition-property
- (let ((condition-property-accessor condition-property-accessor))
- (lambda (c kind prop . err-def)
- ((condition-property-accessor kind prop err-def) c))))
+ (lambda (c kind prop . err-def)
+ ((condition-property-accessor kind prop err-def) c)))
;;; Error hook (called by runtime-system):
@@ -4021,8 +4004,6 @@ EOF
(set! ##sys#user-read-hook
(let ([old ##sys#user-read-hook]
- [open-output-string open-output-string]
- [get-output-string get-output-string]
[reverse reverse]
[read read]
[display display] )
@@ -4174,26 +4155,24 @@ EOF
(define ##sys#set-finalizer! (##core#primitive "C_register_finalizer"))
(define set-finalizer!
- (let ((print print))
- (lambda (x y)
- (when (fx> (##sys#fudge 26) _max_pending_finalizers)
- (if (##core#inline "C_resize_pending_finalizers" (fx* 2 _max_pending_finalizers))
- (begin
- (set! ##sys#pending-finalizers (##sys#grow-vector ##sys#pending-finalizers
- (fx+ (fx* 2 _max_pending_finalizers) 1)
- (##core#undefined)))
- (when (##sys#fudge 13)
- (print "[debug] too many finalizers (" (##sys#fudge 26)
- "), resized max finalizers to " _max_pending_finalizers "...") ) )
- (begin
- (when (##sys#fudge 13)
- (print "[debug] too many finalizers (" (##sys#fudge 26) "), forcing ...") )
- (##sys#force-finalizers) ) ) )
- (##sys#set-finalizer! x y) ) ) )
+ (lambda (x y)
+ (when (fx> (##sys#fudge 26) _max_pending_finalizers)
+ (if (##core#inline "C_resize_pending_finalizers" (fx* 2 _max_pending_finalizers))
+ (begin
+ (set! ##sys#pending-finalizers (##sys#grow-vector ##sys#pending-finalizers
+ (fx+ (fx* 2 _max_pending_finalizers) 1)
+ (##core#undefined)))
+ (when (##sys#fudge 13)
+ (print "[debug] too many finalizers (" (##sys#fudge 26)
+ "), resized max finalizers to " _max_pending_finalizers "...") ) )
+ (begin
+ (when (##sys#fudge 13)
+ (print "[debug] too many finalizers (" (##sys#fudge 26) "), forcing ...") )
+ (##sys#force-finalizers) ) ) )
+ (##sys#set-finalizer! x y) ) )
(define ##sys#run-pending-finalizers
(let ([vector-fill! vector-fill!]
- [print print]
[working #f] )
(lambda (state)
(unless working
@@ -4283,10 +4262,9 @@ EOF
;;; Internal string-reader:
(define ##sys#read-from-string
- (let ([open-input-string open-input-string])
- (lambda (s)
- (let ([i (open-input-string s)])
- (read i) ) ) ) )
+ (lambda (s)
+ (let ([i (open-input-string s)])
+ (read i) ) ) )
;;; Convenient error printing:
@@ -4542,11 +4520,10 @@ EOF
s) )
(define procedure-information
- (let ((open-input-string open-input-string))
- (lambda (x)
- (##sys#check-closure x 'procedure-information)
- (and-let* ((info (##sys#lambda-info x)))
- (##sys#read (open-input-string (##sys#lambda-info->string info)) #f) ) ) ) )
+ (lambda (x)
+ (##sys#check-closure x 'procedure-information)
+ (and-let* ((info (##sys#lambda-info x)))
+ (##sys#read (open-input-string (##sys#lambda-info->string info)) #f) ) ) )
;;; SRFI-17
diff --git a/manual/Unit data-structures b/manual/Unit data-structures
index 217b2857..80cc7e48 100644
--- a/manual/Unit data-structures
+++ b/manual/Unit data-structures
@@ -579,13 +579,6 @@ arguments swapped:
Returns its sole argument {{X}}.
-==== project
-
-<procedure>(project N)</procedure>
-
-Returns a procedure that returns its {{N}}th argument (starting from 0).
-
-
==== list-of?
<procedure>(list-of? PRED)</procedure>
diff --git a/ports.scm b/ports.scm
index 38582a24..88e9fe46 100644
--- a/ports.scm
+++ b/ports.scm
@@ -186,32 +186,26 @@
;;; Extended string-port operations:
(define call-with-input-string
- (let ([open-input-string open-input-string])
- (lambda (str proc)
- (let ((in (open-input-string str)))
- (proc in) ) ) ) )
+ (lambda (str proc)
+ (let ((in (open-input-string str)))
+ (proc in) ) ) )
(define call-with-output-string
- (let ((open-output-string open-output-string)
- (get-output-string get-output-string) )
- (lambda (proc)
- (let ((out (open-output-string)))
- (proc out)
- (get-output-string out) ) ) ) )
+ (lambda (proc)
+ (let ((out (open-output-string)))
+ (proc out)
+ (get-output-string out) ) ) )
(define with-input-from-string
- (let ((open-input-string open-input-string))
- (lambda (str thunk)
- (fluid-let ([##sys#standard-input (open-input-string str)])
- (thunk) ) ) ) )
+ (lambda (str thunk)
+ (fluid-let ([##sys#standard-input (open-input-string str)])
+ (thunk) ) ) )
(define with-output-to-string
- (let ([open-output-string open-output-string]
- [get-output-string get-output-string] )
- (lambda (thunk)
- (fluid-let ([##sys#standard-output (open-output-string)])
- (thunk)
- (get-output-string ##sys#standard-output) ) ) ) )
+ (lambda (thunk)
+ (fluid-let ([##sys#standard-output (open-output-string)])
+ (thunk)
+ (get-output-string ##sys#standard-output) ) ) )
;;; Custom ports:
diff --git a/posix-common.scm b/posix-common.scm
index 55f9f488..f4b771f5 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -233,64 +233,52 @@ EOF
;;; Filename globbing:
(define glob
- (let ((regexp regexp)
- (string-match string-match)
- (glob->regexp glob->regexp)
- (directory directory)
- (make-pathname make-pathname)
- (decompose-pathname decompose-pathname) )
- (lambda paths
- (let conc-loop ((paths paths))
- (if (null? paths)
- '()
- (let ((path (car paths)))
- (let-values (((dir fil ext) (decompose-pathname path)))
- (let* ((patt (glob->regexp (make-pathname #f (or fil "*") ext)))
- (rx (regexp patt)))
- (let loop ((fns (directory (or dir ".") #t)))
- (cond ((null? fns) (conc-loop (cdr paths)))
- ((string-match rx (car fns))
- => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) )
- (else (loop (cdr fns))) ) ) ) ) ) ) ) ) ) )
+ (lambda paths
+ (let conc-loop ((paths paths))
+ (if (null? paths)
+ '()
+ (let ((path (car paths)))
+ (let-values (((dir fil ext) (decompose-pathname path)))
+ (let* ((patt (glob->regexp (make-pathname #f (or fil "*") ext)))
+ (rx (regexp patt)))
+ (let loop ((fns (directory (or dir ".") #t)))
+ (cond ((null? fns) (conc-loop (cdr paths)))
+ ((string-match rx (car fns))
+ => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) )
+ (else (loop (cdr fns))) ) ) ) ) ) ) ) ) )
;;; Find matching files:
(define ##sys#find-files
- (let ((glob glob)
- (string-match string-match)
- (make-pathname make-pathname)
- (pathname-file pathname-file)
- (symbolic-link? symbolic-link?)
- (directory? directory?) )
- (lambda (dir pred action id limit follow dot loc)
- (##sys#check-string dir loc)
- (let* ((depth 0)
- (lproc
- (cond ((not limit) (lambda _ #t))
- ((fixnum? limit) (lambda _ (fx< depth limit)))
- (else limit) ) )
- (pproc
- (if (or (string? pred) (regexp? pred))
- (let ((pred (regexp pred))) ; force compilation
- (lambda (x) (string-match pred x)))
- pred) ) )
- (let loop ((fs (glob (make-pathname dir (if dot "?*" "*"))))
- (r id) )
- (if (null? fs)
- r
- (let ((f (##sys#slot fs 0))
- (rest (##sys#slot fs 1)) )
- (cond ((directory? f)
- (cond ((member (pathname-file f) '("." "..")) (loop rest r))
- ((lproc f)
- (loop rest
- (fluid-let ((depth (fx+ depth 1)))
- (loop (glob (make-pathname f "*"))
- (if (pproc f) (action f r) r)) ) ) )
- (else (loop rest (if (pproc f) (action f r) r))) ) )
- ((pproc f) (loop rest (action f r)))
- (else (loop rest r)) ) ) ) ) ) ) ) )
+ (lambda (dir pred action id limit follow dot loc)
+ (##sys#check-string dir loc)
+ (let* ((depth 0)
+ (lproc
+ (cond ((not limit) (lambda _ #t))
+ ((fixnum? limit) (lambda _ (fx< depth limit)))
+ (else limit) ) )
+ (pproc
+ (if (or (string? pred) (regexp? pred))
+ (let ((pred (regexp pred))) ; force compilation
+ (lambda (x) (string-match pred x)))
+ pred) ) )
+ (let loop ((fs (glob (make-pathname dir (if dot "?*" "*"))))
+ (r id) )
+ (if (null? fs)
+ r
+ (let ((f (##sys#slot fs 0))
+ (rest (##sys#slot fs 1)) )
+ (cond ((directory? f)
+ (cond ((member (pathname-file f) '("." "..")) (loop rest r))
+ ((lproc f)
+ (loop rest
+ (fluid-let ((depth (fx+ depth 1)))
+ (loop (glob (make-pathname f "*"))
+ (if (pproc f) (action f r) r)) ) ) )
+ (else (loop rest (if (pproc f) (action f r) r))) ) )
+ ((pproc f) (loop rest (action f r)))
+ (else (loop rest r)) ) ) ) ) ) ) )
(define (find-files dir . args)
(cond ((or (null? args) (not (keyword? (car args))))
diff --git a/posixunix.scm b/posixunix.scm
index e17f6b3e..2260c671 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -748,21 +748,19 @@ EOF
(posix-error #:file-error loc "cannot create directory" name)) )
(define create-directory
- (let ((decompose-pathname decompose-pathname)
- (pathname-directory pathname-directory) )
- (lambda (name #!optional parents?)
- (##sys#check-string name 'create-directory)
- (let ((name (##sys#expand-home-path name)))
- (unless (or (fx= 0 (##sys#size name))
- (file-exists? name))
- (if parents?
- (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
- (if file (make-pathname dir file ext) dir))))
- (when (and dir (not (directory? dir)))
- (loop (pathname-directory dir))
- (*create-directory 'create-directory dir)) )
- (*create-directory 'create-directory name) ) )
- name))))
+ (lambda (name #!optional parents?)
+ (##sys#check-string name 'create-directory)
+ (let ((name (##sys#expand-home-path name)))
+ (unless (or (fx= 0 (##sys#size name))
+ (file-exists? name))
+ (if parents?
+ (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
+ (if file (make-pathname dir file ext) dir))))
+ (when (and dir (not (directory? dir)))
+ (loop (pathname-directory dir))
+ (*create-directory 'create-directory dir)) )
+ (*create-directory 'create-directory name) ) )
+ name)))
(define change-directory
(lambda (name)
@@ -814,46 +812,44 @@ EOF
r) ) )
(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) ) ) ) ) )
(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
@@ -1374,186 +1370,182 @@ EOF
fd) ) )
(define ##sys#custom-input-port
- (let ([make-input-port make-input-port]
- [set-port-name! set-port-name!] )
- (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f))
- (when nonblocking? (##sys#file-nonblocking! fd) )
- (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))]
- [buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
- [buflen 0]
- [bufpos 0] )
- (let (
+ (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f))
+ (when nonblocking? (##sys#file-nonblocking! fd) )
+ (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))]
+ [buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
+ [buflen 0]
+ [bufpos 0] )
+ (let (
[ready?
- (lambda ()
- (let ((res (##sys#file-select-one fd)))
- (if (fx= -1 res)
- (if (fx= _errno _ewouldblock)
- #f
- (posix-error #:file-error loc "cannot select" fd nam))
- (fx= 1 res))))]
+ (lambda ()
+ (let ((res (##sys#file-select-one fd)))
+ (if (fx= -1 res)
+ (if (fx= _errno _ewouldblock)
+ #f
+ (posix-error #:file-error loc "cannot select" fd nam))
+ (fx= 1 res))))]
[peek
- (lambda ()
- (if (fx>= bufpos buflen)
- #!eof
- (##core#inline "C_subchar" buf bufpos)) )]
+ (lambda ()
+ (if (fx>= bufpos buflen)
+ #!eof
+ (##core#inline "C_subchar" buf bufpos)) )]
[fetch
- (lambda ()
- (when (fx>= bufpos buflen)
- (let loop ()
- (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
- (cond [(fx= cnt -1)
- (if (fx= _errno _ewouldblock)
- (begin
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
- (##sys#thread-yield!)
- (loop) )
- (posix-error #:file-error loc "cannot read" fd nam) )]
- [(and more? (fx= cnt 0))
- ; When "more" keep trying, otherwise read once more
- ; to guard against race conditions
- (if (more?)
- (begin
- (##sys#thread-yield!)
- (loop) )
- (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
- (when (fx= cnt -1)
- (if (fx= _errno _ewouldblock)
- (set! cnt 0)
- (posix-error #:file-error loc "cannot read" fd nam) ) )
- (set! buflen cnt)
- (set! bufpos 0) ) )]
- [else
- (set! buflen cnt)
- (set! bufpos 0)]) ) ) ) )] )
- (letrec (
- [this-port
- (make-input-port
- (lambda () ; read-char
- (fetch)
- (let ([ch (peek)])
- #; ; Allow increment since overflow is far, far away
- (unless (eof-object? ch) (set! bufpos (fx+ bufpos 1)))
- (set! bufpos (fx+ bufpos 1))
- ch ) )
- (lambda () ; char-ready?
- (or (fx< bufpos buflen)
- (ready?)) )
- (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) )
- (on-close) ) )
- (lambda () ; peek-char
- (fetch)
- (peek) )
- (lambda (port n dest start) ; read-string!
- (let loop ([n (or n (fx- (##sys#size dest) start))] [m 0] [start start])
- (cond [(eq? 0 n) m]
- [(fx< bufpos buflen)
+ (lambda ()
+ (when (fx>= bufpos buflen)
+ (let loop ()
+ (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
+ (cond [(fx= cnt -1)
+ (if (fx= _errno _ewouldblock)
+ (begin
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
+ (##sys#thread-yield!)
+ (loop) )
+ (posix-error #:file-error loc "cannot read" fd nam) )]
+ [(and more? (fx= cnt 0))
+ ; When "more" keep trying, otherwise read once more
+ ; to guard against race conditions
+ (if (more?)
+ (begin
+ (##sys#thread-yield!)
+ (loop) )
+ (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
+ (when (fx= cnt -1)
+ (if (fx= _errno _ewouldblock)
+ (set! cnt 0)
+ (posix-error #:file-error loc "cannot read" fd nam) ) )
+ (set! buflen cnt)
+ (set! bufpos 0) ) )]
+ [else
+ (set! buflen cnt)
+ (set! bufpos 0)]) ) ) ) )] )
+ (letrec (
+ [this-port
+ (make-input-port
+ (lambda () ; read-char
+ (fetch)
+ (let ([ch (peek)])
+ #; ; Allow increment since overflow is far, far away
+ (unless (eof-object? ch) (set! bufpos (fx+ bufpos 1)))
+ (set! bufpos (fx+ bufpos 1))
+ ch ) )
+ (lambda () ; char-ready?
+ (or (fx< bufpos buflen)
+ (ready?)) )
+ (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) )
+ (on-close) ) )
+ (lambda () ; peek-char
+ (fetch)
+ (peek) )
+ (lambda (port n dest start) ; read-string!
+ (let loop ([n (or n (fx- (##sys#size dest) start))] [m 0] [start start])
+ (cond [(eq? 0 n) m]
+ [(fx< bufpos buflen)
(let* ([rest (fx- buflen bufpos)]
[n2 (if (fx< n rest) n rest)])
(##core#inline "C_substring_copy" buf dest bufpos (fx+ bufpos n2) start)
(set! bufpos (fx+ bufpos n2))
(loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
- [else
+ [else
(fetch)
(if (eq? 0 buflen)
m
(loop n m start) ) ] ) ) )
- (lambda (port limit) ; read-line
- (let loop ([str #f])
- (let ([bumper
- (lambda (cur ptr)
- (let* ([cnt (fx- cur bufpos)]
- [dest
- (if (eq? 0 cnt)
- (or str "")
- (let ([dest (##sys#make-string cnt)])
- (##core#inline "C_substring_copy"
- buf dest bufpos cur 0)
- (##sys#setislot port 5
- (fx+ (##sys#slot port 5) cnt))
- (if str
- (##sys#string-append str dest)
- dest ) ) ) ] )
- (set! bufpos ptr)
- (cond [(eq? cur ptr) ; no EOL encountered
+ (lambda (port limit) ; read-line
+ (let loop ([str #f])
+ (let ([bumper
+ (lambda (cur ptr)
+ (let* ([cnt (fx- cur bufpos)]
+ [dest
+ (if (eq? 0 cnt)
+ (or str "")
+ (let ([dest (##sys#make-string cnt)])
+ (##core#inline "C_substring_copy"
+ buf dest bufpos cur 0)
+ (##sys#setislot port 5
+ (fx+ (##sys#slot port 5) cnt))
+ (if str
+ (##sys#string-append str dest)
+ dest ) ) ) ] )
+ (set! bufpos ptr)
+ (cond [(eq? cur ptr) ; no EOL encountered
(fetch)
(values dest (fx< bufpos buflen)) ]
- [else ; at EOL
- (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
- (##sys#setislot port 5 0)
- (values dest #f) ] ) ) ) ] )
- (cond [(fx< bufpos buflen)
+ [else ; at EOL
+ (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
+ (##sys#setislot port 5 0)
+ (values dest #f) ] ) ) ) ] )
+ (cond [(fx< bufpos buflen)
(let-values ([(dest cont?)
(##sys#scan-buffer-line buf buflen bufpos bumper)])
(if cont?
(loop dest)
dest ) ) ]
- [else
+ [else
(fetch)
(if (fx< bufpos buflen)
(loop str)
#!eof) ] ) ) ) ) ) ] )
- (set-port-name! this-port nam)
- this-port ) ) ) ) ) )
+ (set-port-name! this-port nam)
+ this-port ) ) ) ) )
(define ##sys#custom-output-port
- (let ([make-output-port make-output-port]
- [set-port-name! set-port-name!] )
- (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void))
- (when nonblocking? (##sys#file-nonblocking! fd) )
+ (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void))
+ (when nonblocking? (##sys#file-nonblocking! fd) )
+ (letrec (
+ [poke
+ (lambda (str len)
+ (let ([cnt (##core#inline "C_write" fd str len)])
+ (cond [(fx= -1 cnt)
+ (if (fx= _errno _ewouldblock)
+ (begin
+ (##sys#thread-yield!)
+ (poke str len) )
+ (posix-error loc #:file-error "cannot write" fd nam) ) ]
+ [(fx< cnt len)
+ (poke (##sys#substring str cnt len) (fx- len cnt)) ] ) ) )]
+ [store
+ (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])
+ (if (fx= 0 bufsiz)
+ (lambda (str)
+ (when str
+ (poke str (##sys#size str)) ) )
+ (let ([buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
+ [bufpos 0])
+ (lambda (str)
+ (if str
+ (let loop ([rem (fx- bufsiz bufpos)] [start 0] [len (##sys#size str)])
+ (cond [(fx= 0 rem)
+ (poke buf bufsiz)
+ (set! bufpos 0)
+ (loop bufsiz 0 len)]
+ [(fx< rem len)
+ (##core#inline "C_substring_copy" str buf start rem bufpos)
+ (loop 0 rem (fx- len rem))]
+ [else
+ (##core#inline "C_substring_copy" str buf start len bufpos)
+ (set! bufpos (fx+ bufpos len))] ) )
+ (when (fx< 0 bufpos)
+ (poke buf bufpos) ) ) ) ) ) )])
(letrec (
- [poke
- (lambda (str len)
- (let ([cnt (##core#inline "C_write" fd str len)])
- (cond [(fx= -1 cnt)
- (if (fx= _errno _ewouldblock)
- (begin
- (##sys#thread-yield!)
- (poke str len) )
- (posix-error loc #:file-error "cannot write" fd nam) ) ]
- [(fx< cnt len)
- (poke (##sys#substring str cnt len) (fx- len cnt)) ] ) ) )]
- [store
- (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])
- (if (fx= 0 bufsiz)
- (lambda (str)
- (when str
- (poke str (##sys#size str)) ) )
- (let ([buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
- [bufpos 0])
- (lambda (str)
- (if str
- (let loop ([rem (fx- bufsiz bufpos)] [start 0] [len (##sys#size str)])
- (cond [(fx= 0 rem)
- (poke buf bufsiz)
- (set! bufpos 0)
- (loop bufsiz 0 len)]
- [(fx< rem len)
- (##core#inline "C_substring_copy" str buf start rem bufpos)
- (loop 0 rem (fx- len rem))]
- [else
- (##core#inline "C_substring_copy" str buf start len bufpos)
- (set! bufpos (fx+ bufpos len))] ) )
- (when (fx< 0 bufpos)
- (poke buf bufpos) ) ) ) ) ) )])
- (letrec (
- [this-port
- (make-output-port
- (lambda (str) ; write-string
- (store str) )
- (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) )
- (on-close) ) )
- (lambda () ; flush
- (store #f) ) )] )
- (set-port-name! this-port nam)
- this-port ) ) ) ) )
+ [this-port
+ (make-output-port
+ (lambda (str) ; write-string
+ (store str) )
+ (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) )
+ (on-close) ) )
+ (lambda () ; flush
+ (store #f) ) )] )
+ (set-port-name! this-port nam)
+ this-port ) ) ) )
;;; Other file operations:
@@ -1949,15 +1941,13 @@ EOF
(list "-c" cmdlin) )
(define process-run
- (let ([process-fork process-fork]
- [process-execute process-execute])
- (lambda (f . args)
- (let ([args (if (pair? args) (car args) #f)]
- [pid (process-fork)] )
- (cond [(not (eq? 0 pid)) pid]
- [args (process-execute f args)]
- [else
- (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) ) )
+ (lambda (f . args)
+ (let ([args (if (pair? args) (car args) #f)]
+ [pid (process-fork)] )
+ (cond [(not (eq? 0 pid)) pid]
+ [args (process-execute f args)]
+ [else
+ (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) )
;;; Run subprocess connected with pipes:
@@ -1980,12 +1970,6 @@ EOF
(define ##sys#process
(let (
- [create-pipe create-pipe]
- [process-wait process-wait]
- [process-fork process-fork]
- [process-execute process-execute]
- [duplicate-fileno duplicate-fileno]
- [file-close file-close]
[replace-fd
(lambda (loc fd stdfd)
(unless (fx= stdfd fd)
diff --git a/posixwin.scm b/posixwin.scm
index 9dee8ede..db4dc9f0 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1622,7 +1622,6 @@ EOF
(define $exec-setup
(let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
[setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
- [pathname-strip-directory pathname-strip-directory]
[build-exec-argvec
(lambda (loc lst argvec-setter idx)
(if lst
@@ -1678,13 +1677,11 @@ EOF
(list "/c" cmdlin) )
(define process-run
- (let ([process-spawn process-spawn]
- [get-environment-variable get-environment-variable] )
- (lambda (f . args)
- (let ([args (if (pair? args) (car args) #f)])
- (if args
- (process-spawn spawn/nowait f args)
- (process-spawn spawn/nowait (##sys#shell-command) (##sys#shell-command-arguments f)) ) ) ) ) )
+ (lambda (f . args)
+ (let ([args (if (pair? args) (car args) #f)])
+ (if args
+ (process-spawn spawn/nowait f args)
+ (process-spawn spawn/nowait (##sys#shell-command) (##sys#shell-command-arguments f)) ) ) ) )
;;; Run subprocess connected with pipes:
(define-foreign-variable _rdbuf char "C_rdbuf")
diff --git a/srfi-18.scm b/srfi-18.scm
index cfae1e46..d9ad0bf0 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -69,7 +69,7 @@
(define (seconds->time n)
(##sys#check-number n 'seconds->time)
- (##sys#make-structure 'time (fp* (##sys#exact->inexact n) 1000)))
+ (##sys#make-structure 'time (fp* (##sys#exact->inexact n) 1000.0)))
(define (milliseconds->time nms) ; DEPRECATED
(##sys#check-number nms 'milliseconds->time)
@@ -107,24 +107,23 @@
;;; Threads:
(define make-thread
- (let ((gensym gensym))
- (lambda (thunk . name)
- (let ((thread
- (##sys#make-thread
- #f
- 'created
- (if (pair? name) (##sys#slot name 0) (gensym 'thread))
- (##sys#slot ##sys#current-thread 9) ) ) )
- (##sys#setslot
- thread 1
- (lambda ()
- (##sys#call-with-values
- thunk
- (lambda results
- (##sys#setslot thread 2 results)
- (##sys#thread-kill! thread 'dead)
- (##sys#schedule) ) ) ) )
- thread) ) ) )
+ (lambda (thunk . name)
+ (let ((thread
+ (##sys#make-thread
+ #f
+ 'created
+ (if (pair? name) (##sys#slot name 0) (gensym 'thread))
+ (##sys#slot ##sys#current-thread 9) ) ) )
+ (##sys#setslot
+ thread 1
+ (lambda ()
+ (##sys#call-with-values
+ thunk
+ (lambda results
+ (##sys#setslot thread 2 results)
+ (##sys#thread-kill! thread 'dead)
+ (##sys#schedule) ) ) ) )
+ thread) ) )
(define (thread? x) (##sys#structure? x 'thread))
(define (current-thread) ##sys#current-thread)
@@ -155,16 +154,15 @@
(##sys#slot x 6) )
(define thread-start!
- (let ([make-thread make-thread])
- (lambda (thread)
- (if (procedure? thread)
- (set! thread (make-thread thread))
- (##sys#check-structure thread 'thread 'thread-start!) )
- (unless (eq? 'created (##sys#slot thread 3))
- (##sys#error 'thread-start! "thread cannot be started a second time" thread) )
- (##sys#setslot thread 3 'ready)
- (##sys#add-to-ready-queue thread)
- thread) ) )
+ (lambda (thread)
+ (if (procedure? thread)
+ (set! thread (make-thread thread))
+ (##sys#check-structure thread 'thread 'thread-start!) )
+ (unless (eq? 'created (##sys#slot thread 3))
+ (##sys#error 'thread-start! "thread cannot be started a second time" thread) )
+ (##sys#setslot thread 3 'ready)
+ (##sys#add-to-ready-queue thread)
+ thread) )
(define thread-yield! ##sys#thread-yield!) ;In library.scm
@@ -244,11 +242,10 @@
(define (mutex? x) (##sys#structure? x 'mutex))
(define make-mutex
- (let ((gensym gensym))
- (lambda id
- (let* ((id (if (pair? id) (car id) (gensym 'mutex)))
- (m (##sys#make-mutex id ##sys#current-thread)) )
- m) ) ) )
+ (lambda id
+ (let* ((id (if (pair? id) (car id) (gensym 'mutex)))
+ (m (##sys#make-mutex id ##sys#current-thread)) )
+ m) ) )
(define (mutex-name x)
(##sys#check-structure x 'mutex 'mutex-name)
@@ -378,15 +375,14 @@
;;; Condition variables:
(define make-condition-variable
- (let ([gensym gensym])
- (lambda name
- (##sys#make-structure
- 'condition-variable
- (if (pair? name) ; #1 name
- (car name)
- (gensym 'condition-variable) )
- '() ; #2 list of waiting threads
- (##core#undefined) ) ) ) ) ; #3 specific
+ (lambda name
+ (##sys#make-structure
+ 'condition-variable
+ (if (pair? name) ; #1 name
+ (car name)
+ (gensym 'condition-variable) )
+ '() ; #2 list of waiting threads
+ (##core#undefined) ) ) ) ; #3 specific
(define (condition-variable? x)
(##sys#structure? x 'condition-variable) )
@@ -455,8 +451,7 @@
(unless (eq? (build-platform) 'msvc)
(set! ##sys#read-prompt-hook
- (let ([old ##sys#read-prompt-hook]
- [thread-yield! thread-yield!] )
+ (let ([old ##sys#read-prompt-hook])
(lambda ()
(when (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input))
(old)
diff --git a/srfi-4.scm b/srfi-4.scm
index b5f4371b..166861e5 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -263,7 +263,6 @@ EOF
[ext-free
(foreign-lambda* void ([scheme-object bv])
"C_free((void *)C_block_item(bv, 1));") ]
- [set-finalizer! set-finalizer!]
[alloc
(lambda (loc len ext?)
(if ext?
@@ -427,36 +426,28 @@ EOF
;;; More constructors:
(define u8vector
- (let ((list->u8vector list->u8vector))
- (lambda xs (list->u8vector xs)) ) )
+ (lambda xs (list->u8vector xs)) )
(define s8vector
- (let ((list->s8vector list->s8vector))
- (lambda xs (list->s8vector xs)) ) )
+ (lambda xs (list->s8vector xs)) )
(define u16vector
- (let ((list->u16vector list->u16vector))
- (lambda xs (list->u16vector xs)) ) )
+ (lambda xs (list->u16vector xs)) )
(define s16vector
- (let ((list->s16vector list->s16vector))
- (lambda xs (list->s16vector xs)) ) )
+ (lambda xs (list->s16vector xs)) )
(define u32vector
- (let ((list->u32vector list->u32vector))
- (lambda xs (list->u32vector xs)) ) )
+ (lambda xs (list->u32vector xs)) )
(define s32vector
- (let ((list->s32vector list->s32vector))
- (lambda xs (list->s32vector xs)) ) )
+ (lambda xs (list->s32vector xs)) )
(define f32vector
- (let ((list->f32vector list->f32vector))
- (lambda xs (list->f32vector xs)) ) )
+ (lambda xs (list->f32vector xs)) )
(define f64vector
- (let ((list->f64vector list->f64vector))
- (lambda xs (list->f64vector xs)) ) )
+ (lambda xs (list->f64vector xs)) )
;;; Creating lists from a vector:
@@ -666,8 +657,7 @@ EOF
(##sys#read-string! n dest port start) ) )
(define read-u8vector
- (let ((open-output-string open-output-string)
- (get-output-string get-output-string) )
+ (let ()
(define (wrap str n)
(##sys#make-structure
'u8vector
diff --git a/srfi-69.scm b/srfi-69.scm
index 69ea74cd..a46acb0a 100644
--- a/srfi-69.scm
+++ b/srfi-69.scm
@@ -975,16 +975,15 @@
(cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
(define alist->hash-table
- (let ([make-hash-table make-hash-table])
- (lambda (alist . rest)
- (##sys#check-list alist 'alist->hash-table)
- (let ([ht (apply make-hash-table rest)])
- (for-each
- (lambda (x)
- (##sys#check-pair x 'alist->hash-table)
- (*hash-table-update!/default ht (##sys#slot x 0) (lambda (x) x) (##sys#slot x 1)) )
- alist)
- ht ) ) ) )
+ (lambda (alist . rest)
+ (##sys#check-list alist 'alist->hash-table)
+ (let ([ht (apply make-hash-table rest)])
+ (for-each
+ (lambda (x)
+ (##sys#check-pair x 'alist->hash-table)
+ (*hash-table-update!/default ht (##sys#slot x 0) (lambda (x) x) (##sys#slot x 1)) )
+ alist)
+ ht ) ) )
;; Hash-Table Keys & Values:
diff --git a/utils.scm b/utils.scm
index 03bd4ed6..82e750fa 100644
--- a/utils.scm
+++ b/utils.scm
@@ -40,13 +40,11 @@
;;; Like `system', but allows format-string and bombs on nonzero return code:
(define system*
- (let ([sprintf sprintf]
- [system system] )
- (lambda (fstr . args)
- (let* ([str (apply sprintf fstr args)]
- [n (system str)] )
- (unless (zero? n)
- (##sys#error "shell invocation failed with non-zero return status" str n) ) ) ) ) )
+ (lambda (fstr . args)
+ (let* ([str (apply sprintf fstr args)]
+ [n (system str)] )
+ (unless (zero? n)
+ (##sys#error "shell invocation failed with non-zero return status" str n) ) ) ) )
;;; Read file as string from given filename or port:
@@ -83,8 +81,8 @@
(define compile-file
(let ((csc (foreign-value "C_CSC_PROGRAM" c-string))
- (path (foreign-value "C_INSTALL_BIN_HOME" c-string))
- (load-file load))
+ (load-file load)
+ (path (foreign-value "C_INSTALL_BIN_HOME" c-string)) )
(lambda (filename #!key (options '()) output-file (load #t))
(let ((cscpath (or (file-exists? (make-pathname path csc)) "csc"))
(tmpfile (and (not output-file) (create-temporary-file "so")))
@@ -115,18 +113,15 @@
;;; Scan lines until regex or predicate matches
(define scan-input-lines
- (let ((regexp regexp)
- (read-line read-line)
- (string-search string-search))
- (lambda (rx #!optional (port ##sys#standard-input))
- (let ((rx (if (procedure? rx)
- rx
- (cut string-search (regexp rx) <>))))
- (let loop ()
- (let ((ln (read-line port)))
- (and (not (eof-object? ln))
- (or (rx ln)
- (loop)))))))))
+ (lambda (rx #!optional (port ##sys#standard-input))
+ (let ((rx (if (procedure? rx)
+ rx
+ (cut string-search (regexp rx) <>))))
+ (let loop ()
+ (let ((ln (read-line port)))
+ (and (not (eof-object? ln))
+ (or (rx ln)
+ (loop))))))))
;; Ask for confirmation
Trap