home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / lambdx.scm < prev    next >
Text File  |  2000-10-13  |  2KB  |  71 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: lambdx.scm,v 14.9 2000/10/14 00:56:20 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Alternative Components for Lambda
  23. ;;; package: ()
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (make-lambda* name required optional rest body)
  28.   (scan-defines
  29.    body
  30.    (lambda (auxiliary declarations body*)
  31.      (make-lambda name required optional rest auxiliary declarations body*))))
  32.  
  33. (define (lambda-components* *lambda receiver)
  34.   (lambda-components *lambda
  35.     (lambda (name required optional rest auxiliary declarations body)
  36.       (receiver name required optional rest
  37.         (make-open-block auxiliary declarations body)))))
  38.  
  39. (define (lambda-components** *lambda receiver)
  40.   (lambda-components* *lambda
  41.     (lambda (name required optional rest body)
  42.       (receiver (make-lambda-pattern name required optional rest)
  43.         (append required optional (if (false? rest) '() (list rest)))
  44.         body))))
  45.  
  46. (define-structure (lambda-pattern (conc-name lambda-pattern/))
  47.   (name false read-only true)
  48.   (required false read-only true)
  49.   (optional false read-only true)
  50.   (rest false read-only true))
  51.  
  52. (define (make-lambda** pattern bound body)
  53.  
  54.   (define (split pattern bound receiver)
  55.     (cond ((null? pattern)
  56.        (receiver '() bound))
  57.       (else
  58.        (split (cdr pattern) (cdr bound)
  59.          (lambda (copy tail)
  60.            (receiver (cons (car bound) copy)
  61.              tail))))))
  62.  
  63.   (split (lambda-pattern/required pattern) bound
  64.     (lambda (required tail)
  65.       (split (lambda-pattern/optional pattern) tail
  66.     (lambda (optional rest)
  67.       (make-lambda* (lambda-pattern/name pattern)
  68.             required
  69.             optional
  70.             (if (null? rest) #F (car rest))
  71.             body))))))