/[guile]/guile/guile-core/ice-9/optargs.scm
ViewVC logotype

Diff of /guile/guile-core/ice-9/optargs.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14.2.3 by mdj, Thu Oct 18 19:41:08 2001 UTC revision 1.14.2.4 by mvo, Thu Dec 12 19:58:42 2002 UTC
# Line 1  Line 1 
1  ;;;; optargs.scm -- support for optional arguments  ;;;; optargs.scm -- support for optional arguments
2  ;;;;  ;;;;
3  ;;;;    Copyright (C) 1997, 1998, 1999, 2001 Free Software Foundation, Inc.  ;;;;    Copyright (C) 1997, 1998, 1999, 2001, 2002 Free Software Foundation, Inc.
4  ;;;;  ;;;;
5  ;;;; This program is free software; you can redistribute it and/or modify  ;;;; 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  ;;;; it under the terms of the GNU General Public License as published by
# Line 326  Line 326 
326    (or (symbol? obj)    (or (symbol? obj)
327        (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))        (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
328    
329    ;; XXX - not tail recursive
330    (define (improper-list-copy obj)
331      (if (pair? obj)
332          (cons (car obj) (improper-list-copy (cdr obj)))
333          obj))
334    
335  (define (parse-arglist arglist cont)  (define (parse-arglist arglist cont)
336    (define (split-list-at val lst cont)    (define (split-list-at val lst cont)
337      (cond      (cond
# Line 368  Line 374 
374       ((null? arglist) (cont '() '() '() #f #f))       ((null? arglist) (cont '() '() '() #f #f))
375       ((not (pair? arglist)) (cont '() '() '() #f arglist))       ((not (pair? arglist)) (cont '() '() '() #f arglist))
376       ((not (list? arglist))       ((not (list? arglist))
377            (let* ((copy (list-copy arglist))        (let* ((copy (improper-list-copy arglist))
378                   (lp (last-pair copy))               (lp (last-pair copy))
379                   (ra (cdr lp)))               (ra (cdr lp)))
380              (set-cdr! lp '())          (set-cdr! lp '())
381              (if (memq #:rest copy)          (if (memq #:rest copy)
382                  (error "Cannot specify both #:rest and dotted rest argument.")              (error "Cannot specify both #:rest and dotted rest argument.")
383                  (parse-keys copy ra cont))))              (parse-keys copy ra cont))))
384       (else (split-list-at       (else (split-list-at
385              #:rest arglist              #:rest arglist
386              (lambda (before after split?)              (lambda (before after split?)

Legend:
Removed from v.1.14.2.3  
changed lines
  Added in v.1.14.2.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26