diff options
Diffstat (limited to 'ice-9/optargs.scm')
-rw-r--r-- | ice-9/optargs.scm | 444 |
1 files changed, 0 insertions, 444 deletions
diff --git a/ice-9/optargs.scm b/ice-9/optargs.scm deleted file mode 100644 index bbeab8cf4..000000000 --- a/ice-9/optargs.scm +++ /dev/null @@ -1,444 +0,0 @@ -;;;; 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> - - - -;;; 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 |