~ chicken-core (chicken-5) afa4512d8cd9ea482acab0adea812b16b16de339
commit afa4512d8cd9ea482acab0adea812b16b16de339
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Feb 1 13:01:26 2011 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Feb 1 13:01:26 2011 +0100
added subvector; types.db enhancements; better handling of not in specializer signature; slight optimization in reverse-string->list
diff --git a/chicken.import.scm b/chicken.import.scm
index 863bd8c2..77bb385d 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -215,6 +215,7 @@
string->uninterned-symbol
strip-syntax
sub1
+ subvector
symbol-append
symbol-escape
symbol-plist
diff --git a/data-structures.scm b/data-structures.scm
index 85d42d10..b03318eb 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -266,20 +266,18 @@ EOF
; (reverse-string-append l) = (apply string-append (reverse l))
(define (reverse-string-append l)
-
(define (rev-string-append l i)
(if (pair? l)
(let* ((str (car l))
(len (string-length str))
- (result (rev-string-append (cdr l) (+ i len))))
- (let loop ((j 0) (k (- (- (string-length result) i) len)))
- (if (< j len)
+ (result (rev-string-append (cdr l) (fx+ i len))))
+ (let loop ((j 0) (k (fx- (fx- (string-length result) i) len)))
+ (if (fx< j len)
(begin
(string-set! result k (string-ref str j))
- (loop (+ j 1) (+ k 1)))
+ (loop (fx+ j 1) (fx+ k 1)))
result)))
(make-string i)))
-
(rev-string-append l 0))
;;; Anything->string conversion:
diff --git a/library.scm b/library.scm
index 4635af06..f714eaa1 100644
--- a/library.scm
+++ b/library.scm
@@ -1349,18 +1349,30 @@ EOF
(define (vector-copy! from to . n)
(##sys#check-vector from 'vector-copy!)
(##sys#check-vector to 'vector-copy!)
- (let* ([len-from (##sys#size from)]
- [len-to (##sys#size to)]
- [n (if (pair? n) (car n) (fxmin len-to len-from))] )
+ (let* ((len-from (##sys#size from))
+ (len-to (##sys#size to))
+ (n (if (pair? n) (car n) (fxmin len-to len-from))) )
(##sys#check-exact n 'vector-copy!)
(when (or (fx> n len-to) (fx> n len-from))
(##sys#signal-hook
#:bounds-error 'vector-copy!
"cannot copy vector - count exceeds length" from to n) )
- (do ([i 0 (fx+ i 1)])
+ (do ((i 0 (fx+ i 1)))
((fx>= i n))
(##sys#setslot to i (##sys#slot from i)) ) ) )
+(define (subvector v i #!optional j)
+ (##sys#check-vector v 'subvector)
+ (let* ((len (##sys#size v))
+ (j (or j len))
+ (len2 (fx- j i)))
+ (##sys#check-range i 0 len 'subvector)
+ (##sys#check-range j 0 len 'subvector)
+ (let ((v2 (make-vector len2)))
+ (do ((k 0 (fx+ k 1)))
+ ((fx>= k len2) v2)
+ (##sys#setslot v2 k (##sys#slot v (fx+ k i)))))))
+
(define (vector-resize v n #!optional init)
(##sys#check-vector v 'vector-resize)
(##sys#check-exact n 'vector-resize)
diff --git a/manual/Accessing external objects b/manual/Accessing external objects
index e043e926..6a1323ee 100644
--- a/manual/Accessing external objects
+++ b/manual/Accessing external objects
@@ -142,9 +142,10 @@ in {{STRING ...}}:
(my-strlen "one two three") ==> 13
</enscript>
-For obscure technical reasons you should use the {{C_return}} macro instead of the normal {{return}} statement
-to return a result from the foreign lambda body as some cleanup code has to be run before execution
-commences in the calling code.
+For obscure technical reasons you should use the {{C_return}} macro
+instead of the normal {{return}} statement to return a result from the
+foreign lambda body as some cleanup code has to be run before
+execution commences in the calling code.
=== foreign-safe-lambda
diff --git a/manual/Unit library b/manual/Unit library
index 6584fe1c..a684cfe8 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -943,6 +943,13 @@ additional items are initialized to {{INIT}}. If {{INIT}} is not specified, the
contents are initialized to some unspecified value.
+==== subvector
+
+<procedure>(subvector VECTOR FROM [TO])</procedure>
+
+Returns a new vector with elements taken from {{VECTOR}} in the
+given range. {{TO}} defaults to {{(vector-length VECTOR)}}.
+
=== The unspecified value
diff --git a/manual/Using the interpreter b/manual/Using the interpreter
index 5248a991..1e981a05 100644
--- a/manual/Using the interpreter
+++ b/manual/Using the interpreter
@@ -252,27 +252,32 @@ The {{,e}} command runs the editor given by:
=== History access
The interpreter toplevel accepts the special object {{#[INDEX]}} which
-returns the result of entry number {{INDEX}} in the history list. If the expression
-for that entry resulted in multiple values, the first result (or an unspecified value for no values)
-is returned. If no {{INDEX}} is given (and if a whitespace or closing paranthesis character follows
-the {{#}}, then the result of the last expression is returned.
-Note that the value returned is implicitly quoted.
+returns the result of entry number {{INDEX}} in the history list. If
+the expression for that entry resulted in multiple values, the first
+result (or an unspecified value for no values) is returned. If no
+{{INDEX}} is given (and if a whitespace or closing paranthesis
+character follows the {{#}}, then the result of the last expression is
+returned. Note that the value returned is implicitly quoted.
=== set-describer!
<procedure>(set-describer! TAG PROC)</procedure>
-Sets a custom description handler that invokes {{PROC}} when the {{,d}} command is invoked
-with a record-type object that has the type {{TAG}} (a symbol). {{PROC}} is called with
-two arguments: the object to be described and an output-port. It should write a possibly useful
-textual description of the object to the passed output-port. For example:
+Sets a custom description handler that invokes {{PROC}} when the
+{{,d}} command is invoked with a record-type object that has the type
+{{TAG}} (a symbol). {{PROC}} is called with two arguments: the object
+to be described and an output-port. It should write a possibly useful
+textual description of the object to the passed output-port. For
+example:
#;1> (define-record-type point (make-point x y) point?
(x point-x)
(y point-y))
#;2> (set-describer! 'point
(lambda (pt o)
- (print "a point with x=" (point-x pt) " and y=" (point-y pt))))
+ (with-output-to-port o
+ (lambda ()
+ (print "a point with x=" (point-x pt) " and y=" (point-y pt))))))
#;3> ,d (make-point 1 2)
a point with x=1 and y=2
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 1303f126..e9b6ded5 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -702,8 +702,11 @@
(define (match st t)
(if (pair? st)
(case (car st)
- ((not) (not (equal? (cadr st) t)))
- ((or) (any (cut equal? <> t) (cdr st)))
+ ((not)
+ (if (and (pair? t) (eq? 'or (car t)))
+ (not (any (cute match (cadr st) <>) (cdr t)))
+ (not (match (cadr st) t))))
+ ((or) (any (cut match <> t) (cdr st)))
(else (equal? st t)))
(eq? st t)))
(let loop ((tl typelist) (atypes atypes))
diff --git a/types.db b/types.db
index 9d291514..9d791d46 100644
--- a/types.db
+++ b/types.db
@@ -262,10 +262,13 @@
(argv (procedure argv () list))
(arithmetic-shift (procedure arithmetic-shift (number number) number))
(bit-set? (procedure bit-set? (number fixnum) boolean))
-(bitwise-and (procedure bitwise-and (#!rest number) number))
-(bitwise-ior (procedure bitwise-ior (#!rest number) number))
+(bitwise-and (procedure bitwise-and (#!rest number) number)
+ ((fixnum fixnum) (fxand #(1) #(2))))
+(bitwise-ior (procedure bitwise-ior (#!rest number) number)
+ ((fixnum fixnum) (fxior #(1) #(2))))
(bitwise-not (procedure bitwise-not (number) number))
-(bitwise-xor (procedure bitwise-xor (#!rest number) number))
+(bitwise-xor (procedure bitwise-xor (#!rest number) number)
+ ((fixnum fixnum) (fxxor #(1) #(2))))
(blob->string (procedure blob->string (blob) string))
(blob-size (procedure blob-size (blob) fixnum))
(blob? (procedure blob? (*) boolean))
@@ -310,7 +313,8 @@
(directory-exists? (procedure directory-exists? (string) *))
(fixnum-bits fixnum)
(fixnum-precision fixnum)
-(fixnum? (procedure fixnum? (*) boolean))
+(fixnum? (procedure fixnum? (*) boolean)
+ ((fixnum) #t))
(flonum-decimal-precision fixnum)
(flonum-epsilon float)
(flonum-maximum-decimal-exponent fixnum)
@@ -320,7 +324,8 @@
(flonum-precision fixnum)
(flonum-print-precision (procedure (#!optional fixnum) fixnum))
(flonum-radix fixnum)
-(flonum? (procedure flonum? (*) boolean))
+(flonum? (procedure flonum? (*) boolean)
+ ((float) #t))
(flush-output (procedure flush-output (#!optional port) undefined))
(force-finalizers (procedure force-finalizers () undefined))
(fp- (procedure fp- (float float) float))
@@ -445,6 +450,7 @@
(string->uninterned-symbol (procedure string->uninterned-symbol (string) symbol))
(strip-syntax (procedure strip-syntax (*) *))
(sub1 (procedure sub1 (number) number))
+(subvector (procedure subvector (vector fixnum #!optional fixnum) vector))
(symbol-escape (procedure symbol-escape (#!optional *) *))
(symbol-plist (procedure symbol-plist (symbol) list))
(syntax-error (procedure syntax-error (#!rest) noreturn))
Trap