mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
<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.
This commit is contained in:
Andy Wingo
parent
a970ed5bd5
commit
60d852248f
17 changed files with 109 additions and 113 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 '()))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue