Skip to content

Instantly share code, notes, and snippets.

@mietek
Forked from bitmappergit/lisp15.lisp
Created June 17, 2020 14:39
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save mietek/b97e0f5896327221c12bab415ad2aa9f to your computer and use it in GitHub Desktop.
Save mietek/b97e0f5896327221c12bab415ad2aa9f to your computer and use it in GitHub Desktop.
(defun lapply (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 'read) (read))
(t (lapply (leval fn a) x a))))
((eq (car fn) 'lambda) (leval (caddr fn) (pairlis (cadr fn) x a)))
((eq (car fn) 'label) (lapply (caddr fn) (cons (cons (cadr fn)
(caddr fn))
a)))))
(defun leval (e a)
(cond ((atom e) (cdr (assoc e a)))
((atom (car e)) (cond ((eq (car e) 'quote) (cadr e))
((eq (car e) 'cond) (levcon (cdr e) a))
(t (lapply (car e) (levlis (cdr e) a) a))))
(t (lapply (car e) (levlis (cdr e) a) a))))
(defun levcon (c a)
(cond ((leval (caar c) a) (leval (cadar c) a))
(t (levcon (cdr c) a))))
(defun levlis (m a)
(cond ((null m) nil)
(t (cons (leval (car m) a)
(levlis (cdr m) a)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment