program. Scheme 求值器 evaluate 与特殊形式[mce-eval]

Defines: (syntax-check evaluate-sequence evaluate-arguments evaluate valid-bindings? expand-let expand-let-star evaluate-cond evaluate-and evaluate-or every-symbol? unique-symbols?)

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

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

Requires: lookup, define-value!, apply-value

(define (syntax-check condition expression)
       (unless condition (throw 'mce-syntax expression)))

(define (evaluate-sequence expressions environment)
       (syntax-check (and (list? expressions) (pair? expressions)) expressions)
       (let loop ((remaining expressions))
         (let ((value (evaluate (car remaining) environment)))
           (if (null? (cdr remaining)) value (loop (cdr remaining))))))

(define (evaluate-arguments expressions environment)
       (if (null? expressions) '()
           ;; 不依赖宿主的参数求值顺序。
           (let ((value (evaluate (car expressions) environment)))
             (cons value (evaluate-arguments (cdr expressions) environment)))))

(define (evaluate expression environment)
       (cond
         ((or (number? expression) (boolean? expression) (string? expression)) expression)
         ((symbol? expression) (lookup expression environment))
         ((not (and (list? expression) (pair? expression)))
          (throw 'mce-syntax expression))
         (else
          (let ((head (car expression)) (arguments (cdr expression)))
            (cond
              ((eq? head 'quote)
               (syntax-check (= (length arguments) 1) expression)
               (car arguments))
              ((eq? head 'if)
               (syntax-check (= (length arguments) 3) expression)
               (evaluate (if (eq? (evaluate (car arguments) environment) #f)
                             (caddr arguments) (cadr arguments)) environment))
              ((eq? head 'lambda)
               (syntax-check (and (>= (length arguments) 2)
                                  (list? (car arguments))
                                  (every-symbol? (car arguments))
                                  (unique-symbols? (car arguments))) expression)
               (vector 'closure (car arguments) (cdr arguments) environment))
              ((eq? head 'begin) (evaluate-sequence arguments environment))
              ((eq? head 'let) (evaluate (expand-let arguments) environment))
              ((eq? head 'let*)
               (syntax-check (and (>= (length arguments) 2)
                                  (valid-bindings? (car arguments))) expression)
               (evaluate (expand-let-star (car arguments) (cdr arguments)) environment))
              ((eq? head 'cond) (evaluate-cond arguments environment))
              ((eq? head 'and) (evaluate-and arguments environment))
              ((eq? head 'or) (evaluate-or arguments environment))
              ((or (eq? head 'unless) (eq? head 'when))
               (syntax-check (>= (length arguments) 2) expression)
               (let ((truth (not (eq? (evaluate (car arguments) environment) #f))))
                 (if (eq? truth (eq? head 'when))
                     (evaluate-sequence (cdr arguments) environment) #f)))
              ((eq? head 'define)
               (syntax-check (>= (length arguments) 2) expression)
               (let ((target (car arguments)))
                 (cond
                   ((symbol? target)
                    (syntax-check (= (length arguments) 2) expression)
                    (define-value! target (evaluate (cadr arguments) environment) environment)
                    target)
                   ((and (pair? target) (symbol? (car target)))
                    (define-value! (car target)
                      (evaluate (cons 'lambda (cons (cdr target) (cdr arguments))) environment)
                      environment)
                    (car target))
                   (else (throw 'mce-syntax expression)))))
              (else
               (let ((procedure (evaluate head environment)))
                 (apply-value procedure (evaluate-arguments arguments environment)))))))))

(define (valid-bindings? bindings)
       (and (list? bindings)
            (let loop ((remaining bindings))
              (or (null? remaining)
                  (and (list? (car remaining)) (= (length (car remaining)) 2)
                       (symbol? (caar remaining)) (loop (cdr remaining)))))))

(define (expand-let arguments)
       (syntax-check (>= (length arguments) 2) arguments)
       (let* ((named? (symbol? (car arguments)))
              (bindings (if named? (cadr arguments) (car arguments)))
              (body (if named? (cddr arguments) (cdr arguments))))
         (syntax-check (and (valid-bindings? bindings) (pair? body)
                            (unique-symbols? (map car bindings))) arguments)
         (let ((names (map car bindings)) (values (map cadr bindings)))
           (if named?
               (cons (list 'lambda names
                           (list 'define (car arguments) (cons 'lambda (cons names body)))
                           (cons (car arguments) names)) values)
               (cons (cons 'lambda (cons names body)) values)))))

(define (expand-let-star bindings body)
       (if (null? bindings) (cons 'begin body)
           (list 'let (list (car bindings)) (expand-let-star (cdr bindings) body))))

(define (evaluate-cond clauses environment)
       (if (null? clauses) #f
           (let ((clause (car clauses)))
             (syntax-check (and (list? clause) (pair? clause)) clause)
             (if (eq? (car clause) 'else)
                 (begin
                   (syntax-check (and (null? (cdr clauses)) (pair? (cdr clause))) clause)
                   (evaluate-sequence (cdr clause) environment))
                 (let ((value (evaluate (car clause) environment)))
                   (if (eq? value #f) (evaluate-cond (cdr clauses) environment)
                       (if (null? (cdr clause)) value
                           (evaluate-sequence (cdr clause) environment))))))))

(define (evaluate-and expressions environment)
       (if (null? expressions) #t
           (let ((value (evaluate (car expressions) environment)))
             (if (or (eq? value #f) (null? (cdr expressions))) value
                 (evaluate-and (cdr expressions) environment)))))

(define (evaluate-or expressions environment)
       (if (null? expressions) #f
           (let ((value (evaluate (car expressions) environment)))
             (if (eq? value #f) (evaluate-or (cdr expressions) environment) value))))

(define (every-symbol? xs)
       (or (null? xs) (and (symbol? (car xs)) (every-symbol? (cdr xs)))))

(define (unique-symbols? xs)
       (or (null? xs) (and (not (memq (car xs) (cdr xs))) (unique-symbols? (cdr xs)))))