[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: <lambda-case> must have list of optargs
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/02: <lambda-case> must have list of optargs |
|
Date: |
Thu, 29 Aug 2024 03:57:12 -0400 (EDT) |
wingo pushed a commit to branch wip-3.2
in repository guile.
commit 60d852248f3d8849a3b409381cf956a90db8e4a0
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Aug 29 09:53:37 2024 +0200
<lambda-case> must have list of optargs
Before, the optional args in a lambda-case could be #f or a list of
symbols. However the list of symbols is entirely sufficient; no
optional args means a null list. Change everywhere that produces
lambda-case, matches on lambda-case, and reads deserialized lambda-case.
---
module/ice-9/psyntax-pp.scm | 6 +--
module/ice-9/psyntax.scm | 10 ++--
module/language/elisp/compile-tree-il.scm | 4 +-
module/language/scheme/decompile-tree-il.scm | 18 +++----
module/language/tree-il/analyze.scm | 10 ++--
module/language/tree-il/compile-bytecode.scm | 22 ++++----
module/language/tree-il/compile-cps.scm | 12 ++---
module/language/tree-il/debug.scm | 12 ++---
module/language/tree-il/demux-lambda.scm | 2 +-
module/language/tree-il/effects.scm | 4 +-
module/language/tree-il/eta-expand.scm | 12 ++---
module/language/tree-il/inlinable-exports.scm | 8 +--
module/language/tree-il/peval.scm | 16 +++---
module/language/tree-il/primitives.scm | 6 +--
test-suite/tests/compiler.test | 2 +-
test-suite/tests/peval.test | 74 +++++++++++++--------------
test-suite/tests/tree-il.test | 4 +-
17 files changed, 109 insertions(+), 113 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index bd90b37b4..f9b64c702 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -106,7 +106,7 @@
(make-toplevel-define sourcev (and mod (cdr mod)) var exp)))
(build-simple-lambda
(lambda (src req rest vars meta exp)
- (make-lambda src meta (make-lambda-case src req #f rest #f '()
vars exp #f))))
+ (make-lambda src meta (make-lambda-case src req '() rest #f '()
vars exp #f))))
(build-case-lambda (lambda (src meta body) (make-lambda src meta
body)))
(build-lambda-case
(lambda (src req opt rest kw inits vars body else-case)
@@ -1205,7 +1205,7 @@
(w* (make-binding-wrap (list rest)
l w*)))
(parse-kw
req
- (and (pair? out) (reverse out))
+ (reverse out)
(syntax->datum rest)
(if (pair? kw) (cdr kw) kw)
body
@@ -1217,7 +1217,7 @@
inits)))
(else (parse-kw
req
- (and (pair? out) (reverse out))
+ (reverse out)
#f
(if (pair? kw) (cdr kw) kw)
body
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 7ca6bfafa..44909b540 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -284,7 +284,7 @@
;; hah, a case in which kwargs would be nice.
(make-lambda-case
;; src req opt rest kw inits vars body else
- src req #f rest #f '() vars exp #f))))
+ src req '() rest #f '() vars exp #f))))
(define build-case-lambda
(lambda (src meta body)
@@ -292,7 +292,7 @@
(define build-lambda-case
;; req := (name ...)
- ;; opt := (name ...) | #f
+ ;; opt := (name ...)
;; rest := name | #f
;; kw := (allow-other-keys? (keyword name var) ...) | #f
;; inits: (init ...)
@@ -1749,7 +1749,7 @@
(define (check req rest)
(cond
((distinct-bound-ids? (if rest (cons rest req) req))
- (values req #f rest #f))
+ (values req '() rest #f))
(else
(syntax-violation 'lambda "duplicate identifier in argument list"
orig-args))))
@@ -1876,14 +1876,14 @@
(l (gen-labels (list v)))
(r* (extend-var-env l (list v) r*))
(w* (make-binding-wrap (list rest) l w*)))
- (parse-kw req (if (pair? out) (reverse out) #f)
+ (parse-kw req (reverse out)
(syntax->datum rest)
(if (pair? kw) (cdr kw) kw)
body (cons v vars) r* w*
(if (pair? kw) (car kw) #f)
'() inits)))
(else
- (parse-kw req (if (pair? out) (reverse out) #f) #f
+ (parse-kw req (reverse out) #f
(if (pair? kw) (cdr kw) kw)
body vars r* w*
(if (pair? kw) (car kw) #f)
diff --git a/module/language/elisp/compile-tree-il.scm
b/module/language/elisp/compile-tree-il.scm
index adbeb2005..ad5264865 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;; Copyright (C) 2009-2011, 2013, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2011, 2013, 2018, 2024 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -314,7 +314,7 @@
(make-lambda
src '()
(make-lambda-case
- src '() #f #f #f '() '()
+ src '() '() #f #f '() '()
(lp (cdr f) (cdr v))
#f))))))))))
diff --git a/module/language/scheme/decompile-tree-il.scm
b/module/language/scheme/decompile-tree-il.scm
index 99edee44c..fb59169de 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2012, 2013, 2024 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -281,10 +281,10 @@
((<lambda-case> req opt rest kw inits gensyms body alternate)
(let ((names (map output-name gensyms)))
(cond
- ((and (not opt) (not kw) (not alternate))
+ ((and (null? opt) (not kw) (not alternate))
`(lambda ,(if rest (apply cons* names) names)
,@(recurse-body body)))
- ((and (not opt) (not kw))
+ ((and (null? opt) (not kw))
(let ((alt-expansion (recurse alternate))
(formals (if rest (apply cons* names) names)))
(case (car alt-expansion)
@@ -303,16 +303,16 @@
(else
(let* ((alt-expansion (and alternate (recurse alternate)))
(nreq (length req))
- (nopt (if opt (length opt) 0))
+ (nopt (length opt))
(restargs (if rest (list-ref names (+ nreq nopt)) '()))
(reqargs (list-head names nreq))
- (optargs (if opt
+ (optargs (if (zero? nopt)
+ '()
`(#:optional
,@(map list
(list-head (list-tail names nreq)
nopt)
(map recurse
- (list-head inits nopt))))
- '()))
+ (list-head inits nopt))))))
(kwargs (if kw
`(#:key
,@(map list
@@ -694,13 +694,13 @@
((<lambda-case> req opt rest kw inits gensyms body alternate)
(primitive 'lambda)
- (cond ((or opt kw alternate)
+ (cond ((or (pair? opt) kw alternate)
(primitive 'lambda*)
(primitive 'case-lambda)
(primitive 'case-lambda*)))
(primitive 'let)
(if use-derived-syntax? (primitive 'let*))
- (let* ((names (append req (or opt '()) (if rest (list rest) '())
+ (let* ((names (append req opt (if rest (list rest) '())
(map cadr (if kw (cdr kw) '()))))
(base-names (map base-name names))
(body-bindings
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index e9a803919..49811f7ba 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1,6 +1,6 @@
;;; Diagnostic warnings for Tree-IL
-;; Copyright (C) 2001,2008-2014,2016,2018-2023 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2008-2014,2016,2018-2024 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -129,7 +129,7 @@ given `tree-il' element."
(make-binding-info vars (vhash-consq gensym #t refs)))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
(let ((names `(,@req
- ,@(or opt '())
+ ,@opt
,@(if rest (list rest) '())
,@(if kw (map cadr (cdr kw)) '()))))
(make-binding-info (extend gensyms names) refs)))
@@ -885,10 +885,6 @@ given `tree-il' element."
(define (arities proc)
;; Return the arities of PROC, which can be either a tree-il or a
;; procedure.
- (define (len x)
- (or (and (or (null? x) (pair? x))
- (length x))
- 0))
(cond ((program? proc)
(values (procedure-name proc)
(map (lambda (a)
@@ -916,7 +912,7 @@ given `tree-il' element."
(match proc
(($ <lambda-case> src req opt rest kw inits gensyms body
alt)
(loop name alt
- (cons (list (len req) (len opt) rest
+ (cons (list (length req) (length opt) rest
(and (pair? kw) (map car (cdr kw)))
(and (pair? kw) (car kw)))
arities)))
diff --git a/module/language/tree-il/compile-bytecode.scm
b/module/language/tree-il/compile-bytecode.scm
index a581b7f6c..4633e2c25 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Lightweight compiler directly from Tree-IL to bytecode
-;; Copyright (C) 2020-2021,2023 Free Software Foundation, Inc.
+;; Copyright (C) 2020-2021,2023,2024 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
@@ -469,7 +469,7 @@
(($ <lambda> src meta #f)
(make-lambda src meta
(make-lambda-case
- src '() #f #f #f '() '()
+ src '() '() #f #f '() '()
(make-primcall
src 'throw
(list (make-const src 'wrong-number-of-args)
@@ -606,7 +606,7 @@
(define x-thunk
(let ((src (tree-il-srcv exp)))
(make-lambda src '()
- (make-lambda-case src '() #f #f #f '() '() exp #f))))
+ (make-lambda-case src '() '() #f #f '() '() exp #f))))
(values (cons (make-closure 'init x-thunk #f '())
(reverse closures))
assigned)))
@@ -656,7 +656,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
- ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ ($ <lambda-case> _ hreq () hrest #f () hsyms hbody #f)))
(max (visit tag)
(visit body)
(+ (length hsyms) (visit hbody))))
@@ -678,7 +678,7 @@ in the frame with for the lambda-case clause @var{clause}."
(+ (length funs) (visit body)))
(($ <let-values> src exp
- ($ <lambda-case> lsrc req #f rest #f () syms body #f))
+ ($ <lambda-case> lsrc req () rest #f () syms body #f))
(max (visit exp)
(+ (length syms) (visit body))))))
@@ -826,7 +826,7 @@ in the frame with for the lambda-case clause @var{clause}."
(match exp
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
- ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ ($ <lambda-case> _ hreq () hrest #f () hsyms hbody #f)))
(maybe-emit-source src)
(let ((tag (env-idx (for-value tag env)))
(proc-slot (stack-height env))
@@ -935,7 +935,7 @@ in the frame with for the lambda-case clause @var{clause}."
(define (visit-let-values exp env ctx)
(match exp
(($ <let-values> src exp
- ($ <lambda-case> lsrc req #f rest #f () syms body #f))
+ ($ <lambda-case> lsrc req () rest #f () syms body #f))
(maybe-emit-source src)
(for-values exp env)
(visit-values-handler lsrc req rest syms body env ctx))))
@@ -1307,15 +1307,15 @@ in the frame with for the lambda-case clause
@var{clause}."
(match clause
(($ <lambda-case> src req opt rest kw inits syms body alt)
(let ((names (append req
- (or opt '())
+ opt
(if rest (list rest) '())
(match kw
((aok? (key name sym) ...) name)
(#f '()))))
(inits (append (make-list (length req) #f)
- (list-head inits (if opt (length opt) 0))
+ (list-head inits (length opt))
(if rest '(#f) '())
- (list-tail inits (if opt (length opt) 0)))))
+ (list-tail inits (length opt)))))
(unless (= (length names) (length syms) (length inits))
(error "unexpected args" names syms inits))
(maybe-emit-source src)
@@ -1340,7 +1340,7 @@ in the frame with for the lambda-case clause
@var{clause}."
kw)))))
(lambda (allow-other-keys? kw-indices)
(when label (emit-label asm label))
- (let ((has-closure? #t) (opt (or opt '())))
+ (let ((has-closure? #t))
(emit-begin-kw-arity asm has-closure? req opt rest kw-indices
allow-other-keys? frame-size alt-label))
(compile-body clause module-scope free frame-size)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index ea5be8aa8..04195048a 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013-2015,2017-2021,2023 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015,2017-2021,2023,2024 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -1709,7 +1709,7 @@ use as the proc slot."
(match body
(#f (values cps #f))
(($ <lambda-case> src req opt rest kw inits gensyms body alternate)
- (let* ((arity (make-$arity req (or opt '()) rest
+ (let* ((arity (make-$arity req opt rest
(map (match-lambda
((kw name sym)
(list kw name (bound-var sym))))
@@ -1937,7 +1937,7 @@ use as the proc slot."
;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
- ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ ($ <lambda-case> _ hreq () hrest #f () hsyms hbody #f)))
;; Handler:
;; khargs: check args returned to handler, -> khbody
;; khbody: the handler, -> k
@@ -2145,7 +2145,7 @@ use as the proc slot."
($ (capture-toplevel-scope src scope-id kscope))))))
(($ <let-values> src exp
- ($ <lambda-case> lsrc req #f rest #f () syms body #f))
+ ($ <lambda-case> lsrc req () rest #f () syms body #f))
(let ((names (append req (if rest (list rest) '())))
(bound-vars (map bound-var syms)))
(with-cps cps
@@ -2187,7 +2187,7 @@ integer."
(list (fresh-var) (fresh-var) #f)
(fresh-var))))
#f
- (make-$arity req (or opt '()) rest
+ (make-$arity req opt rest
(if kw (cdr kw) '()) (and kw (car kw)))
gensyms
inits))
@@ -2402,7 +2402,7 @@ integer."
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
- ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ ($ <lambda-case> _ hreq () hrest #f () hsyms hbody #f)))
exp)
(($ <primcall> src 'ash (a b))
diff --git a/module/language/tree-il/debug.scm
b/module/language/tree-il/debug.scm
index 773b84bee..c1649d749 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -1,6 +1,6 @@
;;; Tree-IL verifier
-;; Copyright (C) 2011,2013,2019,2023 Free Software Foundation, Inc.
+;; Copyright (C) 2011,2013,2019,2023,2024 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -43,10 +43,10 @@
(cond
((not (and (list? req) (and-map symbol? req)))
(error "bad required args (should be list of symbols)" exp))
- ((and opt (not (and (list? opt) (and-map symbol? opt))))
- (error "bad optionals (should be #f or list of symbols)" exp))
+ ((not (and (list? opt) (and-map symbol? opt)))
+ (error "bad optional args (should be list of symbols)" exp))
((and rest (not (symbol? rest)))
- (error "bad required args (should be #f or symbol)" exp))
+ (error "bad rest arg (should be #f or symbol)" exp))
((and kw (not (match kw
((aok . kwlist)
(and (list? kwlist)
@@ -65,7 +65,7 @@
(error "bad gensyms (should be list of symbols)" exp))
((not (= (length gensyms)
(+ (length req)
- (if opt (length opt) 0)
+ (length opt)
;; FIXME: technically possible for kw gensyms to
;; alias other gensyms
(if rest 1 0)
@@ -73,7 +73,7 @@
(error "unexpected gensyms length" exp))
(else
(let lp ((env (add-env (take gensyms (length req)) env))
- (nopt (if opt (length opt) 0))
+ (nopt (length opt))
(inits inits)
(tail (drop gensyms (length req))))
(if (zero? nopt)
diff --git a/module/language/tree-il/demux-lambda.scm
b/module/language/tree-il/demux-lambda.scm
index 661ce7962..c31df415d 100644
--- a/module/language/tree-il/demux-lambda.scm
+++ b/module/language/tree-il/demux-lambda.scm
@@ -42,7 +42,7 @@
(call-with-values (lambda () (demux-clause func-name alternate))
(lambda (bindings alternate)
(define simple-req
- (append req (or opt '()) (if rest (list rest) '())
+ (append req opt (if rest (list rest) '())
(match kw
((aok? (kw name sym) ...) name)
(#f '()))))
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index fa05ac02c..426656349 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -1,6 +1,6 @@
;;; Effects analysis on Tree-IL
-;; Copyright (C) 2011, 2012, 2013, 2021, 2023 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013, 2021, 2023, 2024 Free Software Foundation,
Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -560,7 +560,7 @@ of an expression."
(($ <call> _ ($ <lambda> _ _ body) args)
(logior (accumulate-effects args)
(match body
- (($ <lambda-case> _ req #f #f #f () syms body #f)
+ (($ <lambda-case> _ req () #f #f () syms body #f)
(logior (compute-effects body)
(if (= (length req) (length args))
0
diff --git a/module/language/tree-il/eta-expand.scm
b/module/language/tree-il/eta-expand.scm
index d3af839b4..5f7898b2f 100644
--- a/module/language/tree-il/eta-expand.scm
+++ b/module/language/tree-il/eta-expand.scm
@@ -1,6 +1,6 @@
;;; Making lexically-bound procedures well-known
-;; Copyright (C) 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2020, 2024 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -78,7 +78,7 @@
(define (maybe-add-proc! gensym val)
(match val
(($ <lambda> src1 meta
- ($ <lambda-case> src2 req #f rest #f () syms body #f))
+ ($ <lambda-case> src2 req () rest #f () syms body #f))
(hashq-set! proc-infos gensym (proc-info val)))
(_ #f)))
(tree-il-for-each
@@ -127,7 +127,7 @@
(match (hashq-ref to-expand sym)
(#f #f)
(($ <lambda> src1 meta
- ($ <lambda-case> src2 req #f rest #f () syms body #f))
+ ($ <lambda-case> src2 req () rest #f () syms body #f))
(let* ((syms (map gensym (map symbol->string syms)))
(args (map (lambda (req sym) (make-lexical-ref src2 req
sym))
(if rest (append req (list rest)) req)
@@ -136,19 +136,19 @@
(make-primcall src 'apply (cons lexical args))
(make-call src lexical args))))
(make-lambda src1 meta
- (make-lambda-case src2 req #f rest #f '() syms
+ (make-lambda-case src2 req '() rest #f '() syms
body #f))))))))
(define (eta-reduce proc)
(match proc
(($ <lambda> _ meta
- ($ <lambda-case> _ req #f #f #f () syms
+ ($ <lambda-case> _ req () #f #f () syms
($ <call> src ($ <lexical-ref> _ name sym)
(($ <lexical-ref> _ _ arg) ...))
#f))
(and (equal? arg syms)
(make-lexical-ref src name sym)))
(($ <lambda> _ meta
- ($ <lambda-case> _ req #f (not #f) #f () syms
+ ($ <lambda-case> _ req () (not #f) #f () syms
($ <primcall> src 'apply
(($ <lexical-ref> _ name sym) ($ <lexical-ref> _ _ arg) ...))
#f))
diff --git a/module/language/tree-il/inlinable-exports.scm
b/module/language/tree-il/inlinable-exports.scm
index d1fb74254..36d9908c6 100644
--- a/module/language/tree-il/inlinable-exports.scm
+++ b/module/language/tree-il/inlinable-exports.scm
@@ -213,14 +213,14 @@
;; Also record lexical for eta-expanded bindings.
(match val
(($ <lambda> _ _
- ($ <lambda-case> _ req #f #f #f () (arg ...)
+ ($ <lambda-case> _ req () #f #f () (arg ...)
($ <call> _
(and eta ($ <lexical-ref> _ _ var))
(($ <lexical-ref> _ _ arg) ...))
#f))
(add-binding-lexical! var mod name))
(($ <lambda> _ _
- ($ <lambda-case> _ req #f (not #f) #f () (arg ...)
+ ($ <lambda-case> _ req () (not #f) #f () (arg ...)
($ <primcall> _ 'apply
((and eta ($ <lexical-ref> _ _ var))
($ <lexical-ref> _ _ arg) ...))
@@ -339,13 +339,13 @@
;; Undo the result of eta-expansion pass.
(match exp
(($ <lambda> _ _
- ($ <lambda-case> _ req #f #f #f () (sym ...)
+ ($ <lambda-case> _ req () #f #f () (sym ...)
($ <call> _
(and eta ($ <lexical-ref>)) (($ <lexical-ref> _ _ sym) ...))
#f))
eta)
(($ <lambda> _ _
- ($ <lambda-case> _ req #f (not #f) #f () (sym ...)
+ ($ <lambda-case> _ req () (not #f) #f () (sym ...)
($ <primcall> _ 'apply
((and eta ($ <lexical-ref>)) ($ <lexical-ref> _ _ sym) ...))
#f))
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index f8fca0012..f9e85d177 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -136,7 +136,7 @@
(fold (lambda (name sym res)
(vhash-consq sym (make-var name sym 0 #f) res))
res
- (append req (or opt '()) (if rest (list rest) '())
+ (append req opt (if rest (list rest) '())
(match kw
((aok? (kw name sym) ...) name)
(_ '())))
@@ -176,7 +176,7 @@ referenced multiple times."
(match exp
(($ <lambda-case> src req opt rest kw init gensyms body alt)
(fold maybe-add-var table
- (append req (or opt '()) (if rest (list rest) '())
+ (append req opt (if rest (list rest) '())
(match kw
((aok? (kw name sym) ...) name)
(_ '())))
@@ -536,7 +536,7 @@ top-level bindings from ENV and return the resulting
expression."
(record-new-temporary! 'vals vals 1)
(make-lambda-case
#f
- '() #f 'vals #f '() (list vals)
+ '() '() 'vals #f '() (list vals)
(make-seq
src
second
@@ -1066,7 +1066,7 @@ top-level bindings from ENV and return the resulting
expression."
;; reconstruct the let-values, pevaling the consumer.
(let ((producer (for-values producer)))
(or (match consumer
- ((and ($ <lambda-case> src () #f rest #f () (rest-sym) body #f)
+ ((and ($ <lambda-case> src () () rest #f () (rest-sym) body #f)
(? (lambda _ (singly-valued-expression? producer))))
(let ((tmp (gensym "tmp ")))
(record-new-temporary! 'tmp tmp 1)
@@ -1081,7 +1081,7 @@ top-level bindings from ENV and return the resulting
expression."
body)))))
(($ <lambda-case> src req opt rest #f inits gensyms body #f)
(let* ((nmin (length req))
- (nmax (and (not rest) (+ nmin (if opt (length opt)
0)))))
+ (nmax (and (not rest) (+ nmin (length opt)))))
(cond
((inline-values lv-src producer nmin nmax consumer)
=> for-tail)
@@ -1170,7 +1170,7 @@ top-level bindings from ENV and return the resulting
expression."
(list
(make-lambda
#f '()
- (make-lambda-case #f '() #f #f #f '() '() exp #f)))
+ (make-lambda-case #f '() '() #f #f '() '() exp #f)))
(proc (make-call #f (make-lexical-ref #f 'failure t)
'())))))))
(define (simplify-conditional c)
@@ -1252,7 +1252,7 @@ top-level bindings from ENV and return the resulting
expression."
(and consumer
;; No optional or kwargs.
($ <lambda-case>
- _ req #f rest #f () gensyms body #f)))))
+ _ req () rest #f () gensyms body #f)))))
(for-tail (make-let-values src (make-call src producer '())
consumer)))
(($ <primcall> src 'dynamic-wind (w thunk u))
@@ -1863,7 +1863,7 @@ top-level bindings from ENV and return the resulting
expression."
(make-lambda src meta (and body (for-values body)))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
(define (lift-applied-lambda body gensyms)
- (and (not opt) rest (not kw)
+ (and (null? opt) rest (not kw)
(match body
(($ <primcall> _ 'apply
(($ <lambda> _ _ (and lcase ($ <lambda-case> _ req1)))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index dd5592a41..e3e74422c 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -1,6 +1,6 @@
;;; open-coding primitive procedures
-;; Copyright (C) 2009-2015, 2017-2023 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2015, 2017-2024 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -711,7 +711,7 @@
(case-lambda
((src tag thunk handler)
(match handler
- (($ <lambda> _ _ ($ <lambda-case> _ _ #f _ #f () _ _ #f))
+ (($ <lambda> _ _ ($ <lambda-case> _ _ () _ #f () _ _ #f))
(make-prompt src #f tag thunk handler))
(_
;; Eta-convert prompts without inline handlers.
@@ -730,7 +730,7 @@
(make-lambda
src '()
(make-lambda-case
- src '() #f 'args #f '() (list args)
+ src '() '() 'args #f '() (list args)
(primcall apply handler (make-lexical-ref #f 'args args))
#f)))
(primcall raise-type-error
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 0b47d0e32..8f2502831 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -425,7 +425,7 @@
(seq
(define forty-two
(lambda ((name . forty-two))
- (lambda-case ((() #f #f #f () ()) (const 42)))))
+ (lambda-case ((() () #f #f () ()) (const 42)))))
(toplevel forty-two))")
(bytecode #f)
(proc #f))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 756cccdf3..1fa6c7d30 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -280,7 +280,7 @@
(define +
(lambda (_)
(lambda-case
- (((x y) #f #f #f () (_ _))
+ (((x y) () #f #f () (_ _))
(call (toplevel pk) (lexical x _) (lexical y _))))))
(call (toplevel +) (const 1) (const 2))))
@@ -307,7 +307,7 @@
(define foo
(lambda (_)
(lambda-case
- (((x) #f #f #f () (_))
+ (((x) () #f #f () (_))
(primcall + (lexical x _) (const 9)))))))
(pass-if-peval
@@ -366,7 +366,7 @@
'never-reached)))
(lambda ()
(lambda-case
- (((x) #f #f #f () (_))
+ (((x) () #f #f () (_))
(call (toplevel display) (lexical x _))))))
(pass-if-peval
@@ -551,11 +551,11 @@
(primitive zero?)
(lambda ()
(lambda-case
- (((x1) #f #f #f () (_))
+ (((x1) () #f #f () (_))
(lexical x1 _))))
(lambda ()
(lambda-case
- (((x2) #f #f #f () (_))
+ (((x2) () #f #f () (_))
(primcall - (lexical x2 _) (const 1))))))))
(pass-if "inlined lambdas are alpha-renamed"
@@ -578,13 +578,13 @@
((primcall cons
(lambda ()
(lambda-case
- (((y) #f #f #f () (,gensym1))
+ (((y) () #f #f () (,gensym1))
(primcall +
(const 1)
(lexical y ,ref1)))))
(lambda ()
(lambda-case
- (((y) #f #f #f () (,gensym2))
+ (((y) () #f #f () (,gensym2))
(primcall +
(const 2)
(lexical y ,ref2))))))
@@ -667,7 +667,7 @@
((primcall make-vector (const 6) (const #f)))
(lambda ()
(lambda-case
- (((n) #f #f #f () (_))
+ (((n) () #f #f () (_))
(primcall vector-set!
(lexical v _) (lexical n _) (lexical n _)))))))
@@ -680,7 +680,7 @@
((primcall vector (const 1) (const 2) (const 3)))
(lambda ()
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(lexical v _))))))
(pass-if-peval
@@ -784,7 +784,7 @@
(if (< x 0) x (loop (1- x))))
(fix (loop) (_) ((lambda (_)
(lambda-case
- (((x) #f #f #f () (_))
+ (((x) () #f #f () (_))
(if _ _
(call (lexical loop _)
(primcall - (lexical x _)
@@ -813,7 +813,7 @@
(loop (1+ x) (1+ y)))))
(fix (loop) (_) ((lambda (_)
(lambda-case
- (((x y) #f #f #f () (_ _))
+ (((x y) () #f #f () (_ _))
(if (primcall >
(lexical y _) (const 0))
_ _)))))
@@ -882,12 +882,12 @@
(fix (a) (_)
((lambda _
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(call (lexical a _))))))
(fix (b) (_)
((lambda _
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(call (lexical a _))))))
(call (toplevel foo) (lexical b _)))))
@@ -901,11 +901,11 @@
(call (toplevel foo)
(lambda _
(lambda-case
- (((x) #f #f #f () (_))
+ (((x) () #f #f () (_))
(call (toplevel top) (lexical x _)))))
(lambda _
(lambda-case
- (((x) #f #f #f () (_))
+ (((x) () #f #f () (_))
(call (toplevel top) (lexical x _)))))))
(pass-if-peval
@@ -949,7 +949,7 @@
(primcall apply
(lambda ()
(lambda-case
- (((x y z w) #f #f #f () (_ _ _ _))
+ (((x y z w) () #f #f () (_ _ _ _))
(primcall list
(lexical x _) (lexical y _)
(lexical z _) (lexical w _)))))
@@ -985,7 +985,7 @@
args))))
(lambda ()
(lambda-case
- (((bv offset n) #f #f #f () (_ _ _))
+ (((bv offset n) () #f #f () (_ _ _))
(let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
(lexical bv _)
(primcall +
@@ -1019,7 +1019,7 @@
args)))
(lambda ()
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(let (_) (_) ((call (toplevel foo!)))
(let (z) (_) ((toplevel z))
(primcall 'list
@@ -1038,7 +1038,7 @@
args)))
(lambda ()
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(let (args) (_)
((primcall list (const foo)))
(seq
@@ -1158,10 +1158,10 @@
(primcall wind
(lambda ()
(lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
+ ((() () #f #f () ()) (toplevel foo))))
(lambda ()
(lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
+ ((() () #f #f () ()) (toplevel baz))))))
(let (tmp) (_) ((toplevel bar))
(seq (seq (primcall unwind)
(toplevel baz))
@@ -1175,13 +1175,13 @@
(primcall wind
(lambda ()
(lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
+ ((() () #f #f () ()) (toplevel foo))))
(lambda ()
(lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
+ ((() () #f #f () ()) (toplevel baz))))))
(let-values (call (toplevel bar))
(lambda-case
- ((() #f vals #f () (_))
+ ((() () vals #f () (_))
(seq (seq (primcall unwind)
(toplevel baz))
(primcall apply (primitive values) (lexical vals _))))))))
@@ -1212,7 +1212,7 @@
(const 1)
(lambda _
(lambda-case
- (((k x) #f #f #f () (_ _))
+ (((k x) () #f #f () (_ _))
(lexical x _))))))
;; Handler toplevel not inlined
@@ -1226,11 +1226,11 @@
(toplevel tag)
(lambda _
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(const 1))))
(lambda _
(lambda-case
- ((() #f args #f () (_))
+ ((() () args #f () (_))
(primcall apply
(lexical handler _)
(lexical args _))))))
@@ -1249,11 +1249,11 @@
(fix (lp) (_)
((lambda _
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(fix (loop) (_)
((lambda _
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(call (lexical loop _))))))
(call (lexical loop _)))))))
(call (lexical lp _)))))
@@ -1264,7 +1264,7 @@
a rest))
(lambda _
(lambda-case
- (((x y) #f #f #f () (_ _))
+ (((x y) () #f #f () (_ _))
_))))
(pass-if-peval
@@ -1296,7 +1296,7 @@
(qux x))))
(let (failure) (_) ((lambda _
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(call (toplevel qux) (toplevel x))))))
(if (primcall struct? (toplevel x))
(if (primcall eq?
@@ -1325,7 +1325,7 @@
(qux x))))
(let (failure) (_) ((lambda _
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(call (toplevel qux) (toplevel x))))))
(if (primcall struct? (toplevel x))
(if (primcall eq?
@@ -1371,7 +1371,7 @@
(call-with-values foo (lambda (x) (bar x)))
(let-values (call (toplevel foo))
(lambda-case
- (((x) #f #f #f () (_))
+ (((x) () #f #f () (_))
(call (toplevel bar) (lexical x _))))))
(pass-if-peval
@@ -1411,12 +1411,12 @@
(if (eq? x x*) x* (lp x*)))))
(lambda ()
(lambda-case
- (((f x) #f #f #f () (_ _))
+ (((f x) () #f #f () (_ _))
(fix (lp)
(_)
((lambda ((name . lp))
(lambda-case
- (((x) #f #f #f () (_))
+ (((x) () #f #f () (_))
(let (x*)
(_)
((call (lexical f _) (lexical x _)))
@@ -1436,12 +1436,12 @@
(add1 1 2))
(lambda ()
(lambda-case
- ((() #f #f #f () ())
+ ((() () #f #f () ())
(fix (add1)
(_)
((lambda ((name . add1))
(lambda-case
- (((n) #f #f #f () (_))
+ (((n) () #f #f () (_))
(primcall + (const 1) (lexical n _))))))
(call (lexical add1 _)
(const 1)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index dd2e707b2..31bc8ee9e 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009-2014,2018-2021,2023 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014,2018-2021,2023,2024 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -171,7 +171,7 @@
(parse-tree-il
'(lambda ()
(lambda-case
- (((x y) #f #f #f () (x1 y1))
+ (((x y) () #f #f () (x1 y1))
(call (toplevel +)
(lexical x x1)
(lexical y y1)))