![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to vlp.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / vlp|
Return to vlp.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / vlp |
1.1 root 1: ;$Header: vlp.l,v 1.5 84/05/07 15:09:59 jkf Exp $
2: ;$Locker: layer $
3: ;
4: ; -[Mon May 7 15:04:34 1984 by jkf]-
5: ;
6: ; Filter for nroffing or troffing Lisp code.
7: ; This program reads files containing Lisp code and writes them out
8: ; along with the nroff (troff) commands required to make the Lisp line up.
9: ; It does this alignment by insuring that the leftmost
10: ; blank character lines up with the closest non blank character above it.
11: ;
12: ; The program operates in one of two modes: filter mode or non-filter mode.
13: ;
14: ; In filter mode, only characters between lines beginning with .Ls and .Le
15: ; are processed. The directive .Ls accepts an optional argument that is
16: ; the point size of the output. Pages have no titles and point size is set
17: ; by the macro, so most shell arguments are ignored.
18: ;
19: ; In non-filter mode, all lines in the file are processed.
20: ;
21: ; The output goes to the standard output, unless the v switch is set,
22: ; in which case it goes to vtroff.
23: ;
24: ; Usage:
25: ; vlp [-p size] [-d] [-f] [-l] [-v] [-T title1] file1 ....
26: ;
27: ; where,
28: ; -p Sets the point size to "size"
29: ; -d Turn on debugging mode
30: ; -f Run in filtered mode
31: ; -l Turns OFF the labeling of functions
32: ; -v Sends the output to vtroff
33: ; -T Sets the title of the next file to "titleN"
34: ;
35: ; NOTE: If vlp is on the right side of a pipe, the "-T" switch can not be
36: ; used.
37: ;
38: ;
39: ; Written by John Foderaro
40: ; Modified by:
41: ; Kevin Layer to have enough tags.
42: ; Jim Larus to work in filtered mode.
43: ;
44:
45: (declare (macros t))
46:
47: (allocate 'list 220)
48:
49: (declare (special user-top-level EOF lines g-psize inport
50: spaces sps chs tls trname errport outfilename
51: filtermode g-title rest funcname readstdin debug
52: spout outfile tagsleft LabelFunctions))
53:
54: (defvar space-count 500.) ; large number
55:
56: ;--- toplev :: top level lisp
57: ;
58: (defun toplev nil
59: (let ((args (command-line-args)))
60: (signal 2 'vlp-interrupt-routine)
61: (signal 15 'vlp-interrupt-routine)
62: (errset (apply 'vlp args))
63: (exit 0)))
64:
65: (eval-when (load) (setq user-top-level 'toplev))
66:
67: (setq g-psize 8
68: debug nil
69: g-filtmode nil
70: readstdin nil
71: filtermode nil
72: outfilename nil
73: LabelFunctions t)
74:
75:
76: (defun GetModTime (FileName)
77: ;
78: ; Returns the last modification time as a string.
79: ;
80: (time-string (filestat:mtime (filestat (get_pname FileName)))))
81:
82:
83: (defun vlp fexpr (args)
84: (prog (inport outfile)
85: ;check command line for switches
86: (setq args (do ((i args (cdr i)) (ll) (tem))
87: ((null i) (reverse ll))
88: (setq tem (aexplodec (car i)))
89: (cond ((eq '- (car tem)) ; if switch
90: (cond ((eq 'd (cadr tem))
91: (setq debug t))
92: ((eq 'f (cadr tem))
93: (setq filtermode t))
94: ((eq 'l (cadr tem))
95: (setq LabelFunctions nil))
96: ((eq 'p (cadr tem))
97: (setq g-psize
98: (cond ((eq '|6| (cadr i)) 6)
99: ((eq '|10| (cadr i)) 10)
100: ((eq '|12| (cadr i)) 12)
101: (t 8)))
102: (setq i (cdr i)))
103: ((eq 'v (cadr tem))
104: (setq outfilename
105: (concat "/tmp/vlp" (sys:getpid))))
106: (t (setq ll (cons (car i) ll)))))
107: (t (setq ll (cons (car i) ll)))))) ; else skip it
108: ;
109: (if debug then (msg (P errport) "args = " args N))
110: ;
111: ; insure all file names given actually exist before starting.
112: (cond ((null (do ((xx args (cdr xx)))
113: ((null xx) t)
114: (if (eq '- (getchar (car xx) 1))
115: then (setq xx (cdr xx)) ; skip switches
116: else (if (not (probef (car xx)))
117: then (msg (P errport)
118: "File does not exist: "
119: (car xx))
120: (return nil)))))
121: (return nil)))
122: ;
123: ; do before-starting-first-file actions
124: ;
125: (if outfilename then (setq outfile (outfile outfilename)))
126: (if (null args) then (setq readstdin t))
127:
128: (if (and LabelFunctions (null filtermode))
129: then ;; NOTE: the following concat'ing of strings
130: ;; is neccessary because when vlp'ing vlp.l
131: ;; soelim would source the file.
132: (msg (P outfile) (concat "." "so /usr/lib/vlpmacs") N))
133: (setq g-title "")
134: ;
135: ;
136: (if readstdin
137: then (setq EOF nil)
138: (setq lines nil)
139: (if (not filtermode)
140: then (msg (P outfile) ".ps " g-psize N
141: ".vs " (+ g-psize 2) "p" N)
142: (msg (P outfile) ".Ti " '\" g-title '\" N)
143: (msg (P outfile) ".wh -1.25i He" N)
144: (msg (P outfile) ".nf" N))
145: (do ()
146: (EOF t)
147: (if filtermode then (skiptostarter))
148: (processblock))
149: else (do ((files args (cdr files)))
150: ((null files) t)
151: (if (eq '- (getchar (car files) 1))
152: then (if (eq '-p (car files))
153: then (if (null (setq g-psize
154: (cdr (assoc (cadr files)
155: '((\6 . 6)
156: (\8 . 8)
157: (\10 . 10)
158: (\12 . 12))))))
159: then (error "bad point size"
160: (cadr files)))
161: elseif (eq '-T (car files))
162: then (setq g-title (cadr files))
163: else (error "bad switch " (car files)))
164: (setq files (cdr files))
165: else (setq EOF nil)
166: (setq lines nil)
167: (cond ((null (errset
168: (setq inport (infile (car files)))))
169: (msg (P errport) "Can't open file: "
170: (car args))
171: (return nil)))
172: (if (not filtermode)
173: then (msg (P outfile)
174: ".ps " g-psize N
175: ".vs " (+ g-psize 2) "p" N)
176: (msg (P outfile)
177: ".Fi " (car files)
178: " \"" (GetModTime (car files)) '\"
179: " \"" (time-string) '\"
180: N)
181: (msg (P outfile)
182: ".Ti " '\" g-title '\" N)
183: (msg (P outfile) ".wh -1.25i He" N)
184: (msg (P outfile) ".nf" N))
185: (do ()
186: (EOF)
187: (if filtermode then (skiptostarter))
188: (processblock))
189: (close inport))))
190: (if outfilename
191: then
192: (close outfile)
193: (apply 'process
194: (ncons (concat "/bin/cat " outfilename
195: " | /usr/ucb/vtroff")))
196: (if debug
197: then (msg (P errport)
198: "Troff filename is " outfilename N)
199: else (sys:unlink outfilename)))))
200:
201:
202: ;--- skiptostarter :: skip to start directive (.Ls)
203: ;
204: (defun skiptostarter nil
205: ;
206: ; Define a simple finite state machine that reads and prints everything
207: ; up-to and including the directive .Ls.
208: ; All text outside of the .Ls directive is simply sent on to the output.
209: ;
210: (do ((State 0)
211: (c (tyi inport) (tyi inport)))
212: ((=& 4 State))
213: (cond ((and (=& State 0) (=& c #/.))
214: (setq State 1))
215: ((and (=& State 1) (=& c #/L))
216: (setq State 2))
217: ((and (=& State 2) (=& c #/s))
218: (setq State 3))
219: ((=& State 3) ; Read through arguments
220: (cond ((=& c #\lf)
221: (setq State 4)
222: (untyi c inport)))) ; In case text starts immed.
223: ((=& c #\eof)
224: (setq EOF t)
225: (return))
226: (t
227: (setq State 0)))
228: (tyo c outfile)))
229:
230: (defun processblock nil
231: ;
232: ; Read lines until we come to one that has no blank space at its begining.
233: ; Then process the previously accumulated lines.
234: ; If the last line contains the directive .Le, then find the next block
235: ; enclosed by .Ls.
236: ;
237: (do ((newline (getline) (getline)))
238: (nil)
239: (if (or EOF (and (zerop (car newline)) (cadr newline)))
240: then (flushlines)
241: (setq lines nil)
242: (if (=& (caadr newline) #/') ;then must quote ' for troff
243: then (msg (P outfile) "\\")
244: elseif (and filtermode
245: (=& (caadr newline) #/.)
246: (=& (cadadr newline) #/L)
247: (=& (caddadr newline) #/e))
248: then (msg (P outfile) ".Le" N)
249: (return nil))
250: (if EOF then (return nil)))
251: (setq lines (cons newline lines))))
252:
253:
254: ;--- getline :: read in new line and return structure:
255: ; (spaces chars)
256: ; spaces is a fixnum giving the number of spaces before the first
257: ; non-blank on the line.
258: ; chars is the list of characters appearing on the line, in order.
259: ;
260: (defun getline nil
261: (do ((col 1)
262: (spaces 0)
263: (chars nil)
264: (spacemode t)
265: (newc (tyi inport) (tyi inport) ))
266: (nil)
267: (if (=& #\eof newc)
268: then (if (null chars)
269: then (setq EOF t)
270: (return nil)
271: else (setq newc #\lf)))
272: (if (=& #\lf newc)
273: then (if (null chars)
274: then ; for totally blank lines return a large
275: ; space count so this won't be used for tags
276: (return (list space-count nil))
277: else (return (list spaces (nreverse chars)))))
278: (if (=& #\ff newc)
279: then (return (list spaces (nreverse (cons newc chars)))))
280: (if spacemode
281: then (if (=& #\sp newc)
282: then (setq spaces (1+ spaces))
283: elseif (=& #\tab newc)
284: then (setq spaces (* (/ (+ spaces 8) 8) 8))
285: else (setq spacemode nil
286: chars (list newc)))
287: else (setq chars (cons newc chars)))))
288:
289:
290: ;--- flushlines
291: ; go back on all lines and determine where to put tags and reference
292: ; tags.
293: ;
294: (defun flushlines nil
295: (let (thistag tagref rlines tagloc)
296: (inittagslist '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
297: a b c d e f g h i j k l m n o p q r s t u v w x y z
298: 1 2 3 4 5 6 7 8 9 0))
299: (setq tagref nil tagloc nil rlines nil)
300: (do ((xx lines (cdr xx))
301: (thistagloc nil nil)
302: (pendingtags)
303: (thistagref))
304: ((null xx))
305: (setq rlines (cons (car xx) rlines)
306: spaces (caar xx)
307: thistag (alloctag))
308: ; determine which of the pending tags we can insert at this level
309: (do ((yy pendingtags (cdr yy)))
310: ((or (null yy) (>& spaces (caar yy)))
311: (setq pendingtags yy))
312: (setq thistagloc (cons (car yy) thistagloc)))
313: (setq tagloc (cons thistagloc tagloc))
314: ; free up the tags we allocated at this level.
315: (mapc '(lambda (x) (freetag (cadr x))) thistagloc)
316: ;
317: ; we only need to refer to a tags at this level if
318: ; we are not at the left edge of the paper
319: ;
320: (if (and (greaterp spaces 0) (cdr xx))
321: then (setq tagref (cons thistag tagref))
322: (setq pendingtags (addtotags spaces thistag pendingtags))
323: else (setq tagref (cons nil tagref))))
324: (if debug then (msg " **tagref = " tagref N " **tagloc = " tagloc N))
325: ;
326: ; print out the lines.
327: ; the lines we want to print are in the list rlines. They are
328: ; in the correct order.
329: ;
330: (do ((yy rlines (cdr yy))
331: (commentmode nil nil)
332: (escapemode nil nil))
333: ((null yy))
334: ; first print out spaces
335: (setq sps (caar yy)
336: chs (cadar yy)
337: tls (car tagloc)
338: trname (car tagref))
339: (headercheck sps chs)
340: (if debug
341: then (msg " spaces " sps N " chs " chs N
342: " tagloc " (car tagloc) N " tagref " (car tagref) N))
343: (setq spout 0)
344: ; if there are characters on this line, print out
345: ; leading spaces
346: (if chs
347: then (do ()
348: ((eq spout sps))
349: (tyo #\sp outfile)
350: (setq spout (1+ spout)))
351:
352: (if trname then (tagrefprint trname)))
353:
354: (do ((xx chs (cdr xx)))
355: ((null xx)
356: (if (and tls (not (<& (caar tls) spout)))
357: then (do ((i spout (1+ i)))
358: ((null tls))
359: (if (=& (caar tls) i)
360: then (taglocprint (cadar tls))
361: (setq tls (cdr tls)))))
362: (if commentmode then (msg (P outfile) "\\fP"))
363: (terpr outfile))
364: (if (and tls (eq (caar tls) spout))
365: then (taglocprint (cadar tls))
366: (setq tls (cdr tls)))
367: (if (and (not escapemode)
368: (null commentmode)
369: (=& #/; (car xx)))
370: then (msg (P outfile) "\\fI")
371: (setq commentmode t)
372: elseif (=& #/\ (car xx))
373: then (tyo #/\ outfile)) ; escape backslashes
374: (if (memq (car xx) '(#/\ #//))
375: then (setq escapemode t)
376: else (setq escapemode nil))
377: (if (=& (car xx) #\ff)
378: then (msg (P outfile) N ".bp" N)
379: else (tyo (car xx) outfile))
380: (setq spout (1+ spout)))
381: (setq tagloc (cdr tagloc)
382: tagref (cdr tagref)))))
383:
384:
385: ; headercheck :: check if this is a function declaration.
386: ; currently this means that there are no more than 2 spaces before
387: ; the line begins and that the line begins with (defxxx <name>)
388: (defun headercheck (spaces chars)
389: (if (<& spaces 3)
390: then (if (setq rest (match chars '(#/( #/d #/e #/f)))
391: then (setq funcname (skippastblkn rest))
392: (if (and funcname LabelFunctions)
393: then (msg (P outfile) ".Lf " funcname N)))))
394:
395: ;--- match :: match lists
396: ; list1 - list of characters (fixnum rep)
397: ; list2 - master list of characters (fixnum rep)
398: ; list2 should be shorter than list1. If list2 is a substring of list1
399: ; then the rest of list1 will be returned. Otherwise nil is returned.
400: ;
401: (defun match (list1 list2)
402: (cond ((null list1) nil)
403: ((null list2) list1)
404: ((or (eq (car list1) (car list2))
405: (eq (car list1) (uppercase (car list2))))
406: (match (cdr list1) (cdr list2)))
407: (t nil)))
408:
409: ;--- uppercase :: convert fixnum rep to upper case
410: ; char - fixnum representation of character
411: ; convert character to upper case.
412: ;
413: (defun uppercase (ch)
414: (if (and (not (<& ch #/a)) (not (>& ch #/z)))
415: then (- ch #.(- #/a #/A))))
416:
417:
418:
419: ;--- skippastblnk :: skip to and past blank field and return following name
420: ; list - list of characters (fixnums)
421: ;
422: ; We skip past all non blanks then all blanks and finally implode the next
423: ; word after that and return it.
424: ;
425: ; bug- we can't tell the difference between a function named nil and
426: ; no valid function, but then again you can't have a function named nil.
427: ;
428: (defun skippastblkn (list)
429: (let (res)
430: ; skip to first blank
431: (do ()
432: ((null list) nil)
433: (if (=& (car list) #\sp) then (return nil))
434: (setq list (cdr list)))
435: ; skip to first non-blank
436: (do ()
437: ((null list) nil)
438: (if (not (=& (car list) #\sp)) then (return nil))
439: (setq list (cdr list)))
440: ; collect non blanks
441: (if list
442: then (do ()
443: ((null list))
444: (if (and (=& #\lpar (car list))
445: (null res))
446: then (setq list (cdr list)) ; form like "defun (foo ..)"
447: elseif (or (=& #\lpar (car list))
448: (=& #\rpar (car list))
449: (=& #\sp (car list)))
450: then (return nil)
451: else (setq res (cons (car list) res))
452: (setq list (cdr list))))
453: (if res then (implode (nreverse res))))))
454:
455: ;
456: ; add (spaces character) to list so that the spaces number are in
457: ; ascending order.
458: ;
459: (defun addtotags (spaces character oldlist)
460: (if (or (null oldlist) (>& spaces (caar oldlist)))
461: then (cons (list spaces character) oldlist)
462: else (do ((prevtag oldlist (cdr prevtag))
463: (thistag (cdr oldlist) (cdr thistag)))
464: ((or (null thistag) (>& spaces (caar thistag)))
465: (setq thistag (cons (list spaces character) thistag))
466: (rplacd prevtag thistag)))))
467:
468: (defun inittagslist (list)
469: (setq tagsleft list))
470:
471: (defun alloctag nil
472: (if (null tagsleft)
473: then (msg "Out of tags, aauuuuggh " N)
474: (exit)
475: else (prog1 (car tagsleft) (setq tagsleft (cdr tagsleft)))))
476:
477: (defun freetag (tagname)
478: (setq tagsleft (cons tagname tagsleft)))
479:
480:
481: (defun taglocprint (name)
482: (msg (P outfile) "\\k" name))
483:
484:
485: (defun tagrefprint (name)
486: (msg (P outfile) "\\h'|\\n" name "u'"))
487:
488:
489: ;---new stuff
490: ;
491: ;--- programs deal in lineblk's
492: ; A lineblk has these components:
493: ; class : normal or comment
494: ; comment is a line beginning with ;, in which case it is
495: ; not counted as far as spacing goes.
496: ; spaces : number of spaces before first useful info
497: ; dead : list of dead linblk's, that is those ready to print but
498: ; waiting for this line to be done.
499: ; tagref: tag to go to at the beginning of this line
500: ; tagloc : tags defined on this line
501: ; chars : list of characters to print
502:
503: (defun make-lineblk (class spaces chars)
504: (list class spaces nil nil nil chars))
505: (defmacro get:class (lineblk) `(car ,lineblk))
506: (defmacro set:class (lineblk val) `(setf (get:class ,lineblk) ,val))
507: (defmacro get:spaces (lineblk) `(cadr ,lineblk))
508: (defmacro set:spaces (lineblk val) `(setf (get:spaces ,lineblk) ,val))
509: (defmacro get:dead (lineblk) `(caddr ,lineblk))
510: (defmacro set:dead (lineblk val) `(setf (get:dead ,lineblk) ,val))
511: (defmacro get:tagref (lineblk) `(cadddr ,lineblk))
512: (defmacro set:tagref (lineblk val) `(setf (get:tagref ,lineblk) ,val))
513: (defmacro get:tagloc (lineblk) `(caddddr ,lineblk))
514: (defmacro set:tagloc (lineblk val) `(setf (get:tagloc ,lineblk) ,val))
515: (defmacro get:chars (lineblk) `(cadddddr ,lineblk))
516: (defmacro set:chars (lineblk val) `(setf (get:chars ,lineblk) ,val))
517:
518:
519: (defun vlp-interrupt-routine (sig)
520: (if (and (boundp 'outfilename) outfilename)
521: then (sys:unlink outfilename))
522: (exit 1))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.