mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 08:50:23 +02:00
Code Activity

Surround commentary w/ standard markers; nfc.

Browse source
This commit is contained in:
Thien-Thi Nguyen 2001-04-28 18:58:09 +00:00
parent e7d82febca
commit afab82bc00
1 changed files with 42 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

82
ice-9/optargs.scm
View file

@ -1,29 +1,27 @@
;;;; optargs.scm -- support for optional arguments ;;;; optargs.scm -- support for optional arguments
;;;; ;;;;
;;;; Copyright (C) 1997, 1998, 1999 Free Software Foundation, Inc. ;;;; Copyright (C) 1997, 1998, 1999 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
;;;; the Free Software Foundation; either version 2, or (at your option) ;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version. ;;;; any later version.
;;;; ;;;;
;;;; This program is distributed in the hope that it will be useful, ;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details. ;;;; GNU General Public License for more details.
;;;; ;;;;
;;;; You should have received a copy of the GNU General Public License ;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to ;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA ;;;; Boston, MA 02111-1307 USA
;;;; ;;;;
;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu> ;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
(define-module (ice-9 optargs)) ;;; Commentary:
;;; {Optional Arguments} ;;; {Optional Arguments}
;;; ;;;
@ -40,7 +38,7 @@
;;; let-keywords* ;;; let-keywords*
;;; lambda* ;;; lambda*
;;; define* ;;; define*
;;; define*-public ;;; define*-public
;;; defmacro* ;;; defmacro*
;;; defmacro*-public ;;; defmacro*-public
;;; ;;;
@ -49,17 +47,19 @@
;;; are used to indicate grouping only): ;;; are used to indicate grouping only):
;;; ;;;
;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]? ;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]? ;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
;;; [[#:rest identifier]|[. identifier]]? ;;; [[#:rest identifier]|[. identifier]]?
;;; ;;;
;;; ext-var-decl ::= identifier | ( identifier expression ) ;;; ext-var-decl ::= identifier | ( identifier expression )
;;; ;;;
;;; The characters `*', `+' and `?' are not to be taken literally; they ;;; The characters `*', `+' and `?' are not to be taken literally; they
;;; mean respectively, zero or more occurences, one or more occurences, ;;; mean respectively, zero or more occurences, one or more occurences,
;;; and one or zero occurences. ;;; and one or zero occurences.
;;; ;;;
;;; Code:
(define-module (ice-9 optargs))
;; bound? var ;; bound? var
;; Checks if a variable is bound in the current environment. ;; Checks if a variable is bound in the current environment.
@ -71,9 +71,9 @@
(defmacro-public bound? (var) (defmacro-public bound? (var)
`(catch 'misc-error `(catch 'misc-error
(lambda () (lambda ()
,var ,var
(not (eq? ,var ,(variable-ref (not (eq? ,var ,(variable-ref
(make-undefined-variable))))) (make-undefined-variable)))))
(lambda args #f))) (lambda args #f)))
@ -111,7 +111,7 @@
;; duplicates keyword args in the rest arg. More explanation of what ;; duplicates keyword args in the rest arg. More explanation of what
;; keyword arguments in a lambda list look like can be found below in ;; keyword arguments in a lambda list look like can be found below in
;; the documentation for lambda*. Bindings can have the same form as ;; the documentation for lambda*. Bindings can have the same form as
;; for let-optional. If allow-other-keys? is false, an error will be ;; 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 ;; thrown if anything that looks like a keyword argument but does not
;; match a known keyword parameter will result in an error. ;; match a known keyword parameter will result in an error.
;; ;;
@ -127,7 +127,7 @@
;; some utility procedures for implementing the various let-forms. ;; some utility procedures for implementing the various let-forms.
(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc) (define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
(let ((bindings (map (lambda (x) (let ((bindings (map (lambda (x)
(if (list? x) (if (list? x)
x x
(list x (variable-ref (list x (variable-ref
@ -139,8 +139,8 @@
(if (null? BINDINGS) (if (null? BINDINGS)
`(begin ,@BODY) `(begin ,@BODY)
(let-o-k-template REST-ARG BINDINGS BODY let-type (let-o-k-template REST-ARG BINDINGS BODY let-type
(lambda (optional) (lambda (optional)
`(,(car optional) `(,(car optional)
(cond (cond
((not (null? ,REST-ARG)) ((not (null? ,REST-ARG))
(let ((result (car ,REST-ARG))) (let ((result (car ,REST-ARG)))
@ -157,11 +157,11 @@
(bindfilter (lambda (key) (bindfilter (lambda (key)
`(,(car key) `(,(car key)
(cond (cond
((assq ',(car key) ,kb-list-gensym) ((assq ',(car key) ,kb-list-gensym)
=> cdr) => cdr)
(else (else
,(cadr key))))))) ,(cadr key)))))))
`(let* ((ra->kbl ,rest-arg->keyword-binding-list) `(let* ((ra->kbl ,rest-arg->keyword-binding-list)
(,kb-list-gensym (ra->kbl ,REST-ARG ',(map (,kb-list-gensym (ra->kbl ,REST-ARG ',(map
(lambda (x) (symbol->keyword (if (pair? x) (car x) x))) (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
BINDINGS) BINDINGS)
@ -186,7 +186,7 @@
(error "Keyword argument has no value.") (error "Keyword argument has no value.")
(next (cons (cons (keyword->symbol first) (next (cons (cons (keyword->symbol first)
(car rest)) accum)))) (car rest)) accum))))
((not allow-other-keys?) ((not allow-other-keys?)
(error "Unknown keyword in arguments.")) (error "Unknown keyword in arguments."))
(else (if (null? rest) (else (if (null? rest)
accum accum
@ -199,7 +199,7 @@
;; "#&optional" instead of "#:optional" ;; "#&optional" instead of "#:optional"
(read-hash-extend #\& (lambda (c port) (read-hash-extend #\& (lambda (c port)
(display (display
"WARNING: `#&' is deprecated, use `#:' instead\n" "WARNING: `#&' is deprecated, use `#:' instead\n"
(current-error-port)) (current-error-port))
(case (read port) (case (read port)
@ -212,7 +212,7 @@
;; lambda* args . body ;; lambda* args . body
;; lambda extended for optional and keyword arguments ;; lambda extended for optional and keyword arguments
;; ;;
;; lambda* creates a procedure that takes optional arguments. These ;; lambda* creates a procedure that takes optional arguments. These
;; are specified by putting them inside brackets at the end of the ;; are specified by putting them inside brackets at the end of the
;; paramater list, but before any dotted rest argument. For example, ;; paramater list, but before any dotted rest argument. For example,
@ -232,11 +232,11 @@
;; Optional and keyword arguments can also be given default 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 ;; 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: ;; two-item list in place of an optional argument, for example in:
;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz)) ;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
;; foo is a fixed argument, bar is an optional argument with default ;; foo is a fixed argument, bar is an optional argument with default
;; value 42, and baz is a keyword argument with default value 73. ;; value 42, and baz is a keyword argument with default value 73.
;; Default value expressions are not evaluated unless they are needed ;; Default value expressions are not evaluated unless they are needed
;; and until the procedure is called. ;; and until the procedure is called.
;; ;;
;; lambda* now supports two more special parameter list keywords. ;; lambda* now supports two more special parameter list keywords.
;; ;;
@ -259,7 +259,7 @@
(defmacro-public lambda* (ARGLIST . BODY) (defmacro-public lambda* (ARGLIST . BODY)
(parse-arglist (parse-arglist
ARGLIST ARGLIST
(lambda (non-optional-args optionals keys aok? rest-arg) (lambda (non-optional-args optionals keys aok? rest-arg)
; Check for syntax errors. ; Check for syntax errors.
@ -281,7 +281,7 @@
(string? (car BODY))) (string? (car BODY)))
(list (car BODY)) (list (car BODY))
'()) '())
(let-optional* (let-optional*
,rest-gensym ,rest-gensym
,optionals ,optionals
(let-keywords* ,rest-gensym (let-keywords* ,rest-gensym
@ -292,7 +292,7 @@
(error "Too many arguments."))) (error "Too many arguments.")))
'()) '())
,@BODY))) ,@BODY)))
`(lambda (,@non-optional-args . ,(if rest-arg rest-arg '())) `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
,@BODY)))))) ,@BODY))))))
@ -302,7 +302,7 @@
(every? pred (cdr lst))))) (every? pred (cdr lst)))))
(define (ext-decl? obj) (define (ext-decl? obj)
(or (symbol? obj) (or (symbol? obj)
(and (list? obj) (= 2 (length obj)) (symbol? (car obj))))) (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
(define (parse-arglist arglist cont) (define (parse-arglist arglist cont)
@ -311,9 +311,9 @@
((memq val lst) ((memq val lst)
=> (lambda (pos) => (lambda (pos)
(if (memq val (cdr pos)) (if (memq val (cdr pos))
(error (with-output-to-string (error (with-output-to-string
(lambda () (lambda ()
(map display `(,val (map display `(,val
" specified more than once in argument list."))))) " specified more than once in argument list.")))))
(cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t)))) (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
(else (cont lst '() #f)))) (else (cont lst '() #f))))
@ -325,25 +325,25 @@
(error "#:optional specified but no optional arguments declared.") (error "#:optional specified but no optional arguments declared.")
(cont before after keys aok? rest))))) (cont before after keys aok? rest)))))
(define (parse-keys arglist rest cont) (define (parse-keys arglist rest cont)
(split-list-at (split-list-at
#:allow-other-keys arglist #:allow-other-keys arglist
(lambda (aok-before aok-after aok-split?) (lambda (aok-before aok-after aok-split?)
(if (and aok-split? (not (null? aok-after))) (if (and aok-split? (not (null? aok-after)))
(error "#:allow-other-keys not at end of keyword argument declarations.") (error "#:allow-other-keys not at end of keyword argument declarations.")
(split-list-at (split-list-at
#:key aok-before #:key aok-before
(lambda (key-before key-after key-split?) (lambda (key-before key-after key-split?)
(cond (cond
((and aok-split? (not key-split?)) ((and aok-split? (not key-split?))
(error "#:allow-other-keys specified but no keyword arguments declared.")) (error "#:allow-other-keys specified but no keyword arguments declared."))
(key-split? (key-split?
(cond (cond
((null? key-after) (error "#:key specified but no keyword arguments declared.")) ((null? key-after) (error "#:key specified but no keyword arguments declared."))
((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments.")) ((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 key-before key-after aok-split? rest cont))))
(else (parse-opt-and-fixed arglist '() #f rest cont))))))))) (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
(define (parse-rest arglist cont) (define (parse-rest arglist cont)
(cond (cond
((null? arglist) (cont '() '() '() #f #f)) ((null? arglist) (cont '() '() '() #f #f))
((not (pair? arglist)) (cont '() '() '() #f arglist)) ((not (pair? arglist)) (cont '() '() '() #f arglist))
((not (list? arglist)) ((not (list? arglist))
@ -354,8 +354,8 @@
(if (memq #:rest copy) (if (memq #:rest copy)
(error "Cannot specify both #:rest and dotted rest argument.") (error "Cannot specify both #:rest and dotted rest argument.")
(parse-keys copy ra cont)))) (parse-keys copy ra cont))))
(else (split-list-at (else (split-list-at
#:rest arglist #:rest arglist
(lambda (before after split?) (lambda (before after split?)
(if split? (if split?
(case (length after) (case (length after)
@ -382,7 +382,7 @@
;; (define-public* ((foo #:optional bar) #:optional baz) '()) ;; (define-public* ((foo #:optional bar) #:optional baz) '())
;; This illustrates currying. A procedure foo is defined, which, ;; This illustrates currying. A procedure foo is defined, which,
;; when called with an optional argument bar, returns a procedure that ;; when called with an optional argument bar, returns a procedure that
;; takes an optional argument baz. ;; takes an optional argument baz.
;; ;;
;; Of course, define*[-public] also supports #:rest and #:allow-other-keys ;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
;; in the same way as lambda*. ;; in the same way as lambda*.
@ -414,7 +414,7 @@
;; defmacro* name args . body ;; defmacro* name args . body
;; defmacro*-public args . body ;; defmacro*-public args . body
;; defmacro and defmacro-public extended for optional and keyword arguments ;; defmacro and defmacro-public extended for optional and keyword arguments
;; ;;
;; These are just like defmacro and defmacro-public except that they ;; These are just like defmacro and defmacro-public except that they
;; take lambda*-style extended paramter lists, where #:optional, ;; take lambda*-style extended paramter lists, where #:optional,
;; #:key, #:allow-other-keys and #:rest are allowed with the usual ;; #:key, #:allow-other-keys and #:rest are allowed with the usual
@ -432,3 +432,5 @@
`(,DT ,NAME `(,DT ,NAME
(,(lambda (transformer) (defmacro:transformer transformer)) (,(lambda (transformer) (defmacro:transformer transformer))
(lambda* ,ARGLIST ,@BODY)))) (lambda* ,ARGLIST ,@BODY))))
;;; optargs.scm ends here