![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ucisubset.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 / pearl|
Return to ucisubset.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl |
1.1 root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ucisubset.l ;;;;;;;;;;;;;;;;;;;;;;;;;
2: ; Functions for a subset of UCI Lisp that are either used by PEARL
3: ; or were needed by PEARL users at Berkeley.
4: ; This was purposely designed to interfere as little as necessary
5: ; with Franz Lisp, so things like the standard UCI do macro
6: ; and the Charniak (et al) let macro are not provided.
7: ; Includes what used to be sprint.l (at the end).
8: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9: ; Copyright (c) 1983 , The Regents of the University of California.
10: ; All rights reserved.
11: ; Authors: Joseph Faletti and Michael Deering.
12:
13: (eval-when (compile)
14: (declare (special defmacro-for-compiling *savedefs*))
15: (setq defmacro-for-compiling t)
16: (setq *savedefs* nil))
17:
18: (declare (macros t))
19:
20: (defvar poport)
21: (defvar pparm1 50)
22: (defvar pparm2 100)
23: (defvar lpar)
24: (defvar rpar)
25: (defvar form)
26: (defvar linel)
27: (defvar *outport* nil)
28: (defvar *fileopen*)
29: (defvar prettyprops '((comment . pp-comment)
30: (function . pp-function)
31: (value . pp-value)))
32:
33: (declare (localf *patom1))
34:
35: (defvar *file* nil)
36: (defvar *oldfunctiondefinition*)
37: (defvar *savedefs* t)
38:
39: (defmacro funl (&rest rest)
40: `(function (lambda .,rest)))
41:
42: ;
43: ; ucilisp (de df dm) declare function macros.
44: ;
45: ; (DE name args body) -> declare exprs and lexprs.
46: ; If *savedefs* is t and function has previous definition,
47: ; save it under the property OLDDEF, and return '(name Redefined).
48: ; Otherwise, just do a defun and return name (as with defun).
49: ;
50: (defun de macro (l)
51: (cond (*savedefs*
52: `(progn 'compile
53: (setq *oldfunctiondefinition* (getd ',(cadr l)))
54: (defun .,(cdr l))
55: (and *file*
56: (putprop ',(cadr l) *file* 'sourcefile))
57: (cond (*oldfunctiondefinition*
58: (putprop ',(cadr l) *oldfunctiondefinition* 'olddef)
59: (list ',(cadr l) 'Redefined))
60: ( t ',(cadr l)))))
61: ( t `(defun .,(cdr l)))))
62:
63: ;
64: ; (df name args body) -> declare fexprs.
65: ;
66: (defun df macro (l)
67: (cond (*savedefs*
68: `(progn 'compile
69: (setq *oldfunctiondefinition* (getd ',(cadr l)))
70: (defun ,(cadr l) fexpr .,(cddr l))
71: (and *file*
72: (putprop ',(cadr l) *file* 'sourcefile))
73: (cond (*oldfunctiondefinition*
74: (putprop ',(cadr l) *oldfunctiondefinition* 'olddef)
75: (list ',(cadr l) 'Redefined))
76: ( t ',(cadr l)))))
77: ( t `(defun ,(cadr l) fexpr .,(cddr l)))))
78:
79: ;
80: ; macro's are not compiled except under the same
81: ; conditions as in franz lisp.
82: ; (usually just do (declare (macros t))
83: ; to have macros also compiled).
84: ;
85: ;
86: ; (dm name args body) -> declare macros. same as (defun name 'macro body)
87: ;
88: (defun dm macro (l)
89: (cond (*savedefs*
90: `(progn 'compile
91: (setq *oldfunctiondefinition* (getd ',(cadr l)))
92: (defun ,(cadr l) macro .,(cddr l))
93: (and *file*
94: (putprop ',(cadr l) *file* 'sourcefile))
95: (cond (*oldfunctiondefinition*
96: (putprop ',(cadr l) *oldfunctiondefinition* 'olddef)
97: (list ',(cadr l) 'Redefined))
98: ( t ',(cadr l)))))
99: ( t `(defun ,(cadr l) macro .,(cddr l)))))
100:
101: ; UCI Lisp character macros are non-separating when occurring in
102: ; the middle of atoms.
103: (eval-when (compile load eval)
104: (add-syntax-class 'vucisplicemacro
105: '(csplicing-macro escape-when-first))
106: (add-syntax-class 'vucireadmacro
107: '(cmacro escape-when-first)))
108:
109: ;
110: ; ucilisp functions which declare character macros.
111: ;
112: ;
113: ; dsm - declare splicing read macro.
114: ;
115: (defun dsm macro (l)
116: (cond (*savedefs*
117: `(progn 'compile
118: (setq *oldfunctiondefinition*
119: (and (memq (getsyntax ',(cadr l))
120: '(vucireadmacro vucisplicemacro
121: vsplicing-macro vmacro))
122: (get ',(cadr l) readtable)))
123: (eval-when (compile load eval)
124: (setsyntax ',(cadr l) 'vucisplicemacro ',(caddr l)))
125:
126: (and *file*
127: (putprop ',(cadr l) *file* 'sourcefile))
128: (cond (*oldfunctiondefinition*
129: (putprop ',(cadr l) *oldfunctiondefinition* 'oldmacro)
130: (list ',(cadr l) 'Redefined))
131: ( t ',(cadr l)))))
132: ( t `(eval-when (compile load eval)
133: (setsyntax ',(cadr l) 'vucisplicemacro ',(caddr l))))))
134:
135: ;
136: ; drm - declare read macro.
137: ;
138: (defun drm macro (l)
139: (cond (*savedefs*
140: `(progn 'compile
141: (setq *oldfunctiondefinition*
142: (and (memq (getsyntax ',(cadr l))
143: '(vucireadmacro vucisplicemacro
144: vsplicing-macro vmacro))
145: (get ',(cadr l) readtable)))
146: (eval-when (compile load eval)
147: (setsyntax ',(cadr l) 'vucireadmacro ',(caddr l)))
148:
149: (and *file*
150: (putprop ',(cadr l) *file* 'sourcefile))
151: (cond (*oldfunctiondefinition*
152: (putprop ',(cadr l) *oldfunctiondefinition* 'oldmacro)
153: (list ',(cadr l) 'Redefined))
154: ( t ',(cadr l)))))
155: ( t `(eval-when (compile load eval)
156: (setsyntax ',(cadr l) 'vucireadmacro ',(caddr l))))))
157:
158: ;
159: ; ucilisp selectq function. (written by jkf)
160: ;
161: (defun selectq* macro (form)
162: ((lambda (x)
163: `((lambda (,x)
164: (cond
165: ,@(maplist
166: (function
167: (lambda (ff)
168: (cond ((null (cdr ff))
169: `( t ,(car ff)))
170: ((atom (caar ff))
171: `((eq ,x ',(caar ff))
172: . ,(cdar ff)))
173: (t
174: `((memq ,x ',(caar ff))
175: . ,(cdar ff))))))
176: (cddr form))))
177: ,(cadr form)))
178: (gensym 'z)))
179:
180: (defun some macro (l)
181: `((lambda (f a)
182: (prog ()
183: loop
184: (cond ((null a) (return nil))
185: ((funcall f (car a))
186: (return a))
187: ( t (setq a (cdr a))
188: (go loop)))))
189: ,(cadr l)
190: ,(caddr l)))
191:
192: (defmacro subset (fun lis)
193: `(mapcan (function (lambda (ele)
194: (cond ((funcall ,fun ele) (ncons ele)))))
195: ,lis))
196:
197: (defun length (l)
198: (prog (n)
199: (setq n 0)
200: loop
201: (and (atom l)
202: (return n))
203: (setq l (cdr l))
204: (setq n (1+ n))
205: (go loop)))
206:
207: (defmacro apply* (fcn args)
208: `(prog (fcndef)
209: (return
210: (cond ((atom ,fcn)
211: (or (and (eq 'binary (type ,fcn))
212: (setq fcndef ,fcn))
213: (setq fcndef (getd ,fcn)))
214: (cond ((or (and (eq 'binary (type fcndef))
215: (eq 'macro (getdisc fcndef)))
216: (and (dtpr fcndef)
217: (eq 'macro (car fcndef))))
218: (funcall ,fcn (cons ,fcn ,args)))
219: ( t (apply ,fcn ,args))))
220: ( t (apply ,fcn ,args))))))
221:
222: (defmacro every (fcn args)
223: `(prog (kkkk)
224: (setq kkkk ,args)
225: loop
226: (cond ((null kkkk)
227: (return t))
228: ((apply* ,fcn (list (pop kkkk)))
229: (go loop)))
230: (return nil)))
231:
232: (defun timer fexpr (request)
233: (let ((timein (ptime)) timeout result cpu garbage)
234: (prog ()
235: loop
236: (setq result (eval (car request)))
237: (and (setq request (cdr request))
238: (go loop)))
239: (setq timeout (ptime))
240: (setq cpu (quotient (fix (times 1000
241: (quotient (difference (car timeout)
242: (car timein))
243: 60.0)))
244: 1000.0))
245: (setq garbage (quotient (fix (times 1000
246: (quotient (difference (cadr timeout)
247: (cadr timein))
248: 60.0)))
249: 1000.0))
250: (print (cons cpu garbage))
251: (terpri)
252: result))
253:
254: (putd 'consp (getd 'dtpr))
255:
256: (putd 'msgprintfn (getd 'patom))
257:
258: ;
259: ; ucilisp msg function. (written by jkf)
260: ;
261: (defmacro msg ( &rest body)
262: `(progn ,@(mapcar
263: (function
264: (lambda (form)
265: (cond ((eq form t) '(line-feed 1))
266: ((numberp form)
267: (cond ((>& form 0)
268: `(msg-space ,form))
269: ( t `(line-feed ,(minus form)))))
270: ((atom form) `(msgprintfn ,form))
271: ((eq (car form) t) '(msgprintfn '\ ))
272: ((eq (car form) 'e)
273: `(msgprintfn ,(cadr form)))
274: ( t `(msgprintfn ,form)))))
275: body)
276: nil)) ; return nil!
277:
278: ;
279: ; this NEED NOT be fixed to not use do.
280: ;
281: (defmacro msg-space (n)
282: (cond ((eq 1 n) '(patom '" "))
283: ( t `(do i ,n (1- i) (<& i 1) (patom '\ )))))
284:
285: (defmacro line-feed (n)
286: (cond ((eq 1 n) '(terpr))
287: ( t `(do i ,n (1- i) (<& i 1) (terpr)))))
288:
289: ; compatability functions: functions required by uci lisp but not
290: ; present in franz
291: ;
292: ; union uses the franz do loop (not the ucilisp one).
293:
294: (defvar membfn 'member)
295:
296: (defun union n
297: (and (> n 0)
298: (do ((res (ncons nil))
299: (i 1 (1+ i)))
300: ((eq i (1+ n)) (car res))
301: (mapc (function
302: (lambda (arg)
303: (or (apply* membfn (list arg (car res)))
304: (tconc res arg))))
305: (arg i)))))
306:
307: (defun enter (v l)
308: (cond ((apply* membfn (list v l)) l)
309: ( t (cons v l))))
310:
311: (defun append2 (a b &aux (c (ncons nil)))
312: (do ((a a (cdr a)))
313: ((null a))
314: (tconc c (car a)))
315: (rplacd (cdr c) b)
316: (car c))
317:
318: (putd 'noduples (getd 'union))
319: (putd 'append* (getd 'append))
320: (putd '*append (getd 'append))
321: (putd '*dif (getd 'diff))
322: (putd '*eval (getd 'eval))
323: (putd '*great (getd 'greaterp))
324: (putd '*less (getd 'lessp))
325: (putd '*max (getd 'max))
326: (putd '*nconc (getd 'nconc))
327: (putd '*plus (getd 'plus))
328: (putd '*times (getd 'times))
329: (putd 'expandmacro (getd 'macroexpand))
330: (putd 'mapcl (getd 'mapcar))
331: (putd 'memb (getd 'member))
332:
333: (dm clrbfi ()
334: '(drain piport))
335:
336: (defun save fexpr (l)
337: (let ((fcnname (car l)))
338: (putprop fcnname (getd fcnname) 'olddef)))
339:
340: (defun unsave fexpr (l)
341: (let* ((name (car l))
342: (old (get name 'olddef)))
343: (and old
344: (putprop name (getd name) 'olddef)
345: (putd name old))
346: old))
347:
348: (putd 'atcat (getd 'concat))
349:
350: (putd 'gt (getd '>))
351: (putd 'lt (getd '<))
352:
353: (defun le macro (x)
354: `(not (> .,(cdr x))))
355:
356: (defun ge macro (x)
357: `(not (< .,(cdr x))))
358:
359: (defun litatom macro (x)
360: `(and (atom .,(cdr x))
361: (not (numberp .,(cdr x)))))
362:
363: (putd 'peekc (getd 'tyipeek))
364:
365: ;
366: ; unbound - (setq x (unbound)) will unbind x.
367: ; "this [code] is sick" - jkf.
368: ;
369: (defun unbound macro (l)
370: `(fake -4))
371:
372: (or (getd 'franzboundp)
373: (putd 'franzboundp (getd 'boundp)))
374:
375: (defun boundp (item)
376: (cond ((arrayp item))
377: ((franzboundp item))))
378:
379: (defvar *dskin* t)
380: (defvar piport)
381:
382: ;(eval-when (load eval compile)
383: ; (or (boundp '*dskin*)
384: ; (setq *dskin* t)))
385:
386: (eval-when (load eval)
387: (or (getd 'dskprintfn)
388: (putd 'dskprintfn (getd 'patom))))
389:
390: (defun dskin fexpr (l)
391: (mapc 'dskin1 l)
392: (terpri) t )
393:
394: (defun dskin1 (*file*)
395: (prog (port)
396: (terpri)
397: (patom '|>>>|)
398: (cond ((null (setq port (car (errset (infile *file*) nil))))
399: (patom '|couldn't open file |)
400: (patom *file*))
401: ( t (patom *file*)
402: (patom '| |)
403: (dskin2 port)
404: (close port)))))
405:
406: (defun dskin2 (port)
407: (prog (expr value)
408: loop
409: (cond ((null (setq expr (read port))) nil)
410: ( t (cond ((memq (car expr) '(de df defmacro dm drm
411: dsm setq def defun))
412: (cond ((memq *dskin* '(name both))
413: (patom (cadr expr))
414: (patom '|: |))))
415: ((eq (car expr) 'create)
416: (cond ((memq *dskin* '(name both))
417: (patom (caddr expr))
418: (patom '|: |)))))
419: (setq value (eval expr))
420: (and (memq *dskin* '(t both))
421: (or (eq value '*invisible*)
422: (progn (dskprintfn value)
423: (patom '| |))))
424: (go loop)))))
425:
426: (defun nequal (arg1 arg2)
427: (not (equal arg1 arg2)))
428:
429: (defun readl fexpr (l)
430: (cond ((null l) (readl1 nil))
431: ( t (readl1 (eval (car l))))))
432:
433: (putd 'lineread (getd 'readl))
434:
435: (defun readl1 (flag)
436: (cond ((not (and flag
437: (eq (tyipeek) 10)
438: (tyi)))
439: (prog (input)
440: (setq input (ncons nil)) ; initialize for tconc.
441: loop
442: (cond ((not (eq (tyipeek) 10))
443: (tconc input (read))
444: (go loop))
445: ( t ; the actual list is in the CAR.
446: (tyi)
447: (return (car input))))))))
448:
449: (defun defv fexpr (l)
450: (set (car l) (cadr l)))
451:
452: (defun remprops (item proplist)
453: (mapc (funl (prop)
454: (remprop item prop))
455: proplist)
456: nil)
457:
458: (defun addprop (id value prop)
459: (putprop id (enter value (get id prop)) prop))
460:
461: (defun nconc1 (l elmt)
462: (rplacd (last l) (cons elmt nil)))
463:
464: (defun dremove (elmt l)
465: (let (newl)
466: (cond ((dtpr l)
467: (cond ((eq elmt (car l))
468: (setq newl (delq elmt l))
469: (rplaca l (car newl))
470: (rplacd l (cdr newl)))
471: ( t (delq elmt l))))
472: ( t l))))
473:
474: (defun intersection (set1 set2)
475: (prog (inter)
476: (mapc (funl (elt) (putprop elt t '*inter*)) set1)
477: (mapc (funl (elt) (and (get elt '*inter*)
478: (setq inter (cons elt inter))))
479: set2)
480: (mapc (funl (elt) (remprop elt '*inter*)) set1)
481: (return inter)))
482:
483: (defun initsym1 expr (l)
484: (prog (num)
485: (cond ((dtpr l)
486: (setq num (cadr l))
487: (setq l (car l)))
488: ( t (setq num 0)))
489: (putprop l num 'symctr)
490: (return (concat l num))))
491:
492: (defun initsym fexpr (l)
493: (mapcar (function initsym1) l))
494:
495: (defun newsym fexpr (l)
496: (let ((name (car l)))
497: (concat name
498: (putprop name
499: (1+ (or (get name 'symctr)
500: -1))
501: 'symctr))))
502:
503: (defun oldsym fexpr (l)
504: (let ((sym (car l)))
505: (concat sym (get sym 'symctr))))
506:
507: (defun allsym fexpr (l)
508: (prog (num symctr syms)
509: (cond ((dtpr (car l))
510: (setq num (cadar l))
511: (setq l (caar l)))
512: ( t (setq num 0)
513: (setq l (car l))))
514: (or (setq symctr (get l 'symctr))
515: (return))
516: loop
517: (and (>& num symctr)
518: (return syms))
519: (setq syms (cons (concat l symctr) syms))
520: (setq symctr (1- symctr))
521: (go loop)))
522:
523: (defun remsym1 expr (l)
524: (prog1 (funcall (function oldsym)
525: (cond ((dtpr (car l)) (car l))
526: ( t l)))
527: (mapc (function remob) (apply (function allsym) l))
528: (cond ((dtpr (car l)) (putprop (caar l) (1- (cadar l)) 'symctr))
529: ( t (remprop (car l) 'symctr)))))
530:
531: (defun remsym fexpr (l)
532: (maplist (function remsym1) l))
533:
534: (defun symstat fexpr (l)
535: (mapcar (funl (k)
536: (list k (get k 'symctr)))
537: l))
538:
539: (defun suflist (itemlist num)
540: (cond ((dtpr itemlist) (nth (1+ num) itemlist))))
541:
542: ;;;;;;;;;;;;;;;;;;;;;;; (formerly sprint.l) ;;;;;;;;;;;;;;;;;;;;;;;;
543: ; A few additions to the library file ucbpp.l, mostly to add
544: ; a UCI Lisp-like "sprint" including some modifications for
545: ; more flexible printmacros.
546: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
547:
548: ; Moved to front and converted to defvar.
549: ; (declare (special poport pparm1 pparm2 lpar rpar form linel))
550: ; (declare (localf *patom1))
551: ; (declare (special *outport* *fileopen* prettyprops))
552:
553: ; =======================================
554: ; pretty printer top level routine pp
555: ;
556: ;
557: ; calling form- (pp arg1 arg2 ... argn)
558: ; the args may be names of functions, atoms with associated values
559: ; or output descriptors.
560: ; if argi is:
561: ; an atom - it is assumed to be a function name, if there is no
562: ; function property associated with it,then it is assumed
563: ; to be an atom with a value
564: ; (P port)- port is the output port where the results of the
565: ; pretty printing will be sent.
566: ; poport is the default if no (P port) is given.
567: ; (F fname)- fname is a file name to write the results in
568: ; (A atmname) - means, treat this as an atom with a value, dont
569: ; check if it is the name of a function.
570: ; (E exp)- evaluate exp without printing anything
571: ; other - pretty-print the expression as is - no longer an error
572: ;
573: ; Also, rather than printing only a function defn or only a value, we will
574: ; let prettyprops decide which props to print. Finally, prettyprops will
575: ; follow the CMULisp format where each element is either a property
576: ; or a dotted pair of the form (prop . fn) where in order to print the
577: ; given property we call (fn id val prop). The special properties
578: ; function and value are used to denote those "properties" which
579: ; do not actually appear on the plist.
580: ;
581: ; [history of this code: originally came from Harvard Lisp, hacked to
582: ; work under franz at ucb, hacked to work at cmu and finally rehacked
583: ; to work without special cmu macros]
584: ; THEN, hacked to use for PEARL.
585:
586: ; moved to front.
587: ;(setq prettyprops '((comment . pp-comment)
588: ; (function . pp-function)
589: ; (value . pp-value)))
590:
591: ; printret is like print yet it returns the value printed, this is used
592: ; by pp
593: (def printret
594: (macro (*l*)
595: `(progn (print ,@(cdr *l*)) ,(cadr *l*))))
596:
597: (def pp
598: (nlambda (*xlist*)
599: (prog (*outport* *cur* *fileopen* *prl* *atm*)
600:
601: (setq *outport* poport) ; default port
602: ; check if more to do, if not close output file if it is
603: ; open and leave
604:
605:
606: toploop (cond ((null (setq *cur* (car *xlist*)))
607: (condclosefile)
608: (terpr)
609: (return t)))
610:
611: (cond ((dtpr *cur*)
612: (cond ((equal 'P (car *cur*)) ; specifying a port
613: (condclosefile) ; close file if open
614: (setq *outport* (eval (cadr *cur*))))
615:
616: ((equal 'F (car *cur*)) ; specifying a file
617: (condclosefile) ; close file if open
618: (setq *outport* (outfile (cadr *cur*))
619: *fileopen* t))
620:
621:
622: ((equal 'E (car *cur*))
623: (eval (cadr *cur*)))
624:
625: ( t (terpri *outport*)
626: (*prpr *cur*))) ;-DNC inserted
627: (go botloop)))
628:
629:
630: (mapc (function
631: (lambda (prop)
632: (prog (printer)
633: (cond ((dtpr prop)
634: (setq printer (cdr prop))
635: (setq prop (car prop)))
636: ( t (setq printer 'pp-prop)))
637: (cond ((eq 'value prop)
638: (cond ((boundp *cur*)
639: (apply printer
640: (list *cur*
641: (eval *cur*)
642: 'value)))))
643: ((eq 'function prop)
644: (cond ((and (getd *cur*)
645: (not (bcdp (getd *cur*))))
646: (apply printer
647: (list *cur*
648: (getd *cur*)
649: 'function)))))
650: ((get *cur* prop)
651: (apply printer
652: (list *cur*
653: (get *cur* prop)
654: prop)))))))
655: prettyprops)
656:
657:
658: botloop (setq *xlist* (cdr *xlist*))
659:
660: (go toploop))))
661:
662: ; moved to front.
663: ;(setq pparm1 50 pparm2 100)
664:
665: ; -DNC These "prettyprinter parameters" are used to decide when we should
666: ; quit printing down the right margin and move back to the left -
667: ; Do it when the leftmargin > pparm1 and there are more than pparm2
668: ; more chars to print in the expression
669:
670: ; cmu prefers dv instead of setq
671:
672: #+cmu
673: (def pp-value (lambda (i v p)
674: (terpri *outport*) (*prpr (list 'dv i v))))
675:
676: #-cmu
677: (def pp-value (lambda (i v p)
678: (terpr *outport*) (*prpr `(setq ,i ',v))))
679: (def pp-function (lambda (i v p)
680: (terpri *outport*) (*prpr (list 'def i v))))
681: (def pp-prop (lambda (i v p)
682: (terpri *outport*) (*prpr (list 'defprop i v p))))
683:
684: (def condclosefile
685: (lambda nil
686: (cond (*fileopen*
687: (terpr *outport*)
688: (close *outport*)
689: (setq *fileopen* nil)))))
690:
691: ;
692: ; these routines are meant to be used by pp but since
693: ; some people insist on using them we will set *outport* to nil
694: ; as the default (moved to front).
695: ;(setq *outport* nil)
696:
697:
698: (def *prpr
699: (lambda (x)
700: (cond ((not (boundp '*outport*)) (setq *outport* poport)))
701: (terpr *outport*)
702: (*prdf x 0 0)))
703:
704: ; This is the principle addition for PEARL.
705: ; SPRINT simply calls *prdf after filling in any missing parameters.
706: (defun sprint (value &optional (lmar 0) (rmar 0))
707: (cond ((not (boundp '*outport*)) (setq *outport* poport)))
708: (*prdf value lmar rmar))
709:
710: (defvar rmar) ; -DNC this used to be m - I've tried to
711: ; to fix up the pretty printer a bit. It
712: ; used to mess up regularly on (a b .c) types
713: ; of lists. Also printmacros have been added.
714:
715:
716:
717: ; Used to be $prdf but added a bit and changed to * to avoid
718: ; PEARL's history read macro $.
719: (def *prdf
720: (lambda (l lmar rmar)
721: (prog (pmac)
722: ;
723: ; - DNC - Here we try to fix the tendency to print a
724: ; thin column down the right margin by allowing it
725: ; to move back to the left if necessary.
726: ;
727: (cond ((and (>& lmar pparm1) (>& (flatc l (1+ pparm2)) pparm2))
728: (terpri *outport*)
729: (princ '"; <<<<< start back on the left <<<<<" *outport*)
730: (*prdf l 5 0)
731: (terpri *outport*)
732: (princ '"; >>>>> continue on the right >>>>>" *outport*)
733: (terpri *outport*)
734: (return nil)))
735: (tab lmar *outport*)
736: a (cond ((and (dtpr l)
737: (atom (car l))
738: (setq pmac (get (car l) 'printmacro))
739: (cond ((stringp pmac)
740: ; Added for PEARL (and UCI Lisp compatibility).
741: ; a string printmacro means print this
742: ; string and then the cadr of l if
743: ; it's not nil, and only if l is
744: ; a one- or two-element list.
745: (cond ((cddr l) ; more than two elements.
746: nil)
747: ((null (cdr l)) ; only one element.
748: (patom pmac)
749: t)
750: ( t (patom pmac) ; two elements.
751: (patom (cadr l))
752: t)))
753: ( t (apply pmac (list l lmar rmar)))))
754: (return nil))
755: ;
756: ; -DNC - a printmacro is a lambda (l lmar rmar)
757: ; attached to the atom. If it returns nil then
758: ; we assume it did not apply and we continue.
759: ; Otherwise we assume it did the job.
760: ;
761: ((or (not (dtpr l))
762: ; (*** at the moment we just punt hunks etc)
763: (and (atom (car l)) (atom (cdr l))))
764: (return (printret l *outport*)))
765: ((<& (+ rmar (flatc l (chrct *outport*)))
766: (chrct *outport*))
767: ;
768: ; This is just a heuristic - if print can fit it in then figure that
769: ; the printmacros won't hurt. Note that despite the pretentions there
770: ; is no guarantee that everything will fit in before rmar - for example
771: ; atoms (and now even hunks) are just blindly printed. - DNC
772: ;
773: (printaccross l lmar rmar))
774: ((and (*patom1 lpar)
775: (atom (car l))
776: (not (atom (cdr l)))
777: (not (atom (cddr l))))
778: (prog (c)
779: (printret (car l) *outport*)
780: (*patom1 '" ")
781: (setq c (nwritn *outport*))
782: a (*prd1 (cdr l) c)
783: (cond
784: ((not (atom (cdr (setq l (cdr l)))))
785: (terpr *outport*)
786: (go a)))))
787: (t
788: (prog (c)
789: (setq c (nwritn *outport*))
790: a (*prd1 l c)
791: (cond
792: ((not (atom (setq l (cdr l))))
793: (terpr *outport*)
794: (go a))))))
795: b (*patom1 rpar))))
796:
797: (def *prd1
798: (lambda (l n)
799: (prog nil
800: (*prdf (car l)
801: n
802: (cond ((null (setq l (cdr l))) (|1+| rmar))
803: ((atom l) (setq n nil) (+ 4 rmar (pntlen l)))
804: ( t rmar)))
805: (cond
806: ((null n) (*patom1 '" . ") (return (printret l *outport*))))
807: ; (*** setting n is pretty disgusting)
808: ; (*** the last arg to *prdf is the space needed for the suffix)
809: ; ;Note that this is still not really right - if the prefix
810: ; takes several lines one would like to use the old rmar
811: ;( until the last line where the " . mumble)" goes.
812: )))
813:
814: ; -DNC here's the printmacro for progs - it replaces some hackery that
815: ; used to be in the guts of *prdf.
816:
817: (def printprog
818: (lambda (l lmar rmar)
819: (prog (col)
820: (cond ((cdr (last l)) (return nil)))
821: (setq col (1+ lmar))
822: (princ '|(| *outport*)
823: (princ (car l) *outport*)
824: (princ '| | *outport*)
825: (print (cadr l) *outport*)
826: (mapc '(lambda (x)
827: (cond ((atom x)
828: (tab col *outport*)
829: (print x *outport*))
830: ( t (*prdf x (+ lmar 6) rmar))))
831: (cddr l))
832: (princ '|)| *outport*)
833: (return t))))
834:
835: (putprop 'prog 'printprog 'printmacro)
836:
837: ; Here's the printmacro for def. The original *prdf had some special code
838: ; for lambda and nlambda.
839:
840: (def printdef
841: (lambda (l lmar rmar)
842: (cond ((and (\=& 0 lmar) ; only if we're really printing a defn
843: (\=& 0 rmar)
844: (cadr l)
845: (atom (cadr l))
846: (caddr l)
847: (null (cdddr l))
848: (memq (caaddr l) '(lambda nlambda macro lexpr))
849: (null (cdr (last (caddr l)))))
850: (princ '|(| *outport*)
851: (princ 'def *outport*)
852: (princ '| | *outport*)
853: (princ (cadr l) *outport*)
854: (terpri *outport*)
855: (princ '| (| *outport*)
856: (princ (caaddr l) *outport*)
857: (princ '| | *outport*)
858: (princ (cadaddr l) *outport*)
859: (terpri *outport*)
860: (mapc '(lambda (x) (*prdf x 4 0)) (cddaddr l))
861: (princ '|))| *outport*)
862: t))))
863:
864: (putprop 'def 'printdef 'printmacro)
865:
866: ; There's a version of this hacked into the printer (where it don't belong!)
867: ; Note that it must NOT apply to things like (quote a b).
868:
869: (def printquote
870: (lambda (l lmar rmar)
871: (cond ((or (null (cdr l)) (cddr l)) nil)
872: ( t (princ '|'| *outport*)
873: (*prdf (cadr l) (1+ lmar) rmar)
874: t))))
875:
876: (putprop 'quote 'printquote 'printmacro)
877:
878:
879:
880:
881: (def printaccross
882: (lambda (l lmar rmar)
883: (prog nil
884: ; (*** this is needed to make sure the printmacros are executed)
885: (princ '|(| *outport*) ;)
886: l: (cond ((null l))
887: ((atom l) (princ '|. | *outport*) (princ l *outport*))
888: ( t (*prdf (car l) (nwritn *outport*) rmar)
889: (setq l (cdr l))
890: (cond (l (princ '| | *outport*)))
891: (go l:))))))
892:
893:
894:
895: (def tab (lexpr (n)
896: (prog (nn prt) (setq nn (arg 1))
897: (cond ((>& n 1) (setq prt (arg 2))))
898: (cond ((>& (nwritn prt) nn) (terpri prt)))
899: (printblanks (- nn (nwritn prt)) prt))))
900:
901: ; ========================================
902: ;
903: ; (charcnt port)
904: ; returns the number of characters left on the current line
905: ; on the given port
906: ;
907: ; =======================================
908:
909:
910: (def charcnt
911: (lambda (port) (- linel (nwritn port))))
912:
913: (putd 'chrct (getd 'charcnt))
914:
915: (def *patom1 (lambda (x) (patom x *outport*)))
916:
917: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.