~ chicken-core (chicken-5) 898c3a8cff0958dff859a4400ffbc4f192dddf04
commit 898c3a8cff0958dff859a4400ffbc4f192dddf04
Merge: 5e76f95e 610b76c9
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jul 23 12:55:14 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Jul 23 12:55:14 2011 +0200
resolved conflicts; no -verbose in debugbuild; simplify type after validation
diff --cc defaults.make
index 3ed7ae45,76f8f581..ee811fd0
--- a/defaults.make
+++ b/defaults.make
@@@ -275,8 -272,7 +272,8 @@@ CSI ?= csi$(EXE
CHICKEN_OPTIONS = -optimize-level 2 -include-path . -include-path $(SRCDIR) -inline -ignore-repository -feature chicken-bootstrap
ifdef DEBUGBUILD
- CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db -verbose
+ CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db
+CHICKEN_OPTIONS += -feature debugbuild
else
CHICKEN_OPTIONS += -no-warnings
endif
diff --cc rules.make
index 5eed53fc,fc719023..3e7fd117
--- a/rules.make
+++ b/rules.make
@@@ -35,11 -35,10 +35,11 @@@ VPATH=$(SRCDIR
SETUP_API_OBJECTS_1 = setup-api setup-download
-LIBCHICKEN_OBJECTS_1 = \
+LIBCHICKEN_SCHEME_OBJECTS_1 = \
library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
srfi-14 srfi-18 srfi-69 $(POSIXFILE) irregex scheduler \
- profiler stub expand modules chicken-syntax chicken-ffi-syntax
- profiler stub expand modules chicken-syntax chicken-ffi-syntax runtime build-version
++ profiler stub expand modules chicken-syntax chicken-ffi-syntax build-version
+LIBCHICKEN_OBJECTS_1 = $(LIBCHICKEN_SCHEME_OBJECTS_1) runtime
LIBCHICKEN_SHARED_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=$(O))
LIBCHICKEN_STATIC_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=-static$(O))
diff --cc scrutinizer.scm
index b1f9d974,99f6840c..700deaf8
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@@ -1076,352 -637,12 +1076,353 @@@
(for-each
(lambda (e)
(let* ((name (car e))
- (old (##sys#get name '##core#type))
- (new (cadr e)))
- (when (and old (not (equal? old new)))
- (##sys#notice
+ (old (variable-mark name '##compiler#type))
+ (new (cadr e))
+ (specs (and (pair? (cddr e)) (cddr e))))
+ (when (pair? new)
+ (case (car new)
+ ((procedure!)
+ (mark-variable name '##compiler#enforce #t)
+ (set-car! new 'procedure))
+ ((procedure!? procedure?!)
+ (mark-variable name '##compiler#enforce #t)
+ (mark-variable name '##compiler#predicate (cadr new))
+ (set! new (cons 'procedure (cddr new))))
+ ((procedure?)
+ (mark-variable name '##compiler#predicate (cadr new))
+ (set! new (cons 'procedure (cddr new))))))
+ (cond-expand
+ (debugbuild
+ (let-values (((t _) (validate-type new name)))
+ (unless t
+ (warning "invalid type specification" name new))))
+ (else))
+ (when (and old (not (compatible-types? old new)))
+ (warning
(sprintf
"type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
- name new old)))
- (##sys#put! name '##core#type new)))
+ name new old)))
+ (mark-variable name '##compiler#type new)
+ (when specs
+ ;;XXX validate types in specs
+ (mark-variable name '##compiler#specializations specs))))
(read-file dbfile))))
+
+(define (emit-type-file filename db)
+ (with-output-to-file filename
+ (lambda ()
+ (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
+ source-filename "\n")
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (when (variable-visible? sym)
+ (when (variable-mark sym '##compiler#declared-type)
+ (let ((specs (or (variable-mark sym '##compiler#specializations) '()))
+ (type (variable-mark sym '##compiler#type))
+ (pred (variable-mark sym '##compiler#predicate))
+ (enforce (variable-mark sym '##compiler#enforce)))
+ (pp (cons*
+ sym
+ (if (and (pair? type) (eq? 'procedure (car type)))
+ `(,(cond ((and enforce pred) 'procedure!?)
+ (pred 'procedure?)
+ (enforce 'procedure!)
+ (else 'procedure))
+ ,@(if pred (list pred) '())
+ ,@(cdr type))
+ type)
+ specs))))))
+ db)
+ (print "; END OF FILE"))))
+
+(define (match-specialization typelist atypes exact)
+ ;; - does not accept complex procedure types in typelist!
+ ;; - "exact" means: "or"-type in atypes is not allowed
+ (define (match st t)
+ (cond ((eq? st t))
+ ((pair? st)
+ (case (car st)
+ ((not) (matchnot (cadr st) t))
+ ((or) (any (cut match <> t) (cdr st)))
+ ((and) (every (cut match <> t) (cdr st)))
+ ((procedure) (bomb "match-specialization: invalid complex procedure type" st))
+ (else (equal? st t))))
+ ((eq? st '*))
+ ;; "list" different from "number": a pair is not necessarily a list:
+ ((eq? st 'list) (eq? t 'list))
+ ((eq? st 'number) (match '(or fixnum float) t))
+ ((pair? t)
+ (case (car t)
+ ((or) ((if exact every any) (cut match st <>) (cdr t)))
+ ((and) (every (cut match st <>) (cdr t)))
+ ((procedure) (match st 'procedure))
+ ;; (not ...) should not occur
+ (else (equal? st t))))
+ (else (equal? st t))))
+ (define (matchnot st t)
+ (cond ((eq? st t) #f)
+ ((eq? 'list t) (matchnot st '(or null pair)))
+ ((eq? 'number t) (matchnot st '(or fixnum float)))
+ ((eq? '* t) #f)
+ ((eq? 'list st) (not (match '(or null pair) t)))
+ ((eq? 'number st) (not (match '(or fixnum float) t)))
+ ((pair? t)
+ (case (car t)
+ ((or) (every (cut matchnot st <>) (cdr t)))
+ ((and) (any (cut matchnot st <>) (cdr t))) ;XXX test for "exact" here, too?
+ (else (not (match st t)))))
+ (else (not (match st t)))))
+ (let loop ((tl typelist) (atypes atypes))
+ (cond ((null? tl) (null? atypes))
+ ((null? atypes) #f)
+ ((eq? (car tl) '#!rest)
+ (every (cute match (cadr tl) <>) atypes))
+ ((match (car tl) (car atypes)) (loop (cdr tl) (cdr atypes)))
+ (else #f))))
+
+(define (specialize-node! node template)
+ (let ((args (cdr (node-subexpressions node)))
+ (env '()))
+ (define (subst x)
+ (cond ((and (vector? x)
+ (= 1 (vector-length x)) )
+ (let ((y (vector-ref x 0)))
+ (cond ((integer? y)
+ (if (negative? y)
+ (list-tail args (sub1 (- y)))
+ (list-ref args (sub1 y))))
+ ((symbol? y)
+ (cond ((assq y env) => cdr)
+ (else
+ (let ((var (gensym y)))
+ (set! env (alist-cons y var env))
+ var)))))))
+ ((and (vector? x)
+ (= 2 (vector-length x))
+ (integer? (vector-ref x 0))
+ (eq? '... (vector-ref x 1)))
+ (list-tail args (sub1 (vector-ref x 0))))
+ ((not (pair? x)) x)
+ ((eq? 'quote (car x)) x) ; to handle numeric constants
+ (else (cons (subst (car x)) (subst (cdr x))))))
+ (let ((spec (subst template)))
+ (copy-node! (build-node-graph spec) node))))
+
+(define (validate-type type name)
+ ;; - returns converted type or #f
+ ;; - also converts "(... -> ...)" types
+ ;; - drops "#!key ..." args by converting to #!rest
+ ;; - handles "(T1 -> T2 : T3)" (predicate)
++ ;; - simplifies result
+ (let ((ptype #f)) ; (T . PT) | #f
+ (define (upto lst p)
+ (let loop ((lst lst))
+ (cond ((eq? lst p) '())
+ (else (cons (car lst) (loop (cdr lst)))))))
+ (define (validate-llist llist)
+ (cond ((null? llist) '())
+ ((symbol? llist) '(#!rest *))
+ ((not (pair? llist)) #f)
+ ((eq? '#!optional (car llist))
+ (let ((l1 (validate-llist (cdr llist))))
+ (and l1 (cons '#!optional l1))))
+ ((eq? '#!rest (car llist))
+ (cond ((null? (cdr llist)) '(#!rest *))
+ ((not (pair? (cdr llist))) #f)
+ (else
+ (let ((l1 (validate (cadr llist))))
+ (and l1 `(#!rest ,l1))))))
+ ((eq? '#!key (car llist)) '(#!rest *))
+ (else
+ (let* ((l1 (validate (car llist)))
+ (l2 (validate-llist (cdr llist))))
+ (and l1 l2 (cons l1 l2))))))
+ (define (validate t #!optional (rec #t))
+ (cond ((memq t '(* string symbol char number boolean list pair
+ procedure vector null eof undefined port blob
+ pointer locative fixnum float pointer-vector
+ deprecated noreturn values))
+ t)
+ ((not (pair? t)) #f)
+ ((eq? 'or (car t))
+ (and (list? t)
+ (let ((ts (map validate (cdr t))))
+ (and (every identity ts)
+ `(or ,@ts)))))
+ ((eq? 'struct (car t))
+ (and (= 2 (length t))
+ (symbol? (cadr t))
+ t))
+ ((eq? 'procedure (car t))
+ (and (pair? (cdr t))
+ (let* ((name (if (symbol? (cadr t))
+ (cadr t)
+ name))
+ (t2 (if (symbol? (cadr t)) (cddr t) (cdr t))))
+ (and (pair? t2)
+ (list? (car t2))
+ (let ((ts (validate-llist (car t2))))
+ (and ts
+ (every identity ts)
+ (let* ((rt2 (cdr t2))
+ (rt (if (eq? '* rt2)
+ rt2
+ (and (list? rt2)
+ (let ((rts (map validate rt2)))
+ (and (every identity rts)
+ rts))))))
+ (and rt
+ `(procedure
+ ,@(if (and name (not rec)) (list name) '())
+ ,ts
+ ,@rt)))))))))
+ ((and (pair? (cdr t)) (memq '-> (cdr t))) =>
+ (lambda (p)
+ (let ((cp (memq ': (cdr t))))
+ (cond ((not cp)
+ (validate
+ `(procedure ,(upto t p) ,@(cdr p))
+ rec))
+ ((and (= 5 (length t))
+ (eq? p (cdr t))
+ (eq? cp (cdddr t)))
+ (set! t (validate `(procedure (,(first t)) ,(third t)) rec))
+ ;; we do it this way to distinguish the "outermost" predicate
+ ;; procedure type
+ (set! ptype (cons t (validate (cadr cp))))
+ t)
+ (else #f)))))
+ (else #f)))
- (let ((type (validate type #f)))
++ (let ((type (simplify-type (validate type #f))))
+ (values type (and ptype (eq? (car ptype) type) (cdr ptype))))))
+
+(define (initial-argument-types dest vars argc)
+ (if (and dest
+ strict-variable-types
+ (variable-mark dest '##compiler#declared-type))
+ (let ((ptype (variable-mark dest '##compiler#type)))
+ (if (procedure-type? ptype)
+ (nth-value 0 (procedure-argument-types ptype argc #t))
+ (make-list argc '*)))
+ (make-list argc '*)))
+
+
+;;; generate type-checks for formal variables
+
+#;(define (generate-type-checks! node loc vars inits)
+ ;; assumes type is validated
+ (define (test t v)
+ (case t
+ ((null) `(##core#inline "C_eqp" ,v '()))
+ ((eof) `(##core#inline "C_eofp" ,v))
+ ((string) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_stringp" ,v)
+ '#f))
+ ((float) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_flonump" ,v)
+ '#f))
+ ((char) `(##core#inline "C_charp" ,v))
+ ((fixnum) `(##core#inline "C_fixnump" ,v))
+ ((number) `(##core#inline "C_i_numberp" ,v))
+ ((list) `(##core#inline "C_i_listp" ,v))
+ ((symbol) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_symbolp" ,v)
+ '#f))
+ ((pair) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_pairp" ,v)
+ '#f))
+ ((boolean) `(##core#inline "C_booleanp" ,v))
+ ((procedure) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_closurep" ,v)
+ '#f))
+ ((vector) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_vectorp" ,v)
+ '#f))
+ ((pointer) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_pointerp" ,v)
+ '#f))
+ ((blob) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_byteblockp" ,v)
+ '#f))
+ ((pointer-vector) `(##core#inline "C_i_structurep" ,v 'pointer-vector))
+ ((port) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_portp" ,v)
+ '#f))
+ ((locative) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_locativep" ,v)
+ '#f))
+ (else
+ (case (car t)
+ ((procedure) `(if (##core#inline "C_blockp" ,v)
+ (##core#inline "C_closurep" ,v)
+ '#f))
+ ((or)
+ (cond ((null? (cdr t)) '(##core#undefined))
+ ((null? (cddr t)) (test (cadr t) v))
+ (else
+ `(if ,(test (cadr t) v)
+ '#t
+ ,(test `(or ,@(cddr t)) v)))))
+ ((and)
+ (cond ((null? (cdr t)) '(##core#undefined))
+ ((null? (cddr t)) (test (cadr t) v))
+ (else
+ `(if ,(test (cadr t) v)
+ ,(test `(and ,@(cddr t)) v)
+ '#f))))
+ ((not)
+ `(not ,(test (cadr t) v)))
+ (else (bomb "invalid type" t v))))))
+ (let ((body (first (node-subexpressions node))))
+ (let loop ((vars (reverse vars)) (inits (reverse inits)) (b body))
+ (cond ((null? inits)
+ (if (eq? b body)
+ body
+ (copy-node!
+ (make-node
+ (node-class node) ; lambda
+ (node-parameters node)
+ (list b))
+ node)))
+ ((eq? '* (car inits))
+ (loop (cdr vars) (cdr inits) b))
+ (else
+ (loop
+ (cdr vars) (cdr inits)
+ (make-node
+ 'let (list (gensym))
+ (list
+ (build-node-graph
+ (let ((t (car inits))
+ (v (car vars)))
+ `(if ,(test t v)
+ (##core#undefined)
+ (##core#app
+ ##sys#error ',loc
+ ',(sprintf "expected argument `~a' to be of type `~s'"
+ v t)
+ ,v))))
+ b))))))))
+
+
+;;; hardcoded result types for certain primitives
+
+(define-syntax define-special-case
+ (syntax-rules ()
+ ((_ name handler)
+ (##sys#put! 'name '##compiler#special-result-type handler))))
+
+(define-special-case ##sys#make-structure
+ (lambda (node rtypes)
+ (or (let ((subs (node-subexpressions node)))
+ (and (>= (length subs) 2)
+ (let ((arg1 (second subs)))
+ (and (eq? 'quote (node-class arg1))
+ (let ((val (first (node-parameters arg1))))
+ (and (symbol? val)
+ ;;XXX a bit of a hack - we should remove the distinct
+ ;; "pointer-vector" type.
+ (if (eq? 'pointer-vector val)
+ '(pointer-vector)
+ `((struct ,val)))))))))
+ rtypes)))
diff --cc tcp.scm
index ff74f133,18530924..1e094208
--- a/tcp.scm
+++ b/tcp.scm
@@@ -642,19 -642,17 +642,19 @@@ EO
(##sys#string-append "cannot compute remote address - " strerror) p) ) ) ) )
(define (tcp-port-numbers p)
- (##sys#check-port p 'tcp-port-numbers)
+ (##sys#check-port* p 'tcp-port-numbers)
(let ((fd (##sys#tcp-port->fileno p)))
- (values
- (or (##net#getsockport fd)
- (##sys#signal-hook
- #:network-error 'tcp-port-numbers
- (##sys#string-append "cannot compute local port - " strerror) p) )
- (or (##net#getpeerport fd)
- (##sys#signal-hook
- #:network-error 'tcp-port-numbers
- (##sys#string-append "cannot compute remote port - " strerror) p) ) ) ) )
+ (let ((sp (##net#getsockport fd))
+ (pp (##net#getpeerport fd)))
+ (when (eq? -1 sp)
+ (##sys#signal-hook
+ #:network-error 'tcp-port-numbers
+ (##sys#string-append "cannot compute local port - " strerror) p))
+ (when (eq? -1 pp)
+ (##sys#signal-hook
+ #:network-error 'tcp-port-numbers
+ (##sys#string-append "cannot compute remote port - " strerror) p) )
+ (values sp pp))))
(define (tcp-listener-port tcpl)
(##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)
diff --cc tests/scrutiny.expected
index 9325c771,cd3a5bc4..1e469592
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@@ -43,55 -43,6 +43,42 @@@ Warning: at toplevel
expected in `let' binding of `g8' a single result, but were given 2 results
Warning: at toplevel:
- g89: in procedure call to `g89', expected a value of type `(procedure () *)', but were given a value of type `fixnum'
+ in procedure call to `g89', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
+
+Warning: in toplevel procedure `foo2':
+ scrutiny-tests.scm:57: in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `number'
+
+Warning: at toplevel:
+ scrutiny-tests.scm:65: in procedure call to `foo3', expected argument #1 of type `string', but was given an argument of type `fixnum'
+
+Warning: in toplevel procedure `foo4':
+ scrutiny-tests.scm:70: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+
+Warning: in toplevel procedure `foo5':
+ scrutiny-tests.scm:76: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+
+Warning: in toplevel procedure `foo6':
+ scrutiny-tests.scm:82: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+
- Warning: at toplevel:
- scrutiny-tests.scm:89: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
-
+Warning: in toplevel procedure `foo9':
+ scrutiny-tests.scm:97: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+
+Note: in toplevel procedure `foo10':
+ expression returns a result of type `string', but is declared to return `pair', which is not a subtype
+
+Warning: in toplevel procedure `foo10':
+ scrutiny-tests.scm:101: in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `pair'
+
+Warning: in toplevel procedure `foo10':
+ expression returns 2 values but is declared to have a single result
+
+Note: in toplevel procedure `foo10':
+ expression returns a result of type `fixnum', but is declared to return `*', which is not a subtype
+
+Warning: in toplevel procedure `foo10':
+ expression returns zero values but is declared to have a single result of type `*'
+
+Warning: in toplevel procedure `foo10':
+ scrutiny-tests.scm:104: in procedure call to `*', expected argument #1 of type `number', but was given an argument of type `string'
Warning: redefinition of standard binding: car
-
- Warning: (in k161) constant-folding expression results in error: "bad argument type": (+ (quote a) (quote b))
-
- Warning: (in k171) constant-folding expression results in error: "bad argument type - not a string": (string-append (quote 99) (quote "abc"))
-
- Warning: (in k171) constant-folding expression results in error: "bad argument type - not a string": (string-append (quote 99) (quote "abc"))
-
- Warning: (in k171) constant-folding expression results in error: "bad argument type - not a string": (string-append (quote 99) (quote "abc"))
-
- Warning: (in k171) constant-folding expression results in error: "bad argument type - not a string": (string-append (quote 99) (quote "abc"))
diff --cc types.db
index 58a0bbe0,1603fda7..decdf091
--- a/types.db
+++ b/types.db
@@@ -780,35 -377,27 +780,36 @@@
(minimum-flonum float)
(most-negative-fixnum fixnum)
(most-positive-fixnum fixnum)
-(on-exit (procedure on-exit ((procedure () . *)) undefined))
-(open-input-string (procedure open-input-string (string #!rest) port))
+(on-exit (procedure! on-exit ((procedure () . *)) undefined))
+(open-input-string (procedure! open-input-string (string #!rest) port))
(open-output-string (procedure open-output-string (#!rest) port))
(parentheses-synonyms (procedure parentheses-synonyms (#!optional *) *))
-(port-name (procedure port-name (#!optional port) *))
-(port-position (procedure port-position (#!optional port) fixnum))
-(port? (procedure port? (*) boolean))
+
+(port-name (procedure! port-name (#!optional port) *)
+ ((port) (##sys#slot #(1) '3)))
+
+(port-position (procedure! port-position (#!optional port) fixnum))
+
+(port? (procedure? port port? (*) boolean))
+
(print (procedure print (#!rest *) undefined))
-(print-call-chain (procedure print-call-chain (#!optional port fixnum * string) undefined))
-(print-error-message (procedure print-error-message (* #!optional port string) undefined))
+(print-call-chain (procedure! print-call-chain (#!optional port fixnum * string) undefined))
+(print-error-message (procedure! print-error-message (* #!optional port string) undefined))
(print* (procedure print* (#!rest) undefined))
-(procedure-information (procedure procedure-information (procedure) *))
-(program-name (procedure program-name (#!optional string) string))
-(promise? (procedure promise? (*) boolean))
-(put! (procedure put! (symbol symbol *) undefined))
+(procedure-information (procedure! procedure-information (procedure) *))
+(program-name (procedure! program-name (#!optional string) string))
+(promise? (procedure? (struct promise) promise? (*) boolean))
+
+(put! (procedure! put! (symbol symbol *) undefined)
+ ((symbol symbol *)
+ (##core#inline_allocate ("C_a_i_putprop" 8) #(1) #(2) #(3))))
+
+ (quit (procedure quit (#!optional *) noreturn))
-(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))
+(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))
(repository-path (procedure repository-path (#!optional *) *))
(require (procedure require (#!rest *) undefined))
(reset (procedure reset () undefined))
Trap