Permalink
Cannot retrieve contributors at this time
Name already in use
A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
ZickStandardLisp/lisp.lsp
Go to fileThis commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
108 lines (91 sloc)
4.23 KB
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;;; A Lisp evaluator in Lisp. | |
;;; | |
;;; It consists of QUOTE, IF, LAMBDA, DEFUN, SETQ, CAR, CDR, CONS, EQ, ATOM, +, | |
;;; *, -, /, and MOD. It provides them all, so it can run itself recursively. | |
;;; This program is for both Zick's Lisp and Common Lisp. | |
((lambda (ge) | |
;; HACK: Common Lisp treats this as (setq) but my implementations treat #+nil | |
;; as just a symbol so it defines funcall. Please modify this line if you | |
;; want to run this evaluator with itself recursively in Common Lisp. CL's | |
;; reader skips the defun of funcall but it's necessary for this evaluator. | |
(setq #+nil (defun funcall (f x) (f x))) | |
;; Makes mutable cons using lambda. | |
;; Example: | |
;; (setq x (mcon% 1 2)) | |
;; (x 'car) ;=> 1 | |
;; (x 'cdr) ;=> 2 | |
;; (x (cons 'cdr 99)) ;=> 99 (mutation) | |
;; (x 'cdr) ;=> 99 | |
(defun mcon% (a d) | |
(lambda (c) (if (eq c 'car) a | |
(if (eq c 'cdr) d | |
(if (eq (car c) 'car) (setq a (cdr c)) | |
(if (eq (car c) 'cdr) (setq d (cdr c)))))))) | |
;; Initialize the global environment. An environment consists of a list of | |
;; alist. | |
(setq ge (mcon% (mcon% (mcon% 't 't) ()) ())) | |
(defun cadr% (x) (car (cdr x))) | |
(defun cddr% (x) (cdr (cdr x))) | |
;; assoc for mutable cons. | |
(defun assoc% (k l) | |
(if l (if (eq k (funcall (funcall l 'car) 'car)) (funcall l 'car) | |
(assoc% k (funcall l 'cdr))) ())) | |
;; Finds a variable from environment. | |
(defun fv% (k a) (if a ((lambda (r) (if r r (fv% k (funcall a 'cdr)))) | |
(assoc% k (funcall a 'car))) ())) | |
;; Evaluates an atom. It returns the corresponding value when the given | |
;; environment has a bind. Otherwise returns the given atom itself. | |
(defun ea% (e a) ((lambda (b) (if b (funcall b 'cdr) e)) (fv% e a))) | |
;; Makes an EXPR from lambda or defun. | |
(defun el% (e a) (cons '%e% (cons (car e) (cons (cdr e) a)))) | |
;; Adds a bind to the global environment. | |
(defun ae% (s v) (funcall ge | |
(cons 'car | |
(mcon% (mcon% s v) | |
(funcall ge 'car)))) s) | |
(defun eval% (e a) | |
(if (atom e) (ea% e a) | |
(if (eq (car e) 'quote) (cadr% e) | |
(if (eq (car e) 'if) | |
(if (eval% (cadr% e) a) | |
(eval% (cadr% (cdr e)) a) (eval% (cadr% (cddr% e)) a)) | |
(if (eq (car e) 'lambda) (el% (cdr e) a) | |
(if (eq (car e) 'defun) | |
(ae% (cadr% e) (el% (cddr% e) a)) | |
(if (eq (car e) 'setq) | |
((lambda (b v) | |
(if b (funcall b (cons 'cdr v)) | |
(ae% (cadr% e) v)) | |
v) | |
(fv% (cadr% e) a) (eval% (cadr% (cdr e)) a)) | |
(apply% (eval% (car e) a) | |
(evlis% (cdr e) a))))))))) | |
(defun pairlis% (x y) | |
(if x (if y (mcon% (mcon% (car x) (car y)) | |
(pairlis% (cdr x) (cdr y))) ()) ())) | |
(defun evlis% (l a) (if l (cons (eval% (car l) a) (evlis% (cdr l) a)) ())) | |
(defun progn% (l a r) (if l (progn% (cdr l) a (eval% (car l) a)) r)) | |
(defun apply% (f a) | |
(if (eq (car f) '%e%) | |
(progn% (cadr% (cdr f)) | |
(mcon% (pairlis% (cadr% f) a) (cddr% (cdr f))) ()) | |
(if (eq (car f) '%s%) | |
(funcall (cdr f) a) | |
f))) | |
;; Makes SUBR and EXPR more readable. | |
(defun es% (e) | |
(if (atom e) e | |
(if (eq (car e) '%s%) '<subr> (if (eq (car e) '%e%) '<expr> e)))) | |
(defun eval%% (e) (es% (eval% e ge))) | |
(ae% 'car (cons '%s% (lambda(x)(car(car x))))) | |
(ae% 'cdr (cons '%s% (lambda(x)(cdr(car x))))) | |
(ae% 'cons (cons '%s% (lambda(x)(cons(car x)(cadr% x))))) | |
(ae% 'eq (cons '%s% (lambda(x)(eq(car x)(cadr% x))))) | |
(ae% 'atom (cons '%s% (lambda(x)(atom(car x))))) | |
(ae% '+ (cons '%s% (lambda(x)(+(car x)(cadr% x))))) | |
(ae% '* (cons '%s% (lambda(x)(*(car x)(cadr% x))))) | |
(ae% '- (cons '%s% (lambda(x)(-(car x)(cadr% x))))) | |
(ae% '/ (cons '%s% (lambda(x)(*(car x)(cadr% x))))) | |
(ae% 'mod (cons '%s% (lambda(x)(mod(car x)(cadr% x))))) | |
(eval%% 'WRITE_HERE)) | |
()) |