;******************************************************************************
;*      ROSENMUELLER    TPRINT.QUE                                            *
;******************************************************************************

;;** displace zu displac0 umbenannt, weil paket gedruckt wird 22.08.1990 
**;;

(write-to-string 
        '(let ((a a1)
               (b b1))
              1 2
              (3 4)
              (5 6)
              7 8) :pretty t)
"(LET ((A A1) 
      (B B1)) 
     1 2 
     (3 4) 
     (5 6) 
     7 8)"

(write-to-string 
        '(prog (1 2)
               (3 4)
          a    (5 6)
               (8 9)
          x    (zzz)) :pretty t)
"(PROG (1 2)
      (3 4)
 A    (5 6)
      (8 9)
 X    (ZZZ))"

(write-to-string 
        '(do ((l '(1 2 3)
                 (cdr l)))
             ((null l) 
              (print 'a1)
              (print 'a2))
             (print l)) :pretty t)
"(DO ((L '(1 2 3) 
        (CDR L))) 
    ((NULL L) 
     (PRINT 'A1) 
     (PRINT 'A2)) 
    (PRINT L))"

(setq *print-level* nil *print-length* nil *print-pretty* t)
T

(WRITE-TO-STRING
'(123 
"das ist der 1. string laenger als 80 zeichen aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
456
"das ist der 2. bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
789)
)
"(123 \"das ist der 1. string laenger als 80 zeichen aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\" 

     456 
     \"das ist der 2. bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\" 

     789)"

(setq tarray
        #4a((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))
             ((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))
             ((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60)))
            (((61 62 63 64 65)(66 67 68 69 70)(11 12 13 14 15)(16 17 18 19 20))
             ((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))
             ((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60)))
           ))
#4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 
49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(11 
12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(
36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 
60))))

(setq tal
        '((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))
             ((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))
             ((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60)))
            (((61 62 63 64 65)(66 67 68 69 70)(11 12 13 14 15)(16 17 18 19 20))
             ((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))
             ((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60)))
           ))
((((1 2 3 4 5) 
   (6 7 8 9 10) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))) 
 (((61 62 63 64 65) 
   (66 67 68 69 70) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))))

(setq tlist (list 'a 'b 'c tarray))
(A B C 
   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 
   34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 
   57 58 59 60)))))

(setq *print-length* 6)
6

tarray
#4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(
26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 
50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(11 12 
13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 
37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60))))

(WRITE-TO-STRING tal)
"((((1 2 3 4 5) 
   (6 7 8 9 10) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))) 
 (((61 62 63 64 65) 
   (66 67 68 69 70) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))))"

(setq *print-length* 5)
5

tarray
#4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(
26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 
50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(11 12 
13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 
37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60))))

(WRITE-TO-STRING tal)
"((((1 2 3 4 5) 
   (6 7 8 9 10) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))) 
 (((61 62 63 64 65) 
   (66 67 68 69 70) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))))"

(setq *print-length* 4)
4

(WRITE-TO-STRING tarray)
"#4A((((1 2 3 4 ...)(6 7 8 9 ...)(11 12 13 14 ...)(16 17 18 19 ...))((21 22 23 24 ...)(
26 27 28 29 ...)(31 32 33 34 ...)(36 37 38 39 ...))((41 42 43 44 ...)(46 47 48 
49 ...)(51 52 53 54 ...)(56 57 58 59 ...)))(((61 62 63 64 ...)(66 67 68 69 ...)(
11 12 13 14 ...)(16 17 18 19 ...))((21 22 23 24 ...)(26 27 28 29 ...)(31 32 33 
34 ...)(36 37 38 39 ...))((41 42 43 44 ...)(46 47 48 49 ...)(51 52 53 54 ...)(56 
57 58 59 ...))))"
;;"#4A((((1 2 3 4 ...)(6 7 8 9 ...)(11 12 13 14 ...)(16 17 18 19 ...))((21 22 23 
;;24 ...)(26 27 28 29 ...)(31 32 33 34 ...)(36 37 38 39 ...))((41 42 43 44 ...)(
;;46 47 48 49 ...)(51 52 53 54 ...)(56 57 58 59 ...)))(((61 62 63 64 ...)(66 67 
;;68 69 ...)(11 12 13 14 ...)(16 17 18 19 ...))((21 22 23 24 ...)(26 27 28 29 ...)(
;;31 32 33 34 ...)(36 37 38 39 ...))((41 42 43 44 ...)(46 47 48 49 ...)(51 52 53 
;;54 ...)(56 57 58 59 ...))))"

(WRITE-TO-STRING tal)
"((((1 2 3 4 ...) 
   (6 7 8 9 ...) 
   (11 12 13 14 ...) 
   (16 17 18 19 ...)) 
  ((21 22 23 24 ...) 
   (26 27 28 29 ...) 
   (31 32 33 34 ...) 
   (36 37 38 39 ...)) 
  ((41 42 43 44 ...) 
   (46 47 48 49 ...) 
   (51 52 53 54 ...) 
   (56 57 58 59 ...))) 
 (((61 62 63 64 ...) 
   (66 67 68 69 ...) 
   (11 12 13 14 ...) 
   (16 17 18 19 ...)) 
  ((21 22 23 24 ...) 
   (26 27 28 29 ...) 
   (31 32 33 34 ...) 
   (36 37 38 39 ...)) 
  ((41 42 43 44 ...) 
   (46 47 48 49 ...) 
   (51 52 53 54 ...) 
   (56 57 58 59 ...))))"

(setq *print-length* 3)
3

(WRITE-TO-STRING tarray)
"#4A((((1 2 3 ...)(6 7 8 ...)(11 12 13 ...)...)((21 22 23 ...)(26 27 28 ...)(31 
32 33 ...)...)((41 42 43 ...)(46 47 48 ...)(51 52 53 ...)...))(((61 62 63 ...)(
66 67 68 ...)(11 12 13 ...)...)((21 22 23 ...)(26 27 28 ...)(31 32 33 ...)...)((
41 42 43 ...)(46 47 48 ...)(51 52 53 ...)...)))"

(WRITE-TO-STRING tal)
"((((1 2 3 ...) 
   (6 7 8 ...) 
   (11 12 13 ...) ...) 
  ((21 22 23 ...) 
   (26 27 28 ...) 
   (31 32 33 ...) ...) 
  ((41 42 43 ...) 
   (46 47 48 ...) 
   (51 52 53 ...) ...)) 
 (((61 62 63 ...) 
   (66 67 68 ...) 
   (11 12 13 ...) ...) 
  ((21 22 23 ...) 
   (26 27 28 ...) 
   (31 32 33 ...) ...) 
  ((41 42 43 ...) 
   (46 47 48 ...) 
   (51 52 53 ...) ...)))"

(setq *print-length* 2)
2

(WRITE-TO-STRING tarray)
"#4A((((1 2 ...)(6 7 ...)...)((21 22 ...)(26 27 ...)...)...)(((61 62 ...)(66 67 ...)...)((
21 22 ...)(26 27 ...)...)...))"

(WRITE-TO-STRING tal)
"((((1 2 ...) 
   (6 7 ...) ...) 
  ((21 22 ...) 
   (26 27 ...) ...) ...) 
 (((61 62 ...) 
   (66 67 ...) ...) 
  ((21 22 ...) 
   (26 27 ...) ...) ...))"

(setq *print-length* 1)
1

(WRITE-TO-STRING tarray)
"#4A((((1 ...)...)...)...)"

(WRITE-TO-STRING tal)
"((((1 ...) 
   ...) 
  ...) 
 ...)"
;;"((((1 ...) ...) ...) ...)"

(setq *print-length* 0)
0

(WRITE-TO-STRING tarray)
"#4A(...)"

(WRITE-TO-STRING tal)
"(...)"

;***1

(setq *print-length* 6)
6

tarray   
#4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(
26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 
50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(11 12 
13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 
37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60))))

(WRITE-TO-STRING tal)
"((((1 2 3 4 5) 
   (6 7 8 9 10) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))) 
 (((61 62 63 64 65) 
   (66 67 68 69 70) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))))"

(setq *print-level* 5)
5

tarray
#4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(
26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 
50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(11 12 
13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 
37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60))))

(WRITE-TO-STRING tal)
"((((1 2 3 4 5) 
   (6 7 8 9 10) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))) 
 (((61 62 63 64 65) 
   (66 67 68 69 70) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))))"

(setq *print-level* 4)
4

tarray
#4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(
26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 
50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(11 12 
13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 
37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60))))

(WRITE-TO-STRING tal)
"((((1 2 3 4 5) 
   (6 7 8 9 10) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))) 
 (((61 62 63 64 65) 
   (66 67 68 69 70) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))))"

(setq *print-level* 3)
3

(WRITE-TO-STRING tarray)
"#4A(((# # # #)(# # # #)(# # # #))((# # # #)(# # # #)(# # # #)))"

(WRITE-TO-STRING tal)
"(((# 
   # 
   # 
   #) 
  (# 
   # 
   # 
   #) 
  (# 
   # 
   # 
   #)) 
 ((# 
   # 
   # 
   #) 
  (# 
   # 
   # 
   #) 
  (# 
   # 
   # 
   #)))"

(setq *print-level* 2)
2

(WRITE-TO-STRING tarray)
"#4A((# # #)(# # #))"

(WRITE-TO-STRING tal)
"((# 
  # 
  #) 
 (# 
  # 
  #))"

(setq *print-level* 1)
1

(WRITE-TO-STRING tarray)
"#4A(# #)"

(WRITE-TO-STRING tal)
"(# 
 #)"

(setq *print-level* 0)
0

(WRITE-TO-STRING tarray)
"#4A#"

(WRITE-TO-STRING tal)
"#"

(setq *print-level* 6)
6

tarray
#4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(
26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 
50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(11 12 
13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 35)(36 
37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 58 59 60))))

(WRITE-TO-STRING tal)
"((((1 2 3 4 5) 
   (6 7 8 9 10) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))) 
 (((61 62 63 64 65) 
   (66 67 68 69 70) 
   (11 12 13 14 15) 
   (16 17 18 19 20)) 
  ((21 22 23 24 25) 
   (26 27 28 29 30) 
   (31 32 33 34 35) 
   (36 37 38 39 40)) 
  ((41 42 43 44 45) 
   (46 47 48 49 50) 
   (51 52 53 54 55) 
   (56 57 58 59 60))))"

(setq *print-length* 6)
6

(WRITE-TO-STRING tlist)
"(A B C 
   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 
   35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 
   58 59 60)))))"
;;"(A B C 
;;   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
;;   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
;;   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
;;   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 
;;   34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 
;;   57 58 59 60)))))"

(setq *print-length* 5)
5

(WRITE-TO-STRING tlist)
"(A B C 
   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 
   35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 
   58 59 60)))))"
;;"(A B C 
;;   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
;;   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
;;   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
;;   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 
;;   34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 
;;   57 58 59 60)))))"

(setq *print-length* 4)
4

(WRITE-TO-STRING tlist)
"(A B C 
   #4A((((1 2 3 4 ...)(6 7 8 9 ...)(11 12 13 14 ...)(16 17 18 19 ...))((21 22 23 
   24 ...)(26 27 28 29 ...)(31 32 33 34 ...)(36 37 38 39 ...))((41 42 43 44 ...)(
   46 47 48 49 ...)(51 52 53 54 ...)(56 57 58 59 ...)))(((61 62 63 64 ...)(66 67 
   68 69 ...)(11 12 13 14 ...)(16 17 18 19 ...))((21 22 23 24 ...)(26 27 28 29 ...)(
   31 32 33 34 ...)(36 37 38 39 ...))((41 42 43 44 ...)(46 47 48 49 ...)(51 52 
   53 54 ...)(56 57 58 59 ...)))))"
;;"(A B C #4A((((1 2 3 4 ...)(6 7 8 9 ...)(11 12 13 14 ...)(16 17 18 19 ...))((21 
;;   22 23 24 ...)(26 27 28 29 ...)(31 32 33 34 ...)(36 37 38 39 ...))((41 42 43 
;;   44 ...)(46 47 48 49 ...)(51 52 53 54 ...)(56 57 58 59 ...)))(((61 62 63 64 ...)(
;;   66 67 68 69 ...)(11 12 13 14 ...)(16 17 18 19 ...))((21 22 23 24 ...)(26 27 
;;   28 29 ...)(31 32 33 34 ...)(36 37 38 39 ...))((41 42 43 44 ...)(46 47 48 49 ...)(
;;   51 52 53 54 ...)(56 57 58 59 ...)))))"

(setq *print-length* 3)
3

(WRITE-TO-STRING tlist)
"(A B C ...)"


(setq *print-length* 2)
2

(WRITE-TO-STRING tlist)
"(A B ...)"


(setq *print-length* 1)
1

(WRITE-TO-STRING tlist)
"(A ...)"


(setq *print-length* 0)
0

(WRITE-TO-STRING tlist)
"(...)"

(setq *print-length* 6)
6

(WRITE-TO-STRING tlist)
"(A B C 
   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 
   35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 
   58 59 60)))))"
;;"(A B C 
;;   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
;;   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
;;   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
;;   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 
;;   34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 
;;   57 58 59 60)))))"

(setq *print-level* 5)
5

(WRITE-TO-STRING tlist)
"(A B C 
   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 
   35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 
   58 59 60)))))"
;;"(A B C 
;;   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
;;   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
;;   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
;;   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 
;;   34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 
;;   57 58 59 60)))))"

(setq *print-level* 4)
4

(WRITE-TO-STRING tlist)
"(A B C #4A(((# # # #)(# # # #)(# # # #))((# # # #)(# # # #)(# # # 
#))))"

(setq *print-level* 3)
3

(WRITE-TO-STRING tlist)
"(A B C #4A((# # #)(# # #)))"


(setq *print-level* 2)
2

(WRITE-TO-STRING tlist)
"(A B C #4A(# #))"

(setq *print-level* 1)
1

(WRITE-TO-STRING tlist)
"(A B C #4A#)"

(setq *print-level* 0)
0

(WRITE-TO-STRING tlist)
"#"

(setq *print-level* 6)
6

(WRITE-TO-STRING tlist)
"(A B C 
   #4A((((1 2 3 4 5)(6 7 8 9 10)(11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 
   25)(26 27 28 29 30)(31 32 33 34 35)(36 37 38 39 40))((41 42 43 44 45)(46 47 
   48 49 50)(51 52 53 54 55)(56 57 58 59 60)))(((61 62 63 64 65)(66 67 68 69 70)(
   11 12 13 14 15)(16 17 18 19 20))((21 22 23 24 25)(26 27 28 29 30)(31 32 33 34 
   35)(36 37 38 39 40))((41 42 43 44 45)(46 47 48 49 50)(51 52 53 54 55)(56 57 
   58 59 60)))))"

;***2

(setq *print-pretty* t)
t

(setq *print-length* 10.)
10

(setq *print-level* 3.)
3

(setq *print-circle* nil)
NIL

(setq a '(10 11 12))
(10 11 12)

(WRITE-TO-STRING (rplacd (cdr a) a))
"(11 10 11 10 11 10 11 10 11 10 ...)"

(setq b '(10 11 12))
(10 11 12)

(WRITE-TO-STRING (rplaca (cddr b) b))
"((10 11 
     (10 11 
         #)))"

(setq c '(10 11 12 13))
(10 11 12 13)

(WRITE-TO-STRING (rplacd (cddr c) (cdr c)))
"(12 11 12 11 12 11 12 11 12 11 ...)"

(WRITE-TO-STRING (setq d (list 'a 'b a 'c b c 'a )))
"(A B 
   (10 11 10 11 10 11 10 11 10 11 ...) 
   C 
   (10 11 
       (10 11 
           #)) 
   (10 11 12 11 12 11 12 11 12 11 ...) 
   A)"

(setq *print-length* nil)
NIL

(setq *print-level* nil)
NIL

(setq *print-circle* t)
T

(setq a '(10 11 12))
(10 11 12)

(WRITE-TO-STRING (rplacd (cdr a) a))
"#2=(11 10 . #2#)"

(setq b '(10 11 12))
(10 11 12)

(WRITE-TO-STRING (rplaca (cddr b) b))
"(#1=(10 11 
        #1#))"
;;"(#1=(10 11 
;;     #1#))"

(setq c '(10 11 12 13))
(10 11 12 13)

(WRITE-TO-STRING (rplacd (cddr c) (cdr c)))
"#2=(12 11 . #2#)"

(WRITE-TO-STRING (setq d (list 'a 'b a 'c b c 'a )))
"(A B 
   #3=(10 11 . #3#) 
   C 
   #6=(10 11 
          #6#) 
   (10 . #8=( 11 12 . #8#)) 
   A)"
;;"(A B 
;;   #3=(10 11 . #3#) 
;;   C 
;;   #6=(10 11 
;;       #6#) 
;;   (10 . #8=( 11 12 . #8#)) 
;;   A)"

(setq *print-circle* nil)
NIL

;***3

(setq sys::*pprint-max-indentation* 5)
5

;       (a b c )  ==>  (a b c)
(WRITE-TO-STRING        '(a b c))
"(A B C)"

;       (aaaaaaaaaaa.. bbbbbbb.. cccc..) lang 
;               ==> (aaaaa... bbbbb.. 
;                             ccc...)
(WRITE-TO-STRING        '(aaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb 
cc
         bbbbbbbbbbbbbbbbbbbbbbbbbbbbbb dd
         cccccccccccccccccccccccccccccccccccccccccccccc eeeeeee))
"(AAAAAAAAA BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB CC 
       BBBBBBBBBBBBBBBBBBBBBBBBBBBBBB DD 
       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC EEEEEEE)"

;       ((a)(b)(c)) ==> ((a) (b) (c))
(WRITE-TO-STRING        '((a) (b) (c)))
"((A) 
 (B) 
 (C))"

;       ((aaaa..) (bbbb..) (cccc..)) lang
;               ==> ((aaaa....)
;                    (bbbb...)
;                    (ccc..))
(WRITE-TO-STRING        '((aaaaaaaaaaaaaaaaaaaaaaaaaa)
          (bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb)
          (ccccccccccccccccccccc)
          (dddddddddddddddddddddddddddddddddd)))
"((AAAAAAAAAAAAAAAAAAAAAAAAAA) 
 (BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB) 
 (CCCCCCCCCCCCCCCCCCCCC) 
 (DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD))"

;       (abcde (a)(b)(c)) ==> (abcde (a) (b) (c))
(WRITE-TO-STRING        '(abcde (a)(b)(c)))
"(ABCDE (A) 
       (B) 
       (C))"

;       (abcde (aaaaaa..) (bbb..) ...) lang
;               ==> (abcde (aaaa....)
;                          (bbbb...)
;                          (ccc.......))
(WRITE-TO-STRING        '(abcde (aaaaaaaaaaaaaaaaaaaaaaaaaaaaa) (bbbbbbbbbbbbbbbbbbbbb)
                (cccccccccccccccccccccccccccccccc)
                (dddddddddddddddddddddddddddddddddddddd)))
"(ABCDE (AAAAAAAAAAAAAAAAAAAAAAAAAAAAA) 
       (BBBBBBBBBBBBBBBBBBBBB) 
       (CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC) 
       (DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD))"

;       (form1 form2 ...)   eine Zeile
;               ==> (form1 form2 ...)
(WRITE-TO-STRING        '((a 1 2) (b 1 2) (c 1 2)))
"((A 1 2) 
 (B 1 2) 
 (C 1 2))"

;       (form1 form2 ...) lang
;               ==> (form1
;                    form2 ...)
(WRITE-TO-STRING        '((aaaaaaaaaa 1111111111 2222222222)
         (bbbbbbbbbb 1111111111 2222222222)
         (cccccccccc 1111111111 2222222222)))
"((AAAAAAAAAA 1111111111 2222222222) 
 (BBBBBBBBBB 1111111111 2222222222) 
 (CCCCCCCCCC 1111111111 2222222222))"

;       (atom form1 form2 ....)
;               ==> (atom form1
;                         form2..)
(WRITE-TO-STRING        '(abcde (a 1 2) (b 1 2)))
"(ABCDE (A 1 2) 
       (B 1 2))"

(WRITE-TO-STRING        '(abcde (aaaaaaaaaaaaaaaaa 111111111111 22222222222)
                (bbbbbbbbbbbbbbbbb 111111111111 22222222222)
                (ccccccccccccccccc 111111111111 22222222222)))
"(ABCDE (AAAAAAAAAAAAAAAAA 111111111111 22222222222) 
       (BBBBBBBBBBBBBBBBB 111111111111 22222222222) 
       (CCCCCCCCCCCCCCCCC 111111111111 22222222222))"

;       (prog form1 form2 atom form3 ...)
;               ==> (prog form1
;                         form2
;                    atom form3 ..)
;; 16.8.1990 ab hier alle progs ausgetauscht, da alte am zeilenende zwei space?
(WRITE-TO-STRING        '(prog (a 1 2) (b 1 2) at (c 1 2) (d 1 2)))
"(PROG (A 1 2)
      (B 1 2)
 AT   (C 1 2)
      (D 1 2))"

(WRITE-TO-STRING        '(prog (a 1 2) (b 1 2) atommarke (c 1 2) (d 1 2)))
"(PROG (A 1 2)
      (B 1 2)
 ATOMMARKE
      (C 1 2)
      (D 1 2))"

(WRITE-TO-STRING        '(tagbody (a) (b) at (c) (d)))
"(TAGBODY 
      (A)
      (B)
 AT   (C)
      (D))"
;;"(TAGBODY (A) 
;;       (B) ........)

;       (form1 atom1 atom2 form2..)
;               ==> (form1
;                    atom1 atom2
;                    form2..)
(WRITE-TO-STRING        '((a 1 2) at1 at2 (b 1 2) (c 1 2)))
"((A 1 2) 
 AT1 AT2 
 (B 1 2) 
 (C 1 2))"

(WRITE-TO-STRING        '((aaaaaaaaaaaa 11111111111 22222222222) atom1 atom2
          (bbbbbbbbbbbb 11111111111 222222222222)
          (ccccc 1111 2222 3333)))
"((AAAAAAAAAAAA 11111111111 22222222222) 
 ATOM1 ATOM2 
 (BBBBBBBBBBBB 11111111111 222222222222) 
 (CCCCC 1111 2222 3333))"

;       (atom1 atom2 atom3 .. ) lang
;               ==> (atom1 atom2 ..
;                    atomn..)
(WRITE-TO-STRING        '(aaaaaaaaaaaaaaaa b ccccccccccccccccc dddddd eeeeeeeeeeeeeeee 

          ffffffffffffffffffffffffffffffffffffffff ggg hhhh iiiii
          jjjjjjjjjjjjjjjjjj k l m n ooooooooooooooo))
"(AAAAAAAAAAAAAAAA B CCCCCCCCCCCCCCCCC DDDDDD EEEEEEEEEEEEEEEE 
       FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF GGG HHHH IIIII 
       JJJJJJJJJJJJJJJJJJ K L M N OOOOOOOOOOOOOOO)"

;       Test der Sonderfunktionen
;; ab hier alle gequoteten objekte mit terpri !
(WRITE-TO-STRING        '(a '1 b))
"(A '1 B)"

(WRITE-TO-STRING        '(a `'b c))
"(A `'B 
   C)"

(WRITE-TO-STRING        '(a '''''''''b c))
"(A '''''''''B 
   C)"

(WRITE-TO-STRING        '(a b 'c d))
"(A B 'C D)"

(WRITE-TO-STRING        '(aaaaaaaaaa bbbbbbbbbbbb 'c 
        ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd))
"(AAAAAAAAAA BBBBBBBBBBBB 'C 
       DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD)"

(WRITE-TO-STRING        '(a (b) 'c d))
"(A (B) 
   'C D)"

(WRITE-TO-STRING        '(aaaaaaaaaa (bbbbbbbbbbbb) 'c 
        dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd))
"(AAAAAAAAAA (BBBBBBBBBBBB) 
       'C DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD)"

(WRITE-TO-STRING        '(a #'b c))
"(A #'B 
   C)"
;;"(A #'B C)"

(WRITE-TO-STRING        '(a `b c))
"(A `B 
   C)"
;;"(A `B C)"

(WRITE-TO-STRING        '(a ,b c))
"(A ,B 
   C)"
;;"(A ,B C)"

(WRITE-TO-STRING        '(a ,@b c))
"(A ,@B 
   C)"
;;"(A ,@B C)"

(WRITE-TO-STRING        '(a ,.b c))
"(A ,.B 
   C)"
;;"(A ,.B C)"

(WRITE-TO-STRING        '(displac0 (liste1)(liste2)))
"(displac0 (LISTE1) 
       (LISTE2))"

(WRITE-TO-STRING         
'(lambda (form vare lenv benv)
                        (progn (mapcon '(lambda (x)
                                                (if (typep 'list x)
                                                   (compile-exp x vare 
                                                            lenv benv)
                                                   '((lbl ,(cdr(assoc x 
                                                                lenv ))))))))))
"(LAMBDA (FORM VARE LENV BENV) 
       (PROGN (MAPCON '(LAMBDA (X) 
                              (IF (TYPEP 'LIST X) 
                                  (COMPILE-EXP X VARE LENV BENV) 
                                  '((LBL ,(CDR (ASSOC X LENV)))))))))"

(WRITE-TO-STRING         
'(lambda ()
                        ((c) nil "12345678901234567890123456789012")))
"(LAMBDA NIL 
       ((C) 
        NIL \"12345678901234567890123456789012\"))"

(WRITE-TO-STRING         '(lambda ()
        ((cccccccccccccccccccccccccccccccccccccccccccc) nil 
        "12345678901234567890123456789012")))
"(LAMBDA NIL 
       ((CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC) 
        NIL \"12345678901234567890123456789012\"))"

(WRITE-TO-STRING         '(defun ed-search-all
                        (cl)
                        (cond ((null (consp cl)) nil)
                                ((ed-search cl) t)
                                (t nil))))
"(DEFUN ED-SEARCH-ALL 
       (CL) 
       (COND ((NULL (CONSP CL)) 
              NIL) 
             ((ED-SEARCH CL) 
              T) 
             (T NIL)))"

(WRITE-TO-STRING         '(defun ed-search-all
                        (cl)
                        (cond ((null (consp ccccccccclllllllllll)) nil)
                                ((ed-search ccccccccclllllllllll) t)
                                (t nil))))
"(DEFUN ED-SEARCH-ALL 
       (CL) 
       (COND ((NULL (CONSP CCCCCCCCCLLLLLLLLLLL)) 
              NIL) 
             ((ED-SEARCH CCCCCCCCCLLLLLLLLLLL) 
              T) 
             (T NIL)))"

(WRITE-TO-STRING         '(a b c 
                    (d)
                    'e f g h i ))
"(A B C 
   (D) 
   'E F G H I)"

(WRITE-TO-STRING         '(aaaaaaaaaaa bbbbbbbbbb cccccccccc 
                    (dddddddddd)
                    'eeeeeeeeee fffffffffff gggggggggg hhhhhhhhhh iiiiiiiiii ))
"(AAAAAAAAAAA BBBBBBBBBB CCCCCCCCCC 
       (DDDDDDDDDD) 
       'EEEEEEEEEE FFFFFFFFFFF GGGGGGGGGG HHHHHHHHHH IIIIIIIIII)"

(WRITE-TO-STRING '(DEFMACRO DEFSTRUCT 
       (LET ((TYPE (CAR TYPE-OPTIONS)) (OPTIONS (CDR TYPE-OPTIONS))) 
            (LET ((DEFSTRUCT-TYPE (ANY-KNOWN-TYPE OPTIONS))) 
                 `(PROGN 'COMPILE 
                      (PUT ',TYPE 
                      (MAKE-DEFSTRUCT-DESCRIPTION NAME 
                         (LET ((I (1- (DEFSTRUCT-TYPE-DESCRIPTION-OVERHEAD (
                                             GET ',DEFSTRUCT-TYPE 
                                             'DEFSTRUCT-TYPE-DESCRIPTION)))))))))))))
"(DEFMACRO DEFSTRUCT 
       (LET ((TYPE (CAR TYPE-OPTIONS)) 
             (OPTIONS (CDR TYPE-OPTIONS))) 
            (LET ((DEFSTRUCT-TYPE (ANY-KNOWN-TYPE OPTIONS))) 
                 `(PROGN 'COMPILE 
                         (PUT ',TYPE 
                              (MAKE-DEFSTRUCT-DESCRIPTION NAME 
                                     (LET ((I (1- 
                                           (DEFSTRUCT-TYPE-DESCRIPTION-OVERHEAD 
                                                  (GET ',DEFSTRUCT-TYPE 
                                                    'DEFSTRUCT-TYPE-DESCRIPTION))))))))))))"

(WRITE-TO-STRING '(SETQ (COND ((SETQ (CATCH (MAPCAN '(LAMBDA (SPEC) 

              (CASE (T (COND ((SETQ (COND ((MINUSP SPEC))))))))))))))))
"(SETQ (COND ((SETQ (CATCH (MAPCAN '(LAMBDA (SPEC) 
                                          (CASE (T (COND ((SETQ (COND ((MINUSP 
                                                                           SPEC)))))))))))))))"

(WRITE-TO-STRING '((SETQ (CATCH (MAPCAN '(LAMBDA (SPEC) 
              (CASE (T (COND ((COND (EVENT1 (COND ((AND (EQCAR INPU 
))))))))))))))))
"((SETQ (CATCH (MAPCAN '(LAMBDA (SPEC) 
                              (CASE (T (COND ((COND (EVENT1 (COND ((AND (EQCAR 
                                                                           INPU)))))))))))))))"
(WRITE-TO-STRING '(case a
       (otto (aaaaaaaaaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbb)
             (ccccccccccccccccccccc ddddddddddddddddddddddddddddddddddddd))
       (:otto (aaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb)
              (ccccccccccccccccccccccccc ddddddddddddddddddddddddd))
       (12 (aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbbbb)
           (ccccccccccccccccccccccccccccccccc  ddddddddddddddddddddddddddd))
       (#\n (aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbbbbb)
            (ccccccccccccccccccccccccccccccccccccccc ddddddddddddddddddddddd))))
"(CASE A 
      (OTTO (AAAAAAAAAAAAAAAAAAAAAAAAAAAAA BBBBBBBBBBBBBBBBBBBBBB) 
            (CCCCCCCCCCCCCCCCCCCCC DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD)) 
      (:OTTO (AAAAAAAAAAAAAAAAAAAAAA BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB) 
             (CCCCCCCCCCCCCCCCCCCCCCCCC DDDDDDDDDDDDDDDDDDDDDDDDD)) 
      (12 (AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA BBBBBBBBBBBBBBBBBBBBBBBBBBB) 
          (CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DDDDDDDDDDDDDDDDDDDDDDDDDDD)) 
      (#\\n (AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA BBBBBBBBBBBBBBBBBBBBBBBBB) 
           (CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DDDDDDDDDDDDDDDDDDDDDDD)))"

(WRITE-TO-STRING '(DEFMACRO DEFSTRUCT-TYPE-DESCRIPTION-OVERHEAD (A_STRUCTURE) 

(LET ((TYPE (QUOTE DEFSTRUCT-TYPE-DESCRIPTION)) (SLOT-NAME (QUOTE OVERHEAD))) 

(EVAL (DEFSTRUCT-TYPE-DESCRIPTION-REF 
(GET (QUOTE LIST) (QUOTE DEFSTRUCT-TYPE-DESCRIPTION)))))))
"(DEFMACRO DEFSTRUCT-TYPE-DESCRIPTION-OVERHEAD 
       (A_STRUCTURE) 
       (LET ((TYPE 'DEFSTRUCT-TYPE-DESCRIPTION) 
             (SLOT-NAME 'OVERHEAD)) 
            (EVAL (DEFSTRUCT-TYPE-DESCRIPTION-REF (GET 'LIST 
                                                    'DEFSTRUCT-TYPE-DESCRIPTION)))))"

(WRITE-TO-STRING '(defmacro aaa
(let--eval--defstruct-type-description-ref 
(get lista qdefstruct-type-description))))
"(DEFMACRO AAA 
       (LET--EVAL--DEFSTRUCT-TYPE-DESCRIPTION-REF (GET LISTA 
                                                    QDEFSTRUCT-TYPE-DESCRIPTION)))"

(WRITE-TO-STRING 
      '(UN-MAC-EXPAND DM-DF KWOTE MOVD SP VIRGINFN OK EF EXPAND-MCALL 
              EXPANDMACROS IS-displac0 IS-MACRO MAC-EXPAND R-EXPANDMACROS 
              PUTPROPS1 *UNDIS *DIS COPY PUTPROPS *CHE *CL *CLE *TEST *UNBLOCK 
        CH 
              EDITCOMS EDREPLACE PRINTLEVEL NEQ *UNDO ABFRAGE ATOML CONS0 CONT 
        EDFIND1ST 
              EDITF ))
"(UN-MAC-EXPAND DM-DF KWOTE MOVD SP VIRGINFN OK EF EXPAND-MCALL EXPANDMACROS 
       IS-displac0 IS-MACRO MAC-EXPAND R-EXPANDMACROS PUTPROPS1 *UNDIS *DIS 
       COPY PUTPROPS *CHE *CL *CLE *TEST *UNBLOCK CH EDITCOMS EDREPLACE 
       PRINTLEVEL NEQ *UNDO ABFRAGE ATOML CONS0 CONT EDFIND1ST EDITF)"

(WRITE-TO-STRING '(DEFUN MAKEFILE 
       (LET 
            (PRINT (displac0 (LIST 'PRINT (LIST 'QUOTE (LIST 'LAST 'UPDATE 
        (DATE-TIME)))) `(PRINT '(LAST UPDATE ,(DATE-TIME)))) (OR ECHO STREAM)) 
            (PRINT (displac0 (LIST 'PRINT (LIST 'QUOTE (LIST 'VERSION GENV))) 
        `(PRINT '(VERSION ,GENV))) (OR ECHO STREAM)) 
            (WHEN FNSV (PRINT (displac0 (LIST 'SETQ FNS (LIST 'QUOTE FNSV)) 
        `(SETQ ,FNS ',FNSV)) (OR ECHO STREAM))) 
            (WHEN VARSV (PRINT (displac0 (LIST 'SETQ VARS (LIST 'QUOTE VARSV)) 
        `(SETQ ,VARS ',VARSV)) (OR ECHO STREAM))) 
            (PRINT (displac0 (LIST 'SETQ COMS (LIST 'QUOTE COMSV)) `(SETQ 
        ,COMS ',COMSV)) (OR ECHO STREAM)) 
            (PRINT (LIST 'SETQ GEN GENV) (OR ECHO STREAM)) )))
"(DEFUN MAKEFILE 
       (LET (PRINT (displac0 (LIST 'PRINT 
                                   (LIST 'QUOTE 
                                         (LIST 'LAST 'UPDATE 
                                               (DATE-TIME)))) 
                          `(PRINT '(LAST UPDATE 
                                         ,(DATE-TIME)))) 
                   (OR ECHO STREAM)) 
            (PRINT (displac0 (LIST 'PRINT 
                                   (LIST 'QUOTE 
                                         (LIST 'VERSION GENV))) 
                          `(PRINT '(VERSION ,GENV))) 
                   (OR ECHO STREAM)) 
            (WHEN FNSV 
                  (PRINT (displac0 (LIST 'SETQ FNS 
                                         (LIST 'QUOTE FNSV)) 
                                `(SETQ ,FNS 
                                       ',FNSV)) 
                         (OR ECHO STREAM))) 
            (WHEN VARSV 
                  (PRINT (displac0 (LIST 'SETQ VARS 
                                         (LIST 'QUOTE VARSV)) 
                                `(SETQ ,VARS 
                                       ',VARSV)) 
                         (OR ECHO STREAM))) 
            (PRINT (displac0 (LIST 'SETQ COMS 
                                   (LIST 'QUOTE COMSV)) 
                          `(SETQ ,COMS 
                                 ',COMSV)) 
                   (OR ECHO STREAM)) 
            (PRINT (LIST 'SETQ GEN GENV) 
                   (OR ECHO STREAM))))"

(write-to-string  '(DEFUN EVENT-SPEC 
       (aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa (
                                                                       (NUMBERP 
                                                                           SPEC) 
                                                                       (SETQ 
                                                                         EVENT1 
                                                                         (COND (
                                                                        (MINUSP 
                                                                           SPEC) 
                                                                      (NTH-BACK 
                                                                        HISTORY 
                                                                        (1- 
                                                                           SPEC))) 
))))))
"(DEFUN EVENT-SPEC 
       (AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA (
                                                                       (NUMBERP 
                                                                           SPEC) 
                                                                         (SETQ 
                                                                         EVENT1 
                                                                         (COND (
                                                                        (MINUSP 
                                                                           SPEC) 
                                                                      (NTH-BACK 
                                                                        HISTORY 
                                                                        (1- 
                                                                           SPEC))))))))"

(WRITE-TO-STRING '(DEFUN EVENT-SPEC 
       ((LAMBDAxSETQxxCONDxxxSETQxxCATCHxxMAPCANxxxxxCASE (TxxCOND 
                                        (COND (EVENT1 
                                            (COND (E (LIST EVENT1)) 
                                                  ((AND (CONSP INPU)        ;!!!
                                                        (EQCAR INPU '&GROUP)) 
                                                   (APPEND (CDR INPU) NIL)) ;!!!
                                                  (T)))))))))
"(DEFUN EVENT-SPEC 
       ((LAMBDAXSETQXXCONDXXXSETQXXCATCHXXMAPCANXXXXXCASE (TXXCOND (COND 
                                                                        (EVENT1 
                                                                          (COND 
                                                                             (E 
                                                                          (LIST 
                                                                         EVENT1)) 
                                                                                (
                                                                           (AND 
                                                                         (CONSP 
                                                                           INPU) 
                                                                         (EQCAR 
                                                                           INPU 
                                                                        '&GROUP)) 
                                                                        (APPEND 
                                                                           (CDR 
                                                                           INPU) 
                                                                            NIL)) 
                                                                             (T))))))))"
(WRITE-TO-STRING 
'(DEFUN EVENT-SPEC 
   ((LAMBDA (EVENT V INPUT EVENT1 I E) 
      (SETQ INPUT 
        (COND ((SETQ INPUT 
          (CATCH 'TAG 
            (MAPCAN '(LAMBDA (SPEC) 
              (CASE SPEC 
                (T (COND ((NUMBERP SPEC) 
                          (SETQ EVENT1 
                                (COND ((MINUSP SPEC) 
                                       (NTH-BACK HISTORY 
                                                 (1- SPEC))))) 
                          (COND (EVENT1 (COND ((AND (EQCAR INPU '&GROUP))))))) 
            (T (PRINTL-SP "illegale specification" SPEC 'IN L)))))) 
L))))))))))
"(DEFUN EVENT-SPEC 
       ((LAMBDA (EVENT V INPUT EVENT1 I E) 
               (SETQ INPUT 
                     (COND ((SETQ INPUT 
                                  (CATCH 'TAG 
                                         (MAPCAN '(LAMBDA (SPEC) 
                                                         (CASE SPEC 
                                                               (T (COND (
                                                                       (NUMBERP 
                                                                           SPEC) 
                                                                         (SETQ 
                                                                         EVENT1 
                                                                         (COND (
                                                                        (MINUSP 
                                                                           SPEC) 
                                                                      (NTH-BACK 
                                                                        HISTORY 
                                                                        (1- 
                                                                           SPEC))))) 
                                                                         (COND 
                                                                        (EVENT1 
                                                                          (COND (
                                                                           (AND 
                                                                         (EQCAR 
                                                                           INPU 
                                                                        '&GROUP))))))) 
                                                                        (T 
                                                                     (PRINTL-SP 
                                                       \"illegale specification\" 
                                                       SPEC 'IN L)))))) 
                                                L)))))))))"

(WRITE-TO-STRING '(DEFUN EVENT-SPEC 
       (HISTORY &OPTIONAL L) 
       ((LAMBDA (EVENT V INPUT EVENT1 I E) 
               (SETQ INPUT 
                     (COND ((NULL L) 
                            (CAR (CDR (CAR (CAR (CDDDR (CAR HISTORY))))))) 
                           ((SETQ INPUT 
                                  (CATCH 'TAG 
                                         (MAPCAN '(LAMBDA (SPEC) 
                                                         (CASE SPEC 
                                                               (V (SETQ V T) 
                                                                  (SETQ E NIL) 
                                                                  NIL) 
                                                               (I (SETQ V NIL) 
                                                                  (SETQ E NIL)) 
                                                               (E (SETQ E T) 
                                                                  (SETQ V NIL) 
                                                                  (SETQ I NIL)) 
                                                               (T (COND (
                                                                       (NUMBERP 
                                                                           SPEC) 
                                                                       (SETQ 
                                                                         EVENT1 
                                                                         (COND (
                                                                        (MINUSP 
                                                                           SPEC) 
                                                                      (NTH-BACK 
                                                                        HISTORY 
                                                                        (1- 
                                                                           SPEC))) 
                                                                               (
                                                                     (ASSQ-HOLD 
                                                                           SPEC 
                                                                        HISTORY)))) 
                                                                       (COND 
                                                                        (EVENT1 
                                                                          (SETQ 
                                                                           INPU 
                                                                           (CAR 
                                                                           (CDR 
                                                                         EVENT1))) 
                                                                          (COND 
                                                                             (V 
                                                                          (LIST 
                                                                           (CAR 
                                                                          (CDDR 
                                                                         EVENT1)))) 
                                                                             (E 
                                                                          (LIST 
                                                                         EVENT1)) 
                                                                             (
                                                                           (AND 
                                                                         (CONSP 
                                                                           INPU) 
                                                                         (EQCAR 
                                                                           INPU 
                                                                        '&GROUP)) 
                                                                        (APPEND 
                                                                           (CDR 
                                                                           INPU) 
                                                                           NIL)) 
                                                                             (T 
                                                                          (LIST 
                                                                           INPU)))))) 
                                                                        (T 
                                                                     (PRINTL-SP 
                                                                            "illegale specification" 
                                                                           SPEC 
                                                                      'IN L) )))))))))))))))
"(DEFUN EVENT-SPEC 
       (HISTORY &OPTIONAL L) 
       ((LAMBDA (EVENT V INPUT EVENT1 I E) 
               (SETQ INPUT 
                     (COND ((NULL L) 
                            (CAR (CDR (CAR (CAR (CDDDR (CAR HISTORY))))))) 
                           ((SETQ INPUT 
                                  (CATCH 'TAG 
                                         (MAPCAN '(LAMBDA (SPEC) 
                                                         (CASE SPEC 
                                                               (V (SETQ V T) 
                                                                  (SETQ E NIL) 
                                                                  NIL) 
                                                               (I (SETQ V NIL) 
                                                                  (SETQ E NIL)) 
                                                               (E (SETQ E T) 
                                                                  (SETQ V NIL) 
                                                                  (SETQ I NIL)) 
                                                               (T (COND (
                                                                       (NUMBERP 
                                                                           SPEC) 
                                                                         (SETQ 
                                                                         EVENT1 
                                                                         (COND (
                                                                        (MINUSP 
                                                                           SPEC) 
                                                                      (NTH-BACK 
                                                                        HISTORY 
                                                                        (1- 
                                                                           SPEC))) 
                                                                               (
                                                                     (ASSQ-HOLD 
                                                                           SPEC 
                                                                        HISTORY)))) 
                                                                         (COND 
                                                                        (EVENT1 
                                                                          (SETQ 
                                                                           INPU 
                                                                           (CAR 
                                                                           (CDR 
                                                                         EVENT1))) 
                                                                          (COND 
                                                                             (V 
                                                                          (LIST 
                                                                           (CAR 
                                                                          (CDDR 
                                                                         EVENT1)))) 
                                                                             (E 
                                                                          (LIST 
                                                                         EVENT1)) 
                                                                             (
                                                                           (AND 
                                                                         (CONSP 
                                                                           INPU) 
                                                                         (EQCAR 
                                                                           INPU 
                                                                        '&GROUP)) 
                                                                        (APPEND 
                                                                           (CDR 
                                                                           INPU) 
                                                                            NIL)) 
                                                                             (T 
                                                                          (LIST 
                                                                           INPU)))))) 
                                                                        (T 
                                                                     (PRINTL-SP 
                                                       \"illegale specification\" 
                                                       SPEC 'IN L)))))))))))))))"

;***4

(WRITE-TO-STRING '(LAMBDA (PP-CALL &OPTIONAL ENV) 
       (LET ((SYMB (CADR PP-CALL))) 
            (IF (SYMBOLP SYMB) 
                (LIST 'PROGN 
                      (IF (BOUNDP SYMB) 
                          (LIST 'PPRINT SYMB)) 
                      (IF (FBOUNDP SYMB) 
                          (LET ((FUN (SYMBOL-FUNCTION SYMB))) 
                               (COND ((EQ (SYSTEM::%GET-TYPE FUN) 
                                          SYSTEM::%TYPE-CLOSURE) 
                                      (LIST 'PPRINT 
                                            (LIST 'QUOTE 
                                                  (LIST* 'DEFUN SYMB 
                                                         (CDR (SYSTEM::%P-GET-CONTENT 
                                                               (SYSTEM::%INDEX-LOCATION 
                                                                FUN 3))))))) 
                                     ((EQ (SYSTEM::%GET-TYPE FUN) 
                                          SYSTEM::%TYPE-CONS) 
                                      (LIST 'PPRINT 
                                            (LIST 'QUOTE 
                                                  (LIST* 'DEFUN SYMB 
                                                         (CDR FUN))))) 
                                     ((EQ (SYSTEM::%GET-TYPE FUN) 
                                          SYSTEM::%TYPE-MACRO-FUNCTION) 
                                      (LET ((FUNLIS (SYSTEM::%SET-TYPE-POINTER 
                                                           SYSTEM::%TYPE-CONS 
                                                           FUN))) 
                                           (LIST 'PPRINT 
                                                 (LIST 'QUOTE 
                                                       (COND ((NULL (CDR FUNLIS)) 
                                                              (CAR FUNLIS)) 
                                                             (T (CADR FUNLIS)))))))))) 
                      "ok")))))
"(LAMBDA (PP-CALL &OPTIONAL ENV) 
       (LET ((SYMB (CADR PP-CALL))) 
            (IF (SYMBOLP SYMB) 
                (LIST 'PROGN 
                      (IF (BOUNDP SYMB) 
                          (LIST 'PPRINT SYMB)) 
                      (IF (FBOUNDP SYMB) 
                          (LET ((FUN (SYMBOL-FUNCTION SYMB))) 
                               (COND ((EQ (SYSTEM::%GET-TYPE FUN) 
                                          SYSTEM::%TYPE-CLOSURE) 
                                      (LIST 'PPRINT 
                                            (LIST 'QUOTE 
                                                  (LIST* 'DEFUN SYMB 
                                                         (CDR 
                                                        (SYSTEM::%P-GET-CONTENT 
                                                       (SYSTEM::%INDEX-LOCATION 
                                                              FUN 3))))))) 
                                     ((EQ (SYSTEM::%GET-TYPE FUN) 
                                          SYSTEM::%TYPE-CONS) 
                                      (LIST 'PPRINT 
                                            (LIST 'QUOTE 
                                                  (LIST* 'DEFUN SYMB 
                                                         (CDR FUN))))) 
                                     ((EQ (SYSTEM::%GET-TYPE FUN) 
                                          SYSTEM::%TYPE-MACRO-FUNCTION) 
                                      (LET ((FUNLIS (SYSTEM::%SET-TYPE-POINTER 
                                                           SYSTEM::%TYPE-CONS 
                                                           FUN))) 
                                           (LIST 'PPRINT 
                                                 (LIST 'QUOTE 
                                                       (COND ((NULL (CDR FUNLIS)) 
                                                              (CAR FUNLIS)) 
                                                             (T (CADR FUNLIS)))))))))) 
                      \"ok\"))))"

(WRITE-TO-STRING '
(LAMBDA (PP-CALL &OPTIONAL ENV) 
       (LET ((SYMB (CADR PP-CALL))) 
            (IF (SYMBOLP SYMB) 
                (LIST 'PROGN 
                      (IF (BOUNDP SYMB) 
                          (LIST 'PPRINT SYMB)) 
                      (IF (FBOUNDP SYMB) 
                          (LET ((FUN (SYMBOL-FUNCTION SYMB))) 
                               (COND ((EQ (SYSTEM::%GET-TYPE FUN) 
                                          SYSTEM::%TYPE-CLOSURE) 
                                      (LIST 'PPRINT 
                                            (LIST 'QUOTE 
                                                  (LIST* 'DEFUN SYMB 
                                                         (CDR (SYSTEM::%P-GET-CONTENT 
                                                               (SYSTEM::%INDEX-LOCATION 
                                                                FUN 3))))))) ))))))))
"(LAMBDA (PP-CALL &OPTIONAL ENV) 
       (LET ((SYMB (CADR PP-CALL))) 
            (IF (SYMBOLP SYMB) 
                (LIST 'PROGN 
                      (IF (BOUNDP SYMB) 
                          (LIST 'PPRINT SYMB)) 
                      (IF (FBOUNDP SYMB) 
                          (LET ((FUN (SYMBOL-FUNCTION SYMB))) 
                               (COND ((EQ (SYSTEM::%GET-TYPE FUN) 
                                          SYSTEM::%TYPE-CLOSURE) 
                                      (LIST 'PPRINT 
                                            (LIST 'QUOTE 
                                                  (LIST* 'DEFUN SYMB 
                                                         (CDR 
                                                        (SYSTEM::%P-GET-CONTENT 
                                                       (SYSTEM::%INDEX-LOCATION 
                                                              FUN 3))))))))))))))"
(WRITE-TO-STRING '
(LAMBDA (PP-CALL &OPTIONAL ENV) 
       (LET (IF (LIST (IF (LET (COND ((LIST (LIST (LIST* (CDR (SYSTEM::%P-GET-CONTENT 
                                                               (SYSTEM::%INDEX-LOCATION 
                                                                FUN 3))))))) ))))))))
"(LAMBDA (PP-CALL &OPTIONAL ENV) 
       (LET (IF (LIST (IF (LET (COND ((LIST (LIST (LIST* (CDR 
                                                        (SYSTEM::%P-GET-CONTENT 
                                                       (SYSTEM::%INDEX-LOCATION 
                                                              FUN 3))))))))))))))"
(WRITE-TO-STRING '
(LAMBDA (PP-CALL &OPTIONAL ENV) 
       (letttttttttttttttttttttttttttttttttttttttttttttt (CDR (SYSTEM::%P-GET-CONTENT 
                                                               (SYSTEM::%INDEX-LOCATION 
                                                                FUN 3))))))
"(LAMBDA (PP-CALL &OPTIONAL ENV) 
       (LETTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT (CDR 
                                                        (SYSTEM::%P-GET-CONTENT 
                                                       (SYSTEM::%INDEX-LOCATION 
                                                              FUN 3)))))"

(WRITE-TO-STRING '
(lambdaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa (CDR (SYSTEM::%P-GET-CONTENT 
                                                               (SYSTEM::%INDEX-LOCATION 
                                                                FUN 3) ))))
"(LAMBDAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA (CDR 
                                                        (SYSTEM::%P-GET-CONTENT 
                                                       (SYSTEM::%INDEX-LOCATION 
                                                              FUN 3))))"

(WRITE-TO-STRING '
(laaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa (SYSTEM::%P-GET-CONTENT 
                                                               (SYSTEM::%INDEX-LOCATION 
                                                                FUN 3) )))
"(LAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 
       (SYSTEM::%P-GET-CONTENT (SYSTEM::%INDEX-LOCATION FUN 3)))"

(SETQ *PRINT-PRETTY* NIL)
NIL

;***5

(defstruct name a b c d e)
NAME

(progn (setq val '(name 1 2 3 4 5))
       (setq st (sys::%set-type-pointer sys::%type-named-structure val))
        T)
T

(WRITE-TO-STRING st)
"#S(NAME A 1 B 2 C 3 D 4 E 5)"

(defstruct (pcvar (:print-function print-pcvar)) id)
pcvar

(defun print-pcvar (var str dep)
 (format str "?~s" (pcvar-id var)))
print-pcvar

(prin1-to-string (make-pcvar :id 'otto))
"?OTTO"

#|-------------------------------------------------------------------------

-------------------------------------------------------------------------|#