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

psyntax builds case-lambda expressions

Browse source 
* module/ice-9/psyntax.scm (build-case-lambda, build-lambda-case):
  Actually build case-lambda expressions, knowing that the memoizer will
  do the right thing.

* module/ice-9/psyntax-pp.scm: Regenerated.
This commit is contained in:
Andy Wingo 2010-05-13 23:27:00 +02:00
parent 7572ee5261
commit 12922f0dd1
2 changed files with 8061 additions and 8187 deletions
Download patch file Download diff file Expand all files Collapse all files

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

File diff suppressed because it is too large Load diff

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

@ -471,16 +471,14 @@
meta meta
body)) body))
(else (decorate-source (else (decorate-source
;; really gross hack `(case-lambda* ,@body)
`(lambda %%args
(cond ,@body))
src))))) src)))))
(define build-lambda-case (define build-lambda-case
;; req := (name ...) ;; req := (name ...)
;; opt := (name ...) | #f ;; opt := (name ...) | #f
;; rest := name | #f ;; rest := name | #f
;; kw := (allow-other-keys? (keyword name var [init]) ...) | #f ;; kw := (allow-other-keys? (keyword name var) ...) | #f
;; inits: (init ...) ;; inits: (init ...)
;; vars: (sym ...) ;; vars: (sym ...)
;; vars map to named arguments in the following order: ;; vars map to named arguments in the following order:
@ -510,15 +508,24 @@
(error "something went wrong" (error "something went wrong"
req opt rest kw inits vars nreq nopt kw-indices nargs)) req opt rest kw inits vars nreq nopt kw-indices nargs))
(decorate-source (decorate-source
`((((@@ (ice-9 optargs) parse-lambda-case) `(((,@(list-head vars nreq)
'(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices) ,@(if opt
(list ,@(map (lambda (i) `(lambda ,vars ,i)) inits)) `(#:optional ,@(map list
%%args) (list-head (list-tail vars nreq) nopt)
=> (lambda (%%args) (apply (lambda ,vars ,body) %%args))) (list-head inits nopt)))
,@(or else-case '())
`((%%args (scm-error 'wrong-number-of-args #f ,@(if kw
"Wrong number of arguments" '() `(#:key ,@(map (lambda (x init)
%%args))))) (list (caddr x)
init
(car x)))
(cdr kw)
(list-tail inits nopt)))
'())
,@(if allow-other-keys? '(#:allow-other-keys) '())
,@(if rest (list-ref vars rest-idx) '()))
,body)
,@(or else-case '()))
src)))))) src))))))
(define build-primref (define build-primref