From 60d852248f3d8849a3b409381cf956a90db8e4a0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 29 Aug 2024 09:53:37 +0200 Subject: [PATCH] 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 @@ (( 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 @@ (( 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))) (($ 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 (($ 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 @@ (($ 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}." (($ src escape-only? tag body ($ hsrc hmeta - ($ _ hreq #f hrest #f () hsyms hbody #f))) + ($ _ 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))) (($ src exp - ($ lsrc req #f rest #f () syms body #f)) + ($ 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 (($ src escape-only? tag body ($ hsrc hmeta - ($ _ hreq #f hrest #f () hsyms hbody #f))) + ($ _ 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 (($ src exp - ($ lsrc req #f rest #f () syms body #f)) + ($ 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 (($ 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)) (($ 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. (($ src escape-only? tag body ($ hsrc hmeta - ($ _ hreq #f hrest #f () hsyms hbody #f))) + ($ _ 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)))))) (($ src exp - ($ lsrc req #f rest #f () syms body #f)) + ($ 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." (($ src escape-only? tag body ($ hsrc hmeta - ($ _ hreq #f hrest #f () hsyms hbody #f))) + ($ _ hreq () hrest #f () hsyms hbody #f))) exp) (($ 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." (($ _ ($ _ _ body) args) (logior (accumulate-effects args) (match body - (($ _ req #f #f #f () syms body #f) + (($ _ 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 (($ src1 meta - ($ src2 req #f rest #f () syms body #f)) + ($ 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) (($ src1 meta - ($ src2 req #f rest #f () syms body #f)) + ($ 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 (($ _ meta - ($ _ req #f #f #f () syms + ($ _ req () #f #f () syms ($ src ($ _ name sym) (($ _ _ arg) ...)) #f)) (and (equal? arg syms) (make-lexical-ref src name sym))) (($ _ meta - ($ _ req #f (not #f) #f () syms + ($ _ req () (not #f) #f () syms ($ src 'apply (($ _ name sym) ($ _ _ 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 (($ _ _ - ($ _ req #f #f #f () (arg ...) + ($ _ req () #f #f () (arg ...) ($ _ (and eta ($ _ _ var)) (($ _ _ arg) ...)) #f)) (add-binding-lexical! var mod name)) (($ _ _ - ($ _ req #f (not #f) #f () (arg ...) + ($ _ req () (not #f) #f () (arg ...) ($ _ 'apply ((and eta ($ _ _ var)) ($ _ _ arg) ...)) @@ -339,13 +339,13 @@ ;; Undo the result of eta-expansion pass. (match exp (($ _ _ - ($ _ req #f #f #f () (sym ...) + ($ _ req () #f #f () (sym ...) ($ _ (and eta ($ )) (($ _ _ sym) ...)) #f)) eta) (($ _ _ - ($ _ req #f (not #f) #f () (sym ...) + ($ _ req () (not #f) #f () (sym ...) ($ _ 'apply ((and eta ($ )) ($ _ _ 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 (($ 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 ($ src () #f rest #f () (rest-sym) body #f) + ((and ($ 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))))) (($ 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. ($ - _ req #f rest #f () gensyms body #f))))) + _ req () rest #f () gensyms body #f))))) (for-tail (make-let-values src (make-call src producer '()) consumer))) (($ 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))))))) (($ 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 (($ _ 'apply (($ _ _ (and lcase ($ _ 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 - (($ _ _ ($ _ _ #f _ #f () _ _ #f)) + (($ _ _ ($ _ _ () _ #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 --- 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)))