~ chicken-core (chicken-5) fd6335b6130bf0c87a742a37fdd8594ef67e57b6
commit fd6335b6130bf0c87a742a37fdd8594ef67e57b6
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Aug 18 15:15:26 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Aug 18 15:15:26 2011 +0200
work on types.db
diff --git a/types.db.new b/types.db.new
index e3a0f72e..4fcf4f42 100644
--- a/types.db.new
+++ b/types.db.new
@@ -459,20 +459,18 @@
;(string-copy (procedure! string-copy (string) string)) - we use the more general version from srfi-13
-;;XXX continue ...
-
-(string->list (procedure! string->list (string) list))
-(list->string (procedure! list->string (list) string))
+(string->list (procedure! string->list (string) (list char)))
+(list->string (procedure! list->string ((list char)) string))
(substring (procedure! substring (string fixnum #!optional fixnum) string))
;(string-fill! (procedure! string-fill! (string char) string)) - s.a.
(string (procedure! string (#!rest char) string))
(vector? (procedure? vector vector? (*) boolean))
-(make-vector (procedure! make-vector (fixnum #!optional *) vector))
+(make-vector (forall (a) (procedure! make-vector (fixnum #!optional a) (vector a))))
-(vector-ref (procedure! vector-ref (vector fixnum) *))
-(##sys#vector-ref (procedure! ##sys#vector-ref (vector fixnum) *))
+(vector-ref (forall (a) (procedure! vector-ref ((vector a) fixnum) a)))
+(##sys#vector-ref (forall (a) (procedure! ##sys#vector-ref ((vector a) fixnum) a)))
(vector-set! (procedure! vector-set! (vector fixnum *) undefined))
(vector (procedure vector (#!rest) vector))
(##sys#vector (procedure ##sys#vector (#!rest) vector))
@@ -482,67 +480,91 @@
(##sys#vector-length (procedure! ##sys#vector-length (vector) fixnum)
((vector) (##sys#size #(1))))
-(vector->list (procedure! vector->list (vector) list))
-(##sys#vector->list (procedure! ##sys#vector->list (vector) list))
-(list->vector (procedure! list->vector (list) vector))
-(##sys#list->vector (procedure! ##sys#list->vector (list) vector))
-(vector-fill! (procedure! vector-fill! (vector *) vector))
+(vector->list (forall (a) (procedure! vector->list ((vector a)) (list a))))
+(##sys#vector->list (forall (a) (procedure! ##sys#vector->list ((vector a)) (list a))))
+(list->vector (forall (a) (procedure! list->vector ((list a)) (vector a))))
+(##sys#list->vector (forall (a) (procedure! ##sys#list->vector ((list a)) (vector a))))
+(vector-fill! (procedure! vector-fill! (vector *) undefined))
(procedure? (procedure? procedure procedure? (*) boolean))
(vector-copy! (procedure! vector-copy! (vector vector #!optional fixnum) undefined))
-(map (procedure! map (procedure #!rest list) list))
+(map (procedure! map ((procedure (#!rest) *) #!rest list) list))
(for-each (procedure! for-each (procedure #!rest list) undefined))
(apply (procedure! apply (procedure #!rest) . *))
(##sys#apply (procedure! ##sys#apply (procedure #!rest) . *))
-(force (procedure force (*) *))
-(call-with-current-continuation (procedure! call-with-current-continuation (procedure) . *))
+
+(force (procedure force (*) *)
+ ((not (struct promise)) #(1)))
+
+(call-with-current-continuation
+ (procedure! call-with-current-continuation ((procedure (procedure) . *)) . *))
+
(input-port? (procedure input-port? (*) boolean))
(output-port? (procedure output-port? (*) boolean))
-(current-input-port (procedure! current-input-port (#!optional port) port))
-(current-output-port (procedure! current-output-port (#!optional port) port))
-(call-with-input-file (procedure call-with-input-file (string (procedure (port) . *) #!rest) . *))
-(call-with-output-file (procedure call-with-output-file (string (procedure (port) . *) #!rest) . *))
+
+(current-input-port
+ (procedure! current-input-port (#!optional port) port)
+ ((port) (let ((#(tmp1) #(1)))
+ (let ((#(tmp2) (set! ##sys#standard-input #(tmp1))))
+ #(tmp1))))
+ (() ##sys#standard-input))
+
+(current-output-port
+ (procedure! current-output-port (#!optional port) port))
+ ((port) (let ((#(tmp1) #(1)))
+ (let ((#(tmp2) (set! ##sys#standard-output #(tmp1))))
+ #(tmp1))))
+ (() ##sys#standard-output))
+
+(call-with-input-file
+ (procedure call-with-input-file (string (procedure (port) . *) #!rest) . *))
+
+(call-with-output-file
+ (procedure call-with-output-file (string (procedure (port) . *) #!rest) . *))
+
(open-input-file (procedure! open-input-file (string #!rest symbol) port))
(open-output-file (procedure! open-output-file (string #!rest symbol) port))
(close-input-port (procedure! close-input-port (port) undefined))
(close-output-port (procedure! close-output-port (port) undefined))
-(load (procedure load (string #!optional procedure) undefined))
+(load (procedure load (string #!optional (procedure (*) . *)) undefined))
(read (procedure! read (#!optional port) *))
(eof-object? (procedure? eof eof-object? (*) boolean))
;;XXX if we had input/output port distinction, we could specialize these:
-(read-char (procedure! read-char (#!optional port) *)) ; result (or eof char) ?
+(read-char (procedure! read-char (#!optional port) *)) ;XXX result (or eof char) ?
(peek-char (procedure! peek-char (#!optional port) *))
(write (procedure! write (* #!optional port) undefined))
(display (procedure! display (* #!optional port) undefined))
(write-char (procedure! write-char (char #!optional port) undefined))
(newline (procedure! newline (#!optional port) undefined))
-(with-input-from-file (procedure! with-input-from-file (string procedure #!rest symbol) . *))
-(with-output-to-file (procedure! with-output-to-file (string procedure #!rest symbol) . *))
-(dynamic-wind (procedure! dynamic-wind (procedure procedure procedure) . *))
+
+(with-input-from-file
+ (procedure! with-input-from-file (string (procedure () . *) #!rest symbol) . *))
+
+(with-output-to-file
+ (procedure! with-output-to-file (string (procedure () . *) #!rest symbol) . *))
+
+(dynamic-wind
+ (procedure! dynamic-wind ((procedure () . *) (procedure () . *) (procedure () . *)) . *))
+
(values (procedure values (#!rest values) . *))
(##sys#values (procedure ##sys#values (#!rest values) . *))
-(call-with-values (procedure! call-with-values ((procedure () . *) procedure) . *))
-
-#;(call-with-values (procedure! call-with-values ((procedure () . *) procedure) . *)
+(call-with-values (procedure! call-with-values ((procedure () . *) procedure) . *)
(((procedure () *) *) (let ((#(tmp1) #(1)))
(let ((#(tmp2) #(2)))
(#(tmp2) (#(tmp1)))))))
(##sys#call-with-values
- (procedure! ##sys#call-with-values ((procedure () . *) procedure) . *))
-
-#;(##sys#call-with-values
(procedure! ##sys#call-with-values ((procedure () . *) procedure) . *)
(((procedure () *) *) (let ((#(tmp1) #(1)))
(let ((#(tmp2) #(2)))
(#(tmp2) (#(tmp1)))))))
-(eval (procedure eval (* #!optional *) *))
+(eval (procedure eval (* #!optional (struct environment)) *))
(char-ready? (procedure! char-ready? (#!optional port) boolean))
(imag-part (procedure! imag-part (number) number)
@@ -563,9 +585,14 @@
(denominator (procedure! denominator (number) number)
((fixnum) (fixnum) (let ((#(tmp) #(1))) '1)))
-(scheme-report-environment (procedure! scheme-report-environment (#!optional fixnum) *))
-(null-environment (procedure! null-environment (#!optional fixnum) *))
-(interaction-environment (procedure interaction-environment () *))
+(scheme-report-environment
+ (procedure! scheme-report-environment (#!optional fixnum) (struct environment)))
+
+(null-environment
+ (procedure! null-environment (#!optional fixnum) (struct environment)))
+
+(interaction-environment
+ (procedure interaction-environment () (struct environment)))
(port-closed? (procedure! port-closed? (port) boolean)
((port) (##sys#slot #(1) '8)))
@@ -578,8 +605,8 @@
((float) (float)
(##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) '1.0)))
-(argc+argv (procedure argc+argv () fixnum list))
-(argv (procedure argv () list))
+(argc+argv (procedure argc+argv () fixnum (list string fixnum)))
+(argv (procedure argv () (list string)))
(arithmetic-shift (procedure! arithmetic-shift (number number) number))
(bit-set? (procedure! bit-set? (number fixnum) boolean)
@@ -607,20 +634,19 @@
(blob? (procedure? blob blob? (*) boolean))
(blob=? (procedure! blob=? (blob blob) boolean))
-(breakpoint (procedure breakpoint (#!optional *) . *))
(build-platform (procedure build-platform () symbol))
-(call/cc (procedure! call/cc (procedure) . *))
+(call/cc (procedure! call/cc ((procedure (*) . *)) . *))
(case-sensitive (procedure case-sensitive (#!optional *) *))
-(char-name (procedure! char-name ((or char symbol) #!optional char) *))
+(char-name (procedure! char-name ((or char symbol) #!optional char) *)) ;XXX -> (or char symbol) ?
(chicken-home (procedure chicken-home () string))
(chicken-version (procedure chicken-version (#!optional *) string))
-(command-line-arguments (procedure command-line-arguments (#!optional list) list))
+(command-line-arguments (procedure command-line-arguments (#!optional (list string)) (list string)))
(condition-predicate (procedure! condition-predicate (symbol) (procedure ((struct condition)) boolean)))
(condition-property-accessor (procedure! condition-property-accessor (symbol symbol #!optional *) (procedure ((struct condition)) *)))
(condition? (procedure? (struct condition) condition? (*) boolean))
-(condition->list (procedure! condition->list ((struct condition)) list))
+(condition->list (procedure! condition->list ((struct condition)) (list (pair symbol *))))
(continuation-capture (procedure! continuation-capture ((procedure ((struct continuation)) . *)) *))
(continuation-graft (procedure! continuation-graft ((struct continuation) (procedure () . *)) *))
(continuation-return (procedure! continuation-return (procedure #!rest) . *)) ;XXX make return type more specific?
@@ -630,34 +656,52 @@
(copy-read-table (procedure! copy-read-table ((struct read-table)) (struct read-table)))
(cpu-time (procedure cpu-time () fixnum fixnum))
-(current-error-port (procedure! current-error-port (#!optional port) port)
- ((port) (set! ##sys#standard-error #(1)))
- (() ##sys#standard-error))
+(current-error-port
+ (procedure! current-error-port (#!optional port) port)
+ ((port) (let ((#(tmp1) #(1)))
+ (let ((#(tmp2) (set! ##sys#standard-error #(tmp1))))
+ #(tmp1))))
+ (() ##sys#standard-error))
(current-exception-handler
- (procedure! current-exception-handler (#!optional procedure) procedure)
- ((procedure) (set! ##sys#current-exception-handler #(1)))
+ (procedure! current-exception-handler (#!optional (procedure (*) noreturn)) procedure)
+ ((procedure) (let ((#(tmp1) #(1)))
+ (let ((#(tmp2) (set! ##sys#current-exception-handler #(tmp1))))
+ #(tmp1))))
(() ##sys#current-exception-handler))
(current-gc-milliseconds (procedure current-gc-milliseconds () fixnum))
(current-milliseconds (procedure current-milliseconds () float))
-(current-read-table (procedure current-read-table () (struct read-table)))
+
+(current-read-table
+ (procedure current-read-table (#!optional (struct read-table)) (struct read-table)))
+
(current-seconds (procedure current-seconds () float))
(define-reader-ctor (procedure! define-reader-ctor (symbol procedure) undefined))
(delete-file (procedure! delete-file (string) string))
(enable-warnings (procedure enable-warnings (#!optional *) *))
-(equal=? (procedure equal=? (* *) boolean))
-(er-macro-transformer (procedure! er-macro-transformer ((procedure (* * *) *)) (struct transformer)))
+
+(equal=? (procedure equal=? (* *) boolean)
+ (((or fixnum symbol char eof null undefined) *) (eq? #(1) #(2)))
+ ((* (or fixnum symbol char eof null undefined) (eq? #(1) #(2))))
+ (((or float number) (or float number)) (= #(1) #(2))))
+
+(er-macro-transformer
+ (procedure!
+ er-macro-transformer
+ ((procedure (* (procedure (*) *) (procedure (* *) *)) *))
+ (struct transformer)))
+
(errno (procedure errno () fixnum))
-(error (procedure error (#!rest) noreturn))
-(##sys#error (procedure ##sys#error (#!rest) noreturn))
-(##sys#signal-hook (procedure ##sys#signal-hook (#!rest) noreturn))
+(error (procedure error (* #!rest) noreturn))
+(##sys#error (procedure ##sys#error (* #!rest) noreturn))
+(##sys#signal-hook (procedure ##sys#signal-hook (* #!rest) noreturn))
(exit (procedure exit (#!optional fixnum) noreturn))
-(exit-handler (procedure! exit-handler (#!optional procedure) procedure))
-(expand (procedure expand (* #!optional *) *))
+(exit-handler (procedure! exit-handler (#!optional (procedure (fixnum) . *)) procedure))
+(expand (procedure expand (* #!optional list) *))
(extension-information (procedure extension-information (symbol) *))
(feature? (procedure feature? (symbol) boolean))
-(features (procedure features () list))
+(features (procedure features () (list symbol)))
(file-exists? (procedure! file-exists? (string) *))
(directory-exists? (procedure! directory-exists? (string) *))
(fixnum-bits fixnum)
@@ -679,8 +723,8 @@
(flush-output (procedure! flush-output (#!optional port) undefined))
-(foldl (procedure! foldl ((procedure (* *) *) * list) *))
-(foldr (procedure! foldr ((procedure (* *) *) * list) *))
+(foldl (forall (a b) (procedure! foldl ((procedure (a b) a) a (list b)) a)))
+(foldr (forall (a b) (procedure! foldr ((procedure (a b) b) b (list a)) b)))
(force-finalizers (procedure force-finalizers () undefined))
@@ -794,25 +838,38 @@
(fxshr (procedure fxshr (fixnum fixnum) fixnum))
(fxxor (procedure fxxor (fixnum fixnum) fixnum))
(gc (procedure gc (#!optional *) fixnum))
-(gensym (procedure gensym (#!optional *) symbol))
+(gensym (procedure gensym (#!optional (or string symbol)) symbol))
(get (procedure! get (symbol symbol #!optional *) *)
((symbol symbol *) (##core#inline "C_i_getprop" #(1) #(2) #(3))))
-(get-call-chain (procedure! get-call-chain (#!optional fixnum *) list))
+(get-call-chain (procedure! get-call-chain (#!optional fixnum (struct thread)) (list vector)))
(get-condition-property (procedure! get-condition-property ((struct condition) symbol symbol #!optional *) *))
(get-environment-variable (procedure! get-environment-variable (string) *))
(get-keyword (procedure! get-keyword (symbol list #!optional *) *))
(get-output-string (procedure! get-output-string (port) string))
(get-properties (procedure! get-properties (symbol list) symbol * list))
-(getter-with-setter (procedure! getter-with-setter (procedure procedure #!optional string) procedure))
-(implicit-exit-handler (procedure! implicit-exit-handler (#!optional procedure) procedure))
-(ir-macro-transformer (procedure ir-macro-transformer ((procedure (* * *) *)) (struct transformer)))
+
+(getter-with-setter
+ (procedure!
+ getter-with-setter
+ ((procedure (#!rest) *) (procedure (* #!rest) . *) #!optional string)
+ procedure))
+
+(implicit-exit-handler
+ (procedure! implicit-exit-handler (#!optional (procedure () . *)) procedure))
+
+(ir-macro-transformer
+ (procedure
+ ir-macro-transformer
+ ((procedure (procedure (* (propcedure * *) *)) *))
+ (struct transformer)))
+
(keyword->string (procedure! keyword->string (symbol) string))
-(keyword-style (procedure keyword-style (#!optional *) *))
+(keyword-style (procedure keyword-style (#!optional symbol) symbol))
(keyword? (procedure keyword? (*) boolean))
(load-library (procedure! load-library (symbol #!optional string) undefined))
-(load-relative (procedure! load-relative (string #!optional procedure) undefined))
+(load-relative (procedure! load-relative (string #!optional (procedure (*) . *)) undefined))
(load-verbose (procedure load-verbose (#!optional *) *))
(machine-byte-order (procedure machine-byte-order () symbol))
(machine-type (procedure machine-type () symbol))
@@ -824,7 +881,7 @@
(make-parameter (procedure! make-parameter (* #!optional procedure) procedure))
(make-property-condition (procedure! make-property-condition (symbol #!rest *) (struct condition)))
(maximum-flonum float)
-(memory-statistics (procedure memory-statistics () vector))
+(memory-statistics (procedure memory-statistics () (vector fixnum)))
(minimum-flonum float)
(most-negative-fixnum fixnum)
(most-positive-fixnum fixnum)
@@ -856,23 +913,25 @@
(register-feature! (procedure! register-feature! (#!rest symbol) undefined))
(remprop! (procedure! remprop! (symbol symbol) undefined))
(rename-file (procedure! rename-file (string string) string))
-(repl (procedure! repl (#!optional (procedure (*) *)) undefined))
-(repl-prompt (procedure! repl-prompt (#!optional procedure) procedure))
+(repl (procedure! repl (#!optional (procedure (*) . *)) undefined))
+(repl-prompt (procedure! repl-prompt (#!optional (procedure () string)) procedure))
(repository-path (procedure repository-path (#!optional *) *))
-(require (procedure require (#!rest *) undefined))
-(reset (procedure reset () undefined))
-(reset-handler (procedure! reset-handler (#!optional procedure) procedure))
+(require (procedure require (#!rest (or string symbol)) undefined))
+(reset (procedure reset () noreturn))
+(reset-handler (procedure! reset-handler (#!optional (procedure () . *)) procedure))
(return-to-host (procedure return-to-host () . *))
-(reverse-list->string (procedure! reverse-list->string (list) string))
+(reverse-list->string (procedure! reverse-list->string ((list char)) string))
(set-finalizer! (procedure! set-finalizer! (* (procedure (*) . *)) *))
(set-gc-report! (procedure set-gc-report! (*) undefined))
-(set-parameterized-read-syntax! (procedure! set-parameterized-read-syntax! (char procedure) undefined))
+
+(set-parameterized-read-syntax!
+ (procedure! set-parameterized-read-syntax! (char (procedure (port fixnum) . *)) undefined))
(set-port-name! (procedure! set-port-name! (port string) undefined)
((port string) (##sys#setslot #(1) '3 #(2))))
-(set-read-syntax! (procedure! set-read-syntax! (char procedure) undefined))
-(set-sharp-read-syntax! (procedure! set-sharp-read-syntax! (char procedure) undefined))
+(set-read-syntax! (procedure! set-read-syntax! (char (procedure (port) . *)) undefined))
+(set-sharp-read-syntax! (procedure! set-sharp-read-syntax! (char (procedure (port) . *)) undefined))
(setter (procedure! setter (procedure) procedure))
(signal (procedure signal (*) . *))
(signum (procedure! signum (number) number))
@@ -887,19 +946,22 @@
((float) (float)
(##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) '1.0)))
-(subvector (procedure! subvector (vector fixnum #!optional fixnum) vector))
+(subvector (forall (a) (procedure! subvector ((vector a) fixnum #!optional fixnum) (vector a))))
(symbol-escape (procedure symbol-escape (#!optional *) *))
(symbol-plist (procedure! symbol-plist (symbol) list)
((symbol) (##sys#slot #(1) '2)))
-(syntax-error (procedure syntax-error (#!rest) noreturn))
+(syntax-error (procedure syntax-error (* #!rest) noreturn))
(system (procedure! system (string) fixnum))
(unregister-feature! (procedure! unregister-feature! (#!rest symbol) undefined))
-(vector-resize (procedure! vector-resize (vector fixnum) vector))
+(vector-resize (forall (a) (procedure! vector-resize ((vector a) fixnum) (vector a))))
(void (procedure void (#!rest) undefined))
-(warning (procedure warning (#!rest) . *))
-(with-exception-handler (procedure! with-exception-handler (procedure procedure) . *))
+(warning (procedure warning (* #!rest) undefined))
+
+(with-exception-handler
+ (procedure! with-exception-handler ((procedure (*) . *) (procedure () . *)) . *))
+
;; chicken (internal)
@@ -957,6 +1019,8 @@
((procedure *) (let ((#(tmp) #(1))) '#t)))
+;;XXX continue...
+
;; data-structures
(->string (procedure ->string (*) string)
Trap