Display: If possible, show name of closure.
authorJan Nieuwenhuizen <janneke@gnu.org>
Mon, 26 Dec 2016 09:00:17 +0000 (10:00 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Wed, 4 Jan 2017 07:49:45 +0000 (08:49 +0100)
* module/mes/display.mes (display): Lookup closure's name and display it.

lib.c
mes.c
module/mes/display.mes

diff --git a/lib.c b/lib.c
index da55daf637a04110176590ecf0b7450242b1e3fc..e8f288394ad239dc4deaa2dbc7ed8df7b71ab196 100644 (file)
--- a/lib.c
+++ b/lib.c
@@ -23,6 +23,13 @@ SCM cadr (SCM x) {return car (cdr (x));}
 SCM cdar (SCM x) {return cdr (car (x));}
 SCM cddr (SCM x) {return cdr (cdr (x));}
 
 SCM cdar (SCM x) {return cdr (car (x));}
 SCM cddr (SCM x) {return cdr (cdr (x));}
 
+SCM
+xassq (SCM x, SCM a) ///for speed in core only
+{
+  while (a != cell_nil && x != CDAR (a)) a = CDR (a);
+  return a != cell_nil ? CAR (a) : cell_f;
+}
+
 SCM
 length (SCM x)
 {
 SCM
 length (SCM x)
 {
diff --git a/mes.c b/mes.c
index 817e947a0c3f039b01e1fd5f65c3a2aa2c4dbd4e..463b891f8aaac0fbd67b75fdc23aa527e071b531 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -311,12 +311,7 @@ pairlis (SCM x, SCM y, SCM a)
 SCM
 assq (SCM x, SCM a)
 {
 SCM
 assq (SCM x, SCM a)
 {
-  while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f)
-    {
-      if (TYPE (a) == BROKEN_HEART || TYPE (CAR (a)) == BROKEN_HEART)
-        fprintf (stderr, "oops, broken heart\n");
-      a = CDR (a);
-    }
+  while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
   return a != cell_nil ? car (a) : cell_f;
 }
 
   return a != cell_nil ? car (a) : cell_f;
 }
 
index ee5e65b4a5b14484aa6af4e723570e2bb599b689..1792166bb4a9de0f764b82b6e433f1cb512e84e8 100644 (file)
 ;;; Code:
 
 (mes-use-module (mes scm))
 ;;; Code:
 
 (mes-use-module (mes scm))
+;;(mes-use-module (mes srfi srfi-1))
+
+(define (srfi-1:member x lst eq)
+  (if (null? lst) #f
+      (if (eq x (car lst)) lst
+          (srfi-1:member x (cdr lst) eq))))
+
+(define (next-xassq x a)
+  (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
+         (lambda (a) (xassq x (cdr a)))))
+
+(define (next-xassq2 x a)
+  (and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
+         (lambda (a)
+           (and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
+                  (lambda (a) (xassq x (cdr a)))))))
 
 (define (display x . rest)
   (let* ((port (if (null? rest) (current-output-port) (car rest)))
 
 (define (display x . rest)
   (let* ((port (if (null? rest) (current-output-port) (car rest)))
               (if name (display name)
                   (write-char x port)))))
        ((closure? x)
               (if name (display name)
                   (write-char x port)))))
        ((closure? x)
-        (display "#<procedure #f " port)
+        (display "#<procedure " port)
+        (let ((name (and=> (next-xassq2 x (current-module)) car)))
+          (display name port))
+        (display " " port)
         (display (cadr (core:cdr x)) port)
         (display ">" port))
        ((macro? x)
         (display (cadr (core:cdr x)) port)
         (display ">" port))
        ((macro? x)