arities can have noncontiguous starts and ends

* module/language/glil/compile-assembly.scm (open-arity, close-arity)
  (begin-arity, glil->assembly): Refactor so that arities can have
  noncontiguous starts and ends. So within a prelude there is no arity
  -- only before (the previous arity) or after (the new arity).

* module/system/vm/program.scm (arity:end): Add this private accessor.
  Arities are expected to be in the new format. While not a change in
  objcode format, it is an incompatible change, so I'll bump the objcode
  cookie.
  (program-arity): Check that the ip is within both bounds of the arity.

* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.

* libguile/programs.c (scm_i_program_arity): Update for new arity format.

* module/system/vm/frame.scm (vm-frame-arguments): Avoid throwing an
  error in this function, which is called from the backtrace code.

libguile/_scm.h

@@ -172,7 +172,7 @@
 
 /* Major and minor versions must be single characters. */
 #define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION K
+#define SCM_OBJCODE_MINOR_VERSION L
 #define SCM_OBJCODE_MAJOR_VERSION_STRING        \
   SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
 #define SCM_OBJCODE_MINOR_VERSION_STRING        \

libguile/programs.c

@@ -296,7 +296,7 @@ scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
   /* take the last arglist, it will be least specific */
   while (scm_is_pair (scm_cdr (arities)))
     arities = scm_cdr (arities);
-  x = scm_cdar (arities);
+  x = scm_cddar (arities);
   if (scm_is_pair (x))
     {
       *req = scm_to_int (scm_car (x));

module/language/glil/compile-assembly.scm

@@ -125,17 +125,13 @@
   (assoc-ref-or-acons alist x
                       (lambda (x alist)
                         (+ (length alist) *module*))))
-
-(define (compile-assembly glil)
-  (receive (code . _)
-      (glil->assembly glil #t '(()) '() '() #f '() -1)
-    (car code)))
 (define (make-object-table objects)
   (and (not (null? objects))
        (list->vector (cons #f objects))))
 
+;; A functional arities thingamajiggy.
 ;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
-(define (begin-arity addr nreq nopt rest kw arities)
+(define (open-arity addr nreq nopt rest kw arities)
   (cons
    (cond
     (kw (list addr nreq nopt rest kw))
@@ -144,6 +140,19 @@
     (nreq (list addr nreq))
     (else (list addr)))
    arities))
+(define (close-arity addr arities)
+  (pmatch arities
+    (() '())
+    (((,start . ,tail) . ,rest)
+     `((,start ,addr . ,tail) . ,rest))
+    (else (error "bad arities" arities))))
+(define (begin-arity end start nreq nopt rest kw arities)
+  (open-arity start nreq nopt rest kw (close-arity end arities)))
+
+(define (compile-assembly glil)
+  (receive (code . _)
+      (glil->assembly glil #t '(()) '() '() #f '() -1)
+    (car code)))
 
 (define (glil->assembly glil toplevel? bindings
                         source-alist label-alist object-alist arities addr)
@@ -153,7 +162,7 @@
     (values x bindings source-alist label-alist object-alist arities))
   (define (emit-code/arity x nreq nopt rest kw)
     (values x bindings source-alist label-alist object-alist
-            (begin-arity (addr+ addr x) nreq nopt rest kw arities)))
+            (begin-arity addr (addr+ addr x) nreq nopt rest kw arities)))
   
   (record-case glil
     ((<glil-program> meta body)
@@ -168,7 +177,7 @@
                    (limn-sources (reverse! source-alist))
                    (reverse label-alist)
                    (and object-alist (map car (reverse object-alist)))
-                   (reverse arities)
+                   (reverse (close-arity addr arities))
                    addr))
           (else
            (receive (subcode bindings source-alist label-alist object-alist
@@ -309,7 +318,7 @@
                        (reserve-locals ,(quotient nlocs 256)
                                        ,(modulo nlocs 256)))))
            (values code bindings source-alist label-alist object-alist
-                   (begin-arity (addr+ addr code) nreq nopt rest
+                   (begin-arity addr (addr+ addr code) nreq nopt rest
                                 (and kw (cons allow-other-keys? kw))
                                 arities))))))
     

module/system/vm/frame.scm

@@ -96,7 +96,9 @@
               (cons x (lp rest)))
              (,rest (guard (symbol? rest))
               (vm-frame-binding-ref frame rest))
-             (else (error "bad formals" formals))))))
+             ;; let's not error here, as we are called during
+             ;; backtraces...
+             (else '???)))))
    (else
     ;; case 2
     (map (lambda (i)

module/system/vm/program.scm

@@ -97,13 +97,30 @@
                      (cons (car binds) out))
                     (else (inner (cdr binds)))))))))
 
+(define (arity:start a)
+  (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
+(define (arity:end a)
+  (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
+(define (arity:nreq a)
+  (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
+(define (arity:nopt a)
+  (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
+(define (arity:rest? a)
+  (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+(define (arity:kw a)
+  (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+(define (arity:allow-other-keys? a)
+  (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+
 ;; not exported; should it be?
 (define (program-arity prog ip)
   (let ((arities (program-arities prog)))
     (and arities
          (let lp ((arities arities))
            (cond ((null? arities) #f)
-                 ((<= (caar arities) ip) (car arities))
+                 ((and (< (arity:start (car arities)) ip)
+                       (<= ip (arity:end (car arities))))
+                  (car arities))
                  (else (lp (cdr arities))))))))
 
 (define (arglist->arguments arglist)
@@ -117,19 +134,6 @@
        (extents . ,extents)))
     (else #f)))
 
-(define (arity:start a)
-  (pmatch a ((,ip . _) ip) (else (error "bad arity" a))))
-(define (arity:nreq a)
-  (pmatch a ((_ ,nreq . _) nreq) (else 0)))
-(define (arity:nopt a)
-  (pmatch a ((_ ,nreq ,nopt . _) nopt) (else 0)))
-(define (arity:rest? a)
-  (pmatch a ((_ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
-(define (arity:kw a)
-  (pmatch a ((_ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
-(define (arity:allow-other-keys? a)
-  (pmatch a ((_ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
-
 (define (arity->arguments prog arity)
   (define var-by-index
     (let ((rbinds (map (lambda (x)