;; コピペしてpslispの /input_string(...) の...の箇所に貼り付けてください。 ;; 評価する内容を変えたいときは最後にある (universal 関数 引数) の箇所を書き換えてください。 (begin (define caar (lambda (x ) (car (car x ) ) ) ) (define cadr (lambda (x ) (car (cdr x ) ) ) ) (define cdar (lambda (x ) (cdr (car x ) ) ) ) (define caddr (lambda (x ) (car (cdr (cdr x ) ) ) ) ) (define cadar (lambda (x ) (car (cdr (car x ) ) ) ) ) (define universal (lambda (fn x ) (apply1 fn x nil ) ) ) (define apply1 (lambda (fn x a ) (cond ( (atom? fn ) (cond ( (eq? fn 'car ) (caar x ) ) ( (eq? fn 'cdr ) (cdar x ) ) ( (eq? fn 'cons ) (cons (car x ) (cadr x ) ) ) ( (eq? fn 'atom? ) (atom? (car x ) ) ) ( (eq? fn 'eq? ) (eq? (car x ) (cadr x ) ) ) ( (eq? fn 'null? ) (eq? (car x ) nil ) ) (t (apply1 (eval1 fn a ) x a ) ) ) ) ( (eq? (car fn ) 'lambda ) (eval1 (caddr fn ) (pairlis1 (cadr fn ) x a ) ) ) ( (eq? (car fn ) 'label ) (apply1 (cadr fn ) x (cons (cons (cadr fn ) (caddr fn ) ) a ) ) ) ( (eq? (car fn ) 'funarg ) (apply1 (cadr fn ) x (caddr fn ) ) ) (t nil ) ) ) ) (define eval1 (lambda (e a ) (cond ( (atom? e ) (cond ( (eq? e 't ) #t ) ( (eq? e 'nil ) nil ) (t (cdr (assoc1 e a ) ) ) ) ) ( (atom? (car e ) ) (cond ( (eq? (car e ) 'quote ) (cadr e ) ) ( (eq? (car e ) 'cond ) (evcon1 (cdr e ) a ) ) ( (eq? (car e ) 'function ) (cons 'funarg (cons (cadr e ) (cons a nil ) ) ) ) (t (apply1 (car e ) (evlis1 (cdr e ) a ) a ) ) ) ) (#t (apply1 (car e ) (evlis1 (cdr e ) a ) a ) ) ) ) ) (define pairlis1 (lambda (x y a ) (cond ( (null1 x ) a ) (t (cons (cons (car x ) (car y ) ) (pairlis1 (cdr x ) (cdr y ) a ) ) ) ) ) ) (define assoc1 (lambda (x a ) (cond ( (equal1 (caar a ) x ) (car a ) ) (t (assoc1 x (cdr a ) ) ) ) ) ) (define equal1 (lambda (x y ) (cond ( (atom? x ) (eq? x y ) ) ( (atom? y ) #f ) ( (equal1 (car x ) (car y ) ) (equal1 (cdr x ) (cdr y ) ) ) (#t #f ) ) ) ) (define evcon1 (lambda (c a ) (cond ( (eval1 (caar c ) a ) (eval1 (cadar c ) a ) ) (#t (evcon1 (cdr c ) a ) ) ) ) ) (define evlis1 (lambda (m a ) (cond ( (null1 m ) nil ) (#t (cons (eval1 (car m ) a ) (evlis1 (cdr m ) a ) ) ) ) ) ) (define null1 (lambda (x ) (eq? x nil ) ) ) ( universal ' (lambda (a b c ) (cons (cons (cons c nil ) b ) a ) ) ' (ada brainfuck common-lisp ) ) )