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 / apply.scm < prev    next >
Text File  |  1999-01-02  |  3KB  |  97 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: apply.scm,v 1.2 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1992, 1999 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. ;;;; Definition of APPLY
  23. ;;; package: (runtime apply)
  24.  
  25. (declare (usual-integrations apply))
  26.  
  27. ;;;  This is not a definition because APPLY is needed to boot,
  28. ;;;  so there is a binary (primitive) version of apply installed
  29. ;;;  at boot time, and this code replaces it.
  30.  
  31. (define (apply-2 f a0)
  32.   (define (fail)
  33.     (error "apply: Improper argument list" a0))
  34.  
  35.   (let-syntax ((apply-dispatch&bind
  36.         (macro (var clause . clauses)
  37.           (if (null? clauses)
  38.               (cadr clause)
  39.               (let walk ((lv var)
  40.                  (clause clause)
  41.                  (clauses clauses))
  42.             `(if (not (pair? ,lv))
  43.                  (if (null? ,lv)
  44.                  ,(cadr clause)
  45.                  (fail))
  46.                  ,(if (null? (cdr clauses))
  47.                   (cadr (car clauses))
  48.                   (let ((lv* (generate-uninterned-symbol))
  49.                     (av* (car clause)))
  50.                     `(let ((,lv* (cdr ,lv))
  51.                        (,av* (car ,lv)))
  52.                        ,(walk lv* (car clauses)
  53.                           (cdr clauses)))))))))))
  54.  
  55.     (apply-dispatch&bind a0
  56.              (v0 (f))
  57.              (v1 (f v0))
  58.              (v2 (f v0 v1))
  59.              (v3 (f v0 v1 v2))
  60.              (v4 (f v0 v1 v2 v3))
  61.              (v5 (f v0 v1 v2 v3 v4))
  62.              #|
  63.              (v6 (f v0 v1 v2 v3 v4 v5))
  64.              (v7 (f v0 v1 v2 v3 v4 v5 v6))
  65.              |#
  66.              (else
  67.               ((ucode-primitive apply) f a0)))))
  68.   
  69. (define (apply-entity-procedure self f . args)
  70.   ;; This is safe because args is a newly-consed list
  71.   ;; shared with no other code (modulo debugging).
  72.  
  73.   (define (splice! last next)
  74.     (if (null? (cdr next))
  75.     (set-cdr! last (car next))
  76.     (splice! next (cdr next))))
  77.  
  78.   self                    ; ignored
  79.   (apply-2 f
  80.        (cond ((null? args) '())
  81.          ((null? (cdr args))
  82.           (car args))
  83.          (else
  84.           (splice! args (cdr args))
  85.           args))))
  86.  
  87. (define (initialize-package!)
  88.   (set! apply
  89.     (make-entity
  90.      apply-entity-procedure
  91.      (vector (fixed-objects-item 'ARITY-DISPATCHER-TAG)
  92.          (lambda ()
  93.            (error "apply needs at least one argument"))
  94.          (lambda (f)
  95.            (f))
  96.          apply-2)))
  97.   unspecific)