From 21a6f2ca521585199ecad5e79b9d502b9e86d858 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Sat, 7 Jan 2017 01:08:29 +0100
Subject: [PATCH] scm: Fix psyntax/keyword/optargs interaction bug.

* module/mes/psyntax-0.mes (self-evaluating?): Add keyword?.
* module/mes/pmatch.mes (mes): Add missing psyntax dependency.
* module/mes/optargs.scm (rest-arg->keyword-binding-list): Make error
  messages non-constant.
* tests/optargs.test ("clone <info>"): New test.
---
 module/mes/optargs.scm   |  4 +-
 module/mes/pmatch.mes    |  3 +-
 module/mes/psyntax-0.mes |  2 +-
 tests/optargs.test       | 80 ++++++++++++++++++++++++++++++++++++++++
 4 files changed, 85 insertions(+), 4 deletions(-)

diff --git a/module/mes/optargs.scm b/module/mes/optargs.scm
index 8f495cd2..3e3396ce 100644
--- a/module/mes/optargs.scm
+++ b/module/mes/optargs.scm
@@ -173,11 +173,11 @@
 	      (cond
 	       ((memq first keywords)
 		(if (null? rest)
-		    (error "Keyword argument has no value.")
+                    (error "Keyword argument has no value:" first)
 		    (next (cons (cons (keyword->symbol first)
 				      (car rest)) accum))))
 	       ((not allow-other-keys?)
-		(error "Unknown keyword in arguments."))
+                (error "Unknown keyword in arguments:" first))
 	       (else (if (null? rest)
 			 accum
 			 (next accum))))
diff --git a/module/mes/pmatch.mes b/module/mes/pmatch.mes
index 18bd5beb..aefff447 100644
--- a/module/mes/pmatch.mes
+++ b/module/mes/pmatch.mes
@@ -1,7 +1,7 @@
 ;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of Mes.
 ;;;
@@ -24,4 +24,5 @@
 
 (mes-use-module (mes guile))
 (mes-use-module (mes quasiquote))
+(mes-use-module (mes psyntax))
 (include-from-path "mes/pmatch.scm")
diff --git a/module/mes/psyntax-0.mes b/module/mes/psyntax-0.mes
index 0d958a53..54d83162 100644
--- a/module/mes/psyntax-0.mes
+++ b/module/mes/psyntax-0.mes
@@ -26,7 +26,7 @@
 
 (define annotation? (lambda (x) #f))
 (define (self-evaluating? x)
-  (or (boolean? x) (number? x) (string? x) (char? x) (null? x) (closure? x)))
+  (or (null? x) (boolean? x) (char? x) (closure? x) (keyword? x) (number? x) (string? x)))
 
 (define (void) (if #f #f))
 
diff --git a/tests/optargs.test b/tests/optargs.test
index 15c680c9..cffed763 100755
--- a/tests/optargs.test
+++ b/tests/optargs.test
@@ -56,4 +56,84 @@ exit $?
 (pass-if "optargs key" ((lambda* (#:key (foo #f)) foo) #:foo #t))
 (pass-if-equal "optargs key default" #f ((lambda* (#:key (foo #f)) foo)))
 
+(mes-use-module (mes pmatch))
+
+(define <info> '<info>)
+(define <functions> '<functions>)
+(define <globals> '<globals>)
+(define <locals> '<locals>)
+(define <text> '<text>)
+
+(define* (make o #:key (functions '()) (globals '()) (locals '()) (text '()))
+  (pmatch o
+    (<info> (list <info>
+                  (cons <functions> functions)
+                  (cons <globals> globals)
+                  (cons <locals> locals)
+                  (cons <text> text)))))
+
+;; (define* (make o #:key (functions '()) (globals '()) (locals '()) (text '()))
+;;   (format (current-error-port) "make\n")
+;;   ((cond ((info? o)
+;;           (list <info>
+;;                 (cons <functions> functions)
+;;                 (cons <globals> globals)
+;;                 (cons <locals> locals)
+;;                 (cons <text> text))))))
+
+(define (.functions o)
+  (pmatch o
+    ((<info> . ,alist) (assq-ref alist <functions>))))
+
+(define (.globals o)
+  (pmatch o
+    ((<info> . ,alist) (assq-ref alist <globals>))))
+
+(define (.locals o)
+  (pmatch o
+    ((<info> . ,alist) (assq-ref alist <locals>))))
+
+(define (.text o)
+  (pmatch o
+    ((<info> . ,alist) (assq-ref alist <text>))))
+
+(define (info? o)
+  (and (pair? o) (eq? (car o) <info>)))
+
+;; FIXME: psyntax+pmatch+optarg is broken; BINDINGS-> (g1234 g1234)
+;; iso (function function)
+;; (define (clone o . rest)
+;;   (pmatch o
+;;     ((<info>
+;;       (<functions> . ,functions)
+;;       (<globals> . ,globals)
+;;       (<locals> . ,locals)
+;;       (<text> . ,text))
+;;      (let-keywords rest
+;;                    #f
+;;                    ((functions functions)
+;;                     (globals globals)
+;;                     (locals locals)
+;;                     (text text))
+;;                    (make <info> #:functions functions #:globals globals #:locals locals #:text text)))))
+
+(define (clone o . rest)
+  (format (current-error-port) "clone rest=~a\n" rest)
+  (cond ((info? o)
+         (let ((functions (.functions o))
+               (globals (.globals o))
+               (locals (.locals o))
+               (text (.text o)))
+           (let-keywords rest
+                         #f
+                         ((functions functions)
+                          (globals globals)
+                          (locals locals)
+                          (text text))
+                         (make <info> #:functions functions #:globals globals #:locals locals #:text text))))))
+
+(pass-if-equal "clone <info>"
+    (make <info> #:functions '(0))
+  (clone (make <info>) #:functions '(0)))
+
 (result 'report)