Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
58 lines (53 sloc) 1.71 KB
(define-condition invalid-arguments ()()
(:report (lambda (condition stream)
(princ "Not enough arguments to apply current combinator" stream))))
(define-condition invalid-combinator ()()
(:report (lambda (condition stream)
(princ "Trying to execute invalid combinator." stream))))
(defun ski-step (program)
(cond
((eq (car program) :I)
(or (cdr program) (error 'invalid-arguments)))
((eq (car program) :K)
(if (> (length program) 2)
(cons (cadr program)
(cdddr program))
(error 'invalid-arguments)))
((eq (car program) :S)
(if (> (length program) 3)
(cons (cadr program)
(cons (cadddr program)
(cons (list (caddr program)
(cadddr program))
(cddddr program))))
(error 'invalid-arguments)))
(t (error 'invalid-combinator))))
(defun print-program (program)
(princ program))
(defun ski-eval (program)
(handler-case
(cond
((null program) program)
((listp (car program))
(ski-eval (cons (ski-step (car program))
(cdr program))))
(t (ski-eval (ski-step program))))
(invalid-arguments () program)))
(defun test-case (tcase)
(let ((result (ski-eval (car tcase)))
(expected (cadr tcase)))
(unless (equal result expected)
(fresh-line) (princ "========================================")
(fresh-line) (princ "Execution of program: ") (print-program (car tcase))
(fresh-line) (princ "gave: ") (print-program result)
(fresh-line) (princ "instead of: ") (print-program expected) (fresh-line))))
(defun test ()
(let ((tests
'(((:I) (:I))
((:I :I) (:I))
((:K) (:K))
((:K :K) (:K :K))
((:K :K :I) (:K))
((:K :I :K) (:I))
((:K :I :K :I) (:I)))))
(map nil #'test-case tests)))