From 7c98071e5bd7ff0451ad5650b0d728763ddd8924 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès
Date: Wed, 18 Mar 2009 01:15:56 +0100
Subject: writer: Adapt `%procedure-arity' to Guile-VM.

* src/guile/skribilo/writer.scm (%using-vm?): Remove.  It would always
  be true since `resolve-module' creates non-existent modules.
  (%procedure-arity): Use `eval-case', assuming the `else' clause
  matches Guile-VM, which is the case with Guile `master' commit
  7eba9c99c262acb872a52d95c45a216232d2b8dc (dated Wed Mar 18 00:46:16
  2009 +0100).
---
 src/guile/skribilo/writer.scm | 34 +++++++++++++++++++++++++---------
 1 file changed, 25 insertions(+), 9 deletions(-)

(limited to 'src')

diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm
index 9acc195..a57acc5 100644
--- a/src/guile/skribilo/writer.scm
+++ b/src/guile/skribilo/writer.scm
@@ -87,15 +87,31 @@
 	     (proc node e)))))
 
 
-(define %using-vm?
-  ;; #t if using Guile's VM.
-  (false-if-exception (resolve-module '(system vm program))))
-
-(define (%procedure-arity proc)
-  (if (and %using-vm?
-           ((@ (system vm program) program?) proc))
-      (car ((@ (system vm program) program-arity) proc))
-      (car (procedure-property proc 'arity))))
+(define %procedure-arity
+  (eval-case ((load-toplevel)
+              ;; Here we assume Guile's interpreter is used, either from
+              ;; Guile 1.8 or from Guile-VM (aka. Guile 2.x) but using both
+              ;; compiled procedures (aka. "programs") and good old
+              ;; interpreter procedures.
+              ;;
+              ;; This happens, e.g., while compiling Skribilo itself where
+              ;; some of the files loaded by the compiler are already
+              ;; compiled while others are interpreted.
+              (let* ((vm       (resolve-module '(system vm program)))
+                     (program? (false-if-exception
+                                (module-ref vm 'program?))))
+                (lambda (proc)
+                  (if (and (procedure? program?)
+                           (program? proc))
+                      (car ((module-ref vm 'program-arity) proc))
+                      (car (procedure-property proc 'arity))))))
+
+             (else
+              ;; Here we assume Guile-VM compiled code.
+              (lambda (proc)
+                (if ((@ (system vm program) program?) proc)
+                    (car ((@ (system vm program) program-arity) proc))
+                    (car (procedure-property proc 'arity)))))))
 
 (define (make-writer-predicate markup predicate class)
   (let* ((t2 (if class
-- 
cgit v1.2.3