mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

peval reduces some inlined case-lambda calls

Browse source 
* module/language/tree-il/peval.scm (peval): Reduce multiple case lambda
  in <call> trees according to the number of arguments. Do not try to
  reduce case-lambda using keyword arguments.
* test-suite/tests/peval.test: Tests.
This commit is contained in:
Daniel Llorens 2023-02-23 17:38:10 +01:00
parent e2ed33ef04
commit 3b47f87618
2 changed files with 95 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

23
module/language/tree-il/peval.scm
View file

@ -1668,6 +1668,29 @@ top-level bindings from ENV and return the resulting expression."
(log 'inline-end result exp)
result)))))
(($ <lambda> src-proc meta orig-body)
;; If there are multiple cases and one matches nargs, omit all the others.
(or (and
(lambda-case-alternate orig-body)
(let ((nargs (length orig-args)))
(let loop ((body orig-body))
(match body
(#f #f) ;; No matching case; an error.
(($ <lambda-case> src-case req opt rest kw inits gensyms case-body alt)
(cond (kw
;; FIXME: Not handling keyword cases.
#f)
((let ((nreq (length req)))
(if rest
(<= nreq nargs)
(<= nreq nargs (+ nreq (if opt (length opt) 0)))))
;; Keep only this case.
(revisit-proc
(make-lambda
src-proc meta
(make-lambda-case src-case req opt rest kw inits gensyms case-body #f))))
(else (loop alt))))))))
(make-call src (for-call orig-proc) (map for-value orig-args))))
(($ <let> _ _ _ vals _)
;; Attempt to inline `let' in the operator position.
;;

72
test-suite/tests/peval.test
View file

@ -1456,6 +1456,78 @@
;; <https://bugs.gnu.org/60522>.
(primcall make-vector)))
(with-test-prefix "case-lambda"
;; one case
(pass-if-peval
((case-lambda (() 0)))
(const 0))
;; middle
(pass-if-peval
((case-lambda (() 0) ((a b) 1) ((a) 2)) 1 2)
(const 1))
;; last
(pass-if-peval
((case-lambda ((a b) 0) ((a) 1) (() 2)))
(const 2))
;; first
(pass-if-peval
((case-lambda ((a) 0) (() 1) ((a b) 2)) 1)
(const 0))
;; rest arg
(pass-if-peval
((case-lambda (args 0) ((a b) 1) ((a) 2)) 1 2)
(const 0))
;; req before rest I
(pass-if-peval
((case-lambda ((a b) 0) (args 1) ((a) 1)) 1 2)
(const 0))
;; req before rest II
(pass-if-peval
((case-lambda ((a) 0) (args 1) ((a b) 2)) 1 2)
(const 1))
;; optional
(pass-if-peval
((case-lambda* ((a #:optional x) 0) (args 1) ((a) 2)) 1 2)
(const 0))
;; optional and rest, no match I
(pass-if-peval
((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)))
(const 1))
;; optional and rest, match I
(pass-if-peval
((case-lambda* (() 0) ((a #:optional x . rest) 1) ((a) 2)) 1)
(const 1))
;; optional and rest, match II
(pass-if-peval
((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)) 1)
(const 0))
;; optional and rest, match III
(pass-if-peval
((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)) 1 2)
(const 0))
;; optional and rest, match IV
(pass-if-peval
((case-lambda* ((a #:optional x . rest) 0) (args 1) ((a) 2)) 1 2 3)
(const 0))
;; keyword cases survive
(pass-if (= 1 ((case-lambda* ((a b) 0) ((a #:key x) 1)) 0 #:x 1)))
(pass-if (= 0 ((case-lambda* ((a b c) 0) ((a #:key x) 1)) 0 #:x 1)))
(pass-if (= 0 ((case-lambda* ((a #:key x) 0) ((a b) 0)) 0 #:x 1)))
(pass-if (= 1 ((case-lambda* ((a #:key x) 0) ((a b c) 1)) 0 1 2))))
(with-test-prefix "eqv?"
(pass-if-peval (eqv? x #f)
(primcall eq? (toplevel x) (const #f)))