conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fixes bug 175117: Named let violates scoping rules

This commit is contained in:
Abdulaziz Ghuloum 2007-12-09 12:20:13 -05:00
parent 1d5c069273
commit 3562a736c5
6 changed files with 248 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

251
lab/io-spec.ss
View File

@ -10,7 +10,7 @@
transcoded-port port-transcoder
close-port
port-eof?
get-char lookahead-char
get-char lookahead-char read-char peek-char
get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
@ -31,7 +31,7 @@
transcoded-port port-transcoder
close-port
port-eof?
get-char lookahead-char
get-char lookahead-char read-char peek-char
get-string-n get-string-n! get-string-all get-line
get-u8 lookahead-u8
get-bytevector-n get-bytevector-n!
@ -703,7 +703,7 @@
"file already exists"
"invalid file name"))
(define (io-error who id err)
(define (io-error who id err)
(let ([msg
(let ([err (- err)])
(cond
@ -751,7 +751,6 @@
(define (current-input-port) *the-input-port*)
(define (call-with-port p proc)
(if ($port? p)
(if (procedure? proc)
@ -762,15 +761,245 @@
(error 'call-with-port "not a procedure" proc))
(error 'call-with-port "not a port" p)))
(define read-char
(case-lambda
[() (get-char *the-input-port*)]
[(p)
(if (input-port? p)
(if (textual-port? p)
(get-char p)
(error 'read-char "not a textual port" p))
(error 'read-char "not an input-port" p))]))
;;;
(define peek-char
(case-lambda
[() (lookahead-char *the-input-port*)]
[(p)
(if (input-port? p)
(if (textual-port? p)
(lookahead-char p)
(error 'peek-char "not a textual port" p))
(error 'peek-char "not an input-port" p))]))
(define (get-bytevector-n p n)
(import (ikarus system $fx) (ikarus system $bytevectors))
(define (subbytevector s n)
(let ([p ($make-bytevector n)])
(let f ([s s] [n n] [p p])
(let ([n ($fx- n 1)])
($bytevector-set! p n ($bytevector-u8-ref s n))
(if ($fx= n 0)
p
(f s n p))))))
(unless (input-port? p)
(error 'get-bytevector-n "not an input port" p))
(unless (binary-port? p)
(error 'get-bytevector-n "not a binary port" p))
(unless (fixnum? n)
(error 'get-bytevector-n "count is not a fixnum" n))
(cond
[($fx> n 0)
(let ([s ($make-bytevector n)])
(let f ([p p] [n n] [s s] [i 0])
(let ([x (get-u8 p)])
(cond
[(eof-object? x)
(if ($fx= i 0)
(eof-object)
(subbytevector s i))]
[else
($bytevector-set! s i x)
(let ([i ($fxadd1 i)])
(if ($fx= i n)
s
(f p n s i)))]))))]
[($fx= n 0) '#vu8()]
[else (error 'get-bytevector-n "count is negative" n)]))
(define (get-bytevector-n! p s i c)
(import (ikarus system $fx) (ikarus system $bytevectors))
(unless (input-port? p)
(error 'get-bytevector-n! "not an input port" p))
(unless (binary-port? p)
(error 'get-bytevector-n! "not a binary port" p))
(unless (bytevector? s)
(error 'get-bytevector-n! "not a bytevector" s))
(let ([len ($bytevector-length s)])
(unless (fixnum? i)
(error 'get-bytevector-n! "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'get-bytevector-n!
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'get-bytevector-n! "count is not a fixnum" c))
(cond
[($fx> c 0)
(let ([j (+ i c)])
(when (> j len)
(error 'get-bytevector-n!
(format "count is out of range 0..~a" (- len i))
c))
(let ([x (get-u8 p)])
(cond
[(eof-object? x) x]
[else
($bytevector-set! s i x)
(let f ([p p] [s s] [start i] [i 1] [c c])
(let ([x (get-u8 p)])
(cond
[(eof-object? x) i]
[else
($bytevector-set! s ($fx+ start i) x)
(let ([i ($fxadd1 i)])
(if ($fx= i c)
i
(f p s start i c)))])))])))]
[($fx= c 0) 0]
[else (error 'get-bytevector-n! "count is negative" c)])))
(define-rrr get-bytevector-n)
(define-rrr get-bytevector-n!)
(define-rrr get-bytevector-some)
(define-rrr get-bytevector-all)
(define-rrr get-string-n)
(define-rrr get-string-n!)
(define-rrr get-string-all)
(define-rrr get-line)
(define (get-bytevector-all p)
(define (get-it p)
(let f ([p p] [n 0] [ac '()])
(let ([x (get-u8 p)])
(cond
[(eof-object? x)
(if (null? ac)
(eof-object)
(make-it n ac))]
[else (f p (+ n 1) (cons x ac))]))))
(define (make-it n revls)
(let f ([s (make-bytevector n)] [i (- n 1)] [ls revls])
(cond
[(pair? ls)
(bytevector-u8-set! s i (car ls))
(f s (- i 1) (cdr ls))]
[else s])))
(if (input-port? p)
(if (binary-port? p)
(get-it p)
(error 'get-bytevector-all "not a binary port" p))
(error 'get-bytevector-all "not an input port" p)))
(define (get-string-n p n)
(import (ikarus system $fx) (ikarus system $strings))
(unless (input-port? p)
(error 'get-string-n "not an input port" p))
(unless (textual-port? p)
(error 'get-string-n "not a textual port" p))
(unless (fixnum? n)
(error 'get-string-n "count is not a fixnum" n))
(cond
[($fx> n 0)
(let ([s ($make-string n)])
(let f ([p p] [n n] [s s] [i 0])
(let ([x (get-char p)])
(cond
[(eof-object? x)
(if ($fx= i 0)
(eof-object)
(substring s 0 i))]
[else
($string-set! s i x)
(let ([i ($fxadd1 i)])
(if ($fx= i n)
s
(f p n s i)))]))))]
[($fx= n 0) ""]
[else (error 'get-string-n "count is negative" n)]))
(define (get-string-n! p s i c)
(import (ikarus system $fx) (ikarus system $strings))
(unless (input-port? p)
(error 'get-string-n! "not an input port" p))
(unless (textual-port? p)
(error 'get-string-n! "not a textual port" p))
(unless (string? s)
(error 'get-string-n! "not a string" s))
(let ([len ($string-length s)])
(unless (fixnum? i)
(error 'get-string-n! "starting index is not a fixnum" i))
(when (or ($fx< i 0) ($fx> i len))
(error 'get-string-n!
(format "starting index is out of range 0..~a" len)
i))
(unless (fixnum? c)
(error 'get-string-n! "count is not a fixnum" c))
(cond
[($fx> c 0)
(let ([j (+ i c)])
(when (> j len)
(error 'get-string-n!
(format "count is out of range 0..~a" (- len i))
c))
(let ([x (get-char p)])
(cond
[(eof-object? x) x]
[else
($string-set! s i x)
(let f ([p p] [s s] [start i] [i 1] [c c])
(let ([x (get-char p)])
(cond
[(eof-object? x) i]
[else
($string-set! s ($fx+ start i) x)
(let ([i ($fxadd1 i)])
(if ($fx= i c)
i
(f p s start i c)))])))])))]
[($fx= c 0) 0]
[else (error 'get-string-n! "count is negative" c)])))
(define (get-line p)
(define (get-it p)
(let f ([p p] [n 0] [ac '()])
(let ([x (get-char p)])
(cond
[(eqv? x #\newline)
(make-it n ac)]
[(eof-object? x)
(if (null? ac) x (make-it n ac))]
[else (f p (+ n 1) (cons x ac))]))))
(define (make-it n revls)
(let f ([s (make-string n)] [i (- n 1)] [ls revls])
(cond
[(pair? ls)
(string-set! s i (car ls))
(f s (- i 1) (cdr ls))]
[else s])))
(if (input-port? p)
(if (textual-port? p)
(get-it p)
(error 'get-line "not a textual port" p))
(error 'get-line "not an input port" p)))
(define (get-string-all p)
(define (get-it p)
(let f ([p p] [n 0] [ac '()])
(let ([x (get-char p)])
(cond
[(eof-object? x)
(if (null? ac)
(eof-object)
(make-it n ac))]
[else (f p (+ n 1) (cons x ac))]))))
(define (make-it n revls)
(let f ([s (make-string n)] [i (- n 1)] [ls revls])
(cond
[(pair? ls)
(string-set! s i (car ls))
(f s (- i 1) (cdr ls))]
[else s])))
(if (input-port? p)
(if (textual-port? p)
(get-it p)
(error 'get-string-all "not a textual port" p))
(error 'get-string-all "not an input port" p)))
)

3
lab/io-test.ss
View File

@ -2,7 +2,8 @@
(import
(except (ikarus) get-char get-u8 lookahead-u8 close-port
(except (ikarus) get-char peek-char read-char
get-u8 lookahead-u8 close-port
input-port? open-string-input-port output-port?
standard-input-port current-input-port
get-bytevector-n get-bytevector-n!

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

4
scheme/ikarus.intel-assembler.ss
View File

@ -677,6 +677,10 @@
(CODE #x31 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x33 dst src ac)]
[(and (reg? src) (mem? dst))
((CODE/digit #x31 src) dst ac)]
;[(and (imm? src) (mem? dst))
; ((CODE/digit #x81 '/6) dst (IMM32 src ac))]
[else (error who "invalid" instr)])]
[(leal src dst)
(cond

2
scheme/last-revision
View File

@ -1 +1 @@
1200
1201

3
scheme/psyntax.expander.ss
View File

@ -989,8 +989,7 @@
(invalid-fmls-error stx lhs*)))
((_ f ((lhs* rhs*) ...) b b* ...) (id? f)
(if (valid-bound-ids? lhs*)
(bless `(letrec ((,f (lambda ,lhs* ,b . ,b*)))
(,f . ,rhs*)))
(bless `((letrec ((,f (lambda ,lhs* ,b . ,b*))) ,f) . ,rhs*))
(invalid-fmls-error stx lhs*))))))
(define let-values-macro