;;; Generated from an LP program; edit the fragment sources.
;;; Execution order follows the declared program.

;;; mce-primitives — lp-0007.plant:145
(define (initial-environment)
       (let ((bindings (list (cons '+ +) (cons '- -) (cons '* *) (cons '= =)
                             (cons '< <) (cons 'cons cons) (cons 'car car)
                             (cons 'cdr cdr) (cons 'null? null?) (cons 'list list)
                             (cons 'cadr cadr) (cons 'caddr caddr) (cons 'cddr cddr)
                             (cons 'caar caar) (cons 'length length) (cons '>= >=)
                             (cons 'number? number?) (cons 'boolean? boolean?)
                             (cons 'string? string?) (cons 'symbol? symbol?)
                             (cons 'pair? pair?) (cons 'list? list?) (cons 'not not)
                             (cons 'eq? eq?) (cons 'equal? equal?) (cons 'memq memq)
                             (cons 'vector vector) (cons 'vector? vector?)
                             (cons 'vector-ref vector-ref) (cons 'vector-set! vector-set!)
                             (cons 'assq assq) (cons 'set-cdr! set-cdr!) (cons 'throw throw)
                             (cons 'map 'map) (cons 'apply 'apply))))
         (extend-environment (map car bindings)
           (map (lambda (binding) (vector 'primitive (cdr binding))) bindings) '())))

;;; mce-env — lp-0008.plant:51
(define (extend-environment names values outer)
       (unless (= (length names) (length values)) (throw 'mce-arity names values))
       (cons (vector (map cons names values)) outer))

(define (lookup name environment)
       (if (null? environment) (throw 'mce-unbound name)
           (let ((binding (assq name (vector-ref (car environment) 0))))
             (if binding (cdr binding) (lookup name (cdr environment))))))

(define (define-value! name value environment)
       (let* ((frame (car environment)) (binding (assq name (vector-ref frame 0))))
         (if binding (set-cdr! binding value)
             (vector-set! frame 0 (cons (cons name value) (vector-ref frame 0))))))

;;; mce-apply — lp-0008.plant:19
(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)))))

;;; mce-eval — lp-0007.plant:29
(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)))))

;;; mce-entry — lp-0007.plant:22
(define (run expressions)
       ;; 每次用户程序运行都有自己的初始环境。
       (evaluate-sequence expressions (initial-environment)))