![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to auxfns1.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib|
Return to auxfns1.l CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib |
1.1 root 1:
2:
3:
4: ;--- msg - arg1 ... arguments of the form described below
5: ; B - print out a blank
6: ; N - print out a newline (terpr)
7: ; (B n) - print out n blanks
8: ; (P p) - henceforth print on port p
9: ; atom - patom this exactly (no evaluation)
10: ; other - evaluate and patom this expression.
11: ;
12: (def msg
13: (macro (lis)
14: `(progn ,@(msgmake (cdr lis) 'nil))))
15:
16: (eval-when (eval compile load)
17: (def msgmake
18: (lambda (forms outport)
19: ((lambda (thisform)
20:
21: (cond ((null forms) `((drain ,@outport)))
22: ((and (eq 'B thisform) (setq thisform '" ") nil))
23: ((eq 'N thisform) (cons `(terpr ,@outport)
24: (msgmake (cdr forms) outport)))
25: ((atom thisform) (cons `(patom ',thisform
26: ,@outport)
27: (msgmake (cdr forms) outport)))
28: ((eq 'P (car thisform)) (msgmake (cdr forms)
29: `(,@(cdr thisform))))
30:
31: ((eq 'B (car thisform)) (cons `(printblanks ,@(cdr thisform)
32: ,outport)
33: (msgmake (cdr forms) outport)))
34: (t (cons `(patom ,thisform ,@outport)
35: (msgmake (cdr forms) outport)))))
36: (car forms)))))
37:
38: (def printblanks
39: (lambda (n prt)
40: (do ((i n (sub1 i)))
41: ((lessp i 1))
42: (patom '" " prt))))
43:
44:
45:
46:
47: ; ==============================================
48: ;
49: ; (linelength [numb])
50: ;
51: ; sets the linelength (actually just varib linel) to the
52: ; number given: numb
53: ; if numb is not given, the current line length is returned
54: ; =================================================
55:
56: (setq linel 80)
57: (def linelength
58: (nlambda (form)
59: (cond ((null form) linel )
60: ((numberp (car form)) (setq linel (car form)))
61: (t linel))))
62:
63: ; ========================================
64: ;
65: ; (charcnt port)
66: ; returns the number of characters left on the current line
67: ; on the given port
68: ;
69: ; =======================================
70:
71:
72: (def charcnt
73: (lambda (port) (diff linel (nwritn port))))
74:
75: (def nthcdr
76: (lambda (n x)
77: (cond ((equal n 0) x)
78: ((lessp n 0) (cons nil x))
79: (t (nthcdr (sub1 n) (cdr x) )))))
80:
81: ;r lambda: (nthrest numb list)
82: ;- args: numb - integer
83: ;- list - list
84: ;- returns:the rest of the list beginning at the numb'th element.
85: ;- for convience, (nthrest 0 list) equals (nthrest 1 list)
86: ;- equals list. This is designed to be similar to nthelem
87: ;- which returns the nth element of a list.
88:
89: (def nthrest
90: (lambda (number list)
91: (cond ((lessp number 2) list)
92: (t (nthrest (sub1 number) (cdr list))))))
93:
94:
95: ;;==============================
96: ; (assqr val alist)
97: ; acts much like assq, it looks for val in the cdr of elements of
98: ; the alist and returns the element if found.
99: ; fix this when the compiler works
100: (eval-when nil (def assqr
101: (lambda (val alist)
102: (do ((al alist (cdr al)))
103: ((null al) nil)
104: (cond ((eq val (cdar al)) (return (car al))))))))
105:
106:
107: ; ====================
108: ; (listp 'x) is t if x is a non-atom or nil
109: ; ====================
110: (def listp (lambda (val) (or (dtpr val) (null val))))
111:
112:
113:
114: ;--- memcar - VAL : lispval
115: ; - LIS : list
116: ; returns t if VAL found as the car of a top level element.
117: ;temporarily turn this off till the compiler can handle it.
118: (eval-when nil (def memcar
119: (lambda (a l)
120: (do ((ll l (cdr ll)))
121: ((null ll) nil)
122: (cond ((equal (caar ll) a) (return (cdar ll))))))))
123:
124: ; =================================
125: ;
126: ; (memcdr 'val 'listl)
127: ;
128: ; the list listl is searched for a list
129: ; with cdr equal to val. if found, the
130: ; car of that list is returned.
131: ; ==================================
132: ;fix this when compiler works ok
133: (eval-when nil (def memcdr
134: (lambda (a l)
135: (do ((ll l (cdr ll)))
136: ((null ll) nil)
137: (cond ((equal (cdar ll) a) (return (caar l))))))))
138:
139:
140: (def apply*
141: (nlambda ($x$)
142: (eval (cons (eval (car $x$)) (cdr $x$)))))
143:
144:
145:
146:
147:
148: ; =======================================
149: ; pretty printer top level routine pp
150: ;
151: ; calling form- (pp arg1 arg2 ... argn)
152: ; the args may be names of functions, atoms with associated values
153: ; or output descriptors.
154: ; if argi is:
155: ; an atom - it is assumed to be a function name, if there is no
156: ; function property associated with it,then it is assumed
157: ; to be an atom with a value
158: ; (P port)- port is the output port where the results of the
159: ; pretty printing will be sent.
160: ; poport is the default if no (P port) is given.
161: ; (F fname)- fname is a file name to write the results in
162: ; (A atmname) - means, treat this as an atom with a value, dont
163: ; check if it is the name of a function.
164: ;
165: (declare (special $outport$ $fileopen$ ))
166:
167: ; printret is like print yet it returns the value printed, this is used
168: ; by pp
169: (def printret
170: (macro ($l$)
171: `(progn (print ,@(cdr $l$)) ,(cadr $l$))))
172:
173: (def pp
174: (nlambda ($xlist$)
175: (prog ($outport$ $cur$ $fileopen$ $prl$ $atm$)
176:
177: (setq $outport$ poport) ; default port
178: ; check if more to do, if not close output file if it is
179: ; open and leave
180:
181:
182: toploop (cond ((null (setq $cur$ (car $xlist$)))
183: (condclosefile)
184: (return t)))
185:
186: (cond ((dtpr $cur$)
187: (cond ((equal 'P (car $cur$)) ; specifying a port
188: (condclosefile) ; close file if open
189: (setq $outport$ (eval (cadr $cur$))))
190:
191: ((equal 'F (car $cur$)) ; specifying a file
192: (condclosefile) ; close file if open
193: (setq $outport$ (outfile (cadr $cur$))
194: $fileopen$ t))
195:
196: ((equal 'A (car $cur$)) ; declaring atomness
197: (setq $atm$ t)
198: (setq $cur$ (cadr $cur$))
199: (go midstuff))
200:
201: ((eq 'V (car $cur$)) ; print value only
202: (setq $atm$ 'value)
203: (setq $cur$ (cadr $cur$))
204: (go midstuff))
205:
206: (t (msg N "bad arg to pp: " (or $cur$))))
207: (go botloop)))
208: midstuff ; process the atom or function
209:
210: (cond ((eq 'value $atm$)
211: (setq $prl$ (eval $cur$)))
212:
213: ((or $atm$ (null (getd $cur$))) ; check if is atom
214: (cond ((boundp $cur$) ; yes, see if bound
215: (setq $prl$ (list 'setq $cur$ (list 'quote
216: (eval $cur$)))))
217: (t (msg N "pp: atom " (or $cur$) " is unbound")
218: (go botloop))))
219:
220: ((bcdp (getd $cur$)) ; is a fcn, see if bcd
221: (msg N "pp: function " (or $cur$) " is machine coded (bcd) ")
222: (go botloop))
223:
224: (t (setq $prl$ (list 'def $cur$ (getd $cur$)))))
225:
226: ; now print it
227:
228: ($prpr $prl$)
229: (terpr $outport$)
230: (setq $atm$ nil) ; clear flag
231:
232: botloop (setq $xlist$ (cdr $xlist$))
233:
234: (go toploop))))
235:
236:
237:
238: (def condclosefile
239: (lambda nil
240: (cond ($fileopen$
241: (terpr $outport$)
242: (close $outport$)
243: (setq $fileopen$ nil)))))
244:
245: ;
246: ; these routines are meant to be used by pp but since
247: ; some people insist on using them we will set $outport$ to nil
248: ; as the default
249: (setq $outport$ nil)
250:
251:
252: (def $prpr
253: (lambda (x)
254: (cond ((not (boundp '$outport$)) (setq $outport$ poport)))
255: (terpr $outport$)
256: ($prdf x 0 0)))
257:
258:
259: (declare (special m))
260:
261: (def $prdf
262: (lambda (l n m)
263: (prog ()
264: ($tocolumn n)
265: a (cond ((or (atom l)
266: (lessp (add m (flatsize l (chrct $outport$)))
267: (chrct $outport$)))
268: (return (printret l $outport$)))
269: ((and ($patom1 lpar)
270: (lessp 2 (length l))
271: (atom (car l)))
272: (prog (c f g h)
273: (setq g
274: (cond ((member (car l) '(lambda nlambda))
275: -7)
276: (t
277: 0)))
278: (setq f (equal (printret (car l) $outport$) 'prog))
279: ($patom1 ' " ")
280: (setq c ($dinc))
281: a ($prd1
282: (cdr l)
283: (add
284: c
285: (cond ((setq h (and f
286: (cadr l)
287: (atom (cadr l))))
288: -5)
289: (t g))))
290: (cond ((cdr (setq l (cdr l)))
291: (cond ((or (null h) (atom (cadr l)))
292: (terpr $outport$)))
293: (go a)))))
294: ((prog (c)
295: (setq c ($dinc))
296: a ($prd1 l c)
297: (cond ((setq l (cdr l))
298: (terpr $outport$)
299: (go a))))))
300: b ($patom1 rpar))))
301:
302:
303:
304: (def $prd1
305: (lambda (l n)
306: (prog ()
307: ($prdf (car l)
308: n
309: (cond ((null (setq l (cdr l))) (add m 1))
310: ((atom l) (setq n nil) (plus 4 m (pntlen l)))
311: (t m)))
312: (cond ((null n)
313: ($patom1 ' " . ")
314: (return (printret l $outport$)))))))
315:
316:
317:
318:
319:
320: (def $dinc (lambda () (diff (linelength $outport$) (chrct $outport$))))
321:
322:
323: (def $tocolumn
324: (lambda (n)
325: (cond ((greaterp (setq n (diff n (nwritn $outport$))) 0)
326: (do ((i 0 (add1 i)))
327: ((equal i n))
328: (patom '" " $outport$))))))
329:
330: ; ========================================
331: ;
332: ; (charcnt port)
333: ; returns the number of characters left on the current line
334: ; on the given port
335: ;
336: ; =======================================
337:
338:
339: (def charcnt
340: (lambda (port) (diff linel (nwritn port))))
341:
342: (putd 'chrct (getd 'charcnt))
343:
344: (def $patom1 (lambda (x) (patom x $outport$)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.