![[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] / 42BSD / ucb / vlp|
Return to vlp.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / vlp |
1.1 root 1: ;$Header: vlp.l 1.4 83/05/11 23:55:23 layer Exp $
2: ;$Locker: $
3: ;
4: ; -[Wed Feb 16 12:25:15 1983 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: ;;; NOTE: the following concat'ing of strings is neccessary because
128: ;;; when vlp'ing vlp.l soelim would source the file.
129: (msg (P outfile) (concat "." "so /usr/lib/vlpmacs") N)
130: (setq g-title "")
131: ;
132: ;
133: (If readstdin
134: then (setq EOF nil)
135: (setq lines nil)
136: (If (not filtermode)
137: then (msg (P outfile) ".ps " g-psize N
138: ".vs " (+ g-psize 2) "p" N)
139: (msg (P outfile) ".Ti " '\" g-title '\" N)
140: (msg (P outfile) ".wh -1.25i He" N)
141: (msg (P outfile) ".nf" N))
142: (do ()
143: (EOF t)
144: (If filtermode then (skiptostarter))
145: (processblock))
146: else (do ((files args (cdr files)))
147: ((null files) t)
148: (If (eq '- (getchar (car files) 1))
149: then (If (eq '-p (car files))
150: then (If (null (setq g-psize
151: (cdr (assoc (cadr files)
152: '((\6 . 6)
153: (\8 . 8)
154: (\10 . 10)
155: (\12 . 12))))))
156: then (error "bad point size"
157: (cadr files)))
158: elseif (eq '-T (car files))
159: then (setq g-title (cadr files))
160: else (error "bad switch " (car files)))
161: (setq files (cdr files))
162: else (setq EOF nil)
163: (setq lines nil)
164: (cond ((null (errset
165: (setq inport (infile (car files)))))
166: (msg (P errport) "Can't open file: "
167: (car args))
168: (return nil)))
169: (If (not filtermode)
170: then (msg (P outfile)
171: ".ps " g-psize N
172: ".vs " (+ g-psize 2) "p" N)
173: (msg (P outfile)
174: ".Fi " (car files)
175: " \"" (GetModTime (car files)) '\"
176: " \"" (time-string) '\"
177: N)
178: (msg (P outfile)
179: ".Ti " '\" g-title '\" N)
180: (msg (P outfile) ".wh -1.25i He" N)
181: (msg (P outfile) ".nf" N))
182: (do ()
183: (EOF)
184: (If filtermode then (skiptostarter))
185: (processblock))
186: (close inport))))
187: (If outfilename
188: then
189: (close outfile)
190: (apply 'process
191: (ncons (concat "/bin/cat " outfilename
192: " | /usr/ucb/vtroff")))
193: (If debug
194: then (msg (P errport)
195: "Troff filename is " outfilename N)
196: else (sys:unlink outfilename)))))
197:
198:
199: ;--- skiptostarter :: skip to start directive (.Ls)
200: ;
201: (defun skiptostarter nil
202: ;
203: ; Define a simple finite state machine that reads and prints everything
204: ; up-to and including the directive .Ls.
205: ; All text outside of the .Ls directive is simply sent on to the output.
206: ;
207: (do ((State 0)
208: (c (tyi inport) (tyi inport)))
209: ((=& 4 State))
210: (cond ((and (=& State 0) (=& c #/.))
211: (setq State 1))
212: ((and (=& State 1) (=& c #/L))
213: (setq State 2))
214: ((and (=& State 2) (=& c #/s))
215: (setq State 3))
216: ((=& State 3) ; Read through arguments
217: (cond ((=& c #\lf)
218: (setq State 4)
219: (untyi c inport)))) ; In case text starts immed.
220: ((=& c #\eof)
221: (setq EOF t)
222: (return))
223: (t
224: (setq State 0)))
225: (tyo c outfile)))
226:
227: (defun processblock nil
228: ;
229: ; Read lines until we come to one that has no blank space at its begining.
230: ; Then process the previously accumulated lines.
231: ; If the last line contains the directive .Le, then find the next block
232: ; enclosed by .Ls.
233: ;
234: (do ((newline (getline) (getline)))
235: (nil)
236: (If (or EOF (and (zerop (car newline)) (cadr newline)))
237: then (flushlines)
238: (setq lines nil)
239: (If (=& (caadr newline) #/') ;then must quote ' for troff
240: then (msg (P outfile) "\\")
241: elseif (and filtermode
242: (=& (caadr newline) #/.)
243: (=& (cadadr newline) #/L)
244: (=& (caddadr newline) #/e))
245: then (msg (P outfile) ".Le" N)
246: (return nil))
247: (If EOF then (return nil)))
248: (setq lines (cons newline lines))))
249:
250:
251: ;--- getline :: read in new line and return structure:
252: ; (spaces chars)
253: ; spaces is a fixnum giving the number of spaces before the first
254: ; non-blank on the line.
255: ; chars is the list of characters appearing on the line, in order.
256: ;
257: (defun getline nil
258: (do ((col 1)
259: (spaces 0)
260: (chars nil)
261: (spacemode t)
262: (newc (tyi inport) (tyi inport) ))
263: (nil)
264: (If (=& #\eof newc)
265: then (If (null chars)
266: then (setq EOF t)
267: (return nil)
268: else (setq newc #\lf)))
269: (If (=& #\lf newc)
270: then (if (null chars)
271: then ; for totally blank lines return a large
272: ; space count so this won't be used for tags
273: (return (list space-count nil))
274: else (return (list spaces (nreverse chars)))))
275: (If (=& #\ff newc)
276: then (return (list spaces (nreverse (cons newc chars)))))
277: (If spacemode
278: then (If (=& #\sp newc)
279: then (setq spaces (1+ spaces))
280: elseif (=& #\tab newc)
281: then (setq spaces (* (/ (+ spaces 8) 8) 8))
282: else (setq spacemode nil
283: chars (list newc)))
284: else (setq chars (cons newc chars)))))
285:
286:
287: ;--- flushlines
288: ; go back on all lines and determine where to put tags and reference
289: ; tags.
290: ;
291: (defun flushlines nil
292: (let (thistag tagref rlines tagloc)
293: (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
294: 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
295: 1 2 3 4 5 6 7 8 9 0))
296: (setq tagref nil tagloc nil rlines nil)
297: (do ((xx lines (cdr xx))
298: (thistagloc nil nil)
299: (pendingtags)
300: (thistagref))
301: ((null xx))
302: (setq rlines (cons (car xx) rlines)
303: spaces (caar xx)
304: thistag (alloctag))
305: ; determine which of the pending tags we can insert at this level
306: (do ((yy pendingtags (cdr yy)))
307: ((or (null yy) (>& spaces (caar yy)))
308: (setq pendingtags yy))
309: (setq thistagloc (cons (car yy) thistagloc)))
310: (setq tagloc (cons thistagloc tagloc))
311: ; free up the tags we allocated at this level.
312: (mapc '(lambda (x) (freetag (cadr x))) thistagloc)
313: ;
314: ; we only need to refer to a tags at this level if
315: ; we are not at the left edge of the paper
316: ;
317: (If (greaterp spaces 0)
318: then (setq tagref (cons thistag tagref))
319: (setq pendingtags (addtotags spaces thistag pendingtags))
320: else (setq tagref (cons nil tagref))))
321: (If debug then (msg " **tagref = " tagref N " **tagloc = " tagloc N))
322: ;
323: ; print out the lines.
324: ; the lines we want to print are in the list rlines. They are
325: ; in the correct order.
326: ;
327: (do ((yy rlines (cdr yy))
328: (commentmode nil nil)
329: (escapemode nil nil))
330: ((null yy))
331: ; first print out spaces
332: (setq sps (caar yy)
333: chs (cadar yy)
334: tls (car tagloc)
335: trname (car tagref))
336: (headercheck sps chs)
337: (If debug
338: then (msg " spaces " sps N " chs " chs N
339: " tagloc " (car tagloc) N " tagref " (car tagref) N))
340: (setq spout 0)
341: ; if there are characters on this line, print out
342: ; leading spaces
343: (if chs
344: then (do ()
345: ((eq spout sps))
346: (tyo #\sp outfile)
347: (setq spout (1+ spout)))
348:
349: (If trname then (tagrefprint trname)))
350:
351: (do ((xx chs (cdr xx)))
352: ((null xx)
353: (If (and tls (not (<& (caar tls) spout)))
354: then (do ((i spout (1+ i)))
355: ((null tls))
356: (If (=& (caar tls) i)
357: then (taglocprint (cadar tls))
358: (setq tls (cdr tls)))))
359: (If commentmode then (msg (P outfile) "\\fP"))
360: (terpr outfile))
361: (If (and tls (eq (caar tls) spout))
362: then (taglocprint (cadar tls))
363: (setq tls (cdr tls)))
364: (If (and (not escapemode)
365: (null commentmode)
366: (=& #/; (car xx)))
367: then (msg (P outfile) "\\fI")
368: (setq commentmode t)
369: elseif (=& #/\ (car xx))
370: then (tyo #/\ outfile)) ; escape backslashes
371: (If (memq (car xx) '(#/\ #//))
372: then (setq escapemode t)
373: else (setq escapemode nil))
374: (If (=& (car xx) #\ff)
375: then (msg (P outfile) N ".bp" N)
376: else (tyo (car xx) outfile))
377: (setq spout (1+ spout)))
378: (setq tagloc (cdr tagloc)
379: tagref (cdr tagref)))))
380:
381:
382: ; headercheck :: check if this is a function declaration.
383: ; currently this means that there are no more than 2 spaces before
384: ; the line begins and that the line begins with (defxxx <name>)
385: (defun headercheck (spaces chars)
386: (If (<& spaces 3)
387: then (If (setq rest (match chars '(#/( #/d #/e #/f)))
388: then (setq funcname (skippastblkn rest))
389: (If (and funcname LabelFunctions)
390: then (msg (P outfile) ".Lf " funcname N)))))
391:
392: ;--- match :: match lists
393: ; list1 - list of characters (fixnum rep)
394: ; list2 - master list of characters (fixnum rep)
395: ; list2 should be shorter than list1. If list2 is a substring of list1
396: ; then the rest of list1 will be returned. Otherwise nil is returned.
397: ;
398: (defun match (list1 list2)
399: (cond ((null list1) nil)
400: ((null list2) list1)
401: ((or (eq (car list1) (car list2))
402: (eq (car list1) (uppercase (car list2))))
403: (match (cdr list1) (cdr list2)))
404: (t nil)))
405:
406: ;--- uppercase :: convert fixnum rep to upper case
407: ; char - fixnum representation of character
408: ; convert character to upper case.
409: ;
410: (defun uppercase (ch)
411: (If (and (not (<& ch #/a)) (not (>& ch #/z)))
412: then (- ch #.(- #/a #/A))))
413:
414:
415:
416: ;--- skippastblnk :: skip to and past blank field and return following name
417: ; list - list of characters (fixnums)
418: ;
419: ; We skip past all non blanks then all blanks and finally implode the next
420: ; word after that and return it.
421: ;
422: ; bug- we can't tell the difference between a function named nil and
423: ; no valid function, but then again you can't have a function named nil.
424: ;
425: (defun skippastblkn (list)
426: (let (res)
427: ; skip to first blank
428: (do ()
429: ((null list) nil)
430: (If (=& (car list) #\sp) then (return nil))
431: (setq list (cdr list)))
432: ; skip to first non-blank
433: (do ()
434: ((null list) nil)
435: (If (not (=& (car list) #\sp)) then (return nil))
436: (setq list (cdr list)))
437: ; collect non blanks
438: (If list
439: then (do ()
440: ((null list))
441: (If (and (=& #\lpar (car list))
442: (null res))
443: then (setq list (cdr list)) ; form like "defun (foo ..)"
444: elseif (or (=& #\lpar (car list))
445: (=& #\rpar (car list))
446: (=& #\sp (car list)))
447: then (return nil)
448: else (setq res (cons (car list) res))
449: (setq list (cdr list))))
450: (If res then (implode (nreverse res))))))
451:
452: ;
453: ; add (spaces character) to list so that the spaces number are in
454: ; ascending order.
455: ;
456: (defun addtotags (spaces character oldlist)
457: (If (or (null oldlist) (>& spaces (caar oldlist)))
458: then (cons (list spaces character) oldlist)
459: else (do ((prevtag oldlist (cdr prevtag))
460: (thistag (cdr oldlist) (cdr thistag)))
461: ((or (null thistag) (>& spaces (caar thistag)))
462: (setq thistag (cons (list spaces character) thistag))
463: (rplacd prevtag thistag)))))
464:
465: (defun inittagslist (list)
466: (setq tagsleft list))
467:
468: (defun alloctag nil
469: (If (null tagsleft)
470: then (msg "Out of tags, aauuuuggh " N)
471: (exit)
472: else (prog1 (car tagsleft) (setq tagsleft (cdr tagsleft)))))
473:
474: (defun freetag (tagname)
475: (setq tagsleft (cons tagname tagsleft)))
476:
477:
478: (defun taglocprint (name)
479: (msg (P outfile) "\\k" name))
480:
481:
482: (defun tagrefprint (name)
483: (msg (P outfile) "\\h'|\\n" name "u'"))
484:
485:
486: ;---new stuff
487: ;
488: ;--- programs deal in lineblk's
489: ; A lineblk has these components:
490: ; class : normal or comment
491: ; comment is a line beginning with ;, in which case it is
492: ; not counted as far as spacing goes.
493: ; spaces : number of spaces before first useful info
494: ; dead : list of dead linblk's, that is those ready to print but
495: ; waiting for this line to be done.
496: ; tagref: tag to go to at the beginning of this line
497: ; tagloc : tags defined on this line
498: ; chars : list of characters to print
499:
500: (defun make-lineblk (class spaces chars)
501: (list class spaces nil nil nil chars))
502: (defmacro get:class (lineblk) `(car ,lineblk))
503: (defmacro set:class (lineblk val) `(setf (get:class ,lineblk) ,val))
504: (defmacro get:spaces (lineblk) `(cadr ,lineblk))
505: (defmacro set:spaces (lineblk val) `(setf (get:spaces ,lineblk) ,val))
506: (defmacro get:dead (lineblk) `(caddr ,lineblk))
507: (defmacro set:dead (lineblk val) `(setf (get:dead ,lineblk) ,val))
508: (defmacro get:tagref (lineblk) `(cadddr ,lineblk))
509: (defmacro set:tagref (lineblk val) `(setf (get:tagref ,lineblk) ,val))
510: (defmacro get:tagloc (lineblk) `(caddddr ,lineblk))
511: (defmacro set:tagloc (lineblk val) `(setf (get:tagloc ,lineblk) ,val))
512: (defmacro get:chars (lineblk) `(cadddddr ,lineblk))
513: (defmacro set:chars (lineblk val) `(setf (get:chars ,lineblk) ,val))
514:
515:
516: (defun vlp-interrupt-routine (sig)
517: (If (and (boundp 'outfilename) outfilename)
518: then (sys:unlink outfilename))
519: (exit 1))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.