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:
parent
1f40459f5c
commit
f580ec0f56
2 changed files with 27 additions and 12 deletions
|
@ -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!))
|
||||
|
|
|
@ -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))))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue