summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-10-25 13:01:57 +0100
committerAndy Wingo <wingo@pobox.com>2009-10-25 13:12:27 +0100
commitdf435c83072a79d9fdacbc57d9925ab7c0be5deb (patch)
tree13c26c148cf3bd7c9b72ec9788cd3efd128bb49e
parentc89222f8ceb038130c8a3dcdc96f747178ce9607 (diff)
downloadguile-df435c83072a79d9fdacbc57d9925ab7c0be5deb.tar.gz
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.
-rw-r--r--libguile/_scm.h2
-rw-r--r--libguile/programs.c2
-rw-r--r--module/language/glil/compile-assembly.scm27
-rw-r--r--module/system/vm/frame.scm4
-rw-r--r--module/system/vm/program.scm32
5 files changed, 41 insertions, 26 deletions
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 93cdfa15f..33cb375d1 100644
--- a/libguile/_scm.h
+++ b/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 \
diff --git a/libguile/programs.c b/libguile/programs.c
index 61a0f11e7..7399fa05f 100644
--- a/libguile/programs.c
+++ b/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));
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 171032b9f..490d1a4a5 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/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))))))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 2f1da9723..ace7d59e3 100644
--- a/module/system/vm/frame.scm
+++ b/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)
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 823b2a053..68ebb84ef 100644
--- a/module/system/vm/program.scm
+++ b/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)