[bpt/guile.git] / ice-9 / optargs.scm

;;;; optargs.scm -- support for optional arguments
;;;;
;;;; 	Copyright (C) 1997, 1998, 1999, 2001 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
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.
;;;;
;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>

\f

;;; Commentary:

;;; {Optional Arguments}
;;;
;;; The C interface for creating Guile procedures has a very handy
;;; "optional argument" feature. This module attempts to provide
;;; similar functionality for procedures defined in Scheme with
;;; a convenient and attractive syntax.
;;;
;;; exported macros are:
;;;   let-optional
;;;   let-optional*
;;;   let-keywords
;;;   let-keywords*
;;;   lambda*
;;;   define*
;;;   define*-public
;;;   defmacro*
;;;   defmacro*-public
;;;
;;;
;;; Summary of the lambda* extended parameter list syntax (brackets
;;; are used to indicate grouping only):
;;;
;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
;;;   [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
;;;   [[#:rest identifier]|[. identifier]]?
;;;
;;; ext-var-decl ::= identifier | ( identifier expression )
;;;
;;; The characters `*', `+' and `?' are not to be taken literally; they
;;; mean respectively, zero or more occurences, one or more occurences,
;;; and one or zero occurences.
;;;

;;; Code:

(define-module (ice-9 optargs)
  :export-syntax (let-optional
		  let-optional*
		  let-keywords
		  let-keywords*
		  define* lambda*
		  define*-public
		  defmacro*
		  defmacro*-public))

;; let-optional rest-arg (binding ...) . body
;; let-optional* rest-arg (binding ...) . body
;;   macros used to bind optional arguments
;;
;; These two macros give you an optional argument interface that is
;; very "Schemey" and introduces no fancy syntax. They are compatible
;; with the scsh macros of the same name, but are slightly
;; extended. Each of binding may be of one of the forms <var> or
;; (<var> <default-value>). rest-arg should be the rest-argument of
;; the procedures these are used from. The items in rest-arg are
;; sequentially bound to the variable namess are given. When rest-arg
;; runs out, the remaining vars are bound either to the default values
;; or to `#f' if no default value was specified. rest-arg remains
;; bound to whatever may have been left of rest-arg.
;;

(defmacro let-optional (REST-ARG BINDINGS . BODY)
  (let-optional-template REST-ARG BINDINGS BODY 'let))

(defmacro let-optional* (REST-ARG BINDINGS . BODY)
  (let-optional-template REST-ARG BINDINGS BODY 'let*))


;; let-keywords rest-arg allow-other-keys? (binding ...) . body
;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
;;   macros used to bind keyword arguments
;;
;; These macros pick out keyword arguments from rest-arg, but do not
;; modify it. This is consistent at least with Common Lisp, which
;; duplicates keyword args in the rest arg. More explanation of what
;; keyword arguments in a lambda list look like can be found below in
;; the documentation for lambda*.  Bindings can have the same form as
;; for let-optional. If allow-other-keys? is false, an error will be
;; thrown if anything that looks like a keyword argument but does not
;; match a known keyword parameter will result in an error.
;;


(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
  (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))

(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
  (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))


;; some utility procedures for implementing the various let-forms.

(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
  (let ((bindings (map (lambda (x)
			 (if (list? x)
			     x
			     (list x #f)))
		       BINDINGS)))
    `(,let-type ,(map proc bindings) ,@BODY)))

(define (let-optional-template REST-ARG BINDINGS BODY let-type)
    (if (null? BINDINGS)
	`(begin ,@BODY)
	(let-o-k-template REST-ARG BINDINGS BODY let-type
			  (lambda (optional)
			    `(,(car optional)
			      (cond
			       ((not (null? ,REST-ARG))
				(let ((result (car ,REST-ARG)))
				  ,(list 'set! REST-ARG
					 `(cdr ,REST-ARG))
				  result))
			       (else
				,(cadr optional))))))))

(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
    (if (null? BINDINGS)
	`(begin ,@BODY)
	(let* ((kb-list-gensym (gensym "kb:G"))
	       (bindfilter (lambda (key)
			     `(,(car key)
			       (cond
				((assq ',(car key) ,kb-list-gensym)
				 => cdr)
				(else
				 ,(cadr key)))))))
	  `(let* ((ra->kbl ,rest-arg->keyword-binding-list)
		  (,kb-list-gensym (ra->kbl ,REST-ARG ',(map
							 (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
							 BINDINGS)
					    ,ALLOW-OTHER-KEYS?)))
	     ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))


(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
  (if (null? rest-arg)
      '()
      (let loop ((first (car rest-arg))
		 (rest (cdr rest-arg))
		 (accum '()))
	(let ((next (lambda (a)
		      (if (null? (cdr rest))
			  a
			  (loop (cadr rest) (cddr rest) a)))))
	  (if (keyword? first)
	      (cond
	       ((memq first keywords)
		(if (null? rest)
		    (error "Keyword argument has no value.")
		    (next (cons (cons (keyword->symbol first)
				      (car rest)) accum))))
	       ((not allow-other-keys?)
		(error "Unknown keyword in arguments."))
	       (else (if (null? rest)
			 accum
			 (next accum))))
	      (if (null? rest)
		  accum
		  (loop (car rest) (cdr rest) accum)))))))


;; lambda* args . body
;;   lambda extended for optional and keyword arguments
;;
;; lambda* creates a procedure that takes optional arguments. These
;; are specified by putting them inside brackets at the end of the
;; paramater list, but before any dotted rest argument. For example,
;;   (lambda* (a b #:optional c d . e) '())
;; creates a procedure with fixed arguments a and b, optional arguments c
;; and d, and rest argument e. If the optional arguments are omitted
;; in a call, the variables for them are bound to `#f'.
;;
;; lambda* can also take keyword arguments. For example, a procedure
;; defined like this:
;;   (lambda* (#:key xyzzy larch) '())
;; can be called with any of the argument lists (#:xyzzy 11)
;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
;; are given as keywords are bound to values.
;;
;; Optional and keyword arguments can also be given default values
;; which they take on when they are not present in a call, by giving a
;; two-item list in place of an optional argument, for example in:
;;   (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
;; foo is a fixed argument, bar is an optional argument with default
;; value 42, and baz is a keyword argument with default value 73.
;; Default value expressions are not evaluated unless they are needed
;; and until the procedure is called.
;;
;; lambda* now supports two more special parameter list keywords.
;;
;; lambda*-defined procedures now throw an error by default if a
;; keyword other than one of those specified is found in the actual
;; passed arguments. However, specifying #:allow-other-keys
;; immediately after the keyword argument declarations restores the
;; previous behavior of ignoring unknown keywords. lambda* also now
;; guarantees that if the same keyword is passed more than once, the
;; last one passed is the one that takes effect. For example,
;;   ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
;;    #:heads 37 #:tails 42 #:heads 99)
;; would result in (99 47) being displayed.
;;
;; #:rest is also now provided as a synonym for the dotted syntax rest
;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
;; all respects to lambda*. This is provided for more similarity to DSSSL,
;; MIT-Scheme and Kawa among others, as well as for refugees from other
;; Lisp dialects.


(defmacro lambda* (ARGLIST . BODY)
  (parse-arglist
   ARGLIST
   (lambda (non-optional-args optionals keys aok? rest-arg)
     ;; Check for syntax errors.
     (if (not (every? symbol? non-optional-args))
	 (error "Syntax error in fixed argument declaration."))
     (if (not (every? ext-decl? optionals))
	 (error "Syntax error in optional argument declaration."))
     (if (not (every? ext-decl? keys))
	 (error "Syntax error in keyword argument declaration."))
     (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
	 (error "Syntax error in rest argument declaration."))
     ;; generate the code.
     (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
	   (lambda-gensym (gensym "lambda*:L")))
       (if (not (and (null? optionals) (null? keys)))
	   `(let ((,lambda-gensym
		   (lambda (,@non-optional-args . ,rest-gensym)
		     ;; Make sure that if the proc had a docstring, we put it
		     ;; here where it will be visible.
		     ,@(if (and (not (null? BODY))
				(string? (car BODY)))
			   (list (car BODY))
			   '())
		     (let-optional*
		      ,rest-gensym
		      ,optionals
		      (let-keywords* ,rest-gensym
				     ,aok?
				     ,keys
				     ,@(if (and (not rest-arg) (null? keys))
					   `((if (not (null? ,rest-gensym))
						 (error "Too many arguments.")))
					   '())
				     (let ()
				       ,@BODY))))))
	      (set-procedure-property! ,lambda-gensym 'arglist
				       '(,non-optional-args
					 ,optionals
					 ,keys
					 ,aok?
					 ,rest-arg))
	      ,lambda-gensym)
	   `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
	      ,@BODY))))))


(define (every? pred lst)
  (or (null? lst)
      (and (pred (car lst))
	   (every? pred (cdr lst)))))

(define (ext-decl? obj)
  (or (symbol? obj)
      (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))

(define (parse-arglist arglist cont)
  (define (split-list-at val lst cont)
    (cond
     ((memq val lst)
      => (lambda (pos)
	   (if (memq val (cdr pos))
	       (error (with-output-to-string
			(lambda ()
			  (map display `(,val
					 " specified more than once in argument list.")))))
	       (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
     (else (cont lst '() #f))))
  (define (parse-opt-and-fixed arglist keys aok? rest cont)
    (split-list-at
     #:optional arglist
     (lambda (before after split?)
       (if (and split? (null? after))
	   (error "#:optional specified but no optional arguments declared.")
	   (cont before after keys aok? rest)))))
  (define (parse-keys arglist rest cont)
    (split-list-at
     #:allow-other-keys arglist
     (lambda (aok-before aok-after aok-split?)
       (if (and aok-split? (not (null? aok-after)))
	   (error "#:allow-other-keys not at end of keyword argument declarations.")
	   (split-list-at
	    #:key aok-before
	    (lambda (key-before key-after key-split?)
	      (cond
	       ((and aok-split? (not key-split?))
		(error "#:allow-other-keys specified but no keyword arguments declared."))
	       (key-split?
		(cond
		 ((null? key-after) (error "#:key specified but no keyword arguments declared."))
		 ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
		 (else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
	       (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
  (define (parse-rest arglist cont)
    (cond
     ((null? arglist) (cont '() '() '() #f #f))
     ((not (pair? arglist)) (cont '() '() '() #f arglist))
     ((not (list? arglist))
	  (let* ((copy (list-copy arglist))
		 (lp (last-pair copy))
		 (ra (cdr lp)))
	    (set-cdr! lp '())
	    (if (memq #:rest copy)
		(error "Cannot specify both #:rest and dotted rest argument.")
		(parse-keys copy ra cont))))
     (else (split-list-at
	    #:rest arglist
	    (lambda (before after split?)
	      (if split?
		  (case (length after)
		    ((0) (error "#:rest not followed by argument."))
		    ((1) (parse-keys before (car after) cont))
		    (else (error "#:rest argument must be declared last.")))
		  (parse-keys before #f cont)))))))

  (parse-rest arglist cont))


;; define* args . body
;; define*-public args . body
;;   define and define-public extended for optional and keyword arguments
;;
;; define* and define*-public support optional arguments with
;; a similar syntax to lambda*. They also support arbitrary-depth
;; currying, just like Guile's define. Some examples:
;;   (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
;; defines a procedure x with a fixed argument y, an optional agument
;; a, another optional argument z with default value 3, a keyword argument w,
;; and a rest argument u.
;;   (define-public* ((foo #:optional bar) #:optional baz) '())
;; This illustrates currying. A procedure foo is defined, which,
;; when called with an optional argument bar, returns a procedure that
;; takes an optional argument baz.
;;
;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
;; in the same way as lambda*.

(defmacro define* (ARGLIST . BODY)
  (define*-guts 'define ARGLIST BODY))

(defmacro define*-public (ARGLIST . BODY)
  (define*-guts 'define-public ARGLIST BODY))

;; The guts of define* and define*-public.
(define (define*-guts DT ARGLIST BODY)
  (define (nest-lambda*s arglists)
    (if (null? arglists)
        BODY
        `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
  (define (define*-guts-helper ARGLIST arglists)
    (let ((first (car ARGLIST))
	  (al (cons (cdr ARGLIST) arglists)))
      (if (symbol? first)
	  `(,DT ,first ,@(nest-lambda*s al))
	  (define*-guts-helper first al))))
  (if (symbol? ARGLIST)
      `(,DT ,ARGLIST ,@BODY)
      (define*-guts-helper ARGLIST '())))


;; defmacro* name args . body
;; defmacro*-public args . body
;;   defmacro and defmacro-public extended for optional and keyword arguments
;;
;; These are just like defmacro and defmacro-public except that they
;; take lambda*-style extended paramter lists, where #:optional,
;; #:key, #:allow-other-keys and #:rest are allowed with the usual
;; semantics. Here is an example of a macro with an optional argument:
;;   (defmacro* transmorgify (a #:optional b)

(defmacro defmacro* (NAME ARGLIST . BODY)
  (defmacro*-guts 'define NAME ARGLIST BODY))

(defmacro defmacro*-public (NAME ARGLIST . BODY)
  (defmacro*-guts 'define-public NAME ARGLIST BODY))

;; The guts of defmacro* and defmacro*-public
(define (defmacro*-guts DT NAME ARGLIST BODY)
  `(,DT ,NAME
	(,(lambda (transformer) (defmacro:transformer transformer))
	 (lambda* ,ARGLIST ,@BODY))))

;;; optargs.scm ends here
Commit	Line	Data
08394899 MS	1	;;;; optargs.scm -- support for optional arguments
08394899 MS	2	;;;;
e39bbe80	3	;;;; Copyright (C) 1997, 1998, 1999, 2001 Free Software Foundation, Inc.
afab82bc	4	;;;;
08394899 MS	5	;;;; This program is free software; you can redistribute it and/or modify
	6	;;;; it under the terms of the GNU General Public License as published by
	7	;;;; the Free Software Foundation; either version 2, or (at your option)
	8	;;;; any later version.
afab82bc	9	;;;;
08394899 MS	10	;;;; This program is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	13	;;;; GNU General Public License for more details.
afab82bc	14	;;;;
08394899 MS	15	;;;; You should have received a copy of the GNU General Public License
08394899 MS	16	;;;; along with this software; see the file COPYING. If not, write to
c6e23ea2 JB	17	;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
c6e23ea2 JB	18	;;;; Boston, MA 02111-1307 USA
afab82bc	19	;;;;
a482f2cc MV	20	;;;; As a special exception, the Free Software Foundation gives permission
	21	;;;; for additional uses of the text contained in its release of GUILE.
	22	;;;;
	23	;;;; The exception is that, if you link the GUILE library with other files
	24	;;;; to produce an executable, this does not by itself cause the
	25	;;;; resulting executable to be covered by the GNU General Public License.
	26	;;;; Your use of that executable is in no way restricted on account of
	27	;;;; linking the GUILE library code into it.
	28	;;;;
	29	;;;; This exception does not however invalidate any other reasons why
	30	;;;; the executable file might be covered by the GNU General Public License.
	31	;;;;
	32	;;;; This exception applies only to the code released by the
	33	;;;; Free Software Foundation under the name GUILE. If you copy
	34	;;;; code from other Free Software Foundation releases into a copy of
	35	;;;; GUILE, as the General Public License permits, the exception does
	36	;;;; not apply to the code that you add in this way. To avoid misleading
	37	;;;; anyone as to the status of such modified files, you must delete
	38	;;;; this exception notice from them.
	39	;;;;
	40	;;;; If you write modifications of your own for GUILE, it is your choice
	41	;;;; whether to permit this exception to apply to your modifications.
	42	;;;; If you do not wish that, delete this exception notice.
	43	;;;;
08394899 MS	44	;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
	45
	46	\f
	47
afab82bc	48	;;; Commentary:
08394899 MS	49
	50	;;; {Optional Arguments}
	51	;;;
	52	;;; The C interface for creating Guile procedures has a very handy
	53	;;; "optional argument" feature. This module attempts to provide
	54	;;; similar functionality for procedures defined in Scheme with
	55	;;; a convenient and attractive syntax.
	56	;;;
	57	;;; exported macros are:
08394899 MS	58	;;; let-optional
	59	;;; let-optional*
	60	;;; let-keywords
	61	;;; let-keywords*
	62	;;; lambda*
	63	;;; define*
afab82bc	64	;;; define*-public
08394899 MS	65	;;; defmacro*
	66	;;; defmacro*-public
	67	;;;
	68	;;;
	69	;;; Summary of the lambda* extended parameter list syntax (brackets
	70	;;; are used to indicate grouping only):
	71	;;;
dfb49627	72	;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
afab82bc	73	;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
dfb49627	74	;;; [[#:rest identifier]\|[. identifier]]?
08394899	75	;;;
afab82bc	76	;;; ext-var-decl ::= identifier \| ( identifier expression )
08394899 MS	77	;;;
	78	;;; The characters `*', `+' and `?' are not to be taken literally; they
	79	;;; mean respectively, zero or more occurences, one or more occurences,
	80	;;; and one or zero occurences.
	81	;;;
	82
afab82bc	83	;;; Code:
08394899	84
1a179b03 MD	85	(define-module (ice-9 optargs)
	86	:export-syntax (let-optional
	87	let-optional*
	88	let-keywords
	89	let-keywords*
	90	define* lambda*
	91	define*-public
	92	defmacro*
	93	defmacro*-public))
08394899	94
08394899 MS	95	;; let-optional rest-arg (binding ...) . body
	96	;; let-optional* rest-arg (binding ...) . body
	97	;; macros used to bind optional arguments
	98	;;
296ff5e7 MV	99	;; These two macros give you an optional argument interface that is
	100	;; very "Schemey" and introduces no fancy syntax. They are compatible
	101	;; with the scsh macros of the same name, but are slightly
08394899 MS	102	;; extended. Each of binding may be of one of the forms <var> or
	103	;; (<var> <default-value>). rest-arg should be the rest-argument of
	104	;; the procedures these are used from. The items in rest-arg are
	105	;; sequentially bound to the variable namess are given. When rest-arg
	106	;; runs out, the remaining vars are bound either to the default values
296ff5e7	107	;; or to `#f' if no default value was specified. rest-arg remains
08394899 MS	108	;; bound to whatever may have been left of rest-arg.
	109	;;
	110
1a179b03	111	(defmacro let-optional (REST-ARG BINDINGS . BODY)
08394899 MS	112	(let-optional-template REST-ARG BINDINGS BODY 'let))
08394899 MS	113
1a179b03	114	(defmacro let-optional* (REST-ARG BINDINGS . BODY)
08394899 MS	115	(let-optional-template REST-ARG BINDINGS BODY 'let*))
	116
	117
	118
	119	;; let-keywords rest-arg allow-other-keys? (binding ...) . body
	120	;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
	121	;; macros used to bind keyword arguments
	122	;;
	123	;; These macros pick out keyword arguments from rest-arg, but do not
	124	;; modify it. This is consistent at least with Common Lisp, which
	125	;; duplicates keyword args in the rest arg. More explanation of what
	126	;; keyword arguments in a lambda list look like can be found below in
	127	;; the documentation for lambda*. Bindings can have the same form as
afab82bc	128	;; for let-optional. If allow-other-keys? is false, an error will be
08394899 MS	129	;; thrown if anything that looks like a keyword argument but does not
	130	;; match a known keyword parameter will result in an error.
	131	;;
	132
	133
1a179b03	134	(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
08394899 MS	135	(let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
08394899 MS	136
1a179b03	137	(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
08394899 MS	138	(let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
	139
	140
	141	;; some utility procedures for implementing the various let-forms.
	142
	143	(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
afab82bc	144	(let ((bindings (map (lambda (x)
08394899 MS	145	(if (list? x)
08394899 MS	146	x
296ff5e7	147	(list x #f)))
08394899 MS	148	BINDINGS)))
	149	`(,let-type ,(map proc bindings) ,@BODY)))
	150
	151	(define (let-optional-template REST-ARG BINDINGS BODY let-type)
	152	(if (null? BINDINGS)
	153	`(begin ,@BODY)
	154	(let-o-k-template REST-ARG BINDINGS BODY let-type
afab82bc TTN	155	(lambda (optional)
afab82bc TTN	156	`(,(car optional)
08394899 MS	157	(cond
	158	((not (null? ,REST-ARG))
	159	(let ((result (car ,REST-ARG)))
	160	,(list 'set! REST-ARG
	161	`(cdr ,REST-ARG))
	162	result))
	163	(else
	164	,(cadr optional))))))))
	165
	166	(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
	167	(if (null? BINDINGS)
	168	`(begin ,@BODY)
	169	(let* ((kb-list-gensym (gensym "kb:G"))
	170	(bindfilter (lambda (key)
	171	`(,(car key)
	172	(cond
afab82bc	173	((assq ',(car key) ,kb-list-gensym)
08394899	174	=> cdr)
afab82bc	175	(else
08394899	176	,(cadr key)))))))
afab82bc	177	`(let* ((ra->kbl ,rest-arg->keyword-binding-list)
08394899 MS	178	(,kb-list-gensym (ra->kbl ,REST-ARG ',(map
	179	(lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
	180	BINDINGS)
	181	,ALLOW-OTHER-KEYS?)))
	182	,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))
	183
	184
	185	(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
	186	(if (null? rest-arg)
61819670	187	'()
08394899 MS	188	(let loop ((first (car rest-arg))
08394899 MS	189	(rest (cdr rest-arg))
61819670	190	(accum '()))
08394899 MS	191	(let ((next (lambda (a)
	192	(if (null? (cdr rest))
	193	a
	194	(loop (cadr rest) (cddr rest) a)))))
	195	(if (keyword? first)
	196	(cond
	197	((memq first keywords)
	198	(if (null? rest)
	199	(error "Keyword argument has no value.")
	200	(next (cons (cons (keyword->symbol first)
	201	(car rest)) accum))))
afab82bc	202	((not allow-other-keys?)
08394899 MS	203	(error "Unknown keyword in arguments."))
	204	(else (if (null? rest)
	205	accum
	206	(next accum))))
	207	(if (null? rest)
	208	accum
	209	(loop (car rest) (cdr rest) accum)))))))
	210
08394899 MS	211
	212	;; lambda* args . body
	213	;; lambda extended for optional and keyword arguments
afab82bc	214	;;
08394899 MS	215	;; lambda* creates a procedure that takes optional arguments. These
	216	;; are specified by putting them inside brackets at the end of the
	217	;; paramater list, but before any dotted rest argument. For example,
dfb49627	218	;; (lambda* (a b #:optional c d . e) '())
08394899 MS	219	;; creates a procedure with fixed arguments a and b, optional arguments c
08394899 MS	220	;; and d, and rest argument e. If the optional arguments are omitted
296ff5e7	221	;; in a call, the variables for them are bound to `#f'.
08394899 MS	222	;;
	223	;; lambda* can also take keyword arguments. For example, a procedure
	224	;; defined like this:
dfb49627	225	;; (lambda* (#:key xyzzy larch) '())
08394899 MS	226	;; can be called with any of the argument lists (#:xyzzy 11)
	227	;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
	228	;; are given as keywords are bound to values.
	229	;;
	230	;; Optional and keyword arguments can also be given default values
	231	;; which they take on when they are not present in a call, by giving a
	232	;; two-item list in place of an optional argument, for example in:
afab82bc	233	;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
08394899 MS	234	;; foo is a fixed argument, bar is an optional argument with default
	235	;; value 42, and baz is a keyword argument with default value 73.
	236	;; Default value expressions are not evaluated unless they are needed
afab82bc	237	;; and until the procedure is called.
08394899 MS	238	;;
	239	;; lambda* now supports two more special parameter list keywords.
	240	;;
	241	;; lambda*-defined procedures now throw an error by default if a
	242	;; keyword other than one of those specified is found in the actual
dfb49627	243	;; passed arguments. However, specifying #:allow-other-keys
b4ad0dda	244	;; immediately after the keyword argument declarations restores the
08394899 MS	245	;; previous behavior of ignoring unknown keywords. lambda* also now
	246	;; guarantees that if the same keyword is passed more than once, the
	247	;; last one passed is the one that takes effect. For example,
dfb49627	248	;; ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
08394899 MS	249	;; #:heads 37 #:tails 42 #:heads 99)
	250	;; would result in (99 47) being displayed.
	251	;;
dfb49627 MV	252	;; #:rest is also now provided as a synonym for the dotted syntax rest
dfb49627 MV	253	;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
08394899 MS	254	;; all respects to lambda*. This is provided for more similarity to DSSSL,
	255	;; MIT-Scheme and Kawa among others, as well as for refugees from other
	256	;; Lisp dialects.
	257
	258
1a179b03	259	(defmacro lambda* (ARGLIST . BODY)
afab82bc	260	(parse-arglist
08394899 MS	261	ARGLIST
08394899 MS	262	(lambda (non-optional-args optionals keys aok? rest-arg)
4a69c751	263	;; Check for syntax errors.
08394899 MS	264	(if (not (every? symbol? non-optional-args))
	265	(error "Syntax error in fixed argument declaration."))
	266	(if (not (every? ext-decl? optionals))
	267	(error "Syntax error in optional argument declaration."))
	268	(if (not (every? ext-decl? keys))
	269	(error "Syntax error in keyword argument declaration."))
	270	(if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
	271	(error "Syntax error in rest argument declaration."))
	272	;; generate the code.
4a69c751 TTN	273	(let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
4a69c751 TTN	274	(lambda-gensym (gensym "lambda*:L")))
08394899	275	(if (not (and (null? optionals) (null? keys)))
4a69c751 TTN	276	`(let ((,lambda-gensym
	277	(lambda (,@non-optional-args . ,rest-gensym)
	278	;; Make sure that if the proc had a docstring, we put it
	279	;; here where it will be visible.
	280	,@(if (and (not (null? BODY))
	281	(string? (car BODY)))
	282	(list (car BODY))
	283	'())
	284	(let-optional*
	285	,rest-gensym
	286	,optionals
	287	(let-keywords* ,rest-gensym
	288	,aok?
	289	,keys
	290	,@(if (and (not rest-arg) (null? keys))
	291	`((if (not (null? ,rest-gensym))
	292	(error "Too many arguments.")))
	293	'())
	294	(let ()
	295	,@BODY))))))
	296	(set-procedure-property! ,lambda-gensym 'arglist
	297	'(,non-optional-args
	298	,optionals
	299	,keys
	300	,aok?
	301	,rest-arg))
	302	,lambda-gensym)
afab82bc	303	`(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
08394899 MS	304	,@BODY))))))
	305
	306
	307	(define (every? pred lst)
	308	(or (null? lst)
	309	(and (pred (car lst))
	310	(every? pred (cdr lst)))))
	311
	312	(define (ext-decl? obj)
afab82bc	313	(or (symbol? obj)
08394899 MS	314	(and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
	315
	316	(define (parse-arglist arglist cont)
	317	(define (split-list-at val lst cont)
	318	(cond
	319	((memq val lst)
	320	=> (lambda (pos)
	321	(if (memq val (cdr pos))
afab82bc	322	(error (with-output-to-string
08394899	323	(lambda ()
afab82bc	324	(map display `(,val
08394899 MS	325	" specified more than once in argument list.")))))
	326	(cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
	327	(else (cont lst '() #f))))
	328	(define (parse-opt-and-fixed arglist keys aok? rest cont)
	329	(split-list-at
dfb49627	330	#:optional arglist
08394899 MS	331	(lambda (before after split?)
08394899 MS	332	(if (and split? (null? after))
dfb49627	333	(error "#:optional specified but no optional arguments declared.")
08394899 MS	334	(cont before after keys aok? rest)))))
08394899 MS	335	(define (parse-keys arglist rest cont)
afab82bc	336	(split-list-at
dfb49627	337	#:allow-other-keys arglist
08394899 MS	338	(lambda (aok-before aok-after aok-split?)
08394899 MS	339	(if (and aok-split? (not (null? aok-after)))
dfb49627	340	(error "#:allow-other-keys not at end of keyword argument declarations.")
afab82bc	341	(split-list-at
dfb49627	342	#:key aok-before
08394899	343	(lambda (key-before key-after key-split?)
afab82bc	344	(cond
08394899	345	((and aok-split? (not key-split?))
dfb49627	346	(error "#:allow-other-keys specified but no keyword arguments declared."))
afab82bc	347	(key-split?
08394899	348	(cond
dfb49627 MV	349	((null? key-after) (error "#:key specified but no keyword arguments declared."))
dfb49627 MV	350	((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
08394899 MS	351	(else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
	352	(else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
	353	(define (parse-rest arglist cont)
afab82bc	354	(cond
fcdd6672	355	((null? arglist) (cont '() '() '() #f #f))
08394899 MS	356	((not (pair? arglist)) (cont '() '() '() #f arglist))
	357	((not (list? arglist))
	358	(let* ((copy (list-copy arglist))
	359	(lp (last-pair copy))
	360	(ra (cdr lp)))
	361	(set-cdr! lp '())
dfb49627 MV	362	(if (memq #:rest copy)
dfb49627 MV	363	(error "Cannot specify both #:rest and dotted rest argument.")
08394899	364	(parse-keys copy ra cont))))
afab82bc TTN	365	(else (split-list-at
afab82bc TTN	366	#:rest arglist
08394899 MS	367	(lambda (before after split?)
	368	(if split?
	369	(case (length after)
dfb49627	370	((0) (error "#:rest not followed by argument."))
08394899	371	((1) (parse-keys before (car after) cont))
dfb49627	372	(else (error "#:rest argument must be declared last.")))
08394899 MS	373	(parse-keys before #f cont)))))))
	374
	375	(parse-rest arglist cont))
	376
	377
	378
	379	;; define* args . body
	380	;; define*-public args . body
	381	;; define and define-public extended for optional and keyword arguments
	382	;;
	383	;; define* and define*-public support optional arguments with
	384	;; a similar syntax to lambda*. They also support arbitrary-depth
	385	;; currying, just like Guile's define. Some examples:
dfb49627	386	;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
08394899 MS	387	;; defines a procedure x with a fixed argument y, an optional agument
	388	;; a, another optional argument z with default value 3, a keyword argument w,
	389	;; and a rest argument u.
dfb49627	390	;; (define-public* ((foo #:optional bar) #:optional baz) '())
08394899 MS	391	;; This illustrates currying. A procedure foo is defined, which,
08394899 MS	392	;; when called with an optional argument bar, returns a procedure that
afab82bc	393	;; takes an optional argument baz.
08394899	394	;;
dfb49627	395	;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
08394899 MS	396	;; in the same way as lambda*.
08394899 MS	397
1a179b03	398	(defmacro define* (ARGLIST . BODY)
08394899 MS	399	(define*-guts 'define ARGLIST BODY))
08394899 MS	400
1a179b03	401	(defmacro define*-public (ARGLIST . BODY)
08394899 MS	402	(define*-guts 'define-public ARGLIST BODY))
	403
	404	;; The guts of define* and define*-public.
	405	(define (define*-guts DT ARGLIST BODY)
	406	(define (nest-lambda*s arglists)
	407	(if (null? arglists)
	408	BODY
	409	`((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
	410	(define (define*-guts-helper ARGLIST arglists)
	411	(let ((first (car ARGLIST))
	412	(al (cons (cdr ARGLIST) arglists)))
	413	(if (symbol? first)
	414	`(,DT ,first ,@(nest-lambda*s al))
	415	(define*-guts-helper first al))))
	416	(if (symbol? ARGLIST)
	417	`(,DT ,ARGLIST ,@BODY)
	418	(define*-guts-helper ARGLIST '())))
	419
	420
	421
	422	;; defmacro* name args . body
	423	;; defmacro*-public args . body
	424	;; defmacro and defmacro-public extended for optional and keyword arguments
afab82bc	425	;;
08394899	426	;; These are just like defmacro and defmacro-public except that they
dfb49627 MV	427	;; take lambda*-style extended paramter lists, where #:optional,
dfb49627 MV	428	;; #:key, #:allow-other-keys and #:rest are allowed with the usual
08394899	429	;; semantics. Here is an example of a macro with an optional argument:
dfb49627	430	;; (defmacro* transmorgify (a #:optional b)
08394899	431
1a179b03	432	(defmacro defmacro* (NAME ARGLIST . BODY)
08394899 MS	433	(defmacro*-guts 'define NAME ARGLIST BODY))
08394899 MS	434
1a179b03	435	(defmacro defmacro*-public (NAME ARGLIST . BODY)
08394899 MS	436	(defmacro*-guts 'define-public NAME ARGLIST BODY))
	437
	438	;; The guts of defmacro* and defmacro*-public
	439	(define (defmacro*-guts DT NAME ARGLIST BODY)
	440	`(,DT ,NAME
	441	(,(lambda (transformer) (defmacro:transformer transformer))
	442	(lambda* ,ARGLIST ,@BODY))))
afab82bc TTN	443
afab82bc TTN	444	;;; optargs.scm ends here