mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

<lambda-case> must have list of optargs

Browse source 
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.
This commit is contained in:
Andy Wingo 2024-08-29 09:53:37 +02:00
parent a970ed5bd5
commit 60d852248f
17 changed files with 109 additions and 113 deletions
Download patch file Download diff file Expand all files Collapse all files

6
module/ice-9/psyntax-pp.scm
View file

@ -106,7 +106,7 @@
(make-toplevel-define sourcev (and mod (cdr mod)) var exp))) (make-toplevel-define sourcev (and mod (cdr mod)) var exp)))
(build-simple-lambda (build-simple-lambda
(lambda (src req rest vars meta exp) (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-case-lambda (lambda (src meta body) (make-lambda src meta body)))
(build-lambda-case (build-lambda-case
(lambda (src req opt rest kw inits vars body else-case) (lambda (src req opt rest kw inits vars body else-case)
@ -1205,7 +1205,7 @@
(w* (make-binding-wrap (list rest) l w*))) (w* (make-binding-wrap (list rest) l w*)))
(parse-kw (parse-kw
req req
(and (pair? out) (reverse out)) (reverse out)
(syntax->datum rest) (syntax->datum rest)
(if (pair? kw) (cdr kw) kw) (if (pair? kw) (cdr kw) kw)
body body
@ -1217,7 +1217,7 @@
inits))) inits)))
(else (parse-kw (else (parse-kw
req req
(and (pair? out) (reverse out)) (reverse out)
#f #f
(if (pair? kw) (cdr kw) kw) (if (pair? kw) (cdr kw) kw)
body body

10
module/ice-9/psyntax.scm
View file

@ -284,7 +284,7 @@
;; hah, a case in which kwargs would be nice. ;; hah, a case in which kwargs would be nice.
(make-lambda-case (make-lambda-case
;; src req opt rest kw inits vars body else ;; 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 (define build-case-lambda
(lambda (src meta body) (lambda (src meta body)
@ -292,7 +292,7 @@
(define build-lambda-case (define build-lambda-case
;; req := (name ...) ;; req := (name ...)
;; opt := (name ...) | #f ;; opt := (name ...)
;; rest := name | #f ;; rest := name | #f
;; kw := (allow-other-keys? (keyword name var) ...) | #f ;; kw := (allow-other-keys? (keyword name var) ...) | #f
;; inits: (init ...) ;; inits: (init ...)
@ -1749,7 +1749,7 @@
(define (check req rest) (define (check req rest)
(cond (cond
((distinct-bound-ids? (if rest (cons rest req) req)) ((distinct-bound-ids? (if rest (cons rest req) req))
(values req #f rest #f)) (values req '() rest #f))
(else (else
(syntax-violation 'lambda "duplicate identifier in argument list" (syntax-violation 'lambda "duplicate identifier in argument list"
orig-args)))) orig-args))))
@ -1876,14 +1876,14 @@
(l (gen-labels (list v))) (l (gen-labels (list v)))
(r* (extend-var-env l (list v) r*)) (r* (extend-var-env l (list v) r*))
(w* (make-binding-wrap (list rest) l w*))) (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) (syntax->datum rest)
(if (pair? kw) (cdr kw) kw) (if (pair? kw) (cdr kw) kw)
body (cons v vars) r* w* body (cons v vars) r* w*
(if (pair? kw) (car kw) #f) (if (pair? kw) (car kw) #f)
'() inits))) '() inits)))
(else (else
(parse-kw req (if (pair? out) (reverse out) #f) #f (parse-kw req (reverse out) #f
(if (pair? kw) (cdr kw) kw) (if (pair? kw) (cdr kw) kw)
body vars r* w* body vars r* w*
(if (pair? kw) (car kw) #f) (if (pair? kw) (car kw) #f)

4
module/language/elisp/compile-tree-il.scm
View file

@ -1,6 +1,6 @@
;;; Guile Emacs Lisp ;;; 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 ;; 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 ;; it under the terms of the GNU General Public License as published by
@ -314,7 +314,7 @@
(make-lambda (make-lambda
src '() src '()
(make-lambda-case (make-lambda-case
src '() #f #f #f '() '() src '() '() #f #f '() '()
(lp (cdr f) (cdr v)) (lp (cdr f) (cdr v))
#f)))))))))) #f))))))))))

18
module/language/scheme/decompile-tree-il.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM code converters ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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) ((<lambda-case> req opt rest kw inits gensyms body alternate)
(let ((names (map output-name gensyms))) (let ((names (map output-name gensyms)))
(cond (cond
((and (not opt) (not kw) (not alternate)) ((and (null? opt) (not kw) (not alternate))
`(lambda ,(if rest (apply cons* names) names) `(lambda ,(if rest (apply cons* names) names)
,@(recurse-body body))) ,@(recurse-body body)))
((and (not opt) (not kw)) ((and (null? opt) (not kw))
(let ((alt-expansion (recurse alternate)) (let ((alt-expansion (recurse alternate))
(formals (if rest (apply cons* names) names))) (formals (if rest (apply cons* names) names)))
(case (car alt-expansion) (case (car alt-expansion)
@ -303,16 +303,16 @@
(else (else
(let* ((alt-expansion (and alternate (recurse alternate))) (let* ((alt-expansion (and alternate (recurse alternate)))
(nreq (length req)) (nreq (length req))
(nopt (if opt (length opt) 0)) (nopt (length opt))
(restargs (if rest (list-ref names (+ nreq nopt)) '())) (restargs (if rest (list-ref names (+ nreq nopt)) '()))
(reqargs (list-head names nreq)) (reqargs (list-head names nreq))
(optargs (if opt (optargs (if (zero? nopt)
'()
`(#:optional `(#:optional
,@(map list ,@(map list
(list-head (list-tail names nreq) nopt) (list-head (list-tail names nreq) nopt)
(map recurse (map recurse
(list-head inits nopt)))) (list-head inits nopt))))))
'()))
(kwargs (if kw (kwargs (if kw
`(#:key `(#:key
,@(map list ,@(map list
@ -694,13 +694,13 @@
((<lambda-case> req opt rest kw inits gensyms body alternate) ((<lambda-case> req opt rest kw inits gensyms body alternate)
(primitive 'lambda) (primitive 'lambda)
(cond ((or opt kw alternate) (cond ((or (pair? opt) kw alternate)
(primitive 'lambda*) (primitive 'lambda*)
(primitive 'case-lambda) (primitive 'case-lambda)
(primitive 'case-lambda*))) (primitive 'case-lambda*)))
(primitive 'let) (primitive 'let)
(if use-derived-syntax? (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) '())))) (map cadr (if kw (cdr kw) '()))))
(base-names (map base-name names)) (base-names (map base-name names))
(body-bindings (body-bindings

10
module/language/tree-il/analyze.scm
View file

@ -1,6 +1,6 @@
;;; Diagnostic warnings for Tree-IL ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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))) (make-binding-info vars (vhash-consq gensym #t refs)))
(($ <lambda-case> src req opt rest kw inits gensyms body alt) (($ <lambda-case> src req opt rest kw inits gensyms body alt)
(let ((names `(,@req (let ((names `(,@req
,@(or opt '()) ,@opt
,@(if rest (list rest) '()) ,@(if rest (list rest) '())
,@(if kw (map cadr (cdr kw)) '())))) ,@(if kw (map cadr (cdr kw)) '()))))
(make-binding-info (extend gensyms names) refs))) (make-binding-info (extend gensyms names) refs)))
@ -885,10 +885,6 @@ given `tree-il' element."
(define (arities proc) (define (arities proc)
;; Return the arities of PROC, which can be either a tree-il or a ;; Return the arities of PROC, which can be either a tree-il or a
;; procedure. ;; procedure.
(define (len x)
(or (and (or (null? x) (pair? x))
(length x))
0))
(cond ((program? proc) (cond ((program? proc)
(values (procedure-name proc) (values (procedure-name proc)
(map (lambda (a) (map (lambda (a)
@ -916,7 +912,7 @@ given `tree-il' element."
(match proc (match proc
(($ <lambda-case> src req opt rest kw inits gensyms body alt) (($ <lambda-case> src req opt rest kw inits gensyms body alt)
(loop name 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) (map car (cdr kw)))
(and (pair? kw) (car kw))) (and (pair? kw) (car kw)))
arities))) arities)))

22
module/language/tree-il/compile-bytecode.scm
View file

@ -1,6 +1,6 @@
;;; Lightweight compiler directly from Tree-IL to bytecode ;;; 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 ;;; 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 ;;; under the terms of the GNU Lesser General Public License as published by
@ -469,7 +469,7 @@
(($ <lambda> src meta #f) (($ <lambda> src meta #f)
(make-lambda src meta (make-lambda src meta
(make-lambda-case (make-lambda-case
src '() #f #f #f '() '() src '() '() #f #f '() '()
(make-primcall (make-primcall
src 'throw src 'throw
(list (make-const src 'wrong-number-of-args) (list (make-const src 'wrong-number-of-args)
@ -606,7 +606,7 @@
(define x-thunk (define x-thunk
(let ((src (tree-il-srcv exp))) (let ((src (tree-il-srcv exp)))
(make-lambda src '() (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 '()) (values (cons (make-closure 'init x-thunk #f '())
(reverse closures)) (reverse closures))
assigned))) assigned)))
@ -656,7 +656,7 @@ in the frame with for the lambda-case clause @var{clause}."
(($ <prompt> src escape-only? tag body (($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta ($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) ($ <lambda-case> _ hreq () hrest #f () hsyms hbody #f)))
(max (visit tag) (max (visit tag)
(visit body) (visit body)
(+ (length hsyms) (visit hbody)))) (+ (length hsyms) (visit hbody))))
@ -678,7 +678,7 @@ in the frame with for the lambda-case clause @var{clause}."
(+ (length funs) (visit body))) (+ (length funs) (visit body)))
(($ <let-values> src exp (($ <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) (max (visit exp)
(+ (length syms) (visit body)))))) (+ (length syms) (visit body))))))
@ -826,7 +826,7 @@ in the frame with for the lambda-case clause @var{clause}."
(match exp (match exp
(($ <prompt> src escape-only? tag body (($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta ($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) ($ <lambda-case> _ hreq () hrest #f () hsyms hbody #f)))
(maybe-emit-source src) (maybe-emit-source src)
(let ((tag (env-idx (for-value tag env))) (let ((tag (env-idx (for-value tag env)))
(proc-slot (stack-height 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) (define (visit-let-values exp env ctx)
(match exp (match exp
(($ <let-values> src 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) (maybe-emit-source src)
(for-values exp env) (for-values exp env)
(visit-values-handler lsrc req rest syms body env ctx)))) (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 (match clause
(($ <lambda-case> src req opt rest kw inits syms body alt) (($ <lambda-case> src req opt rest kw inits syms body alt)
(let ((names (append req (let ((names (append req
(or opt '()) opt
(if rest (list rest) '()) (if rest (list rest) '())
(match kw (match kw
((aok? (key name sym) ...) name) ((aok? (key name sym) ...) name)
(#f '())))) (#f '()))))
(inits (append (make-list (length req) #f) (inits (append (make-list (length req) #f)
(list-head inits (if opt (length opt) 0)) (list-head inits (length opt))
(if rest '(#f) '()) (if rest '(#f) '())
(list-tail inits (if opt (length opt) 0))))) (list-tail inits (length opt)))))
(unless (= (length names) (length syms) (length inits)) (unless (= (length names) (length syms) (length inits))
(error "unexpected args" names syms inits)) (error "unexpected args" names syms inits))
(maybe-emit-source src) (maybe-emit-source src)
@ -1340,7 +1340,7 @@ in the frame with for the lambda-case clause @var{clause}."
kw))))) kw)))))
(lambda (allow-other-keys? kw-indices) (lambda (allow-other-keys? kw-indices)
(when label (emit-label asm label)) (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 (emit-begin-kw-arity asm has-closure? req opt rest kw-indices
allow-other-keys? frame-size alt-label)) allow-other-keys? frame-size alt-label))
(compile-body clause module-scope free frame-size) (compile-body clause module-scope free frame-size)

12
module/language/tree-il/compile-cps.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -1709,7 +1709,7 @@ use as the proc slot."
(match body (match body
(#f (values cps #f)) (#f (values cps #f))
(($ <lambda-case> src req opt rest kw inits gensyms body alternate) (($ <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 (map (match-lambda
((kw name sym) ((kw name sym)
(list kw name (bound-var sym)))) (list kw name (bound-var sym))))
@ -1937,7 +1937,7 @@ use as the proc slot."
;; Prompts with inline handlers. ;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body (($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta ($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) ($ <lambda-case> _ hreq () hrest #f () hsyms hbody #f)))
;; Handler: ;; Handler:
;; khargs: check args returned to handler, -> khbody ;; khargs: check args returned to handler, -> khbody
;; khbody: the handler, -> k ;; khbody: the handler, -> k
@ -2145,7 +2145,7 @@ use as the proc slot."
($ (capture-toplevel-scope src scope-id kscope)))))) ($ (capture-toplevel-scope src scope-id kscope))))))
(($ <let-values> src exp (($ <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) '()))) (let ((names (append req (if rest (list rest) '())))
(bound-vars (map bound-var syms))) (bound-vars (map bound-var syms)))
(with-cps cps (with-cps cps
@ -2187,7 +2187,7 @@ integer."
(list (fresh-var) (fresh-var) #f) (list (fresh-var) (fresh-var) #f)
(fresh-var)))) (fresh-var))))
#f #f
(make-$arity req (or opt '()) rest (make-$arity req opt rest
(if kw (cdr kw) '()) (and kw (car kw))) (if kw (cdr kw) '()) (and kw (car kw)))
gensyms gensyms
inits)) inits))
@ -2402,7 +2402,7 @@ integer."
(($ <prompt> src escape-only? tag body (($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta ($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) ($ <lambda-case> _ hreq () hrest #f () hsyms hbody #f)))
exp) exp)
(($ <primcall> src 'ash (a b)) (($ <primcall> src 'ash (a b))

12
module/language/tree-il/debug.scm
View file

@ -1,6 +1,6 @@
;;; Tree-IL verifier ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -43,10 +43,10 @@
(cond (cond
((not (and (list? req) (and-map symbol? req))) ((not (and (list? req) (and-map symbol? req)))
(error "bad required args (should be list of symbols)" exp)) (error "bad required args (should be list of symbols)" exp))
((and opt (not (and (list? opt) (and-map symbol? opt)))) ((not (and (list? opt) (and-map symbol? opt)))
(error "bad optionals (should be #f or list of symbols)" exp)) (error "bad optional args (should be list of symbols)" exp))
((and rest (not (symbol? rest))) ((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 ((and kw (not (match kw
((aok . kwlist) ((aok . kwlist)
(and (list? kwlist) (and (list? kwlist)
@ -65,7 +65,7 @@
(error "bad gensyms (should be list of symbols)" exp)) (error "bad gensyms (should be list of symbols)" exp))
((not (= (length gensyms) ((not (= (length gensyms)
(+ (length req) (+ (length req)
(if opt (length opt) 0) (length opt)
;; FIXME: technically possible for kw gensyms to ;; FIXME: technically possible for kw gensyms to
;; alias other gensyms ;; alias other gensyms
(if rest 1 0) (if rest 1 0)
@ -73,7 +73,7 @@
(error "unexpected gensyms length" exp)) (error "unexpected gensyms length" exp))
(else (else
(let lp ((env (add-env (take gensyms (length req)) env)) (let lp ((env (add-env (take gensyms (length req)) env))
(nopt (if opt (length opt) 0)) (nopt (length opt))
(inits inits) (inits inits)
(tail (drop gensyms (length req)))) (tail (drop gensyms (length req))))
(if (zero? nopt) (if (zero? nopt)

2
module/language/tree-il/demux-lambda.scm
View file

@ -42,7 +42,7 @@
(call-with-values (lambda () (demux-clause func-name alternate)) (call-with-values (lambda () (demux-clause func-name alternate))
(lambda (bindings alternate) (lambda (bindings alternate)
(define simple-req (define simple-req
(append req (or opt '()) (if rest (list rest) '()) (append req opt (if rest (list rest) '())
(match kw (match kw
((aok? (kw name sym) ...) name) ((aok? (kw name sym) ...) name)
(#f '())))) (#f '()))))

4
module/language/tree-il/effects.scm
View file

@ -1,6 +1,6 @@
;;; Effects analysis on Tree-IL ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -560,7 +560,7 @@ of an expression."
(($ <call> _ ($ <lambda> _ _ body) args) (($ <call> _ ($ <lambda> _ _ body) args)
(logior (accumulate-effects args) (logior (accumulate-effects args)
(match body (match body
(($ <lambda-case> _ req #f #f #f () syms body #f) (($ <lambda-case> _ req () #f #f () syms body #f)
(logior (compute-effects body) (logior (compute-effects body)
(if (= (length req) (length args)) (if (= (length req) (length args))
0 0

12
module/language/tree-il/eta-expand.scm
View file

@ -1,6 +1,6 @@
;;; Making lexically-bound procedures well-known ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -78,7 +78,7 @@
(define (maybe-add-proc! gensym val) (define (maybe-add-proc! gensym val)
(match val (match val
(($ <lambda> src1 meta (($ <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))) (hashq-set! proc-infos gensym (proc-info val)))
(_ #f))) (_ #f)))
(tree-il-for-each (tree-il-for-each
@ -127,7 +127,7 @@
(match (hashq-ref to-expand sym) (match (hashq-ref to-expand sym)
(#f #f) (#f #f)
(($ <lambda> src1 meta (($ <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))) (let* ((syms (map gensym (map symbol->string syms)))
(args (map (lambda (req sym) (make-lexical-ref src2 req sym)) (args (map (lambda (req sym) (make-lexical-ref src2 req sym))
(if rest (append req (list rest)) req) (if rest (append req (list rest)) req)
@ -136,19 +136,19 @@
(make-primcall src 'apply (cons lexical args)) (make-primcall src 'apply (cons lexical args))
(make-call src lexical args)))) (make-call src lexical args))))
(make-lambda src1 meta (make-lambda src1 meta
(make-lambda-case src2 req #f rest #f '() syms (make-lambda-case src2 req '() rest #f '() syms
body #f)))))))) body #f))))))))
(define (eta-reduce proc) (define (eta-reduce proc)
(match proc (match proc
(($ <lambda> _ meta (($ <lambda> _ meta
($ <lambda-case> _ req #f #f #f () syms ($ <lambda-case> _ req () #f #f () syms
($ <call> src ($ <lexical-ref> _ name sym) ($ <call> src ($ <lexical-ref> _ name sym)
(($ <lexical-ref> _ _ arg) ...)) (($ <lexical-ref> _ _ arg) ...))
#f)) #f))
(and (equal? arg syms) (and (equal? arg syms)
(make-lexical-ref src name sym))) (make-lexical-ref src name sym)))
(($ <lambda> _ meta (($ <lambda> _ meta
($ <lambda-case> _ req #f (not #f) #f () syms ($ <lambda-case> _ req () (not #f) #f () syms
($ <primcall> src 'apply ($ <primcall> src 'apply
(($ <lexical-ref> _ name sym) ($ <lexical-ref> _ _ arg) ...)) (($ <lexical-ref> _ name sym) ($ <lexical-ref> _ _ arg) ...))
#f)) #f))

8
module/language/tree-il/inlinable-exports.scm
View file

@ -213,14 +213,14 @@
;; Also record lexical for eta-expanded bindings. ;; Also record lexical for eta-expanded bindings.
(match val (match val
(($ <lambda> _ _ (($ <lambda> _ _
($ <lambda-case> _ req #f #f #f () (arg ...) ($ <lambda-case> _ req () #f #f () (arg ...)
($ <call> _ ($ <call> _
(and eta ($ <lexical-ref> _ _ var)) (and eta ($ <lexical-ref> _ _ var))
(($ <lexical-ref> _ _ arg) ...)) (($ <lexical-ref> _ _ arg) ...))
#f)) #f))
(add-binding-lexical! var mod name)) (add-binding-lexical! var mod name))
(($ <lambda> _ _ (($ <lambda> _ _
($ <lambda-case> _ req #f (not #f) #f () (arg ...) ($ <lambda-case> _ req () (not #f) #f () (arg ...)
($ <primcall> _ 'apply ($ <primcall> _ 'apply
((and eta ($ <lexical-ref> _ _ var)) ((and eta ($ <lexical-ref> _ _ var))
($ <lexical-ref> _ _ arg) ...)) ($ <lexical-ref> _ _ arg) ...))
@ -339,13 +339,13 @@
;; Undo the result of eta-expansion pass. ;; Undo the result of eta-expansion pass.
(match exp (match exp
(($ <lambda> _ _ (($ <lambda> _ _
($ <lambda-case> _ req #f #f #f () (sym ...) ($ <lambda-case> _ req () #f #f () (sym ...)
($ <call> _ ($ <call> _
(and eta ($ <lexical-ref>)) (($ <lexical-ref> _ _ sym) ...)) (and eta ($ <lexical-ref>)) (($ <lexical-ref> _ _ sym) ...))
#f)) #f))
eta) eta)
(($ <lambda> _ _ (($ <lambda> _ _
($ <lambda-case> _ req #f (not #f) #f () (sym ...) ($ <lambda-case> _ req () (not #f) #f () (sym ...)
($ <primcall> _ 'apply ($ <primcall> _ 'apply
((and eta ($ <lexical-ref>)) ($ <lexical-ref> _ _ sym) ...)) ((and eta ($ <lexical-ref>)) ($ <lexical-ref> _ _ sym) ...))
#f)) #f))

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

@ -136,7 +136,7 @@
(fold (lambda (name sym res) (fold (lambda (name sym res)
(vhash-consq sym (make-var name sym 0 #f) res)) (vhash-consq sym (make-var name sym 0 #f) res))
res res
(append req (or opt '()) (if rest (list rest) '()) (append req opt (if rest (list rest) '())
(match kw (match kw
((aok? (kw name sym) ...) name) ((aok? (kw name sym) ...) name)
(_ '()))) (_ '())))
@ -176,7 +176,7 @@ referenced multiple times."
(match exp (match exp
(($ <lambda-case> src req opt rest kw init gensyms body alt) (($ <lambda-case> src req opt rest kw init gensyms body alt)
(fold maybe-add-var table (fold maybe-add-var table
(append req (or opt '()) (if rest (list rest) '()) (append req opt (if rest (list rest) '())
(match kw (match kw
((aok? (kw name sym) ...) name) ((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) (record-new-temporary! 'vals vals 1)
(make-lambda-case (make-lambda-case
#f #f
'() #f 'vals #f '() (list vals) '() '() 'vals #f '() (list vals)
(make-seq (make-seq
src src
second second
@ -1066,7 +1066,7 @@ top-level bindings from ENV and return the resulting expression."
;; reconstruct the let-values, pevaling the consumer. ;; reconstruct the let-values, pevaling the consumer.
(let ((producer (for-values producer))) (let ((producer (for-values producer)))
(or (match consumer (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)))) (? (lambda _ (singly-valued-expression? producer))))
(let ((tmp (gensym "tmp "))) (let ((tmp (gensym "tmp ")))
(record-new-temporary! 'tmp tmp 1) (record-new-temporary! 'tmp tmp 1)
@ -1081,7 +1081,7 @@ top-level bindings from ENV and return the resulting expression."
body))))) body)))))
(($ <lambda-case> src req opt rest #f inits gensyms body #f) (($ <lambda-case> src req opt rest #f inits gensyms body #f)
(let* ((nmin (length req)) (let* ((nmin (length req))
(nmax (and (not rest) (+ nmin (if opt (length opt) 0))))) (nmax (and (not rest) (+ nmin (length opt)))))
(cond (cond
((inline-values lv-src producer nmin nmax consumer) ((inline-values lv-src producer nmin nmax consumer)
=> for-tail) => for-tail)
@ -1170,7 +1170,7 @@ top-level bindings from ENV and return the resulting expression."
(list (list
(make-lambda (make-lambda
#f '() #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) (proc (make-call #f (make-lexical-ref #f 'failure t)
'()))))))) '())))))))
(define (simplify-conditional c) (define (simplify-conditional c)
@ -1252,7 +1252,7 @@ top-level bindings from ENV and return the resulting expression."
(and consumer (and consumer
;; No optional or kwargs. ;; No optional or kwargs.
($ <lambda-case> ($ <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 '()) (for-tail (make-let-values src (make-call src producer '())
consumer))) consumer)))
(($ <primcall> src 'dynamic-wind (w thunk u)) (($ <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))))))) (make-lambda src meta (and body (for-values body)))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt) (($ <lambda-case> src req opt rest kw inits gensyms body alt)
(define (lift-applied-lambda body gensyms) (define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw) (and (null? opt) rest (not kw)
(match body (match body
(($ <primcall> _ 'apply (($ <primcall> _ 'apply
(($ <lambda> _ _ (and lcase ($ <lambda-case> _ req1))) (($ <lambda> _ _ (and lcase ($ <lambda-case> _ req1)))

6
module/language/tree-il/primitives.scm
View file

@ -1,6 +1,6 @@
;;; open-coding primitive procedures ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -711,7 +711,7 @@
(case-lambda (case-lambda
((src tag thunk handler) ((src tag thunk handler)
(match handler (match handler
(($ <lambda> _ _ ($ <lambda-case> _ _ #f _ #f () _ _ #f)) (($ <lambda> _ _ ($ <lambda-case> _ _ () _ #f () _ _ #f))
(make-prompt src #f tag thunk handler)) (make-prompt src #f tag thunk handler))
(_ (_
;; Eta-convert prompts without inline handlers. ;; Eta-convert prompts without inline handlers.
@ -730,7 +730,7 @@
(make-lambda (make-lambda
src '() src '()
(make-lambda-case (make-lambda-case
src '() #f 'args #f '() (list args) src '() '() 'args #f '() (list args)
(primcall apply handler (make-lexical-ref #f 'args args)) (primcall apply handler (make-lexical-ref #f 'args args))
#f))) #f)))
(primcall raise-type-error (primcall raise-type-error

2
test-suite/tests/compiler.test
View file

@ -425,7 +425,7 @@
(seq (seq
(define forty-two (define forty-two
(lambda ((name . forty-two)) (lambda ((name . forty-two))
(lambda-case ((() #f #f #f () ()) (const 42))))) (lambda-case ((() () #f #f () ()) (const 42)))))
(toplevel forty-two))") (toplevel forty-two))")
(bytecode #f) (bytecode #f)
(proc #f)) (proc #f))

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

@ -280,7 +280,7 @@
(define + (define +
(lambda (_) (lambda (_)
(lambda-case (lambda-case
(((x y) #f #f #f () (_ _)) (((x y) () #f #f () (_ _))
(call (toplevel pk) (lexical x _) (lexical y _)))))) (call (toplevel pk) (lexical x _) (lexical y _))))))
(call (toplevel +) (const 1) (const 2)))) (call (toplevel +) (const 1) (const 2))))
@ -307,7 +307,7 @@
(define foo (define foo
(lambda (_) (lambda (_)
(lambda-case (lambda-case
(((x) #f #f #f () (_)) (((x) () #f #f () (_))
(primcall + (lexical x _) (const 9))))))) (primcall + (lexical x _) (const 9)))))))
(pass-if-peval (pass-if-peval
@ -366,7 +366,7 @@
'never-reached))) 'never-reached)))
(lambda () (lambda ()
(lambda-case (lambda-case
(((x) #f #f #f () (_)) (((x) () #f #f () (_))
(call (toplevel display) (lexical x _)))))) (call (toplevel display) (lexical x _))))))
(pass-if-peval (pass-if-peval
@ -551,11 +551,11 @@
(primitive zero?) (primitive zero?)
(lambda () (lambda ()
(lambda-case (lambda-case
(((x1) #f #f #f () (_)) (((x1) () #f #f () (_))
(lexical x1 _)))) (lexical x1 _))))
(lambda () (lambda ()
(lambda-case (lambda-case
(((x2) #f #f #f () (_)) (((x2) () #f #f () (_))
(primcall - (lexical x2 _) (const 1)))))))) (primcall - (lexical x2 _) (const 1))))))))
(pass-if "inlined lambdas are alpha-renamed" (pass-if "inlined lambdas are alpha-renamed"
@ -578,13 +578,13 @@
((primcall cons ((primcall cons
(lambda () (lambda ()
(lambda-case (lambda-case
(((y) #f #f #f () (,gensym1)) (((y) () #f #f () (,gensym1))
(primcall + (primcall +
(const 1) (const 1)
(lexical y ,ref1))))) (lexical y ,ref1)))))
(lambda () (lambda ()
(lambda-case (lambda-case
(((y) #f #f #f () (,gensym2)) (((y) () #f #f () (,gensym2))
(primcall + (primcall +
(const 2) (const 2)
(lexical y ,ref2)))))) (lexical y ,ref2))))))
@ -667,7 +667,7 @@
((primcall make-vector (const 6) (const #f))) ((primcall make-vector (const 6) (const #f)))
(lambda () (lambda ()
(lambda-case (lambda-case
(((n) #f #f #f () (_)) (((n) () #f #f () (_))
(primcall vector-set! (primcall vector-set!
(lexical v _) (lexical n _) (lexical n _))))))) (lexical v _) (lexical n _) (lexical n _)))))))
@ -680,7 +680,7 @@
((primcall vector (const 1) (const 2) (const 3))) ((primcall vector (const 1) (const 2) (const 3)))
(lambda () (lambda ()
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(lexical v _)))))) (lexical v _))))))
(pass-if-peval (pass-if-peval
@ -784,7 +784,7 @@
(if (< x 0) x (loop (1- x)))) (if (< x 0) x (loop (1- x))))
(fix (loop) (_) ((lambda (_) (fix (loop) (_) ((lambda (_)
(lambda-case (lambda-case
(((x) #f #f #f () (_)) (((x) () #f #f () (_))
(if _ _ (if _ _
(call (lexical loop _) (call (lexical loop _)
(primcall - (lexical x _) (primcall - (lexical x _)
@ -813,7 +813,7 @@
(loop (1+ x) (1+ y))))) (loop (1+ x) (1+ y)))))
(fix (loop) (_) ((lambda (_) (fix (loop) (_) ((lambda (_)
(lambda-case (lambda-case
(((x y) #f #f #f () (_ _)) (((x y) () #f #f () (_ _))
(if (primcall > (if (primcall >
(lexical y _) (const 0)) (lexical y _) (const 0))
_ _))))) _ _)))))
@ -882,12 +882,12 @@
(fix (a) (_) (fix (a) (_)
((lambda _ ((lambda _
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(call (lexical a _)))))) (call (lexical a _))))))
(fix (b) (_) (fix (b) (_)
((lambda _ ((lambda _
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(call (lexical a _)))))) (call (lexical a _))))))
(call (toplevel foo) (lexical b _))))) (call (toplevel foo) (lexical b _)))))
@ -901,11 +901,11 @@
(call (toplevel foo) (call (toplevel foo)
(lambda _ (lambda _
(lambda-case (lambda-case
(((x) #f #f #f () (_)) (((x) () #f #f () (_))
(call (toplevel top) (lexical x _))))) (call (toplevel top) (lexical x _)))))
(lambda _ (lambda _
(lambda-case (lambda-case
(((x) #f #f #f () (_)) (((x) () #f #f () (_))
(call (toplevel top) (lexical x _))))))) (call (toplevel top) (lexical x _)))))))
(pass-if-peval (pass-if-peval
@ -949,7 +949,7 @@
(primcall apply (primcall apply
(lambda () (lambda ()
(lambda-case (lambda-case
(((x y z w) #f #f #f () (_ _ _ _)) (((x y z w) () #f #f () (_ _ _ _))
(primcall list (primcall list
(lexical x _) (lexical y _) (lexical x _) (lexical y _)
(lexical z _) (lexical w _))))) (lexical z _) (lexical w _)))))
@ -985,7 +985,7 @@
args)))) args))))
(lambda () (lambda ()
(lambda-case (lambda-case
(((bv offset n) #f #f #f () (_ _ _)) (((bv offset n) () #f #f () (_ _ _))
(let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
(lexical bv _) (lexical bv _)
(primcall + (primcall +
@ -1019,7 +1019,7 @@
args))) args)))
(lambda () (lambda ()
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(let (_) (_) ((call (toplevel foo!))) (let (_) (_) ((call (toplevel foo!)))
(let (z) (_) ((toplevel z)) (let (z) (_) ((toplevel z))
(primcall 'list (primcall 'list
@ -1038,7 +1038,7 @@
args))) args)))
(lambda () (lambda ()
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(let (args) (_) (let (args) (_)
((primcall list (const foo))) ((primcall list (const foo)))
(seq (seq
@ -1158,10 +1158,10 @@
(primcall wind (primcall wind
(lambda () (lambda ()
(lambda-case (lambda-case
((() #f #f #f () ()) (toplevel foo)))) ((() () #f #f () ()) (toplevel foo))))
(lambda () (lambda ()
(lambda-case (lambda-case
((() #f #f #f () ()) (toplevel baz)))))) ((() () #f #f () ()) (toplevel baz))))))
(let (tmp) (_) ((toplevel bar)) (let (tmp) (_) ((toplevel bar))
(seq (seq (primcall unwind) (seq (seq (primcall unwind)
(toplevel baz)) (toplevel baz))
@ -1175,13 +1175,13 @@
(primcall wind (primcall wind
(lambda () (lambda ()
(lambda-case (lambda-case
((() #f #f #f () ()) (toplevel foo)))) ((() () #f #f () ()) (toplevel foo))))
(lambda () (lambda ()
(lambda-case (lambda-case
((() #f #f #f () ()) (toplevel baz)))))) ((() () #f #f () ()) (toplevel baz))))))
(let-values (call (toplevel bar)) (let-values (call (toplevel bar))
(lambda-case (lambda-case
((() #f vals #f () (_)) ((() () vals #f () (_))
(seq (seq (primcall unwind) (seq (seq (primcall unwind)
(toplevel baz)) (toplevel baz))
(primcall apply (primitive values) (lexical vals _)))))))) (primcall apply (primitive values) (lexical vals _))))))))
@ -1212,7 +1212,7 @@
(const 1) (const 1)
(lambda _ (lambda _
(lambda-case (lambda-case
(((k x) #f #f #f () (_ _)) (((k x) () #f #f () (_ _))
(lexical x _)))))) (lexical x _))))))
;; Handler toplevel not inlined ;; Handler toplevel not inlined
@ -1226,11 +1226,11 @@
(toplevel tag) (toplevel tag)
(lambda _ (lambda _
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(const 1)))) (const 1))))
(lambda _ (lambda _
(lambda-case (lambda-case
((() #f args #f () (_)) ((() () args #f () (_))
(primcall apply (primcall apply
(lexical handler _) (lexical handler _)
(lexical args _)))))) (lexical args _))))))
@ -1249,11 +1249,11 @@
(fix (lp) (_) (fix (lp) (_)
((lambda _ ((lambda _
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(fix (loop) (_) (fix (loop) (_)
((lambda _ ((lambda _
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(call (lexical loop _)))))) (call (lexical loop _))))))
(call (lexical loop _))))))) (call (lexical loop _)))))))
(call (lexical lp _))))) (call (lexical lp _)))))
@ -1264,7 +1264,7 @@
a rest)) a rest))
(lambda _ (lambda _
(lambda-case (lambda-case
(((x y) #f #f #f () (_ _)) (((x y) () #f #f () (_ _))
_)))) _))))
(pass-if-peval (pass-if-peval
@ -1296,7 +1296,7 @@
(qux x)))) (qux x))))
(let (failure) (_) ((lambda _ (let (failure) (_) ((lambda _
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(call (toplevel qux) (toplevel x)))))) (call (toplevel qux) (toplevel x))))))
(if (primcall struct? (toplevel x)) (if (primcall struct? (toplevel x))
(if (primcall eq? (if (primcall eq?
@ -1325,7 +1325,7 @@
(qux x)))) (qux x))))
(let (failure) (_) ((lambda _ (let (failure) (_) ((lambda _
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(call (toplevel qux) (toplevel x)))))) (call (toplevel qux) (toplevel x))))))
(if (primcall struct? (toplevel x)) (if (primcall struct? (toplevel x))
(if (primcall eq? (if (primcall eq?
@ -1371,7 +1371,7 @@
(call-with-values foo (lambda (x) (bar x))) (call-with-values foo (lambda (x) (bar x)))
(let-values (call (toplevel foo)) (let-values (call (toplevel foo))
(lambda-case (lambda-case
(((x) #f #f #f () (_)) (((x) () #f #f () (_))
(call (toplevel bar) (lexical x _)))))) (call (toplevel bar) (lexical x _))))))
(pass-if-peval (pass-if-peval
@ -1411,12 +1411,12 @@
(if (eq? x x*) x* (lp x*))))) (if (eq? x x*) x* (lp x*)))))
(lambda () (lambda ()
(lambda-case (lambda-case
(((f x) #f #f #f () (_ _)) (((f x) () #f #f () (_ _))
(fix (lp) (fix (lp)
(_) (_)
((lambda ((name . lp)) ((lambda ((name . lp))
(lambda-case (lambda-case
(((x) #f #f #f () (_)) (((x) () #f #f () (_))
(let (x*) (let (x*)
(_) (_)
((call (lexical f _) (lexical x _))) ((call (lexical f _) (lexical x _)))
@ -1436,12 +1436,12 @@
(add1 1 2)) (add1 1 2))
(lambda () (lambda ()
(lambda-case (lambda-case
((() #f #f #f () ()) ((() () #f #f () ())
(fix (add1) (fix (add1)
(_) (_)
((lambda ((name . add1)) ((lambda ((name . add1))
(lambda-case (lambda-case
(((n) #f #f #f () (_)) (((n) () #f #f () (_))
(primcall + (const 1) (lexical n _)))))) (primcall + (const 1) (lexical n _))))))
(call (lexical add1 _) (call (lexical add1 _)
(const 1) (const 1)

4
test-suite/tests/tree-il.test
View file

@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009 ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -171,7 +171,7 @@
(parse-tree-il (parse-tree-il
'(lambda () '(lambda ()
(lambda-case (lambda-case
(((x y) #f #f #f () (x1 y1)) (((x y) () #f #f () (x1 y1))
(call (toplevel +) (call (toplevel +)
(lexical x x1) (lexical x x1)
(lexical y y1))) (lexical y y1)))