lac : 1f05982f72a0c9129e57d7f72650a950ad5ba11a
1: ;;; -*-Lisp-*-
2:
3: ;;; Rationale:
4: ;;;
5: ;;; The basic definitions, except where noted, are compatible with
6: ;;; LISP 1.5.
7: ;;; The evaluator itself is, though, different, and this shows in
8: ;;; the presence of LET and the absence of FUNCTION
9:
10: ;;;
11: ;;; Definitions
12: ;;;
13:
14: (define defmacro
15: (macro (name binds &rest body) `(define ,name (macro ,binds ,@body))))
16:
17: (defmacro defun (name binds &rest body)
18: `(define ,name (labels ,name , binds ,@body)))
19:
20: (defmacro setq (x v) `(set ',x ,v))
21:
22: (defun caar (x) (car (car x)))
23: (defun cadr (x) (car (cdr x)))
24: (defun cdar (x) (cdr (car x)))
25: (defun cddr (x) (cdr (cdr x)))
26: (defun caaar (x) (car (car (car x))))
27: (defun caadr (x) (car (car (cdr x))))
28: (defun cadar (x) (car (cdr (car x))))
29: (defun caddr (x) (car (cdr (cdr x))))
30: (defun cdaar (x) (cdr (car (car x))))
31: (defun cdadr (x) (cdr (car (cdr x))))
32: (defun cddar (x) (cdr (cdr (car x))))
33: (defun cdddr (x) (cdr (cdr (cdr x))))
34:
35: (defmacro let (binds &rest body)
36: `((lambda ,(mapcar car binds) ,@body)
37: ,@(mapcar cadr binds)))
38:
39: ;;;
40: ;;; Logical Connectives
41: ;;;
42:
43: (defun not (x)
44: (cond (x NIL) (T)))
45:
46: (defmacro or (&rest y)
47: (cond
48: (y `(cond (,(car y)) ((or ,@(cdr y)))))
49: (T 'NIL)))
50:
51: (defmacro and (&rest y)
52: (cond
53: (y `(cond (,(car y) (and ,@(cdr y)))))
54: (T 'T)))
55:
56:
57: ;;;
58: ;;; Elementary Functions
59: ;;;
60:
61: ;; car implicit
62: ;; cdr implicit
63: ;; cons implicit
64:
65: (defun atom (x) (cond ((consp x) NIL)(T T)))
66:
67: ;; eq implicit
68:
69: (defun equal (x y)
70: (cond
71: ((atom x) (cond ((atom y) (atom-equal x y))))
72: ((consp x)(cond ((consp y) (cond ((equal (car x) (car y))
73: (equal (cdr x) (cdr y)))))))))
74:
75: (defun list (&rest y) y)
76:
77: (defun null (x) (eq x NIL))
78:
79: (defun listp (x) (or (null x) (consp x)))
80:
81: ;; rplaca implicit
82: ;; rplacd implicit
83:
84: ;;;
85: ;;; List Handling Functions
86: ;;;
87:
88: ;;; N.B.: LISP 1.5 seem to support only two arguments
89: (defun append (&rest y)
90: (cond
91: ((null y) NIL)
92: ((null (caar y)) (apply append (cdr y)))
93: (t (cons (caar y)
94: (apply append (cons (cdar y) (cdr y)))))))
95:
96: (defun assoc (x a)
97: (cond
98: ((null a) NIL)
99: ((equal (caar a) x) (car a))
100: (t (assoc x (cdr a)))))
101:
102: (defun assq (x a)
103: (cond
104: ((null a) NIL)
105: ((eq (caar a) x) (car a))
106: (t (assq x (cdr a)))))
107:
108: ;; differ from clisp: (nconc 'X) error here.
109: (defun nconc (x y)
110: (cond ((null x) y)
111: (T (let ((f (labels f (z)
112: (cond ((cdr z) (f (cdr z)))
113: (T (rplacd z y))))))
114: (f x))
115: x)))
116:
117: (defmacro conc (&rest y)
118: (cond
119: ((null y) 'NIL)
120: (T `(nconc ,(car y) (conc ,@(cdr y))))))
121:
122: (defun copy (x)
123: (cond
124: ((null x) NIL)
125: ((atom x) x)
126: (T (cons (copy (car x)) (copy (cdr x))))))
127:
128: (defun reverse (l)
129: (let ((r) (f (labels f (u v)
130: (cond (u (f (cdr u) (cons (car u) v)))
131: (T v)))))
132: (f l NIL)))
133:
134: (defun member (x l)
135: (cond
136: ((null l) NIL)
137: ((equal x (car l)) T)
138: (T (member x (cdr l)))))
139:
140: (defun member (el lst)
141: (if (null lst)
142: NIL
143: (or (eq (car lst) el) (member el (cdr lst)))))
144:
145: (defun length (lst)
146: (cond
147: ((null lst) 0)
148: (T (+ 1 (length (cdr lst))))))
149:
150: (defun efface (x l)
151: (cond
152: ((null l) NIL)
153: ((equal x (car l)) (cdr l))
154: (T (rplacd l (efface x (cdr l))))))
155:
156: (defun subst (x y z)
157: (cond
158: ((equal y z) x)
159: ((atom z) z)
160: (t (cons (subst x y (car z))
161: (subst x y (cdr z))))))
162:
163: ;;;
164: ;;; Functionals
165: ;;; N.B.: Original LISP 1.5 (not MACLISP and subsequents) had the functional
166: ;;; argument as last parameter.
167: ;;;
168:
169: (defun maplist (f x)
170: (cond
171: ((null x) NIL)
172: (T (cons (f x) (maplist (cdr x) f)))))
173:
174: (defun mapcon (f x)
175: (cond
176: ((null x) NIL)
177: (T (nconc (f x) (maplist (cdr x) f)))))
178:
179: (defun map (f x)
180: (cond
181: ((null x) NIL)
182: (T (maplist (cdr x) f)))
183: NIL)
184:
185: ;; mapcar is embedded, for historical reasons
186:
187: (defun search (x p f u)
188: (cond
189: ((null x) (u x))
190: ((p x) (f x))
191: (t (search (cdr x) p f u))))
192:
193:
194: ;;;
195: ;;; Arithmetic Functions
196: ;;; N.B.: These should work both for fixnums and floats
197: ;;;
198:
199: (defun lessp (x y) (< x y))
200: (defun greaterp (x y) (> x y))
201: (defun zerop (x) (eq x 0))
202: (defun onep (x) (eq x 1))
203: (defun minusp (x) (< x 0))
204: (defun numberp (x) (integerp x))
205: ;; fixp is integerp
206:
207: (defun plus (&rest x)
208: (cond
209: ((null x) 0)
210: (t (+ (car x) (apply plus (cdr x))))))
211:
212: (defun difference (x y) (- x y))
213:
214: (defun minus (x) -x)
215:
216: (defun times (&rest x)
217: (cond
218: ((null x) 1)
219: (t (* (car x) (apply times (cdr x))))))
220:
221: (defun add1 (x) (+ x 1))
222:
223: (defun sub1 (x) (- x 1))
224:
225: (defun max (x &rest y)
226: (cond
227: ((null y) x)
228: ((<= x (car y)) (apply max y))
229: (t (apply max (cons x (cdr y))))))
230:
231: (defun min (x &rest y)
232: (cond
233: ((null y) x)
234: ((>= x (car y)) (apply min y))
235: (t (apply min (cons x (cdr y))))))
236:
237: (defun quotient (x y) (/ x y))
238: (defun remainder (x y) (% x y))
239: (defun divide (x y) (list (quotient x y) (remainder x y)))
240:
241: (defun expt (x y)
242: (cond
243: ((zerop y) 1)
244: (t (* x (expt x (sub1 y))))))
245:
246:
247: ;;;
248: ;;; Misc
249: ;;; Mostly from Common Lisp
250: ;;;
251:
252: (defun first (l) (car l))
253: (defun second (l) (first (cdr l)))
254: (defun third (l) (second (cdr l)))
255: (defun fourth (l) (third (cdr l)))
256: (defun fifth (l) (fourth (cdr l)))
257: (defun sixth (l) (fifth (cdr l)))
258: (defun seventh (l) (sixth (cdr l)))
259: (defun eighth (l) (seventh (cdr l)))
260: (defun ninth (l) (eighth (cdr l)))
261: (defun tenth (l) (ninth (cdr l)))
262: (defun last (x) (cond ((null (cdr x)) x) (t (last (cdr x)))))
263:
264: (defmacro if (test true false)
265: `(cond (,test ,true) (t ,false)))
266:
267: (defun remove-if (test lst)
268: (if (null lst)
269: NIL
270: (if (test (car lst))
271: (remove-if test (cdr lst))
272: (cons (car lst) (remove-if test (cdr lst))))))
273:
274: (defun remove-if-not (test lst)
275: (remove-if (lambda (x) (not (test x))) lst))
276:
277: (defmacro push (x place)
278: (list 'set (list 'quote place) (list 'cons x place)))
279:
280: (defun nthcdr (n l)
281: (cond ((eq n 0) l)
282: (t (nthcdr (- n 1) (cdr l)))))
283: (defun nth (n l)
284: (car (nthcdr n l)))
285:
286: (defun 1+ (x) (+ 1 x))
287: (defun 1- (x) (- x 1))
288: (defun evenp (x) (eq (% x 2) 0))
289: (defun oddp (x) (eq (% x 2) 1))
290: (defmacro incf (x) `(setq ,x (1+ ,x)))
291: (defmacro decf (x) `(setq ,x (1- ,x)))
292:
Generated by git2html.