; STORED ON: VLISP.INI AUTHOR: PAUL MENNEN DATE: 6-NOV-80 The programs in this file are loaded when vlisp is started This file contains the pretty printer. Loading this file uses up the following resources: Atom space = 600 List space = 1151 ; (DE ISLIST (B) ; return T if B is a list, otherwise return nil ; (IF (ATOM B) (NULL B) (ISLIST (CDR B)))) ; !.....................?::::::::::::::?! ; (DE LEN (L) ; return the number of characters required to print the expression L. ; (COND ; a ; ((NULL L) 2) ; nil requires two characters: "()" ; ((ATOM L) (LENGTH (EXPLODE L))) ; atoms require the length of their pname ; ; !.........?::::::::::::::::::?! ; ((AND (EQ (1 L) QUOTE) (NULL (CDDR L))) (ADD1 (LEN (2 L)))) ; quote only needs one character "'" ; ; c!....?::::::::::::::?.?:::::::::::::?! !.....?:::::::::?!c ; ((EQ (1 L) 'LIST) (LEN (CDR L))) ; the function list is abreviated [...] ; ; !?::::::::::::::?.?:::::::::::?! ; ((ISLIST L) ; if its a list, add the length of its elements ; ; n + 2 + intervening spaces ; (SETQ S 1) ; initialize S for summing lengths of list ; ; elements ; (MAPC (LAMBDA (X) (SETQ S (+ 1 S (LEN X)))) L) ; sum the lenghts of each element ; ; p q !.......?:::::::::::::?!q p ; S) ; return S ; ; n ; (T (+ 5 (LEN (CAR L)) (LEN (CDR L)))))) ; must be a s-expression (dotted pair) ; ; v !....?:::::::::::?.?:::::::::::?!va thus add in the 5 characters "( . )" ; (DE TO-BIG (L) ; return T if the expression L is to big to fit on one line cpos (comment position) is the right hand limit for the line ; (LT (- CPOS (LMARGIN)) (LEN L))) ; !...?::::::::::::::::?........! ; (DE INSER (X L) ; inserts x into the sorted list L and returns a new sorted list L is a list of lists arranged in increasing order according to the 2nd element of each list ; (COND ; a ; ((NULL L) (SETQ L [X])) ; !.........?::::::::::?! ; ((LE (CADR X) (CADAR L)) (NEWL L X)) ; !?:::::::::::::::::::::?...........! ; (T (SETQ L (CONS (CAR L) (INSER X (CDR L))))))) ; e f !.............?:::::::::::::::?!fea ; (DE PTLIST (L1) ; pretty prints the cdr of list L1. (note car of L1 allready printed) if mlines (multiple lines) is false, print a blank between each element of the list. if mlines is true, terp is called whenever it is desired to advance to the next line. for multiple line lists, there is 3 different formats: format 1 - print 3 elements on first line and 2 elements on succeeding lines (SETQ) format 2 - print 2 elements on first line and 1 on all others (IF, IFN, WHILE, UNTIL, LAMBDA) format nil - print each element on a seperate line ; (COND ; a ; ((NOT MLINES) (NEXTL L1) (WHILE L1 (PRINCH " ") (PT (NEXTL L1) PNUM))) ; this line prints a list on a single line ; ; b !......................?::::::::::::::::::?!b ; ((EQ ; ij ; 1 ; is this format 1? ; (SETQ FORMAT (2 ; determine if format is 1,2,or nil ; ; k l ; (ASSQ ; m ; (NEXTL L1) '((IF 2) ; n ; (IFN 2) (WHILE 2) ; ; (UNTIL 2) (LAMBDA 2) (SETQ 1)))))) ; nmlkj ; (WHILE L1 ; *** come here for format 1 (SETQ), print ; ; q remaining elements in 2 columns ; (OUTPOS (+ (LMARGIN) 3)) ; position for column 1 (variable name) ; ; !.......?:::::::::::::?! ; (PT (NEXTL L1) PNUM T) ; print variable (i.e. quoted argument) ; (LMARGIN (+ (LMARGIN) 12)) ; set left margin for column 2 ; ; !........?::::::::::::::?! ; (OUTPOS (IF (LT (OUTPOS) (LMARGIN)) (LMARGIN) (ADD1 (OUTPOS)))) ; move to left margin if its forward, otherwise ; ; r !...?:::::::::::::::::::::?...........?:::::::::::::?!r skip one space ; (PT (NEXTL L1) PNUM T) ; print expression to be set to variable in ; ; column 1 ; (LMARGIN (- (LMARGIN) 12)) ; restore original margin ; ; !........?::::::::::::::?! ; (IF L1 (TERP)))) ; go to next line if there are more terms in the ; ; !............!qi setq list ; ((EQ 2 FORMAT) ; *** come here for format 2 ; ; B ; (PRINCH " ") ; print a blank between first and 2nd elements ; ; of list ; (SETQ LEFTSV (LMARGIN)) ; save present margin ; (LMARGIN (OUTPOS)) ; present position is new margin ; (PT (NEXTL L1) PNUM T) ; print second element ; (LMARGIN LEFTSV) ; restore margin ; (WHILE L1 (TERP) (PT (NEXTL L1) PNUM T))) ; print rest of list one element per line ; ; !................?::::::::::::::::::::?!B ; (T (WHILE L1 (TERP) (PT (NEXTL L1) PNUM T))))) ; *** come here for format nil - each element ; ; H !................?::::::::::::::::::::?!Ha of the list will appear on a seperate line ; (DE PT (L PNM MLINES BRAK) ; pretty prints the expression L. pnm is the label for the pair of parentheses that encloses this expression call with mlines=true if the expression requires multiple lines to be printed if brak is false, lists are printed normally - ( ... ) if brak is true, lists are printed with brackets - [ ... ] ; (IF MLINES (SETQ MLINES (TO-BIG L))) ; if we are printing L on multiple lines, its ; ; !..........?::::::::::::::::::::::?! time to recompute to see if this is necessary ; (COND ; a ; ((NULL L) (PRINCH "(") (PRINCH ")")) ; print nil as the 2 characters "()" ; ; !..................................! ; ((ATOM L) (PRIN L) (IF (AND (BOUNDP 'COMFLAG) COMFLAG) (GETCOM L))) ; if L is atomic, just print it, then check for ; ; d !...?:::::::::::::::::::::::::::::?...........!d comments ; ((AND (EQ (1 L) QUOTE) (NULL (CDDR L))) ; is L a 2 element list of the form (quote j) ; ; k!....?::::::::::::::?.?:::::::::::::?! ; (PRINCH "'") ; if yes, abrieviate (quote j) by 'j ; (PT (2 L) PNUM MLINES)) ; !....................!k ; ((EQ (1 L) 'LIST) (PT (CDR L) PNUM MLINES T)) ; abrieviate the list function by using [...] ; ; !?::::::::::::::?.?::::::::::::::::::::::::?! ; (T ; L is non atomic and therefore must be a list ; ; u or dotted pair ; (COND ; v ; ((NEQ PNM 96) ; the printing of the first left paren is ; ; w inhibited if pt is called with pnm=96, this is ; ; used by pret since the first left paren has ; ; allready been printed before the de,df, or dm ; (IF PAR (SETQ LRP (INSER [PNM (OUTPOS)] LRP))) ; save this left paren in the sorted list lrp. ; ; y z !......?::::::::::::?....!zy it's sorted in increasing order relative to ; ; outpos (paren position) ; (PRINCH (IF BRAK "[" "(")))) ; print the paren or the bracket ; ; !........................!wv ; (CHANGEP 1) ; move on to the next paren label ; (IF (AND MLINES (CDR L)) (LMARGIN (+ (LMARGIN) 3))) ; if there are multiple lines needed to print ; ; F !..................! !........?:::::::::::::?!F the list, indent succeding lines ; (PT (CAR L) PNUM MLINES) ; pretty print the first element of the list or ; ; dotted pair ; (IF (ISLIST L) ; L ; (PTLIST L) ; if list, print the rest of the elements ; (PROGN (PRINCH " ") (PRINCH ".") (PRINCH " ")) ; for dotted pairs print " . " followed by the ; ; !............................................! second part of the dotted pair ; (PT (CDR L) PNUM MLINES)) ; !......................!L ; (IF (AND PAR (NEQ PNM 96)) (SETQ LRP (INSER [PNM (OUTPOS)] LRP))); also save the right paren in the list lrp ; ; R !....................! U !......?::::::::::::?....!UR; (PRINCH (IF BRAK "]" ")")) ; and then print the right paren or bracket ; (IF MLINES (LMARGIN (- (LMARGIN) 3)))))) ; discontinue the indentation after the list is ; ; Y !........?:::::::::::::?!Yua printed ; (DE TERP () ; this routine is called whenever a line of pretty printing is to be completed. this routine then prints the parenthesis matching information if requested (i.e. if par = t) and also prints any comments that are associated with this line if the comment flag (comt) is true. ; (IFN COMT (TERPRA) (STATUS PRINT 1) (PRINL1 (NEXTL COMLI))) ; advance to next line, if any comments first ; ; !...................................?::::::::::::::::::::?! print the first line of them ; (COND ; c ; ((AND PAR LRP) ; is paren matching selected with a non-empty lrp ; ; d ; (RINNER2) ; yes, first remove deepest level parens from lrp ; (IFN LRP ; was there only that one level? ; ; f ; (CHANGEP -1) ; yes, it's not worth printing, discard one label ; (RINNER2) ; no, extract level 2 (second deepest level) ; ; from lrp ; (IF LRP ; were there only 2 levels on this line? ; ; g ; (PROGN ; no, there were at least 3 levels, so do this ; ; h ; (SETQ A4 (COPY A3)) ; save level 2 in A4 ; (RINNER2) ; extract level 3 parens from lrp into A3 ; (TERP2) ; print paren matching for level 3 ; (TERP3 A4) ; print paren matching for level 2 ; (IFN LRP ; are there any level 4 parens or higher? ; ; i ; (CHANGEP -3) ; no, discard some unneeded labels ; (MAPC (LAMBDA (X) (OUTBUF (2 X) (1 X))) LRP) ; now print paren matching characters for all ; ; j !...........?::::::::::::::::::?! j levels higher than 3 by using paren labels ; (SETQ LRP ())) ; must leave this routine with lrp empty ; ; i ; (TERP4)) ; print the next comment line (if any) following ; ; h the paren matching characters ; (CHANGEP -2) ; yes, there were only 2 levels, no paren labels ; ; will be needed ; (IF (OR (CDR A3) (GE (- (2 (CAR A3)) (1 (CAR A3))) 30)) ; dont print paren matching characters for level ; ; r s u !..?::::::::::?.?::::::::::?! us 2 unless there are more than one pair or ; ; unless the single paren pair spans at least 30 ; ; characters between the left and right paren ; (PROGN (TERP2) (TERP4))))))) ; print paren matching for level 2 and a comment ; ; !.....................!rgfdc line (if any are remaining) ; (COND ; D ; (COMT (MAPC 'PRINL1 COMLI) (SETQ COMLI () COMT ()) (STATUS PRINT 7)))); if comt = true, print any remaining comment ; ; !..................................................................!D lines and restore the print status ; (DE TERPRA () ; advance to the next line, linecnt will contain the number of lines used to pretty print the function ; (TERPRI) (INCR LINECNT)) (DE TERP2 () ; inserts paren matching characters for the parens contained in list A3 ; (SETQ SVLEFT (LMARGIN)) ; save left margin position ; (LMARGIN 0) ; move left margin to position zero ; (OUTPOS (RMARGIN)) ; move output position to right margin so that ; ; outbuf will accept the characters ; (OUTBUF 0 ";") ; signify to vlisp when this file in used as ; ; input, that this is the start of a comment line ; (TERP3 A3)) ; insert paren matching to parens in A3 ; (DE TERP3 (L) ; L contains a collection of parentheses of a single level to be matched on a single line by using a !......! notation or a ?::::::? notation. terp3 inserts these characters into the output buffer. the structure of L is: ((lp1 rp1) (lp2 rp2) ... (lpn rpn)) where lpi is the buffer position of the ith left hand paren and rpi is the buffer position of the ith right hand paren ; (MAPC ; a ; (LAMBDA (X) ; do this function for each paren pair in L ; ; b ; (SETQ I (1 X) J (2 X)) ; I and J are the left and right print positons ; ; of the pair ; (IF (EQ (OUTBUF I) ".") ; are we inside another matched pair of parens? ; ; e !.................! ; (SETQ SYM1 "?" SYM2 ":") ; yes, use ?::::? to indicate the innermost level ; (SETQ SYM1 "!" SYM2 ".")) ; no, use !.......! ; ; e ; (OUTBUF I SYM1) ; print ? or ! for left hand paren ; (OUTBUF J SYM1) ; print ? or ! for right hand paren ; (INCR I) (WHILE (LT I J) (OUTBUF I SYM2) (INCR I))) ; print a . or : in all positions between the ; ; !.......................................!b right and left paren pair ; L)) ; a ; (DE TERP4 () ; if there are any more comments, print the next comment line attached to the paren matching characters otherwise just advance to the next line ; (UNTIL (NEQ (OUTBUF (SUB1 (OUTPOS))) " ") (OUTPOS (SUB1 (OUTPOS)))) ; move output position to rightmost non-blank ; ; a b !.......?:::::::::::::?! b !.......?:::::::::::::?!a character ; (LMARGIN SVLEFT) ; restore left margin to position encountered ; ; before terp was called ; (IF (AND COMT COMLI) ; are there any comments to print? ; ; i ; (PRINL1 (NEXTL COMLI) T) ; yes, print them ; (SETQ JPOS (IF (LT (OUTPOS) CPOS) CPOS (OUTPOS))) ; no, jpos will be the end of the comment line ; ; k !...?::::::::::::::::?..............!k ; (OUTPOS (ADD1 JPOS)) ; move output position so next command will work ; (OUTBUF JPOS ";") ; indicate that this is the end of the comment ; (TERPRA))) ; advance to the next line ; ; i ; (DE RINNER2 () ; removes inner set of parentheses (deepest level) from lrp. A1 is used to collect the remaining parens, and A3 will contain the parens that are removed. lrp is eventually restored with its desired contents (the remaining parens in original order) from A1. the structure used for lrp is: ((L1 P1) (L2 P2) ... (Ln Pn)) where Li is the paren label (PNUM) and Pi is the paren position. note that both left and right parens are stored in lrp but they are not identified as left or right. the structure for list A1 is the same as for lrp. for the structure of A3, see the comments given for terp3 ; (SETQ A1 () A3 ()) (RINNER)) (DE RINNER () ; this routine is called iteratively to do the work for rinner2 ; (IFN LRP ; are we done yet (is lrp empty)? ; ; a ; (SETQ LRP (FREVERSE A1)) ; yes, restore lrp with remaining parens ; (IFN (EQ (1 (1 LRP)) (1 (2 LRP))) ; no, not done yet. do the first two parens in ; ; b !...?:::::::::?.?:::::::::?! lrp have the same label? ; (NEWL A1 (CAR LRP)) ; no, put the first paren of lrp into A1 ; (NEWL A3 [(2 (1 LRP)) (2 (2 LRP))]) ; yes, these two parens must be an inner pair, ; ; h !?:::::::::?.?:::::::::?!h save just the positions into A3 ; (NEXTL LRP)) ; remove first paren from lrp ; ; b ; (NEXTL LRP) ; remove first paren from lrp ; (RINNER))) ; continue the process ; ; a ; (DE CHANGEP (X) ; this routine steps pnum forward or backword by n positions where n= -3, -2, -1, 0, or 1 pnum contains the ascii code of the character currently being used as a label for a right-left parentheses pair. the 52 valid characters for pnum are a thru z and A thru Z ; (SETQ PNUM (+ PNUM X)) (IF (EQ PNUM 123) (SETQ PNUM 65)) ; jump to A after z ; ; !...............................! ; (IF (LT PNUM 65) (CHANGEP 58)) ; if we have decremented beyond the upper case, ; ; jump back to lower case ; (IF (EQ PNUM 91) (SETQ PNUM 97)) ; jump to a after Z ; ; !..............................! ; (IF (AND (LE PNUM 96) (GE PNUM 92)) (CHANGEP -6))) ; if we have decremented beyond the lower case, ; ; !...?:::::::::::::::::::::::::::::?.............! jump back to upper case ; (DF PRETTY (L) ; PRETTY does exactly the same thing as PRET ; (EVAL (CONS 'PRET L))) (DF PRET (L NAME LINECNT XTYPE SVR SVL THISPOS) ; this routine pretty prints a function and returns # of lines printed. (PRET ABC) pretty prints the function ABC without parenthesis matching. (PRET ABC T) pretty prints the function ABC with parenthesis matching. the atom CPOS may be used to define the output linelength if pret is called by save with a comment file then right margin = 127 and cpos indicates the position where the comment lines begin. (i.e. cpos is the max # of characters in a line not counting comments) ; (IFN (BOUNDP 'CPOS) (SETQ CPOS 68)) ; if cpos is undefined use default value of 68 ; ; !.................................! ; (SETQ SVR (RMARGIN) SVL (LMARGIN)) ; save the current value of the margins ; ; !................................! ; (SETQ NAME (1 L) PAR (2 L) LINECNT 0) ; extract function name and paren matching flag ; ; !...................................! from parameter list, clear line count ; (SETQ XTYPE (CDR ; set xtype to DE, DF, or DM (or nil if NAME ; ; d e isnt a function) ; (ASSQ ; f ; (FTYPE NAME) '((EXPR . DE) (FEXPR . DF) (MACRO . DM))))) ; !.....................................!fed ; (PROGN (LMARGIN 0) (RMARGIN 127) (TERPRA)) ; use full line width available, skip a line to ; ; !........................................! start ; (COND ; m ; (XTYPE ; don't pretty print it if it isnt a function ; ; n ; (STATUS PRINT 1) ; dont insert spaces before each print arguement ; (LMARGIN 3) ; indent the next line ; (PRIN "(" XTYPE " " NAME " ") ; now start to print the first line ; (PRIN (COND ((CAR (FVAL NAME))) (T "()")) " ") ; now print the argument list and some spaces to ; ; o p !?:::::::::::::::?! p o seperate the function discripter comments ; (COND ; u ; ((AND (BOUNDP 'COMFLAG) COMFLAG) ; do we have a comment file? ; ; v!.............................! ; (PRIN "; ") ; yes, begin to print the function discripter ; (READLN) ; get first function discripter comment line ; (SETQ THISPOS (OUTPOS)) ; put all lines at current position (thispos) ; (WHILE LIN ; do this until we hit a blank line (LIN=nil), ; ; y means end of function discripter comments ; (PROGN (OUTPOS THISPOS) (PRINL LIN) (READLN)) ; print the line and read the next one ; ; !...........................................! ; (IF LIN (TERPRA))) ; advance to next line except for last time ; ; !...............!y ; (PRIN " ;") ; close the comment ; (READLN))) ; read the next line for PT ; ; vu ; (TERPRA) ; advance to next line to begin function body ; (STATUS PRINT 7) ; no blanks, use " around literals ; (SETQ PNUM 96 LRP () COMT () COMLI ()) ; initialize paren label (PNUM) and others for PT ; (PT (CDR (FVAL NAME)) PNUM T) ; pretty print the function body ; ; !...?:::::::::::::::?.......! ; (TERP))) ; nm ; (PROGN (STATUS PRINT 0) (RMARGIN SVR) (LMARGIN SVL)) ; restore print status and original margins ; ; !..................................................! ; (SETQ LIN ()) ; this helps the save routine ; LINECNT) ; return number of lines printed ; (DE SAVEINI () ; this routine saves all of the routines on this file (VLISP.INI) ; (SETQ CPOS 77) (SAVE ; a ; ISLIST LEN TO-BIG INSER PTLIST PT TERP TERPRA TERP2 TERP3 TERP4 RINNER2 RINNER CHANGEP PRETTY PRET SAVEINI)) ; a ;