diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/system/vm/program.scm | 38 |
1 files changed, 31 insertions, 7 deletions
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 86db41180..4466504de 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -198,7 +198,8 @@ ;; returns list of list of bindings ;; (list-ref ret N) == bindings bound to the Nth local slot (define (program-bindings-by-index prog) - (cond ((program-bindings prog) => collapse-locals) + (cond ((rtl-program? prog) '()) + ((program-bindings prog) => collapse-locals) (else '()))) (define (program-bindings-for-ip prog ip) @@ -291,14 +292,29 @@ ;; the name "program-arguments" is taken by features.c... (define* (program-arguments-alist prog #:optional ip) "Returns the signature of the given procedure in the form of an association list." - (if (rtl-program? prog) + (cond + ((primitive? prog) + (match (procedure-minimum-arity prog) + (#f #f) + ((nreq nopt rest?) + (let ((start (primitive-call-ip prog))) + ;; Assume that there is only one IP for the call. + (and (or (not ip) (= start ip)) + (arity->arguments-alist + prog + (list 0 0 nreq nopt rest? '(#f . ())))))))) + ((rtl-program? prog) + (let ((pc (and ip (+ (rtl-program-code prog) ip)))) (or-map (lambda (arity) - (and #t + (and (or (not pc) + (and (<= (arity-low-pc arity) pc) + (< pc (arity-high-pc arity)))) (arity-arguments-alist arity))) - (or (find-program-arities (rtl-program-code prog)) '())) - (let ((arity (program-arity prog ip))) - (and arity - (arity->arguments-alist prog arity))))) + (or (find-program-arities (rtl-program-code prog)) '())))) + (else + (let ((arity (program-arity prog ip))) + (and arity + (arity->arguments-alist prog arity)))))) (define* (program-lambda-list prog #:optional ip) "Returns the signature of the given procedure in the form of an argument list." @@ -325,6 +341,14 @@ (define (program-arguments-alists prog) (cond + ((primitive? prog) + (match (procedure-minimum-arity prog) + (#f '()) + ((nreq nopt rest?) + (list + (arity->arguments-alist + prog + (list 0 0 nreq nopt rest? '(#f . ()))))))) ((rtl-program? prog) (map arity-arguments-alist (or (find-program-arities (rtl-program-code prog)) '()))) |