scm: Fix psyntax/keyword/optargs interaction bug.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 7 Jan 2017 00:08:29 +0000 (01:08 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 7 Jan 2017 00:08:29 +0000 (01:08 +0100)
* 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
module/mes/pmatch.mes
module/mes/psyntax-0.mes
tests/optargs.test

index 8f495cd2b5084cbf4c9613dc3cd3a1f99cb05116..3e3396ce91da79f5635782ff56f23d3eaa854b9c 100644 (file)
              (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))))
index 18bd5bebfe852a2e940c01b1e2a0ffed28c16b59..aefff4476cc0e4a6f67cfd42478fe47fbfdfd73f 100644 (file)
@@ -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")
index 0d958a536962ced2d232ac370296e4b0f271a783..54d83162eaf93378d8b476a51d5517e058a864ca 100644 (file)
@@ -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))
 
index 15c680c9c2c43584291cfbf60bf158e9c36f5e7c..cffed7634f6f5772a43450b5b3c17fdd5d018948 100755 (executable)
@@ -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)