![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to machacks.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to machacks.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-machacks-
2: "$Header: machacks.l 1.5 83/07/05 00:04:09 jkf Exp $")
3:
4: ;; (c) copywrite 1982, University of California, Berkeley
5: ;; (c) copywrite 1982, Massachusetts Insititute of Technology
6:
7: ;; This file was originally written at the University of California,
8: ;; Berkeley. Some portions were modified and additions made were made at
9: ;; MIT.
10:
11: ;; machacks - maclisp compatibility package.
12: ;; when this file is fasl'ed into a lisp, it will change the syntax to
13: ;; maclisp's syntax and will define functions know to the standard maclisp.
14: ;; it is also used to bootstrap vaxima compilation.
15: ;
16: ; this file will be fasled whenever the -m switch is set for compilation.
17: ;
18:
19: (declare (macros t))
20:
21: (def coutput
22: (lambda (msg)
23: (print msg) ; should go to unfasl port
24: (terpr)))
25:
26: ;--- displace
27: ; this is useful after a macro has been expanded and you want to save the
28: ; interpreter the trouble of expanding the macro again.
29: ; [this is really only useful for interpretation]
30: (defun displace (old-form new-form)
31: (cond ((atom old-form)
32: (error '|not able to displace this form| old-form))
33: ((atom new-form)
34: (rplaca old-form 'progn)
35: (rplacd old-form (list new-form)))
36: (t (rplaca old-form (car new-form))
37: (rplacd old-form (cdr new-form)))))
38:
39:
40:
41: ;--- fboundp :: check if a symbol has a function binding
42: ;
43: (defmacro fboundp (form &protect (form)) `(and (symbolp ,form) (getd ,form)))
44:
45:
46:
47:
48: (defmacro list* (&rest forms)
49: (cond ((null forms) nil)
50: ((null (cdr forms)) (car forms))
51: (t (construct-list* forms))))
52:
53: (eval-when (load compile eval)
54: (defun construct-list* (forms)
55: (setq forms (reverse forms))
56: (do ((forms (cddr forms) (cdr forms))
57: (return-form `(cons ,(cadr forms) ,(car forms))
58: `(cons ,(car forms) ,return-form)))
59: ((null forms) return-form))))
60:
61: (defmacro ttf (&rest l) `(list* . , l))
62:
63:
64: ;; lexpr-funcall is a cross between apply and funcall. the last arguments
65: ;; is a list of the rest of the arguments
66: ;; this is now in Franz Opus 38.35
67: ;; (defmacro lexpr-funcall (func &rest args)
68: ;; `(apply ,func (list* ,@args)))
69:
70: ; contents of the file libmax;macros all of these functions are
71: ; (by default) in maclisp
72: ;; (if x p q1 q2 ...) --> (cond (x p) (t q1 q2 ...))
73: ;; it is important that (if nil <form>) returns nil as macsyma code depends
74: ;; upon this in places. see also ifn in libmax;maxmac.
75: ; in Franz Lisp, opus 38.36 and on
76: ;(defmacro if (predicate then &rest else)
77: ; (cond ((null else) `(cond (,predicate ,then)))
78: ; (t `(cond (,predicate ,then) (t . ,else)))))
79:
80: ;; let, let*, list* are now a part of multics lisp. nobody should miss
81: ;; the code commented out below.
82: ;; (let ((a 3) (b) c) stuff) --> ((lambda (a b c) stuff) 3 nil nil)
83: ;; (let* ((a 3) (b 4)) stuff) --> ((lambda (a) ((lambda (b) stuff) 4)) 3)
84:
85: ;; (push x s) --> (setq s (cons x s))
86: ; in franz
87: ;(defmacro push (object list) `(setf ,list (cons ,object ,list)))
88:
89: ;; (pop s) --> (prog1 (car s) (setf s (cdr s)))
90: ;; (pop s v) --> (prog1 (setf v (car s)) (setf s (cdr s)))
91: ;; this relies on the fact that setf returns the value stored.
92:
93: ;(defmacro pop (list &optional (into nil into-p))
94: ; (cond (into-p `(prog1 (setf ,into (car ,list))
95: ; (setf ,list (cdr ,list))))
96: ; (t `(prog1 (car ,list)
97: ; (setf ,list (cdr ,list))))))
98:
99: ;; (for i m n . body) will evaluate body with i bound to m,m+1,...,n-1
100: ;; sequentially. (for i 0 n . body) --> (dotimes (i n) . body)
101:
102: (defmacro for (var start stop . body)
103: `(do ,var ,start (1+ ,var) (= ,var ,stop) ,@body))
104:
105: ; these were grabbed from lspsrc;umlmac.5
106: (defmacro when (p . c) `(cond (,p . ,c)))
107: (defmacro unless (p . c) `(cond ((not ,p) . ,c)))
108:
109:
110: (defmacro if-for-maclisp-else-lispm (&rest ll) (car ll))
111:
112: (defmacro logand (&rest forms) `(boole 1 . ,forms))
113: (defmacro logior (&rest forms) `(boole 7 . ,forms))
114: (defmacro logxor (&rest forms) `(boole 6 . ,forms))
115: (defmacro lognot (n) `(boole 10. ,n -1))
116: (defmacro bit-test (&rest forms) `(not (zerop (boole 1 . ,forms))))
117: (defmacro bit-set (x y) `(boole 7 ,x ,y))
118: (defmacro bit-clear (x y) `(boole 2 ,x ,y))
119:
120: ;; (<= a b) --> (not (> a b))
121: ;; (<= a b c) --> (not (or (> a b) (> b c)))
122: ;; funny arglist to check for correct number of arguments.
123:
124: (defmacro <= (arg1 arg2 &rest rest &aux result)
125: (setq rest (list* arg1 arg2 rest))
126: (do l rest (cdr l) (null (cdr l))
127: (push `(> ,(car l) ,(cadr l)) result))
128: (cond ((null (cdr result)) `(not ,(car result)))
129: (t `(not (or . ,(nreverse result))))))
130:
131: ;; (>= a b) --> (not (< a b))
132: ;; (>= a b c) --> (not (or (< a b) (< b c)))
133: ;; funny arglist to check for correct number of arguments.
134:
135: (defmacro >= (arg1 arg2 &rest rest &aux result)
136: (setq rest (list* arg1 arg2 rest))
137: (do l rest (cdr l) (null (cdr l))
138: (push `(< ,(car l) ,(cadr l)) result))
139: (cond ((null (cdr result)) `(not ,(car result)))
140: (t `(not (or . ,(nreverse result))))))
141:
142:
143:
144: (defmacro psetq (var value . rest)
145: (cond (rest `(setq ,var (prog1 ,value (psetq . ,rest))))
146: (t `(setq ,var ,value))))
147:
148:
149: ;; (dotimes (i n) body) evaluates body n times, with i bound to 0, 1, ..., n-1.
150: ;; (dolist (x l) body) successively binds x to the elements of l, and evaluates
151: ;; body each time.
152:
153: ;; things to beware of:
154: ;; [1] this won't work for count being a bignum.
155: ;; [2] if count is a symbol, somebody could clobber its value inside the body.
156: ;; [3] somebody inside of body could reference **count**.
157:
158: (defmacro dotimes ((var count) . body)
159: (if (or (fixp count) (symbolp count))
160: `(do ((,var 0 (1+ ,var)))
161: ((>= ,var ,count))
162: (declare (fixnum ,var))
163: . ,body)
164: `(do ((,var 0 (1+ ,var))
165: (**count** ,count))
166: ((>= ,var **count**))
167: (declare (fixnum ,var **count**))
168: . ,body)))
169:
170: (defmacro dolist ((var list) . body)
171: `(do ((**list** ,list (cdr **list**))
172: (,var))
173: ((null **list**))
174: (setq ,var (car **list**))
175: . ,body))
176:
177:
178: ;; symbolconc is the same as concat in franz
179: ;
180: (defmacro symbolconc (&rest args) `(concat ,@args))
181:
182:
183: ;-- these functions are from /usr/lib/lisp/lmhacks on the mit-vax
184:
185: ;; This file contains miscellaneous functions and macros that
186: ;; ZetaLisp users often find useful
187:
188: (declare (macros t))
189:
190: (defmacro macro (name argl &body body)
191: `(def ,name (macro ,argl ,@body)))
192:
193: (defun gcd (a b)
194: (or (plusp a)
195: (setq a (minus a)))
196: (or (plusp b)
197: (setq b (minus b)))
198: (do ((a a b)
199: (b b (remainder a b)))
200: ((zerop b)
201: a)))
202:
203: (defmacro first (a) `(car ,a))
204: (defmacro second (a) `(cadr ,a))
205: (defmacro third (a) `(caddr ,a))
206: (defmacro fourth (a) `(cadddr ,a))
207: (defmacro fifth (a) `(car (cddddr ,a)))
208: (defmacro sixth (a) `(cadr (cddddr ,a)))
209: (defmacro seventh (a) `(caddr (cddddr ,a)))
210:
211: (defmacro rest1 (list) `(cdr ,list))
212: (defmacro rest2 (list) `(cddr ,list))
213: (defmacro rest3 (list) `(cdddr ,list))
214: (defmacro rest4 (list) `(cddddr ,list))
215:
216: (defmacro copylist (list) `(append ,list nil))
217: (defmacro copytree (list) `(subst nil nil ,list))
218:
219: (defun circular-list (&rest elements)
220: (setq elements (copylist elements))
221: (rplacd (last elements) elements)
222: elements)
223:
224: (defun butlast (x)
225: (cond ((null (cdr x)) nil)
226: (t (cons (car x) (butlast (cdr x))))))
227:
228: (defun find-position-in-list (item list)
229: (do ((i 0 (1+ i)))
230: ((null list) nil)
231: (if (eq (car list) item)
232: (return i)
233: (setq list (cdr list)))))
234:
235: (defun find-postion-in-list-equal (item list)
236: (do ((i 0 (1+ i)))
237: ((null list) nil)
238: (if (equal (car list) item)
239: (return i)
240: (setq list (cdr list)))))
241:
242: (defun mem (pred item list)
243: (do ()
244: ((null list) nil)
245: (if (funcall pred item (car list))
246: (return list))
247: (setq list (cdr list))))
248:
249:
250:
251: ;--- remq is in common2.l
252:
253:
254:
255: (defun rem (pred item list &optional (cnt -1))
256: (let ((head '())
257: (tail nil))
258: (do ((l list (cdr l))
259: (newcell))
260: ((null l) head)
261: (cond ((or (funcall pred (car l) item)
262: (zerop cnt))
263: (setq newcell (list (car l)))
264: (cond ((null head) (setq head newcell))
265: (t (rplacd tail newcell)))
266: (setq tail newcell))
267: (t (setq cnt (1- cnt)))))))
268:
269: (defun rem-if (pred list)
270: (let ((head '())
271: (tail nil))
272: (do ((l list (cdr l))
273: (newcell))
274: ((null l) head)
275: (cond ((not (funcall pred (car l)))
276: (setq newcell (list (car l)))
277: (cond ((null head) (setq head newcell))
278: (t (rplacd tail newcell)))
279: (setq tail newcell))))))
280:
281: (defun rem-if-not (pred list)
282: (let ((head '())
283: (tail nil))
284: (do ((l list (cdr l))
285: (newcell))
286: ((null l) head)
287: (cond ((funcall pred (car l))
288: (setq newcell (list (car l)))
289: (cond ((null head) (setq head newcell))
290: (t (rplacd tail newcell)))
291: (setq tail newcell))))))
292:
293: (make-equivalent subset rem-if-not)
294: (make-equivalent subset-not rem-if)
295:
296: (defun del (pred item list &optional (cnt -1))
297: (let ((ret (cons nil list)))
298: (do ((list ret))
299: ((null (cdr list))
300: (cdr ret))
301: (cond ((and (funcall pred item (second list))
302: (not (zerop cnt)))
303: (setq cnt (1- cnt))
304: (rplacd list (cddr list)))
305: (t (setq list (cdr list)))))))
306:
307: (defun del-if (pred list)
308: (let ((ret (cons nil list)))
309: (do ((list ret))
310: ((null (cdr list))
311: (cdr ret))
312: (if (funcall pred (second list))
313: (rplacd list (cddr list))
314: (setq list (cdr list))))))
315:
316: (defun del-if-not (pred list)
317: (let ((ret (cons nil list)))
318: (do ((list ret))
319: ((null (cdr list))
320: (cdr ret))
321: (if (not (funcall pred (second list)))
322: (rplacd list (cddr list))
323: (setq list (cdr list))))))
324:
325: (defun some (forms pred &optional step-function)
326: (and (not (null forms))
327: (if (funcall pred (car forms))
328: forms
329: (some (if (null step-function)
330: (cdr forms)
331: (funcall step-function forms))
332: pred
333: step-function))))
334:
335: (defun every (forms pred &optional step-function)
336: (or (null forms)
337: (and (funcall pred (car forms))
338: (every (if (null step-function)
339: (cdr forms)
340: (funcall step-function forms))
341: pred
342: step-function))))
343:
344: (defmacro pairp (x) `(dtpr ,x))
345:
346: (defun tailp (subset set)
347: (do ((s set (cdr s)))
348: ((null s) nil)
349: (cond ((eq s subset) (return t)))))
350:
351: ; defunp
352: ; like defun except it's an implicit prog
353: ; expands
354: ; (defunp fn (args) form1 form2 ... formn)
355: ; into
356: ; (defun fn (args) (prog () form1 form2 ... (return (formn))))
357: ; and hence allows returns in the middle of "defun"'s
358: ; If original defun body is just one form (eg, let, cond, etc.)
359: ; return is wrapped around the whole thing.
360: ;
361:
362: (defmacro defunp (fn arglist . body)
363: `(defun ,fn ,arglist
364: (prog ()
365: ,@(let ((bodyrev (reverse body)))
366: (nreconc (cdr bodyrev)
367: (cond ((eq 'return (caar bodyrev))
368: ; last form is already a return
369: `(,(car bodyrev)))
370: (t `((return ,(car bodyrev))))))))))
371:
372: (defmacro let-globally (vars-values . body)
373: (let ((temp-vars (mapcar #'(lambda (q) (gensym)) vars-values)))
374: `(progn ((lambda ,temp-vars ,@(mapcar #'(lambda (var-value value)
375: `(setq ,(car var-value) ,value))
376: vars-values temp-vars))
377: ,@(mapcar #'cadr vars-values))
378: ,@body)))
379:
380: (defmacro local-declare (dcls . body)
381: `(progn 'compile ,@(mapcar #'(lambda (x) `(declare ,x)) dcls) ,@body))
382:
383: (defmacro defconst (variable &optional (initial-value nil iv-p) documentation)
384: documentation ;; ignored for now.
385: (if iv-p `(progn 'compile
386: (eval-when (eval compile load)
387: (declare (special ,variable)))
388: (setq ,variable ,initial-value))
389: `(eval-when (eval compile load)
390: (declare (special ,variable)))))
391:
392: (defmacro check-arg (var-name predicate description)
393: `(if (not ,(if (atom predicate)
394: `(,predicate ,var-name)
395: predicate))
396: (ferror t "The argument ~S was ~S, which is not ~A.~%"
397: ',var-name ,var-name ,description)))
398:
399: (defmacro check-arg-type (var-name type-name &optional description)
400: `(if (not (typep ,var-name ,type-name)
401: (ferror t "The argument ~s was ~S, which is not ~A~A.~%"
402: ',var-name ,var-name
403: ,(if (null description) " a" "")
404: ,(if (null description) type-name description)))))
405:
406: ;;; Defsubst
407:
408: (defmacro defsubst (function-spec lambda-list &body body)
409: `(progn 'compile
410: (defun ,function-spec ,lambda-list ,@body)
411: (defcmacro ,function-spec ,lambda-list
412: (sublis (list ,@(do ((v lambda-list (cdr v))
413: (r nil (cons `(cons ',(car v) ,(car v)) r)))
414: ((null v) (nreverse r))))
415: ',(if (null (cdr body)) (car body)
416: `(progn . ,body))))
417: ',function-spec))
418:
419: ;--- ^ :: fixnum expt
420: (defun ^ (x y)
421: (expt x y))
422:
423: (putprop 'machacks t 'version)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.