← Back to branch summary

~ubuntu-branches/ubuntu/karmic/maxima/karmic

« back to all changes in this revision

Viewing changes to share/contrib/gentran/segmnt.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-11-13 18:39:14 UTC
  • mto: (2.1.2 hoary) (3.2.1 sid) (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 3.
  • Revision ID: james.westby@ubuntu.com-20041113183914-ttig0evwuatnqosl
Tags: upstream-5.9.1
Import upstream version 5.9.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
share/contrib/gentran/segmnt.lisp
 
1
;=============================================================================
 
2
;    (c) copyright 1988  Kent State University  kent, ohio 44242 
 
3
;               all rights reserved.
 
4
;
 
5
; Authors:  Paul S. Wang, Barbara Gates
 
6
; Permission to use this work for any purpose is granted provided that
 
7
; the copyright notice, author and support credits above are retained.
 
8
;=============================================================================
 
9
 
 
10
(include-if (null (getd 'wrs)) convmac.l)
 
11
 
 
12
(declare (special *gentran-dir tempvartype* tempvarname* tempvarnum* genstmtno*
 
13
        genstmtincr* *symboltable* *instk* *stdin* *currin* *outstk*
 
14
        *stdout* *currout* *outchanl* *lispdefops* *lisparithexpops*
 
15
        *lisplogexpops* *lispstmtops* *lispstmtgpops*))
 
16
;;  -----------  ;;
 
17
;;  segmnt.l     ;;    segmentation module
 
18
;;  -----------  ;;
 
19
 
 
20
(declare (special *gentranopt *gentranlang maxexpprintlen*))
 
21
 
 
22
;;                           ;;
 
23
;; 1. segmentation routines  ;;
 
24
;;                           ;;
 
25
 
 
26
 
 
27
(de seg (forms)
 
28
  ; exp  --+-->  exp                                          ;
 
29
  ;        +-->  (assign    assign    ... assign      exp   ) ;
 
30
  ;                     (1)       (2)           (n-1)    (n)  ;
 
31
  ; stmt  --+-->  stmt                                        ;
 
32
  ;         +-->  stmtgp                                      ;
 
33
  ; stmtgp  ----->  stmtgp                                    ;
 
34
  ; def  ----->  def                                          ;
 
35
  (foreach f in forms collect
 
36
           (cond ((lispexpp f)
 
37
                  (cond ((toolongexpp f)
 
38
                         (segexp f 'unknown))
 
39
                        (t
 
40
                         f)))
 
41
                 ((lispstmtp f)
 
42
                  (segstmt f))
 
43
                 ((lispstmtgpp f)
 
44
                  (cond ((toolongstmtgpp f)
 
45
                         (seggroup f))
 
46
                        (t
 
47
                         f)))
 
48
                 ((lispdefp f)
 
49
                  (cond ((toolongdefp f)
 
50
                         (segdef f))
 
51
                        (t
 
52
                         f)))
 
53
                 (t
 
54
                  f))))
 
55
 
 
56
(de segexp (exp type)
 
57
  ; exp  -->  (assign    assign    ... assign      exp   ) ;
 
58
  ;                  (1)       (2)           (n-1)    (n)  ;
 
59
  (reverse (segexp1 exp type)))
 
60
 
 
61
(de segexp1 (exp type)
 
62
  ; exp  -->  (exp    assign      assign      ... assign   ) ;
 
63
  ;               (n)       (n-1)       (n-2)           (1)  ;
 
64
  (prog (res tempvarname)
 
65
        (setq tempvarname tempvarname*)
 
66
        (cond (*gentranopt
 
67
               (setq tempvarname (stripdollar1 tempvarname))
 
68
               (setq tempvarname* (explode2 tempvarname))
 
69
               (setq tempvarname* (compress (cons (car tempvarname*)
 
70
                                                  tempvarname*)))))
 
71
        (setq res (segexp2 exp type))
 
72
        (recurunmark res)
 
73
        (setq tempvarname* tempvarname)
 
74
        (cond ((equal (car res) (cadadr res))
 
75
               (progn
 
76
                (setq res (cdr res))
 
77
                (rplaca res (caddar res)))))
 
78
        (return res)))
 
79
 
 
80
(de segexp2 (exp type)
 
81
  ; exp  -->  (exp    assign      assign      ... assign   ) ;
 
82
  ;               (n)       (n-1)       (n-2)           (1)  ;
 
83
  (prog (expn assigns newassigns unops op termlist var tmp)
 
84
        (setq expn exp)
 
85
        (while (equal (length expn) 2)
 
86
               (progn
 
87
                (setq unops (cons (car expn) unops))
 
88
                (setq expn (cadr expn))))
 
89
        (setq op (car expn))
 
90
        (foreach term in (cdr expn) do
 
91
                 (progn
 
92
                  (cond ((toolongexpp term)
 
93
                         (progn
 
94
                          (setq tmp (segexp2 term type))
 
95
                          (setq term (car tmp))
 
96
                          (setq newassigns (cdr tmp))))
 
97
                        (t
 
98
                         (setq newassigns 'nil)))
 
99
                  (cond ((and (toolongexpp (cons op (cons term termlist)))
 
100
                              termlist
 
101
                              (or (> (length termlist) 1)
 
102
                                  (listp (car termlist))))
 
103
                         (progn
 
104
                          (recurunmark termlist)
 
105
                          (setq var (or var (tempvar type)))
 
106
                          (markvar var)
 
107
                          (setq assigns
 
108
                                (cons (mkassign var
 
109
                                                (cond ((onep (length termlist))
 
110
                                                       (car termlist))
 
111
                                                      (t
 
112
                                                       (cons op termlist))))
 
113
                                      assigns))
 
114
                          (setq termlist (list var term))))
 
115
                        (t
 
116
                         (setq termlist (aconc termlist term))))
 
117
                  (setq assigns (append newassigns assigns))))
 
118
        (setq expn (cond ((onep (length termlist))
 
119
                          (car termlist))
 
120
                         (t
 
121
                          (cons op termlist))))
 
122
        (while unops
 
123
               (progn
 
124
                (setq expn (list (car unops) expn))
 
125
                (setq unops (cdr unops))))
 
126
        (cond ((equal expn exp)
 
127
               (progn
 
128
                (recurunmark expn)
 
129
                (setq var (or var (tempvar type)))
 
130
                (markvar var)
 
131
                (setq assigns (list (mkassign var expn)))
 
132
                (setq expn var))))
 
133
        (return (cons expn assigns))))
 
134
 
 
135
(de segstmt (stmt)
 
136
  ; assign  --+-->  assign ;
 
137
  ;           +-->  stmtgp ;
 
138
  ; cond  --+-->  cond     ;
 
139
  ;         +-->  stmtgp   ;
 
140
  ; do --+-->  do          ;
 
141
  ;      +-->  stmtgp      ;
 
142
  ; return  --+-->  return ;
 
143
  ;           +-->  stmtgp ;
 
144
  (cond ((lispassignp stmt)
 
145
         (cond ((toolongassignp stmt)
 
146
                (segassign stmt))
 
147
               (t
 
148
                stmt)))
 
149
        ((lispcondp stmt)
 
150
         (cond ((toolongcondp stmt)
 
151
                (segcond stmt))
 
152
               (t
 
153
                stmt)))
 
154
        ((lispdop stmt)
 
155
         (cond ((toolongdop stmt)
 
156
                (segdo stmt))
 
157
               (t
 
158
                stmt)))
 
159
        ((lispreturnp stmt)
 
160
         (cond ((toolongreturnp stmt)
 
161
                (segreturn stmt))
 
162
               (t
 
163
                stmt)))
 
164
        (t
 
165
         stmt)))
 
166
 
 
167
(de segassign (stmt)
 
168
  ; assign  -->  stmtgp ;
 
169
  (prog (var exp type)
 
170
        (setq var (cadr stmt))
 
171
        (setq type (getvartype var))
 
172
        (setq exp (caddr stmt))
 
173
        (setq stmt (segexp1 exp type))
 
174
        (rplaca stmt (mkassign var (car stmt)))
 
175
        (return (mkstmtgp 0 (reverse stmt)))))
 
176
 
 
177
(de segcond (cond)
 
178
  ; cond  --+-->  cond   ;
 
179
  ;         +-->  stmtgp ;
 
180
  (prog (tassigns res markedvars type)
 
181
        (cond ((eq *gentranlang 'c)
 
182
               (setq type 'int))
 
183
              (t
 
184
               (setq type 'logical)))
 
185
        (while (setq cond (cdr cond))
 
186
               (prog (exp stmt)
 
187
                     (cond ((toolongexpp (setq exp (caar cond)))
 
188
                            (progn
 
189
                             (setq exp (segexp1 exp type))
 
190
                             (setq tassigns (append (cdr exp) tassigns))
 
191
                             (setq exp (car exp))
 
192
                             (markvar exp)
 
193
                             (setq markedvars (cons exp markedvars)))))
 
194
                     (setq stmt (foreach st in (cdar cond) collect
 
195
                                         (segstmt st)))
 
196
                     (setq res (cons (cons exp stmt) res))))
 
197
        (recurunmark markedvars)
 
198
        (return (cond (tassigns
 
199
                       (mkstmtgp 0
 
200
                                 (reverse (cons (mkcond (reverse res))
 
201
                                                tassigns))))
 
202
                      (t
 
203
                       (mkcond (reverse res)))))))
 
204
 
 
205
(de segdo (stmt)
 
206
  ; do  --+-->  do     ;
 
207
  ;       +-->  stmtgp ;
 
208
  (prog (tassigns var initexp nextexp exitcond body markedvars type)
 
209
        (setq body (cdddr stmt))
 
210
        (cond ((setq var (cadr stmt))
 
211
               (progn
 
212
                (cond ((toolongexpp (setq initexp (cadar var)))
 
213
                       (progn
 
214
                        (setq type (getvartype (caar var)))
 
215
                        (setq initexp (segexp1 initexp type))
 
216
                        (setq tassigns (cdr initexp))
 
217
                        (setq initexp (car initexp))
 
218
                        (markvar initexp)
 
219
                        (setq markedvars (cons initexp markedvars)))))
 
220
                (cond ((toolongexpp (setq nextexp (caddar var)))
 
221
                       (progn
 
222
                        (setq type (getvartype (caar var)))
 
223
                        (setq nextexp (segexp1 nextexp type))
 
224
                        (setq body (append body (reverse (cdr nextexp))))
 
225
                        (setq nextexp (car nextexp))
 
226
                        (markvar nextexp)
 
227
                        (setq markedvars (cons nextexp markedvars)))))
 
228
                (setq var (list (list (caar var) initexp nextexp))))))
 
229
        (cond ((toolongexpp (car (setq exitcond (caddr stmt))))
 
230
               (prog (texps ltype)
 
231
                     (cond ((eq *gentranlang 'c)
 
232
                            (setq ltype 'int))
 
233
                           (t
 
234
                            (setq ltype 'logical)))
 
235
                     (setq texps (segexp1 (car exitcond) ltype))
 
236
                     (markvar (car texps))
 
237
                     (setq markedvars (cons (car texps) markedvars))
 
238
                     (rplaca exitcond (car texps))
 
239
                     (foreach texp in (reverse (cdr texps)) do
 
240
                              (progn
 
241
                               (setq texp (reverse texp))
 
242
                               (setq var
 
243
                                     (cons (cdr (reverse (cons (car texp)
 
244
                                                               texp)))
 
245
                                           var))))
 
246
                     (setq var (reverse var)))))
 
247
        (setq body (foreach st in body collect (segstmt st)))
 
248
        (recurunmark markedvars)
 
249
        (return (cond (tassigns
 
250
                       (mkstmtgp 0 (reverse (cons (mkdo var exitcond body)
 
251
                                                  tassigns))))
 
252
                      (t
 
253
                       (mkdo var exitcond body))))))
 
254
 
 
255
(de segreturn (ret)
 
256
  ; return  -->  stmtgp ;
 
257
  (progn
 
258
   (setq ret (segexp1 (cadr ret) 'unknown))
 
259
   (rplaca ret (mkreturn (car ret)))
 
260
   (mkstmtgp 0 (reverse ret))))
 
261
 
 
262
(de seggroup (stmtgp)
 
263
  ; stmtgp  -->  stmtgp ;
 
264
  (prog (locvars res)
 
265
        (cond ((equal (car stmtgp) 'prog)
 
266
               (progn
 
267
                (setq locvars (cadr stmtgp))
 
268
                (setq stmtgp (cdr stmtgp))))
 
269
              (t
 
270
               (setq locvars 0)))
 
271
        (while (setq stmtgp (cdr stmtgp))
 
272
               (setq res (cons (segstmt (car stmtgp)) res)))
 
273
        (return (mkstmtgp locvars (reverse res)))))
 
274
 
 
275
(de segdef (def)
 
276
  ; def  -->  def ;
 
277
  (mkdef (cadr def)
 
278
         (caddr def)
 
279
         (foreach stmt in (cdddr def) collect (segstmt stmt))))
 
280
 
 
281
 
 
282
;;                                             ;;
 
283
;;  2. long statement & expression predicates  ;;
 
284
;;                                             ;;
 
285
 
 
286
 
 
287
(de toolongexpp (exp)
 
288
  (greaterp (numprintlen exp) maxexpprintlen*))
 
289
 
 
290
(de toolongstmtp (stmt)
 
291
  (cond ((atom stmt) nil)  ;; pwang 11/11/86
 
292
        ((lispstmtp stmt)
 
293
         (cond ((lispcondp stmt)
 
294
                (toolongcondp stmt))
 
295
               ((lispassignp stmt)
 
296
                (toolongassignp stmt))
 
297
               ((lispreturnp stmt)
 
298
                (toolongreturnp stmt))
 
299
               ((lispdop stmt)
 
300
                (toolongdop stmt))
 
301
               (t
 
302
                (eval (cons 'or
 
303
                            (foreach exp in stmt collect (toolongexpp exp)))))))
 
304
        (t
 
305
         (toolongstmtgpp stmt))))
 
306
 
 
307
(de toolongassignp (assign)
 
308
  (toolongexpp (caddr assign)))
 
309
 
 
310
(de toolongcondp (cond)
 
311
  (prog (toolong)
 
312
        (while (setq cond (cdr cond))
 
313
               (cond ((or (toolongexpp (caar cond))
 
314
                          (toolongstmtp (cadar cond)))
 
315
                      (setq toolong t))))
 
316
        (return toolong)))
 
317
 
 
318
(de toolongdop (dostmt)
 
319
  (cond ((greaterp (eval (cons 'plus (foreach exp in (caadr dostmt) collect
 
320
                                              (numprintlen exp))))
 
321
                   maxexpprintlen*) t)
 
322
        ((toolongexpp (caaddr dostmt)) t)
 
323
        ((lispstmtgpp (cadddr dostmt)) (toolongstmtgpp (cadddr dostmt)))
 
324
        (t (eval (cons 'or (foreach stmt in (cdddr dostmt) collect
 
325
                                    (toolongstmtp stmt)))))))
 
326
 
 
327
(de toolongreturnp (ret)
 
328
  (toolongexpp (cadr ret)))
 
329
 
 
330
(de toolongstmtgpp (stmtgp)
 
331
  (eval (cons 'or
 
332
              (foreach stmt in (cdr stmtgp) collect (toolongstmtp stmt)))))
 
333
 
 
334
(de toolongdefp (def)
 
335
  (cond ((lispstmtgpp (cadddr def))
 
336
         (toolongstmtgpp (cadddr def)))
 
337
        (t
 
338
         (eval (cons 'or
 
339
                     (foreach stmt in (cdddr def) collect
 
340
                              (toolongstmtp stmt)))))))
 
341
 
 
342
 
 
343
;;                            ;;
 
344
;;  3. print length function  ;;
 
345
;;                            ;;
 
346
 
 
347
 
 
348
(de numprintlen (exp)
 
349
  (cond ((atom exp)
 
350
         (length (explode exp)))
 
351
        ((onep (length exp))
 
352
         (numprintlen (car exp)))
 
353
        (t
 
354
         (plus (length exp)
 
355
               (eval (cons 'plus
 
356
                           (foreach elt in (cdr exp) collect
 
357
                                    (numprintlen elt))))))))