Commit | Line | Data |
---|---|---|
89291b93 C |
1 | (setq rcs-lmhacks- |
2 | "$Header: /usr/lib/lisp/lmhacks.l,v 1.1 83/01/29 18:38:35 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 | \f | |
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 | \f | |
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 | \f | |
178 | (defun named-structure-p (x &aux symbol) | |
179 | (cond ((and (hunkp x) (atom (setq symbol (cxr 0 x)))) | |
180 | (if (get symbol 'defstruct-description) | |
181 | symbol)))) | |
182 | ||
183 | (defun named-structure-symbol (x) | |
184 | (or (named-structure-p x) | |
185 | (ferror () "~S was supposed to have been a named structure." | |
186 | x))) | |
187 | ||
188 | (declare (localf named-structure-invoke-internal)) | |
189 | ||
190 | (defun named-structure-invoke (operation struct &rest args) | |
191 | (named-structure-invoke-internal operation struct args t)) | |
192 | ||
193 | (defun named-structure-invoke-carefully (operation struct &rest args) | |
194 | (named-structure-invoke-internal operation struct args nil)) | |
195 | ||
196 | (defun named-structure-invoke-internal (operation struct args error-p) | |
197 | (let (symbol fun) | |
198 | (setq symbol (named-structure-symbol struct)) | |
199 | (if (setq fun (get symbol ':named-structure-invoke)) | |
200 | then (lexpr-funcall fun operation struct args) | |
201 | else (and error-p | |
202 | (ferror () | |
203 | "No named structure invoke function for ~S" | |
204 | struct))))) | |
205 | ||
206 | (defmacro defselect ((function-spec default-handler no-which-operations) | |
207 | &rest args) | |
208 | (let ((name (intern (gensym))) | |
209 | fun-name) | |
210 | `(progn 'compile | |
211 | (defun ,(if (eq (car function-spec) ':property) | |
212 | (cdr function-spec) | |
213 | (ferror () "Can't interpret ~S defselect function spec" | |
214 | function-spec)) | |
215 | (operation &rest args &aux temp) | |
216 | (if (setq temp (gethash operation (get ',name 'select-table))) | |
217 | (lexpr-funcall temp args) | |
218 | ,(if default-handler | |
219 | `(lexpr-funcall ,default-handler operation args) | |
220 | `(ferror () "No handler for the ~S method of ~S" | |
221 | operation ',function-spec)))) | |
222 | (setf (get ',name 'select-table) (make-hash-table)) | |
223 | ,@(do ((args args (cdr args)) | |
224 | (form) | |
225 | (forms nil)) | |
226 | ((null args) (nreverse forms)) | |
227 | (setq form (car args)) | |
228 | (cond ((atom (cdr form)) | |
229 | (setq fun-name (cdr form))) | |
230 | (t (setq fun-name | |
231 | (intern (concat name (if (atom (car form)) (car form) | |
232 | (caar form))))) | |
233 | (push `(defun ,fun-name ,@(cdr form)) forms))) | |
234 | (if (atom (car form)) | |
235 | (push `(puthash ',(car form) ',fun-name | |
236 | (get ',name 'select-table)) | |
237 | forms) | |
238 | (mapc #'(lambda (q) | |
239 | (push `(puthash ',q ',fun-name | |
240 | (get ',name 'select-table)) | |
241 | forms)) | |
242 | (car form)))) | |
243 | ,@(and (not no-which-operations) | |
244 | `((defun ,(setq fun-name (intern | |
245 | (concat name '-which-operations))) | |
246 | (&rest args) | |
247 | '(:which-operations ,@(loop for form in args | |
248 | appending (if (atom (car form)) | |
249 | (list (car form)) | |
250 | (car form))))) | |
251 | (puthash ':which-operations ',fun-name | |
252 | (get ',name 'select-table)))) | |
253 | ',function-spec))) | |
254 | \f | |
255 | (defun :typep (ob &optional (type nil) &aux temp) | |
256 | (cond ((instancep ob) | |
257 | (instance-typep ob type)) | |
258 | ((setq temp (named-structure-p ob)) | |
259 | (if (null type) temp | |
260 | (if (eq type temp) t | |
261 | (memq type (nth 11. (get temp 'defstruct-description)))))) | |
262 | ((hunkp ob) | |
263 | (if (null type) 'hunk (eq type 'hunk))) | |
264 | ((null type) | |
265 | (funcall 'typep ob)) | |
266 | (t (eq type (funcall 'typep ob))))) | |
267 | ||
268 | (defun send-internal (object message &rest args) | |
269 | (declare (special .own-flavor. self)) | |
270 | (lexpr-funcall (if (eq self object) | |
271 | (or (gethash message | |
272 | (flavor-method-hash-table .own-flavor.)) | |
273 | (flavor-default-handler .own-flavor.)) | |
274 | object) | |
275 | message args)) | |
276 | \f | |
277 | ;; New printer | |
278 | ||
279 | (declare (special poport prinlevel prinlength top-level-print)) | |
280 | ||
281 | (defun zprint (x &optional (stream poport)) | |
282 | (zprin1 x stream) | |
283 | 't) | |
284 | ||
285 | (defun zprinc (x &optional (stream poport)) | |
286 | (zprin1a x stream () (or prinlevel -1))) | |
287 | ||
288 | (defun zprin1 (x &optional (stream poport)) | |
289 | (zprin1a x stream 't (or prinlevel -1))) | |
290 | ||
291 | (defun zprin1a (ob stream slashifyp level &aux temp) | |
292 | (cond ((null ob) (patom "()" stream)) | |
293 | ((setq temp (named-structure-p ob)) | |
294 | (or (named-structure-invoke-carefully ':print-self ob stream | |
295 | level slashifyp) | |
296 | (si:printing-random-object (ob stream :typep)))) | |
297 | ((instancep ob) | |
298 | (if (get-handler-for ob ':print-self) | |
299 | (send ob ':print-self stream) | |
300 | (si:printing-random-object (ob stream :typep)))) | |
301 | ((atom ob) | |
302 | (if slashifyp (xxprint ob stream) | |
303 | (patom ob stream))) | |
304 | ((dtpr ob) (zprint-list ob stream slashifyp (1- level))) | |
305 | ((hunkp ob) (zprint-hunk ob stream slashifyp (1- level))) | |
306 | ((= level 0) | |
307 | (patom "&" stream)) | |
308 | (t | |
309 | (if slashifyp (xxprint ob stream) | |
310 | (patom ob stream)))) | |
311 | 't) | |
312 | ||
313 | (defun zprint-list (l stream slashifyp level) | |
314 | (tyo #/( stream) | |
315 | (do ((l l (cdr l)) | |
316 | (i (or prinlength -1) (1- i)) | |
317 | (first t nil)) | |
318 | ((not (dtpr l)) | |
319 | (cond ((not (null l)) | |
320 | (patom " . " stream) | |
321 | (zprin1a l stream slashifyp level))) | |
322 | 't) | |
323 | (cond ((= i 0) | |
324 | (patom " ..." stream) | |
325 | (return 't))) | |
326 | (if (not first) | |
327 | (tyo #/ stream)) | |
328 | (zprin1a (car l) stream slashifyp level)) | |
329 | (tyo #/) stream)) | |
330 | ||
331 | (defun zprint-hunk (l stream slashifyp level) | |
332 | (tyo #/{ stream) | |
333 | (do ((i 0 (1+ i)) | |
334 | (lim (hunksize l)) | |
335 | (first t nil)) | |
336 | ((= i lim) | |
337 | 't) | |
338 | (cond ((and (not (null prinlength)) (not (< i prinlength))) | |
339 | (patom " ..." stream) | |
340 | (return 't))) | |
341 | (if (not first) | |
342 | (tyo #/ stream)) | |
343 | (zprin1a (cxr i l) stream slashifyp level)) | |
344 | (tyo #/} stream)) | |
345 | ||
346 | (eval-when (load eval) | |
347 | (putd 'xxprint (getd 'print)) | |
348 | (putd 'xxprinc (getd 'princ))) | |
349 | ||
350 | (defun new-printer () | |
351 | (setq top-level-print 'zprint) | |
352 | (putd 'print (getd 'zprint)) | |
353 | (putd 'prin1 (getd 'zprin1)) | |
354 | 't) | |
355 | ||
356 | (defun old-printer () | |
357 | (setq top-level-print 'xxprint) | |
358 | (putd 'print (getd 'xxprint)) | |
359 | (putd 'princ (getd 'xxprinc)) | |
360 | 't) | |
361 | ||
362 | ||
363 | ||
364 | ||
365 | (putprop 'lmhacks t 'version) |