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