diff options
author | Andy Wingo <wingo@pobox.com> | 2009-10-25 13:01:57 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-10-25 13:12:27 +0100 |
commit | df435c83072a79d9fdacbc57d9925ab7c0be5deb (patch) | |
tree | 13c26c148cf3bd7c9b72ec9788cd3efd128bb49e | |
parent | c89222f8ceb038130c8a3dcdc96f747178ce9607 (diff) | |
download | guile-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.h | 2 | ||||
-rw-r--r-- | libguile/programs.c | 2 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 27 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 4 | ||||
-rw-r--r-- | module/system/vm/program.scm | 32 |
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) |