![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lmhacks.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / lisplib|
Return to lmhacks.l CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / lisplib |
1.1 root 1: (setq rcs-lmhacks-
2: "$Header: lmhacks.l,v 1.2 83/08/15 22:32:31 jkf Exp $")
3:
4: ;; This file contains miscellaneous functions and macros that
5: ;; ZetaLisp users often find useful
6:
7:
8: ;;; (c) Copyright 1982 Massachusetts Institute of Technology
9:
10: ;; This is a simple multiple value scheme based on the one implemented
11: ;; in MACLISP. It doesn't clean up after its self properly, so if
12: ;; you ask for multiple values, you will get them regardless of whether
13: ;; they are returned.
14:
15: (environment-maclisp (compile eval) (files struct flavorm))
16:
17: (declare (macros t))
18:
19: (defvar si:argn () "Number of arguments returned by last values")
20: (defvar si:arg2 () "Second return value")
21: (defvar si:arg3 () "Third return value")
22: (defvar si:arg4 () "Fourth return value")
23: (defvar si:arg5 () "Fifth return value")
24: (defvar si:arg6 () "Sixth return value")
25: (defvar si:arg7 () "Seventh return value")
26: (defvar si:arg8 () "Eigth return value")
27: (defvar si:arglist () "Additional return values after the eigth")
28:
29: (defvar si:return-registers
30: '(si:arg2 si:arg3 si:arg4 si:arg5 si:arg6 si:arg7 si:arg8))
31:
32: (defmacro values (&rest values)
33: `(prog2 (setq si:argn ,(length values))
34: ,(first values)
35: ,@(do ((vals (cdr values) (cdr vals))
36: (regs si:return-registers (cdr regs))
37: (forms))
38: (nil)
39: (cond ((null vals)
40: (return (reverse forms)))
41: ((null regs)
42: (return
43: `(,@(reverse forms)
44: (setq si:arglist (list ,@vals)))))
45: (t (push `(setq ,(car regs) ,(car vals))
46: forms))))))
47:
48: (defun values-list (list)
49: (setq si:argn (length list))
50: (do ((vals (cdr list) (cdr vals))
51: (regs si:return-registers (cdr regs)))
52: ((null regs)
53: (if (not (null vals))
54: (setq si:arglist vals))
55: (car list))
56: (set (car regs) (car vals))))
57:
58: (defmacro multiple-value (vars form)
59: `(progn
60: ,@(if (not (null (car vars)))
61: `((setq ,(car vars) ,form)
62: (if (< si:argn 1) (setq ,(car vars) nil)))
63: `(,form))
64: ,@(do ((vs (cdr vars) (cdr vs))
65: (regs si:return-registers (cdr regs))
66: (i 2 (1+ i))
67: (forms))
68: (nil)
69: (cond ((null vars)
70: (return (reverse forms)))
71: ((null regs)
72: (return
73: (do ((vs vs (cdr vs)))
74: ((null vs) (nreverse forms))
75: (and (not (null (car vs)))
76: (push
77: `(setq ,(car vs)
78: (prog1
79: (if (not (> ,i si:argn))
80: (car si:arglist))
81: (setq si:arglist (cdr si:arglist))))
82: forms)))))
83: ((not (null (car vs)))
84: (push `(setq ,(car vs) (if (not (> ,i si:argn)) ,(car regs))
85: ,(car regs) nil)
86: forms))))))
87:
88: (defmacro multiple-value-bind (vars form &rest body)
89: `(let ,vars
90: (multiple-value ,vars ,form)
91: ,@body))
92:
93: (defmacro multiple-value-list (form)
94: `(multiple-value-list-1 ,form))
95:
96: (defun multiple-value-list-1 (si:arg1)
97: (cond ((= 0 si:argn) ())
98: ((= 1 si:argn)
99: (list si:arg1))
100: ((= 2 si:argn)
101: (list si:arg1 si:arg2))
102: ((= 3 si:argn)
103: (list si:arg1 si:arg2 si:arg3))
104: ((= 4 si:argn)
105: (list si:arg1 si:arg2 si:arg3 si:arg4))
106: ((= 5 si:argn)
107: (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5))
108: ((= 6 si:argn)
109: (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6))
110: ((= 7 si:argn)
111: (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6
112: si:arg7))
113: ((= 8 si:argn)
114: (list si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6
115: si:arg7 si:arg8))
116: ((> si:argn 8)
117: (rplacd (nthcdr (- si:argn 9) si:arglist) nil)
118: (list* si:arg1 si:arg2 si:arg3 si:arg4 si:arg5 si:arg6
119: si:arg7 si:arg8 si:arglist))
120: (t (ferror () "Internal error, si:argn = ~D" si:argn))))
121:
122: (defun union (set &rest others)
123: (loop for s in others
124: do (loop for elt in s
125: unless (memq elt set)
126: do (push elt set))
127: finally (return set)))
128:
129: (defun make-list (length &rest options &aux (iv))
130: (loop for (key val) on options by #'cddr
131: do (selectq key
132: (:initial-value
133: (setq iv val))
134: (:area)
135: (otherwise
136: (error "Illegal parameter to make-list" key))))
137: (loop for i from 1 to length collect iv))
138:
139: ;; si:printing-random-object
140: ;; A macro for aiding in the printing of random objects.
141: ;; This macro generates a form which: (by default) includes the virtual
142: ;; address in the printed representation.
143: ;; Options are :NO-POINTER to suppress the pointer
144: ;; :TYPEP princs the typep of the object first.
145:
146: ;; Example:
147: ;; (DEFSELECT ((:PROPERTY HACKER :NAMED-STRUCTURE-INVOKE))
148: ;; (:PRINT-SELF (HACKER STREAM IGNORE IGNORE)
149: ;; (SI:PRINTING-RANDOM-OBJECT (HACKER STREAM :TYPEP)
150: ;; (PRIN1 (HACKER-NAME HACKER) STREAM))))
151: ;; ==> #<HACKER /"MMcM/" 6172536765>
152:
153: (defmacro si:printing-random-object ((object stream . options) &body body)
154: (let ((%pointer t)
155: (typep nil))
156: (do ((l options (cdr l)))
157: ((null l))
158: (selectq (car l)
159: (:no-pointer (setq %pointer nil))
160: (:typep (setq typep t))
161: (:fastp (setq l (cdr l))) ; for compatibility sake
162: (otherwise
163: (ferror nil "~S is an unknown keyword in si:printing-random-object"
164: (car l)))))
165: `(progn
166: (patom "#<" ,stream)
167: ,@(and typep
168: `((patom (:typep ,object) ,stream)))
169: ,@(and typep body
170: `((patom " " ,stream)))
171: ,@body
172: ,@(and %pointer
173: `((patom " " ,stream)
174: (patom (maknum ,object) ,stream)))
175: (patom ">" ,stream)
176: ,object)))
177:
178: (defun named-structure-p (x &aux symbol)
179: (cond ((or (and (hunkp x) (atom (setq symbol (cxr 0 x))))
180: (and (vectorp x)
181: (setq symbol (or (and (atom (vprop x)) (vprop x))
182: (and (dtpr (vprop x))
183: (atom (car (vprop x)))
184: (car (vprop x)))))))
185:
186: (if (get symbol 'defstruct-description)
187: symbol))))
188:
189: (defun named-structure-symbol (x)
190: (or (named-structure-p x)
191: (ferror () "~S was supposed to have been a named structure."
192: x)))
193:
194: (declare (localf named-structure-invoke-internal))
195:
196: (defun named-structure-invoke (operation struct &rest args)
197: (named-structure-invoke-internal operation struct args t))
198:
199: (defun named-structure-invoke-carefully (operation struct &rest args)
200: (named-structure-invoke-internal operation struct args nil))
201:
202: (defun named-structure-invoke-internal (operation struct args error-p)
203: (let (symbol fun)
204: (setq symbol (named-structure-symbol struct))
205: (if (setq fun (get symbol ':named-structure-invoke))
206: then (lexpr-funcall fun operation struct args)
207: else (and error-p
208: (ferror ()
209: "No named structure invoke function for ~S"
210: struct)))))
211:
212: (defmacro defselect ((function-spec default-handler no-which-operations)
213: &rest args)
214: (let ((name (intern (gensym)))
215: fun-name)
216: `(progn 'compile
217: (defun ,(if (eq (car function-spec) ':property)
218: (cdr function-spec)
219: (ferror () "Can't interpret ~S defselect function spec"
220: function-spec))
221: (operation &rest args &aux temp)
222: (if (setq temp (gethash operation (get ',name 'select-table)))
223: (lexpr-funcall temp args)
224: ,(if default-handler
225: `(lexpr-funcall ,default-handler operation args)
226: `(ferror () "No handler for the ~S method of ~S"
227: operation ',function-spec))))
228: (setf (get ',name 'select-table) (make-hash-table))
229: ,@(do ((args args (cdr args))
230: (form)
231: (forms nil))
232: ((null args) (nreverse forms))
233: (setq form (car args))
234: (cond ((atom (cdr form))
235: (setq fun-name (cdr form)))
236: (t (setq fun-name
237: (intern (concat name (if (atom (car form)) (car form)
238: (caar form)))))
239: (push `(defun ,fun-name ,@(cdr form)) forms)))
240: (if (atom (car form))
241: (push `(puthash ',(car form) ',fun-name
242: (get ',name 'select-table))
243: forms)
244: (mapc #'(lambda (q)
245: (push `(puthash ',q ',fun-name
246: (get ',name 'select-table))
247: forms))
248: (car form))))
249: ,@(and (not no-which-operations)
250: `((defun ,(setq fun-name (intern
251: (concat name '-which-operations)))
252: (&rest args)
253: '(:which-operations ,@(loop for form in args
254: appending (if (atom (car form))
255: (list (car form))
256: (car form)))))
257: (puthash ':which-operations ',fun-name
258: (get ',name 'select-table))))
259: ',function-spec)))
260:
261: (defun :typep (ob &optional (type nil) &aux temp)
262: (cond ((instancep ob)
263: (instance-typep ob type))
264: ((setq temp (named-structure-p ob))
265: (if (null type) temp
266: (if (eq type temp) t
267: (memq type (nth 11. (get temp 'defstruct-description))))))
268: ((hunkp ob)
269: (if (null type) 'hunk (eq type 'hunk)))
270: ((null type)
271: (funcall 'typep ob))
272: (t (eq type (funcall 'typep ob)))))
273:
274: (defun send-internal (object message &rest args)
275: (declare (special .own-flavor. self))
276: (lexpr-funcall (if (eq self object)
277: (or (gethash message
278: (flavor-method-hash-table .own-flavor.))
279: (flavor-default-handler .own-flavor.))
280: object)
281: message args))
282:
283: ;; New printer
284:
285: (declare (special poport prinlevel prinlength top-level-print))
286:
287: (defun zprint (x &optional (stream poport))
288: (zprin1 x stream)
289: 't)
290:
291: (defun zprinc (x &optional (stream poport))
292: (zprin1a x stream () (or prinlevel -1)))
293:
294: (defun zprin1 (x &optional (stream poport))
295: (zprin1a x stream 't (or prinlevel -1)))
296:
297: (defun zprin1a (ob stream slashifyp level &aux temp)
298: (cond ((null ob) (patom "()" stream))
299: ((setq temp (named-structure-p ob))
300: (or (named-structure-invoke-carefully ':print-self ob stream
301: level slashifyp)
302: (si:printing-random-object (ob stream :typep))))
303: ((instancep ob)
304: (if (get-handler-for ob ':print-self)
305: (send ob ':print-self stream)
306: (si:printing-random-object (ob stream :typep))))
307: ((atom ob)
308: (if slashifyp (xxprint ob stream)
309: (patom ob stream)))
310: ((dtpr ob) (zprint-list ob stream slashifyp (1- level)))
311: ((hunkp ob) (zprint-hunk ob stream slashifyp (1- level)))
312: ((= level 0)
313: (patom "&" stream))
314: (t
315: (if slashifyp (xxprint ob stream)
316: (patom ob stream))))
317: 't)
318:
319: (defun zprint-list (l stream slashifyp level)
320: (tyo #/( stream)
321: (do ((l l (cdr l))
322: (i (or prinlength -1) (1- i))
323: (first t nil))
324: ((not (dtpr l))
325: (cond ((not (null l))
326: (patom " . " stream)
327: (zprin1a l stream slashifyp level)))
328: 't)
329: (cond ((= i 0)
330: (patom " ..." stream)
331: (return 't)))
332: (if (not first)
333: (tyo #/ stream))
334: (zprin1a (car l) stream slashifyp level))
335: (tyo #/) stream))
336:
337: (defun zprint-hunk (l stream slashifyp level)
338: (tyo #/{ stream)
339: (do ((i 0 (1+ i))
340: (lim (hunksize l))
341: (first t nil))
342: ((= i lim)
343: 't)
344: (cond ((and (not (null prinlength)) (not (< i prinlength)))
345: (patom " ..." stream)
346: (return 't)))
347: (if (not first)
348: (tyo #/ stream))
349: (zprin1a (cxr i l) stream slashifyp level))
350: (tyo #/} stream))
351:
352: (eval-when (load eval)
353: (putd 'xxprint (getd 'print))
354: (putd 'xxprinc (getd 'princ)))
355:
356: (defun new-printer ()
357: (setq top-level-print 'zprint)
358: (putd 'print (getd 'zprint))
359: (putd 'prin1 (getd 'zprin1))
360: 't)
361:
362: (defun old-printer ()
363: (setq top-level-print 'xxprint)
364: (putd 'print (getd 'xxprint))
365: (putd 'princ (getd 'xxprinc))
366: 't)
367:
368:
369:
370:
371: (putprop 'lmhacks t 'version)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.