Commit | Line | Data |
---|---|---|
5ffa1c4c C |
1 | (setq rcs-common2- |
2 | "$Header: common2.l,v 1.10 84/02/29 19:32:00 jkf Exp $") | |
3 | ||
4 | ;; | |
5 | ;; common2.l -[Fri Feb 3 07:42:40 1984 by jkf]- | |
6 | ;; | |
7 | ;; lesser used functions | |
8 | ;; | |
9 | ||
10 | ||
11 | (declare (macros t)) | |
12 | ||
13 | ;--- process functions | |
14 | ; these functions permit the user to start up processes and either | |
15 | ; to either wait for their completion or to continue processing, | |
16 | ; communicating with them through a pipe. | |
17 | ; | |
18 | ; the main function, *process, is written in C. These functions | |
19 | ; handle the common cases | |
20 | ; | |
21 | ;--- *process-send :: start a process and return port to write to | |
22 | ; | |
23 | (defun *process-send (command) | |
24 | (cadr (*process command nil t))) | |
25 | ||
26 | ;--- *process-receive :: start a process and return port to read from | |
27 | ; | |
28 | (defun *process-receive (command) | |
29 | (car (*process command t))) | |
30 | ||
31 | ;--- process :: the old nlambda version of process | |
32 | ; this function is kept around for compatibility | |
33 | ; use: (process command [frompipe [topipe]]) | |
34 | ; if the from and to pipes aren't given, run it and wait | |
35 | ; | |
36 | (defun process fexpr (args) | |
37 | (declare (*args 1 3)) | |
38 | (let ((command (car args)) | |
39 | (fromport (cadr args)) | |
40 | (toport (caddr args))) | |
41 | (cond ((null (cdr args)) (*process command)) ; call and wait | |
42 | (t (let ((res (*process command fromport toport))) | |
43 | (cond (fromport (set fromport (cadr res)))) | |
44 | (cond (toport (set toport (car res)))) | |
45 | ; return pid | |
46 | (caddr res)))))) | |
47 | ||
48 | ||
49 | ;--- msg : print a message consisting of strings and values | |
50 | ; arguments are: | |
51 | ; N - print a newline | |
52 | ; (N foo) - print foo newlines (foo is evaluated) | |
53 | ; B - print a blank | |
54 | ; (B foo) - print foo blanks (foo is evaluated) | |
55 | ; (P foo) - print following args to port foo (foo is evaluated) | |
56 | ; (C foo) - go to column foo (foo is evaluated) | |
57 | ; (T n) - print n tabs | |
58 | ; D - drain | |
59 | ; other - evaluate a princ the result (remember strings eval to themselves) | |
60 | ||
61 | (defmacro msg (&rest msglist) | |
62 | (do ((ll msglist (cdr ll)) | |
63 | (result) | |
64 | (cur nil nil) | |
65 | (curport nil) | |
66 | (current)) | |
67 | ((null ll) `(progn ,@(nreverse result))) | |
68 | (setq current (car ll)) | |
69 | (If (dtpr current) | |
70 | then (If (eq (car current) 'N) | |
71 | then (setq cur `(msg-tyo-char 10 ,(cadr current))) | |
72 | elseif (eq (car current) 'B) | |
73 | then (setq cur `(msg-tyo-char 32 ,(cadr current))) | |
74 | elseif (eq (car current) 'T) | |
75 | then (setq cur `(msg-tyo-char #\tab ,(cadr current))) | |
76 | elseif (eq (car current) 'P) | |
77 | then (setq curport (cadr current)) | |
78 | elseif (eq (car current) 'C) | |
79 | then (setq cur `(tab (1- ,(cadr current)))) | |
80 | else (setq cur `(msg-print ,current))) | |
81 | elseif (eq current 'N) | |
82 | then (setq cur (list 'terpr)) ; (can't use backquote | |
83 | elseif (eq current 'B) ; since must have new | |
84 | then (setq cur (list 'tyo 32)) ; dtpr cell at end) | |
85 | elseif (eq current 'D) | |
86 | then (setq cur '(drain)) | |
87 | else (setq cur `(msg-print ,current))) | |
88 | (If cur | |
89 | then (setq result (cons (If curport then (nconc cur (ncons curport)) | |
90 | else cur) | |
91 | result))))) | |
92 | ||
93 | ||
94 | ||
95 | ||
96 | (defun msg-tyo-char (ch n &optional (port nil)) | |
97 | (do ((i n (1- i))) | |
98 | ((< i 1)) | |
99 | (cond ((eq ch 10) (terpr port)) | |
100 | (t (tyo ch port))))) | |
101 | ||
102 | (defun msg-print (item &optional (port nil)) | |
103 | (patom item port)) | |
104 | ||
105 | ;--- printblanks :: print out a stream of blanks to the given port | |
106 | ; (printblanks 'x_numberofblanks 'p_port) | |
107 | ; | |
108 | (def printblanks | |
109 | (lambda (n prt) | |
110 | (let ((easy (memq n '( 0 "" | |
111 | 1 " " | |
112 | 2 " " | |
113 | 3 " " | |
114 | 4 " " | |
115 | 5 " " | |
116 | 6 " " | |
117 | 7 " " | |
118 | 8 " ")))) | |
119 | (cond (easy (patom (cadr easy) prt)) | |
120 | (t (do ((i n (1- i))) | |
121 | ((<& i 1)) | |
122 | (patom " " prt))))))) | |
123 | ||
124 | ||
125 | ||
126 | ||
127 | ||
128 | ; --- linelength [numb] | |
129 | ; | |
130 | ; sets the linelength (actually just varib linel) to the | |
131 | ; number given: numb | |
132 | ; if numb is not given, the current line length is returned | |
133 | ; | |
134 | ||
135 | (declare (special linel)) | |
136 | ||
137 | (setq linel 80) | |
138 | ||
139 | (def linelength | |
140 | (nlambda (form) | |
141 | (cond ((null form) linel ) | |
142 | ((numberp (car form)) (setq linel (car form))) | |
143 | (t linel)))) | |
144 | ||
145 | ; ======================================== | |
146 | ; | |
147 | ; (charcnt port) | |
148 | ; returns the number of characters left on the current line | |
149 | ; on the given port | |
150 | ; | |
151 | ; ======================================= | |
152 | ||
153 | ||
154 | (def charcnt | |
155 | (lambda (port) (- linel (nwritn port)))) | |
156 | ||
157 | ;--- nthcdr :: do n cdrs of the list and return the result | |
158 | ; | |
159 | ; | |
160 | (defun nthcdr (index list) | |
161 | (cond ((fixp index) | |
162 | (cond ((<& index 0) | |
163 | (cons nil list)) | |
164 | ((=& index 0) | |
165 | list) | |
166 | (t (nthcdr (1- index) (cdr list))))) | |
167 | (t (error "Non fixnum first argument to nthcdr " index)))) | |
168 | ||
169 | ;--- nthcdr (cmacro) :: version of nthcdr for use by the compiler | |
170 | ; | |
171 | (defcmacro nthcdr (index list) | |
172 | (if (and (fixp index) (=& index 0)) | |
173 | then list ; (nthcdr 0 expr) => expr | |
174 | else (let ((val (assq index '((1 . cdr) | |
175 | (2 . cddr) | |
176 | (3 . cdddr) | |
177 | (4 . cddddr) | |
178 | (5 . cdddddr) | |
179 | (6 . cddddddr))))) | |
180 | (cond (val `(,(cdr val) ,list)) ; (nthcdr 1-6 list) | |
181 | (t `(nthcdr ,index ,list)))))) ; other cases | |
182 | ||
183 | ||
184 | ;--- nth :: return nth element of the list | |
185 | ; cdr index times and then car to get the element. | |
186 | ; thus the first element is 0 | |
187 | ; | |
188 | (defun nth (index list) | |
189 | (car (nthcdr index list))) | |
190 | ||
191 | ;--- nth (cmacro) :: compiler macro to do the same thing | |
192 | ; | |
193 | (defcmacro nth (index list) | |
194 | `(car (nthcdr ,index ,list))) | |
195 | ||
196 | ||
197 | ||
198 | ||
199 | ;;============================== | |
200 | ; (assqr val alist) | |
201 | ; acts much like assq, it looks for val in the cdr of elements of | |
202 | ; the alist and returns the element if found. | |
203 | ; fix this when the compiler works | |
204 | (eval-when nil (def assqr | |
205 | (lambda (val alist) | |
206 | (do ((al alist (cdr al))) | |
207 | ((null al) nil) | |
208 | (cond ((eq val (cdar al)) (return (car al)))))))) | |
209 | ||
210 | ||
211 | ; ==================== | |
212 | ; (listp 'x) is t if x is a non-atom or nil | |
213 | ; ==================== | |
214 | (def listp (lambda (val) (or (dtpr val) (null val)))) | |
215 | ||
216 | ||
217 | ||
218 | ;--- memcar - VAL : lispval | |
219 | ; - LIS : list | |
220 | ; returns t if VAL found as the car of a top level element. | |
221 | ;temporarily turn this off till the compiler can handle it. | |
222 | (eval-when nil (def memcar | |
223 | (lambda (a l) | |
224 | (do ((ll l (cdr ll))) | |
225 | ((null ll) nil) | |
226 | (cond ((equal (caar ll) a) (return (cdar ll)))))))) | |
227 | \f | |
228 | ; ================================= | |
229 | ; | |
230 | ; (memcdr 'val 'listl) | |
231 | ; | |
232 | ; the list listl is searched for a list | |
233 | ; with cdr equal to val. if found, the | |
234 | ; car of that list is returned. | |
235 | ; ================================== | |
236 | ;fix this when compiler works ok | |
237 | (eval-when nil (def memcdr | |
238 | (lambda (a l) | |
239 | (do ((ll l (cdr ll))) | |
240 | ((null ll) nil) | |
241 | (cond ((equal (cdar ll) a) (return (caar l)))))))) | |
242 | ||
243 | ||
244 | ;this looks like funcall, so we will just use it | |
245 | '(def apply* | |
246 | (nlambda ($x$) | |
247 | (eval (cons (eval (car $x$)) (cdr $x$))))) | |
248 | ||
249 | (putd 'apply* (getd 'funcall)) | |
250 | ||
251 | (defun remq (item list &optional (cnt -1)) ;no tail recursion sucks. | |
252 | (let ((head nil) | |
253 | (tail nil)) | |
254 | (do ((l list (cdr l)) | |
255 | (newcell)) | |
256 | ((null l) head) | |
257 | (cond ((or (not (eq (car l) item)) | |
258 | (=& 0 cnt)) | |
259 | (setq newcell (list (car l))) | |
260 | (cond ((null head) (setq head newcell)) | |
261 | (t (rplacd tail newcell))) | |
262 | (setq tail newcell)) | |
263 | (t (setq cnt (1- cnt))))))) | |
264 | ||
265 | (defun tab n | |
266 | (prog (nn prt over) | |
267 | (setq nn (arg 1)) | |
268 | (cond ((>& n 1) (setq prt (arg 2)))) | |
269 | (cond ((>& (setq over (nwritn prt)) nn) | |
270 | (terpri prt) | |
271 | (setq over 0))) | |
272 | (printblanks (- nn over) prt))) | |
273 | ||
274 | ;--- charcnt :: returns the number of characters left on the current line | |
275 | ; p - port | |
276 | ;(local function) | |
277 | (def charcnt | |
278 | (lambda (port) (- linel (nwritn port)))) | |
279 | ||
280 | ;(local function) | |
281 | ; | |
282 | (declare (special $outport$)) | |
283 | (def $patom1 (lambda (x) (patom x $outport$))) | |
284 | ||
285 | ;;; --- cmu functions --- | |
286 | (def attach | |
287 | (lambda (x y) | |
288 | (cond ((dtpr y) (rplacd y (cons (car y) (cdr y))) (rplaca y x)) | |
289 | (t (error "An atom can't be attached to " y))))) | |
290 | (def Cnth | |
291 | (lambda (x n) | |
292 | (cond ((> 1 n) (cons nil x)) | |
293 | (t | |
294 | (prog nil | |
295 | lp (cond ((or (atom x) (eq n 1)) (return x))) | |
296 | (setq x (cdr x)) | |
297 | (setq n (1- n)) | |
298 | (go lp)))))) | |
299 | ||
300 | ||
301 | ||
302 | ||
303 | (def dsubst | |
304 | (lambda (x y z) | |
305 | (prog (b) | |
306 | (cond ((eq y (setq b z)) (return (copy x)))) | |
307 | lp | |
308 | (cond ((atom z) (return b)) | |
309 | ((cond ((symbolp y) (eq y (car z))) (t (equal y (car z)))) | |
310 | (rplaca z (copy x))) | |
311 | (t (dsubst x y (car z)))) | |
312 | (cond ((and y (eq y (cdr z))) (rplacd z (copy x)) (return b))) | |
313 | (setq z (cdr z)) | |
314 | (go lp)))) | |
315 | ||
316 | (putd 'eqstr (getd 'equal)) | |
317 | ||
318 | (defun insert (x l comparefn nodups) | |
319 | (cond ((null l) (list x)) | |
320 | ((atom l) (error "an atom, can't be inserted into" l)) | |
321 | ((and nodups (member x l)) l) | |
322 | (t (cond | |
323 | ((null comparefn) (setq comparefn (function alphalessp)))) | |
324 | (prog (l1 n n1 y) | |
325 | (setq l1 l) | |
326 | (setq n (length l)) | |
327 | a (setq n1 (/ (add1 n) 2)) | |
328 | (setq y (Cnth l1 n1)) | |
329 | (cond ((< n 3) | |
330 | (cond ((funcall comparefn x (car y)) | |
331 | (cond | |
332 | ((not (equal x (car y))) | |
333 | (rplacd y (cons (car y) (cdr y))) | |
334 | (rplaca y x)))) | |
335 | ((eq n 1) (rplacd y (cons x (cdr y)))) | |
336 | ((funcall comparefn x (cadr y)) | |
337 | (cond | |
338 | ((not (equal x (cadr y))) | |
339 | (rplacd (cdr y) | |
340 | (cons (cadr y) (cddr y))) | |
341 | (rplaca (cdr y) x)))) | |
342 | (t (rplacd (cdr y) (cons x (cddr y)))))) | |
343 | ((funcall comparefn x (car y)) | |
344 | (cond | |
345 | ((not (equal x (car y))) | |
346 | (setq n (sub1 n1)) | |
347 | (go a)))) | |
348 | (t (setq l1 (cdr y)) (setq n (- n n1)) (go a)))) | |
349 | l))) | |
350 | ||
351 | ||
352 | ||
353 | ||
354 | (def kwote (lambda (x) (list 'quote x))) | |
355 | ||
356 | (def lconc | |
357 | (lambda | |
358 | (ptr x) | |
359 | (prog (xx) | |
360 | (return | |
361 | (cond ((atom x) ptr) | |
362 | (t (setq xx (last x)) | |
363 | (cond ((atom ptr) (cons x xx)) | |
364 | ((dtpr (cdr ptr)) | |
365 | (rplacd (cdr ptr) x) | |
366 | (rplacd ptr xx)) | |
367 | (t (rplaca (rplacd ptr xx) x))))))))) | |
368 | (def ldiff | |
369 | (lambda (x y) | |
370 | (cond ((eq x y) nil) | |
371 | ((null y) x) | |
372 | (t | |
373 | (prog (v z) | |
374 | (setq z (setq v (ncons (car x)))) | |
375 | loop (setq x (cdr x)) | |
376 | (cond ((eq x y) (return z)) | |
377 | ((null x) (error "not a tail - ldiff"))) | |
378 | (setq v (cdr (rplacd v (ncons (car x))))) | |
379 | (go loop)))))) | |
380 | ||
381 | (def lsubst | |
382 | (lambda (x y z) | |
383 | (cond ((null z) nil) | |
384 | ((atom z) (cond ((eq y z) x) (t z))) | |
385 | ((equal y (car z)) (nconc (copy x) (lsubst x y (cdr z)))) | |
386 | (t (cons (lsubst x y (car z)) (lsubst x y (cdr z))))))) | |
387 | ||
388 | (def merge | |
389 | (lambda (a b %%cfn) | |
390 | (declare (special %%cfn)) | |
391 | (cond ((null %%cfn) (setq %%cfn (function alphalessp)))) | |
392 | (merge1 a b))) | |
393 | ||
394 | (def merge1 | |
395 | (lambda (a b) | |
396 | (declare (special %%cfn)) | |
397 | (cond ((null a) b) | |
398 | ((null b) a) | |
399 | (t | |
400 | (prog (val end) | |
401 | (setq val | |
402 | (setq end | |
403 | (cond ((funcall %%cfn (car a) (car b)) | |
404 | (prog1 a (setq a (cdr a)))) | |
405 | (t (prog1 b (setq b (cdr b))))))) | |
406 | loop (cond ((null a) (rplacd end b) (return val)) | |
407 | ((null b) (rplacd end a) (return val)) | |
408 | ((funcall %%cfn (car a) (car b)) | |
409 | (rplacd end a) | |
410 | (setq a (cdr a))) | |
411 | (t (rplacd end b) (setq b (cdr b)))) | |
412 | (setq end (cdr end)) | |
413 | (go loop)))))) | |
414 | ||
415 | (defmacro neq (a b) `(not (eq ,a ,b))) | |
416 | ||
417 | (putd 'nthchar (getd 'getchar)) | |
418 | ;(def nthchar | |
419 | ; (lambda (x n) | |
420 | ; (cond ((plusp n) (car (Cnth (explodec x) n))) | |
421 | ; ((minusp n) (car (Cnth (reverse (explodec x)) (minus n)))) | |
422 | ; ((zerop n) nil)))) | |
423 | ||
424 | (defmacro quote! (&rest a) (quote!-expr-mac a)) | |
425 | ||
426 | (eval-when (compile eval load) | |
427 | ||
428 | (defun quote!-expr-mac (form) | |
429 | (cond ((null form) nil) | |
430 | ((atom form) `',form) | |
431 | ((eq (car form) '!) | |
432 | `(cons ,(cadr form) ,(quote!-expr-mac (cddr form)))) | |
433 | ((eq (car form) '!!) | |
434 | (cond ((cddr form) `(append ,(cadr form) | |
435 | ,(quote!-expr-mac (cddr form)))) | |
436 | (t (cadr form)))) | |
437 | (t `(cons ,(quote!-expr-mac (car form)) | |
438 | ,(quote!-expr-mac (cdr form)))))) | |
439 | ||
440 | ) | |
441 | ||
442 | (defun remove (item list &optional (cnt -1)) | |
443 | (let ((head '()) | |
444 | (tail nil)) | |
445 | (do ((l list (cdr l)) | |
446 | (newcell)) | |
447 | ((null l) head) | |
448 | (cond ((or (not (equal (car l) item)) | |
449 | (zerop cnt)) | |
450 | (setq newcell (list (car l))) | |
451 | (cond ((null head) (setq head newcell)) | |
452 | (t (rplacd tail newcell))) | |
453 | (setq tail newcell)) | |
454 | (t (setq cnt (1- cnt))))))) | |
455 | ||
456 | (def subpair | |
457 | (lambda (old new expr) | |
458 | (cond (old (subpr expr old (or new '(nil)))) (t expr)))) | |
459 | ||
460 | (def subpr | |
461 | (lambda (expr l1 l2) | |
462 | (prog (d a) | |
463 | (cond ((atom expr) (go lp)) | |
464 | ((setq d (cdr expr)) (setq d (subpr d l1 l2)))) | |
465 | (setq a (subpr (car expr) l1 l2)) | |
466 | (return | |
467 | (cond ((or (neq a (car expr)) | |
468 | (neq d (cdr expr))) (cons a d)) | |
469 | (t expr))) | |
470 | lp (cond ((null l1) (return expr)) | |
471 | (l2 (cond ((eq expr (car l1)) | |
472 | (return (car l2))))) | |
473 | (t (cond ((eq expr (caar l1)) | |
474 | (return (cdar l1)))))) | |
475 | (setq l1 (cdr l1)) | |
476 | (and l2 (setq l2 (or (cdr l2) '(nil)))) | |
477 | (go lp)))) | |
478 | (def tailp | |
479 | (lambda (x y) | |
480 | (and x | |
481 | (prog nil | |
482 | lp (cond ((atom y) (return nil)) ((eq x y) (return x))) | |
483 | (setq y (cdr y)) | |
484 | (go lp))))) | |
485 | ||
486 | (def tconc | |
487 | (lambda (p x) | |
488 | (cond ((atom p) (cons (setq x (ncons x)) x)) | |
489 | ((dtpr (cdr p)) (rplacd p (cdr (rplacd (cdr p) (ncons x))))) | |
490 | (t (rplaca p (cdr (rplacd p (ncons x)))))))) | |
491 | ||
492 | ;--- int:vector-range-error | |
493 | ; this is called from compiled code if a vector reference is made | |
494 | ; which is out of bounds. it should print an error message and | |
495 | ; never return | |
496 | (defun int:vector-range-error (vec index) | |
497 | (error "vector index out of range detected in compiled code " | |
498 | (list vec index))) | |
499 | ||
500 | ;--- int:wrong-number-of-args-error :: pass wna error message to user | |
501 | ; this is called from compiled code (through wnaerr in the C interpreter) | |
502 | ; when it has been detected that the wrong number of arguments have | |
503 | ; been passed. The state of the arguments are: | |
504 | ; args 1 to (- n 3) are the acutal arguments | |
505 | ; arg (- n 2) is the name of the function called | |
506 | ; arg (- n 1) is the minimum number of arguments allowed | |
507 | ; arg n is the maximum number of arguments allowed | |
508 | ; (or -1 if there is no maximum) | |
509 | (defun int:wrong-number-of-args-error n | |
510 | (let ((max (arg n)) | |
511 | (min (arg (1- n))) | |
512 | (name (arg (- n 2)))) | |
513 | (do ((i (- n 3) (1- i)) | |
514 | (x) | |
515 | (args)) | |
516 | ((<& i 1) | |
517 | ; cases | |
518 | ; exact number | |
519 | ; min and max | |
520 | ; only a min | |
521 | (if (=& min max) | |
522 | then (setq x | |
523 | (format nil | |
524 | "`~a' expects ~r argument~p but was given ~@d:" | |
525 | name min min (length args))) | |
526 | elseif (=& max -1) | |
527 | then (setq x | |
528 | (format nil | |
529 | "`~a' expects at least ~r argument~p but was given ~@d:" | |
530 | name min min (length args))) | |
531 | else (setq x | |
532 | (format nil | |
533 | "`~a' expects between ~r and ~r arguments but was given ~@d:" | |
534 | name min max (length args)))) | |
535 | ||
536 | (error x args)) | |
537 | (push (arg i) args)))) | |
538 | ;--- functions to retrieve parts of the vector returned by | |
539 | ; filestat | |
540 | ; | |
541 | (eval-when (compile eval) | |
542 | (defmacro filestat-chk (name index) | |
543 | `(defun ,name (arg) | |
544 | (cond ((vectorp arg) | |
545 | (vref arg ,index)) | |
546 | (t (error (concat ',name '|: bad arg |) arg)))))) | |
547 | (filestat-chk filestat:mode 0) | |
548 | (filestat-chk filestat:type 1) | |
549 | (filestat-chk filestat:nlink 2) | |
550 | (filestat-chk filestat:uid 3) | |
551 | (filestat-chk filestat:gid 4) | |
552 | (filestat-chk filestat:size 5) | |
553 | (filestat-chk filestat:atime 6) | |
554 | (filestat-chk filestat:mtime 7) | |
555 | (filestat-chk filestat:ctime 8) | |
556 | (filestat-chk filestat:dev 9) | |
557 | (filestat-chk filestat:rdev 10) | |
558 | (filestat-chk filestat:ino 11) | |
559 | ||
560 | ;; lisp coded showstack and baktrace. | |
561 | ;; | |
562 | ||
563 | (declare (special showstack-prinlevel showstack-prinlength | |
564 | showstack-printer prinlevel prinlength)) | |
565 | ||
566 | (or (boundp 'showstack-prinlevel) (setq showstack-prinlevel 3)) | |
567 | (or (boundp 'showstack-prinlength) (setq showstack-prinlength 4)) | |
568 | (or (boundp 'showstack-printer) (setq showstack-printer 'print)) | |
569 | (or (getd 'old-showstack) (putd 'old-showstack (getd 'showstack))) | |
570 | (or (getd 'old-baktrace) (putd 'old-baktrace (getd 'baktrace))) | |
571 | ||
572 | ;--- showstack :: do a stack backtrace. | |
573 | ; arguments (unevaluated) are | |
574 | ; t - print trace expressions too (normally they are not printed) | |
575 | ; N - for some fixnum N, only print N levels. | |
576 | ; len N - set prinlength to N | |
577 | ; lev N - set prinlevel to N | |
578 | ; | |
579 | (defun showstack fexpr (args) | |
580 | (showstack-baktrace args t)) | |
581 | ||
582 | (defun baktrace fexpr (args) | |
583 | (showstack-baktrace args nil)) | |
584 | ||
585 | (defun showstack-baktrace (args showstackp) | |
586 | (let ((print-trace nil) | |
587 | (levels-to-print -1) | |
588 | (prinlevel showstack-prinlevel) | |
589 | (prinlength showstack-prinlength) | |
590 | (res nil) | |
591 | (newres nil) | |
592 | (oldval nil) | |
593 | (stk nil)) | |
594 | ;; scan arguments | |
595 | (do ((xx args (cdr xx))) | |
596 | ((null xx)) | |
597 | (cond ((eq t (car xx)) (setq print-trace t)) | |
598 | ((fixp (car xx)) (setq levels-to-print (car xx))) | |
599 | ((eq 'lev (car xx)) | |
600 | (setq xx (cdr xx) prinlevel (car xx))) | |
601 | ((eq 'len (car xx)) | |
602 | (setq xx (cdr xx) prinlength (car xx))))) | |
603 | ;; print the levels | |
604 | (do ((levs levels-to-print) | |
605 | (firsttime t nil)) | |
606 | ((or (equal 0 stk) | |
607 | (zerop levs)) | |
608 | (terpr)) | |
609 | (setq res (int:showstack stk)) | |
610 | (cond ((null res) (terpr) (return nil))) | |
611 | (setq stk (cdr res) | |
612 | res (car res)) | |
613 | (cond ((or print-trace (not (trace-funp res))) | |
614 | (cond ((and oldval showstackp) | |
615 | (setq newres (subst-eq '<**> oldval res))) | |
616 | (t (setq newres res))) | |
617 | (cond (showstackp (funcall showstack-printer newres) (terpr)) | |
618 | (t (baktraceprint newres firsttime))) | |
619 | (setq levs (1- levs)) | |
620 | (setq oldval res)))))) | |
621 | ||
622 | (defun baktraceprint (form firsttime) | |
623 | (cond ((not firsttime) (patom " -- "))) | |
624 | (cond ((> (nwritn) 65) (terpr))) | |
625 | (cond ((atom form) (print form)) | |
626 | (t (let ((prinlevel 1) | |
627 | (prinlength 2)) | |
628 | (cond ((dtpr form) (print (car form))) | |
629 | (t (print form))))))) | |
630 | ||
631 | ||
632 | ;--- trace-funp :: see if this is a trace function call | |
633 | ; return t if this call is a result of tracing a function, or of calling | |
634 | ; showstack | |
635 | ; | |
636 | (defun trace-funp (expr) | |
637 | (or (and (symbolp expr) | |
638 | (memq expr '(T-eval T-apply T-setq | |
639 | eval int:showstack showstack-baktrace))) | |
640 | (and (dtpr expr) | |
641 | (cond ((symbolp (car expr)) | |
642 | (memq (car expr) '(trace-break T-cond T-eval T-setq | |
643 | T-apply))) | |
644 | ((dtpr (car expr)) | |
645 | (and (eq 'lambda (caar expr)) | |
646 | (eq 'T-arglst (caadar expr)))))))) | |
647 | ||
648 | ;--- subst-eq :: replace parts eq to new with old | |
649 | ; make new list structure | |
650 | ; | |
651 | (defun subst-eq (new old list) | |
652 | (cond ((eq old list) | |
653 | new) | |
654 | ((and (dtpr list) | |
655 | (subst-eqp old list)) | |
656 | (cond ((eq old (car list)) | |
657 | (cons new (subst-eq new old (cdr list)))) | |
658 | ((dtpr (car list)) | |
659 | (cons (subst-eq new old (car list)) | |
660 | (subst-eq new old (cdr list)))) | |
661 | (t (cons (car list) | |
662 | (subst-eq new old (cdr list)))))) | |
663 | (t list))) | |
664 | ||
665 | (defun subst-eqp (old list) | |
666 | (cond ((eq old list) t) | |
667 | ((dtpr list) | |
668 | (or (subst-eqp old (car list)) | |
669 | (subst-eqp old (cdr list)))) | |
670 | (t nil))) | |
671 | ||
672 | ||
673 | ||
674 | ;;; environment macros | |
675 | ||
676 | (defmacro environment (&rest args) | |
677 | (do ((xx args (cddr xx)) | |
678 | (when)(action)(res)) | |
679 | ((null xx) | |
680 | `(progn 'compile | |
681 | ,@(nreverse res))) | |
682 | (setq when (car xx) | |
683 | action (cadr xx)) | |
684 | (if (atom when) | |
685 | then (setq when (ncons when))) | |
686 | (if (and (dtpr action) | |
687 | (symbolp (car action))) | |
688 | then (setq action (cons (concat "environment-" (car action)) | |
689 | (cdr action)))) | |
690 | (push `(eval-when ,when ,action) res))) | |
691 | ||
692 | ||
693 | (defun environment-files fexpr (names) | |
694 | (mapc '(lambda (filename) | |
695 | (if (not (get filename 'version)) then (load filename))) | |
696 | names)) | |
697 | ||
698 | (defun environment-syntax fexpr (names) | |
699 | (mapc '(lambda (class) | |
700 | (caseq class | |
701 | (maclisp (cvttomaclisp)) | |
702 | (intlisp (cvttointlisp)) | |
703 | (ucilisp (cvttoucilisp)) | |
704 | ((franz franzlisp) (cvttofranzlisp)) | |
705 | (t (error "unknown syntax conversion type " class)))) | |
706 | names)) | |
707 | ||
708 | ;--- standard environments | |
709 | (defmacro environment-maclisp (&rest args) | |
710 | `(environment (compile load eval) (files machacks) | |
711 | (compile eval) (syntax maclisp) | |
712 | ,@args)) | |
713 | ||
714 | ||
715 | (defmacro environment-lmlisp (&rest args) | |
716 | `(environment (compile load eval) (files machacks lmhacks) | |
717 | (compile eval) (syntax maclisp) | |
718 | ,@args)) | |
719 | ||
720 | ;;;--- i/o functions redefined. | |
721 | ; The common I/O functions are redefined here to do tilde expansion | |
722 | ; if the tilde-expansion symbol is non nil | |
723 | (declare (special tilde-expansion)) | |
724 | ||
725 | ;First, define the current <name> as int:<name> | |
726 | ; | |
727 | (cond ((null (getd 'int:infile)) | |
728 | (putd 'int:infile (getd 'infile)) | |
729 | (putd 'int:outfile (getd 'outfile)) | |
730 | (putd 'int:fileopen (getd 'fileopen)) | |
731 | (putd 'int:cfasl (getd 'cfasl)) | |
732 | (putd 'int:fasl (getd 'fasl)))) | |
733 | ||
734 | ;Second, define the new functions: | |
735 | ||
736 | (defun infile (filename) | |
737 | (cond ((not (or (symbolp filename) (stringp filename))) | |
738 | (error "infile: non symbol or string filename " filename))) | |
739 | (cond (tilde-expansion (setq filename (tilde-expand filename)))) | |
740 | (int:infile filename)) | |
741 | ||
742 | (defun outfile (filename &optional args) | |
743 | (cond ((not (or (symbolp filename) (stringp filename))) | |
744 | (error "outfile: non symbol or string filename " filename))) | |
745 | (cond (tilde-expansion (setq filename (tilde-expand filename)))) | |
746 | (int:outfile filename args)) | |
747 | ||
748 | ;--- fileopen :: open a file with a non-standard stdio file | |
749 | ; [this should probably be flushed because it depends on stdio, | |
750 | ; which we may not use in the future] | |
751 | (defun fileopen (filename mode) | |
752 | (cond ((not (or (symbolp filename) (stringp filename))) | |
753 | (error "fileopen: non symbol or string filename " filename))) | |
754 | (cond (tilde-expansion (setq filename (tilde-expand filename)))) | |
755 | (int:fileopen filename mode)) | |
756 | ||
757 | (defun fasl (filename &rest args) | |
758 | (cond ((not (or (symbolp filename) (stringp filename))) | |
759 | (error "fasl: non symbol or string filename " filename))) | |
760 | (cond (tilde-expansion (setq filename (tilde-expand filename)))) | |
761 | (lexpr-funcall 'int:fasl filename args)) | |
762 | ||
763 | (defun cfasl (filename &rest args) | |
764 | (cond ((not (or (symbolp filename) (stringp filename))) | |
765 | (error "cfasl: non symbol or string filename " filename))) | |
766 | (cond (tilde-expansion (setq filename (tilde-expand filename)))) | |
767 | (lexpr-funcall 'int:cfasl filename args)) | |
768 | ||
769 | ||
770 | ;--- probef :: test if a file exists | |
771 | ; | |
772 | (defun probef (filename) | |
773 | (cond ((not (or (symbolp filename) (stringp filename))) | |
774 | (error "probef: non symbol or string filename " filename))) | |
775 | (sys:access filename 0)) | |
776 | ||
777 | ||
778 | ||
779 | (declare (special user-name-to-dir-cache)) | |
780 | (or (boundp 'user-name-to-dir-cache) (setq user-name-to-dir-cache nil)) | |
781 | ||
782 | ;--- username-to-dir | |
783 | ; given a user name, return the home directory name | |
784 | ; | |
785 | (defun username-to-dir (name) | |
786 | (cond ((symbolp name) (setq name (get_pname name))) | |
787 | ((stringp name)) | |
788 | (t (error "username-to-dir: Illegal name " name))) | |
789 | (let ((val (assoc name user-name-to-dir-cache))) | |
790 | (cond ((null val) | |
791 | (setq val (sys:getpwnam name)) | |
792 | (cond (val (push (cons name val) user-name-to-dir-cache)))) | |
793 | (t (setq val (cdr val)))) | |
794 | (cond (val (sys:getpwnam-dir val))))) | |
795 | ||
796 | ;--- username-to-dir-flush-cache :: clear all memory of where users are | |
797 | ; it is important to call this function upon startup to clear all | |
798 | ; knowledge of pathnames since this object file could have been copied | |
799 | ; from another machine | |
800 | ; | |
801 | (defun username-to-dir-flush-cache () | |
802 | (setq user-name-to-dir-cache nil)) | |
803 | ||
804 | ;--- lisp interface to int:franz-call | |
805 | ; | |
806 | (eval-when (compile eval) | |
807 | (setq fc_getpwnam 1 fc_access 2 fc_chdir 3 fc_unlink 4 | |
808 | fc_time 5 fc_chmod 6 fc_getpid 7 fc_stat 8 | |
809 | fc_gethostname 9 fc_link 10 fc_sleep 11 fc_nice 12)) | |
810 | ||
811 | ;--- sys:getpwnam | |
812 | ; (sys:getpwnam 'st_username) | |
813 | ; rets vector: (t_name x_uid x_gid t_dir) | |
814 | ; | |
815 | (defun sys:getpwnam (name) | |
816 | (cond ((or (symbolp name) (stringp name)) | |
817 | (int:franz-call #.fc_getpwnam name)) | |
818 | (t (error "sys:getpwnam : illegal name " name)))) | |
819 | ||
820 | ; return dir portion | |
821 | ; | |
822 | (defun sys:getpwnam-dir (vec) (vref vec 3)) | |
823 | ||
824 | (defun sys:access (name class) | |
825 | (cond ((and (or (symbolp name) (stringp name)) | |
826 | (fixp class)) | |
827 | (cond (tilde-expansion (setq name (tilde-expand name)))) | |
828 | (zerop (int:franz-call #.fc_access name class))) | |
829 | (t (error "sys:access : illegal name or class " name class)))) | |
830 | ||
831 | (defun chdir (dir) | |
832 | (cond ((or (symbolp dir) (stringp dir)) | |
833 | (cond (tilde-expansion (setq dir (tilde-expand dir)))) | |
834 | (cond ((zerop (int:franz-call #.fc_chdir dir))) | |
835 | (t (error "cd: can't chdir to " dir)))) | |
836 | (t (error "chdir: illegal argument " dir)))) | |
837 | ||
838 | ;--- sys:unlink :: unlink (remove) a file | |
839 | ; | |
840 | (defun sys:unlink (name) | |
841 | (cond ((or (symbolp name) (stringp name)) | |
842 | (cond (tilde-expansion (setq name (tilde-expand name)))) | |
843 | (cond ((zerop (int:franz-call #.fc_unlink name))) | |
844 | (t (error "sys:unlink : unlink failed of " name)))) | |
845 | (t (error "sys:unlink : illegal argument " name)))) | |
846 | ||
847 | ;--- sys:link :: make (hard) link to file | |
848 | ; | |
849 | (defun sys:link (oldname newname) | |
850 | (cond ((or (symbolp oldname) (stringp oldname)) | |
851 | (cond (tilde-expansion (setq oldname (tilde-expand oldname)))) | |
852 | (cond ((or (symbolp newname) (stringp newname)) | |
853 | (cond (tilde-expansion (setq newname | |
854 | (tilde-expand newname)))) | |
855 | (cond ((zerop (int:franz-call #.fc_link oldname newname))) | |
856 | (t (error "sys:link : unlink failed of " | |
857 | oldname newname)))) | |
858 | (t (error "sys:unlink : illegal argument " newname)))) | |
859 | (t (error "sys:unlink : illegal argument " oldname)))) | |
860 | ||
861 | ;--- sys:time :: return 'absolute' time in seconds | |
862 | ; | |
863 | (defun sys:time () | |
864 | (int:franz-call #.fc_time)) | |
865 | ||
866 | ;--- sys:chmod :: change mode of file | |
867 | ; return t iff it succeeded. | |
868 | ; | |
869 | (defun sys:chmod (name mode) | |
870 | (cond ((and (or (stringp name) (symbolp name)) | |
871 | (fixp mode)) | |
872 | (cond (tilde-expansion (setq name (tilde-expand name)))) | |
873 | (cond ((zerop (int:franz-call #.fc_chmod name mode))) | |
874 | (t (error "sys:chmod : chmod failed of " name)))) | |
875 | (t (error "sys:chmod : illegal argument(s): " name mode)))) | |
876 | ||
877 | (defun sys:getpid () | |
878 | (int:franz-call #.fc_getpid)) | |
879 | ||
880 | (defun filestat (name) | |
881 | (let (ret) | |
882 | (cond ((or (symbolp name) (stringp name)) | |
883 | (cond (tilde-expansion (setq name (tilde-expand name)))) | |
884 | (cond ((null (setq ret (int:franz-call #.fc_stat name))) | |
885 | (error "filestat : file doesn't exist " name)) | |
886 | (t ret))) | |
887 | (t (error "filestat : illegal argument " name))))) | |
888 | ||
889 | ;--- sys:gethostname :: retrieve the current host name as a string | |
890 | ; | |
891 | (defun sys:gethostname () | |
892 | (int:franz-call #.fc_gethostname)) | |
893 | ||
894 | (defun sleep (seconds) | |
895 | ;; (sleep 'x_seconds) | |
896 | ;; pause for the given number of seconds | |
897 | (cond ((fixp seconds) (int:franz-call #.fc_sleep seconds)) | |
898 | (t (error "sleep: non-fixnum argument " seconds)))) | |
899 | ||
900 | (defun sys:nice (delta-priority) | |
901 | ;; modify the priority by the given amount | |
902 | (cond ((fixp delta-priority) (int:franz-call #.fc_nice delta-priority)) | |
903 | (t (error "sys:nice: non-fixnum argument " delta-priority)))) |