1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00

fix use of `binding' data abstraction

* module/system/vm/assemble.scm (make-temp-binding, btemp:name)
  (btemp:extp, btemp:index): Don't abuse program.scm's make-binding to
  make something that actually isn't a binding.
  (codegen): Do use program.scm's make-binding to make something that
  actually is a binding.

* module/system/vm/program.scm (binding:start, binding:end): New
  accessors.
  (make-binding): Expand to have the start and end arguments in the
  constructor.
This commit is contained in:
Andy Wingo 2008-10-16 13:49:57 +02:00
parent 1f40459f5c
commit f580ec0f56
2 changed files with 27 additions and 12 deletions

View file

@ -100,6 +100,13 @@
(1+ (instruction-length (car x))))
(else (error "variable-length instruction?" x))))
;; a binding that doesn't yet know its extents
(define (make-temp-binding name ext? index)
(list name ext? index))
(define btemp:name car)
(define btemp:extp cadr)
(define btemp:index caddr)
(define (codegen glil toplevel)
(record-case glil
((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
@ -128,9 +135,9 @@
(lambda (v)
(let ((name (car v)) (type (cadr v)) (i (caddr v)))
(case type
((argument) (make-binding name #f i))
((local) (make-binding name #f (+ nargs i)))
((external) (make-binding name #t i))
((argument) (make-temp-binding name #f i))
((local) (make-temp-binding name #f (+ nargs i)))
((external) (make-temp-binding name #t i))
(else (error "unknown binding type" name type)))))
bindings))
(define (push-bindings! bindings)
@ -140,8 +147,12 @@
(start (car bindings))
(end (current-address)))
(for-each
(lambda (binding)
(push `(,start ,@binding ,start ,end) closed-bindings))
(lambda (open)
;; the cons is for dsu sort
(push (cons start
(make-binding (btemp:name open) (btemp:extp open)
(btemp:index open) start end))
closed-bindings))
(cdr bindings))))
(define (finish-bindings!)
(while (not (null? open-bindings)) (close-binding!))

View file

@ -21,7 +21,10 @@
(define-module (system vm program)
#:export (arity:nargs arity:nrest arity:nlocs arity:nexts
make-binding binding:name binding:extp binding:index
make-binding binding:name binding:extp binding:index
binding:start binding:end
source:addr source:line source:column source:file
program-bindings program-sources
program-properties program-property program-documentation
@ -38,12 +41,13 @@
(define arity:nlocs caddr)
(define arity:nexts cadddr)
(define (make-binding name extp index)
(list name extp index))
(define binding:name car)
(define binding:extp cadr)
(define binding:index caddr)
(define (make-binding name extp index start end)
(list name extp index start end))
(define (binding:name b) (list-ref b 0))
(define (binding:extp b) (list-ref b 1))
(define (binding:index b) (list-ref b 2))
(define (binding:start b) (list-ref b 3))
(define (binding:end b) (list-ref b 4))
(define (curry1 proc)
(lambda (x) (proc (x))))