[Chicken-hackers] [PATCH] Re: wrong type for alist-delete!

[Evan Hanson]

Hi Peter,

That's great, thanks for the patch necromancy and all of the related
improvements. I especially like the argument order standardization. I've
applied these, and will update the srfi-1 egg as well.

Attached is another small improvement: if memq, memv, or member return a
list, the type of its first element will be the same as the first
procedure argument. Actually, this isn't true of member in CHICKEN 4
since one can do footgunish things with the comparison procedure, but it
works for the rest.

Evan
From cea8d86a0de9416d64dcac5dc305faf9d696853b Mon Sep 17 00:00:00 2001
From: Evan Hanson 
Date: Sat, 13 Feb 2016 23:51:07 +1300
Subject: [PATCH] Preserve type of first element in memq/memv procedure results

If the result is a list, its first element will be the same type as the
first procedure argument.
---
 types.db | 8 
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/types.db b/types.db
index 114aac1..aa38648 100644
--- a/types.db
+++ b/types.db
@@ -174,13 +174,13 @@
 (reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a)) (list-of a)))
  ((null) (null) (let ((#(tmp) #(1))) '(
 
-(memq (forall (a) (#(procedure #:clean) memq (* (list-of a))
-		   (or false (list-of a
+(memq (forall (a b) (#(procedure #:clean) memq (a (list-of b))
+ (or false (pair a (list-of b)
   ((* null) (let ((#(tmp) #(1))) '#f))
   ((* list) (##core#inline "C_u_i_memq" #(1) #(2
 
-(memv (forall (a) (#(procedure #:clean) memv (* (list-of a))
-		   (or false (list-of a
+(memv (forall (a b) (#(procedure #:clean) memv (a (list-of b))
+ (or false (pair a (list-of b)
   ((* null) (let ((#(tmp) #(1))) '#f))
   (((or symbol procedure immediate) list)
(##core#inline "C_u_i_memq" #(1) #(2
-- 
2.7.0.rc3

From 0028c1afb143dcf72747e153e9a251ebf857e511 Mon Sep 17 00:00:00 2001
From: Evan Hanson 
Date: Sat, 13 Feb 2016 23:56:40 +1300
Subject: [PATCH] Preserve type of first element in mem* procedure results

If the result is a list, its first element will be the same type as the
first procedure argument.
---
 types.db | 12 ++--
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/types.db b/types.db
index b5a5333..9d565df 100644
--- a/types.db
+++ b/types.db
@@ -179,19 +179,19 @@
 (reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a)) (list-of a)))
  ((null) (null) (let ((#(tmp) #(1))) '(
 
-(memq (forall (a) (#(procedure #:clean #:foldable) memq (* (list-of a))
-		   (or false (list-of a
+(memq (forall (a b) (#(procedure #:clean #:foldable) memq (a (list-of b))
+		 (or false (pair a (list-of b)
   ((* null) (let ((#(tmp) #(1))) '#f))
   ((* list) (##core#inline "C_u_i_memq" #(1) #(2
 
-(memv (forall (a) (#(procedure #:clean #:foldable) memv (* (list-of a))
-		   (or false (list-of a
+(memv (forall (a b) (#(procedure #:clean #:foldable) memv (a (list-of b))
+		 (or false (pair a (list-of b)
   ((* null) (let ((#(tmp) #(1))) '#f))
   (((or symbol procedure immediate) list)
(##core#inline "C_u_i_memq" #(1) #(2
 
-(member (forall (a) (#(procedure #:clean #:foldable) member
- (* (list-of a)) (or false (list-of a
+(member (forall (a b) (#(procedure #:clean #:foldable) member (a (list-of b))
+		   (or false (pair a (list-of b)
 	((* null) (let ((#(tmp) #(1))) '#f))
 	(((or symbol procedure immediate) list)
 	 (##core#inline "C_u_i_memq" #(1) #(2)))
-- 
2.7.0.rc3



signature.asc
Description: PGP signature
___
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers

Re: [Chicken-hackers] [PATCH] Re: wrong type for alist-delete!

[Peter Bex]

On Sun, Feb 14, 2016 at 12:15:15AM +1300, Evan Hanson wrote:
> Hi Peter,
> 
> That's great, thanks for the patch necromancy and all of the related
> improvements. I especially like the argument order standardization. I've
> applied these, and will update the srfi-1 egg as well.

I noticed you forgot to update srfi-1, so I just did that.
Interestingly, srfi-1.types didn't have an entry for assoc or member,
probably because those are also available in core.  I've added them now,
including the specializations, and made then #:foldable too.

I haven't yet published this as a new release because it's a minor
change.  I noticed there are no tests for the srfi-1 egg, maybe we should
consider copying them from another Scheme?  From a quick check, only
Chibi has some minor tests for it.

> Attached is another small improvement: if memq, memv, or member return a
> list, the type of its first element will be the same as the first
> procedure argument. Actually, this isn't true of member in CHICKEN 4
> since one can do footgunish things with the comparison procedure, but it
> works for the rest.

This can be done analogously for assv and assq (and assoc in CHICKEN 5).
We can't do it for assoc in CHICKEN 4 and rassoc in either version because
of the same footgunnery that can be done with the SRFI-1 version of member.

See the attached patches.

Cheers,
Peter
From 8c9b91c9a7920d90bb9be43f56579660d96ccef4 Mon Sep 17 00:00:00 2001
From: Peter Bex 
Date: Sat, 13 Feb 2016 19:23:06 +0100
Subject: [PATCH] Preserve type of argument in car in assq/assv/assoc procedure
 results.

If the result is a pair, the car will always be the same type as the
first procedure argument.  The list may consist of pairs of union
types or unknown types, so this allows us to recover some type info
due to the first argument in most cases being more specific.
---
 types.db | 18 +-
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/types.db b/types.db
index 9d565df..c8accdc 100644
--- a/types.db
+++ b/types.db
@@ -198,24 +198,24 @@
 	((* (list-of (or symbol procedure immediate)))
 	 (##core#inline "C_u_i_memq" #(1) #(2
 
-(assq (forall (a b) (#(procedure #:clean #:foldable) assq
-		 (* (list-of (pair a b)))
-		 (or false (pair a b
+(assq (forall (a b c) (#(procedure #:clean #:foldable) assq
+   (a (list-of (pair b c)))
+   (or false (pair a c
   ((* null) (let ((#(tmp) #(1))) '#f))
   ((* (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2
 
-(assv (forall (a b) (#(procedure #:clean #:foldable) assv
-		 (* (list-of (pair a b)))
-		 (or false (pair a b
+(assv (forall (a b c) (#(procedure #:clean #:foldable) assv
+   (a (list-of (pair b c)))
+   (or false (pair a c
   ((* null) (let ((#(tmp) #(1))) '#f))
   (((or symbol immediate procedure) (list-of pair))
(##core#inline "C_u_i_assq" #(1) #(2)))
   ((* (list-of (pair (or symbol procedure immediate) *)))
(##core#inline "C_u_i_assq" #(1) #(2
 
-(assoc (forall (a b) (#(procedure #:clean #:foldable) assoc
-  (* (list-of (pair a b)))
-  (or false (pair a b
+(assoc (forall (a b c) (#(procedure #:clean #:foldable) assoc
+			(a (list-of (pair b c)))
+			(or false (pair a c
((* null) (let ((#(tmp) #(1))) '#f))
(((or symbol procedure immediate) (list-of pair))
 	(##core#inline "C_u_i_assq" #(1) #(2)))
-- 
2.1.4

From d51ddb2733afc0683b3e581562c70b38ba1658d7 Mon Sep 17 00:00:00 2001
From: Peter Bex 
Date: Sat, 13 Feb 2016 19:21:33 +0100
Subject: [PATCH] Preserve type of argument in car in assq/assv procedure
 results.

If the result is a pair, the car will always be the same type as the
first procedure argument.  The list may consist of pairs of union
types or unknown types, so this allows us to recover some type info
due to the first argument in most cases being more specific.
---
 types.db | 8 
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/types.db b/types.db
index aa38648..920e429 100644
--- a/types.db
+++ b/types.db
@@ -195,13 +195,13 @@
 	((* (list-of (or symbol procedure immediate)))
 	 (##core#inline "C_u_i_memq" #(1) #(2
 
-(assq (forall (a b) (#(procedure #:clean) assq (* (list-of (pair a b)))
-		 (or false (pair a b
+(assq (forall (a b c) (#(procedure #:clean) assq (a (list-of (pair b c)))
+		   (or false (pair a c
   ((* null) (let ((#(tmp) #(1))) '#f))
   ((* (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2
 
-(assv (forall (a b) (#(procedure #:clean) assv (* (list-of (pair a b)))
-		 (or false (pair a b
+(assv (forall (a b c) (#(procedure #:clean) assv (a (list-of (pair b c)))
+		   (or false (pair a c
   ((* null) (let ((#(tmp) #(1))) '#f))
   (((or symbol immediate procedure) (list-of pair))
(##core#inline 

Re: [Chicken-hackers] [PATCH] Re: wrong type for alist-delete!

[John Cowan]

Peter Bex scripsit:

> I haven't yet published this as a new release because it's a minor
> change.  I noticed there are no tests for the srfi-1 egg, maybe we should
> consider copying them from another Scheme?  From a quick check, only
> Chibi has some minor tests for it.

I've modified my tests for SRFI 116 to run against SRFI 1 instead.  You
can snarf them from .
They don't offer complete coverage, but better than nothing.

-- 
John Cowan  http://www.ccil.org/~cowanco...@ccil.org
If I have not seen as far as others, it is because giants were standing
on my shoulders.  --Hal Abelson

___
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers

Re: [Chicken-hackers] [PATCH] Re: wrong type for alist-delete!

[Peter Bex]

On Sun, Feb 14, 2016 at 11:06:33AM +1300, Evan Hanson wrote:
> Hi John,
> 
> On 2016-02-13 16:05, John Cowan wrote:
> > I've modified my tests for SRFI 116 to run against SRFI 1 instead.  You
> > can snarf them from .
> > They don't offer complete coverage, but better than nothing.
> 
> Snarfed, much appreciated, Thanks!

+1, good job guys!

Cheers,
Peter


signature.asc
Description: Digital signature
___
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers

Re: [Chicken-hackers] [PATCH] Re: wrong type for alist-delete!

[Evan Hanson]

Hi John,

On 2016-02-13 16:05, John Cowan wrote:
> I've modified my tests for SRFI 116 to run against SRFI 1 instead.  You
> can snarf them from .
> They don't offer complete coverage, but better than nothing.

Snarfed, much appreciated, Thanks!

Evan

___
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers

Re: [Chicken-hackers] [PATCH] Re: wrong type for alist-delete!

[Mario Domenech Goulart]

Hello,

On Sat, 13 Feb 2016 16:05:46 -0500 John Cowan  wrote:

>> I haven't yet published this as a new release because it's a minor
>> change.  I noticed there are no tests for the srfi-1 egg, maybe we should
>> consider copying them from another Scheme?  From a quick check, only
>> Chibi has some minor tests for it.
>
> I've modified my tests for SRFI 116 to run against SRFI 1 instead.  You
> can snarf them from .
> They don't offer complete coverage, but better than nothing.

Also
https://github.com/mario-goulart/chicken-tests/blob/master/tests/srfi-1.scm
that I ported from Larceny.

All the best.
Mario
-- 
http://parenteses.org/mario

___
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers

[Chicken-hackers] [PATCH] Add line numbers to scrutiny warnings for value count mismatches

[Evan Hanson]

Hello,

This small patch just adds line numbers to the scrutiny messages that
are printed when zero or many values are used in a single-valued context
(see the diff in "tests/scrutiny.expected" for an example of what has
changed).

Cheers,

Evan
>From 4401bae01e9dca24c8a8cdae80933943f76a716b Mon Sep 17 00:00:00 2001
From: Evan Hanson 
Date: Sun, 14 Feb 2016 11:49:02 +1300
Subject: [PATCH] Add line numbers to scrutiny warnings for value count
 mismatches

Pull the logic for node line number extraction into a single procedure
to make it easier to print line numbers during scrutiny, and use it in
the `single` and `call-result` procedures.
---
 scrutinizer.scm | 52 -
 tests/scrutiny.expected |  4 ++--
 2 files changed, 32 insertions(+), 24 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 12251bc..c8c1e2f 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -123,6 +123,16 @@
 (define (walked-result n)
   (first (node-parameters n)))		; assumes ##core#the/result node
 
+(define (node-line-number n)
+  (case (node-class n)
+((##core#call)
+ (let ((params (node-parameters n)))
+   (and (pair? (cdr params))
+	(pair? (cadr params)) ; debug-info has line-number information?
+	(source-info->line (cadr params)
+((##core#typecase)
+ (car (node-parameters n)))
+(else #f)))
 
 (define (scrutinize node db complain specialize)
   (let ((blist '())			; (((VAR . FLOW) TYPE) ...)
@@ -219,7 +229,7 @@
 	   t (pp-fragment x)))
 	f))
 
-(define (single what tv loc)
+(define (single node what tv loc)
   (if (eq? '* tv)
 	  '*
 	  (let ((n (length tv)))
@@ -227,14 +237,14 @@
 		  ((zero? n)
 		   (report
 		loc
-		"expected a single result ~a, but received zero results"
-		what)
+		"~aexpected a single result ~a, but received zero results"
+		(node-source-prefix node) what)
 		   'undefined)
 		  (else
 		   (report
 		loc
-		"expected a single result ~a, but received ~a result~a"
-		what n (multiples n))
+		"~aexpected a single result ~a, but received ~a result~a"
+		(node-source-prefix node) what n (multiples n))
 		   (first tv))
 
 (define (report-notice loc msg . args)
@@ -253,6 +263,10 @@
   (set! errors #t)
   (apply report loc msg args))
 
+(define (node-source-prefix n)
+  (let ((line (node-line-number n)))
+   (if (not line) "" (sprintf "(~a) " line
+
 (define (location-name loc)
   (define (lname loc1)
 	(if loc1
@@ -296,16 +310,9 @@
 
 (define (call-result node args e loc params typeenv)
   (define (pname)
-	(sprintf "~ain procedure call to `~s', " 
-	  (if (and (pair? params)
-		   (pair? (cdr params))
-		   (pair? (cadr params))) ; sourceinfo has line-number information?
-	  (let ((n (source-info->line (cadr params
-		(if n
-		(sprintf "(~a) " n)
-		""))
-	  "")
-	  (fragment (first (node-subexpressions node)
+	(sprintf "~ain procedure call to `~s', "
+		 (node-source-prefix node)
+		 (fragment (first (node-subexpressions node)
   (let* ((actualtypes (map walked-result args))
 	 (ptype (car actualtypes))
 	 (pptype? (procedure-type? ptype))
@@ -480,7 +487,7 @@
 			(tst (first subs))
 			(nor-1 noreturn))
 		(set! noreturn #f)
-		(let* ((rt (single "in conditional" (walk tst e loc #f #f flow tags) loc))
+		(let* ((rt (single n "in conditional" (walk tst e loc #f #f flow tags) loc))
 			   (c (second subs))
 			   (a (third subs))
 			   (nor0 noreturn))
@@ -533,7 +540,8 @@
 			(walk (car body) (append e2 e) loc dest tail flow ctags)
 			(let* ((var (car vars))
 			   (val (car body))
-			   (t (single 
+			   (t (single
+   n
    (sprintf "in `let' binding of `~a'" (real-name var))
    (walk val e loc var #f flow #f) 
    loc)))
@@ -600,7 +608,8 @@
 		 ((set! ##core#set!)
 		  (let* ((var (first params))
 			 (type (variable-mark var '##compiler#type))
-			 (rt (single 
+			 (rt (single
+			  n
 			  (sprintf "in assignment to `~a'" var)
 			  (walk (first subs) e loc var #f flow #f)
 			  loc))
@@ -675,7 +684,8 @@
   (make-node
    '##core#the/result
    (list
-	(single 
+	(single
+	 n
 	 (sprintf 
 	 "in ~a of procedure call `~s'"
 	   (if (zero? i)
@@ -817,9 +827,7 @@
 		  (cond ((null? types)
 			 (quit "~a~ano clause applies in `compiler-typecase' for expression of type `~s':~a" 
    (location-name loc)
-   (if (first params) 
-   (sprintf "(~a) " (first params))
-   "")
+   (node-source-prefix n)
    (car ts)
    (string-concatenate
 (map (lambda (t) (sprintf "\n~a" t))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 04fe472..e7b28cb 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -23,10 +23,10 @@ Warning: at toplevel: