Scheme闭包应用与map／apply原语[#55]

Defines: (apply-value map-values all-lists? all-empty? any-empty?)

Assembled in Scheme 解释器的装配计划, Scheme求值与闭包应用模块

Outputs: metacircular.scm, lp-example/mce/engine.scm

Requires: evaluate-sequence, extend-environment

(define (apply-value procedure arguments)
       (cond
         ((and (vector? procedure) (eq? (vector-ref procedure 0) 'primitive))
          (let ((implementation (vector-ref procedure 1)))
            (cond ((eq? implementation 'map)
                   (map-values (car arguments) (cdr arguments)))
                  ((eq? implementation 'apply)
                   (unless (= (length arguments) 2) (throw 'mce-arity 'apply arguments))
                   (apply-value (car arguments) (cadr arguments)))
                  (else (apply implementation arguments)))))
         ((and (vector? procedure) (eq? (vector-ref procedure 0) 'closure))
          (evaluate-sequence (vector-ref procedure 2)
            (extend-environment (vector-ref procedure 1) arguments
                                (vector-ref procedure 3))))
         (else (throw 'mce-not-procedure procedure))))

(define (map-values procedure lists)
       (unless (and (pair? lists) (all-lists? lists)) (throw 'mce-arity 'map lists))
       (if (null? (car lists))
           (if (all-empty? lists) '() (throw 'mce-arity 'map lists))
           (begin
             (when (any-empty? lists) (throw 'mce-arity 'map lists))
             (let ((value (apply-value procedure (map car lists))))
               (cons value (map-values procedure (map cdr lists)))))))

(define (all-lists? xs)
       (or (null? xs) (and (list? (car xs)) (all-lists? (cdr xs)))))

(define (all-empty? xs)
       (or (null? xs) (and (null? (car xs)) (all-empty? (cdr xs)))))

(define (any-empty? xs)
       (and (pair? xs) (or (null? (car xs)) (any-empty? (cdr xs)))))