![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to common2.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 common2.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 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:
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))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.