?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Print a warning when translating subscripted functions
[maxima.git] / share / contrib / gentran / allgentran.lisp
blobd332135104129c43b7b032afc0b15ea2d22f9aa7
1 ;;; ALL GENTRAN FILES IN ONE
2
3
4 ;*******************************************************************************
5 ;* *
6 ;* copyright (c) 1988 kent state univ. kent, ohio 44242
7 ;* modified for Maxima 01/15/2019 Michael D. Stern, Richard J. Fateman
8 ;* and other unknown soldiers. *
9 ;* *
10 ;*******************************************************************************
11
12
13 ;; --------- ;; load
14 ;; gtload.l ;; gentran code generation package
15 ;; --------- ;; for vaxima
16
17
18 (in-package :maxima)
19
20 (declare-top (special *c *cr* *currin* *currout* *endofloopstack* *eof*
21 *fortran *gendecs *instk* *lisparithexpops* *lispdefops* *lisplogexpops*
22 *lispstmtgpops* *lispstmtops* *outchanl* *outstk* *ratfor *reswds*
23 *slash* *stdin* *stdout* *symboltable* *vexptrm allnum comma* expty
24 oincr onextexp tvname $ccurrind $clinelen $dblfloat $fortcurrind
25 $fortlinelen $genfloat $genstmtincr $genstmtno $gentranlang $gentranopt
26 $gentranparser $gentranseg $implicit $maxexpprintlen $optimvarname
27 $ratcurrind $ratlinelen $tablen $tempvarname $tempvarnum $tempvartype
28 $usefortcomplex $geninpath $genoutpath fnotn))
29
30
31 ;; convmac text follows. garbage redefinition of stuff in lisp.
32 (defvar semicolon '|\;|)
33 (defvar sharpsign '|\#|)
34
35
36 (defmacro foreach (elt kw1 lst kw2 stmt)
37 ; ;
38 ; (foreach elt --> (progn (mapc (function (lambda (elt) stmt)) lst) nil) ;
39 ; in lst ;
40 ; do stmt) ;
41 ; ;
42 ; (foreach elt --> (progn (map (function (lambda (elt) stmt)) lst) nil) ;
43 ; on lst ;
44 ; do stmt) ;
45 ; ;
46 ; (foreach elt --> (mapcar (function (lambda (elt) stmt)) lst) ;
47 ; in lst ;
48 ; collect stmt) ;
49 ; ;
50 ; (foreach elt --> (maplist (function (lambda (elt) stmt)) lst) ;
51 ; on lst ;
52 ; collect stmt) ;
53 ; ;
54 ; (foreach elt --> (mapcan (function (lambda (elt) stmt)) lst) ;
55 ; in lst ;
56 ; conc stmt) ;
57 ; ;
58 ; (foreach elt --> (mapcon (function (lambda (elt) stmt)) lst) ;
59 ; on lst ;
60 ; conc stmt) ;
61 ; ;
62 (let ((fcn (cdr (assoc kw2 (cdr (assoc kw1 '((in (do . mapc)
63 (collect . mapcar)
64 (conc . mapcan))
65 (on (do . map)
66 (collect . maplist)
67 (conc . mapcon)))))))))
68 (cond ((member fcn '(mapc map))
69 `(progn (,fcn (function (lambda (,elt) ,stmt))
70 ,lst)
71 nil))
72 (t
73 `(,fcn (function (lambda (,elt) ,stmt))
74 ,lst)))))
75
76
77 (defmacro aconc (m1 m2)
78 ; ;
79 ; (aconc lst elt) --> (nconc lst (list elt)) ;
80 ; ;
81 `(nconc ,m1 (list ,m2)))
82
83 ;; really naive stuff below. rjf's opinion..
84 (defun caaaddr (p) (caaar (cddr p)))
85
86 (defun CADADDR (x) (car(cdr(car(cdr(cdr x))))))
87
88 (defun CADDADDR (x) (car(cdr(cdr(car(cdr(cdr x)))))))
89
90 (defun CADDDDDDDR (x) (car(cdr(cdr(cdr(cdr(cdr(cdr(cdr x)))))))))
91 ;;8th item. initial one is (nth 0) so this, above, is (nth 7 x)
92
93 (defun CADDDDDDR (x) (car(cdr(cdr(cdr(cdr(cdr(cdr x))))))))
94
95 (defun CADDDDDR (x) (car(cdr(cdr(cdr(cdr(cdr x)))))))
96
97 (defun CDADADDR (x) (cdr(car(cdr(car(cdr(cdr x)))))))
98
99 (defun CADDDDR (x) (car(cdr(cdr(cdr(cdr x))))))
100
101 (defun compress (m)
102 ; ;
103 ; (compress lst) --> (implode lst) ;
104 ; ;
105 (coerce m 'string))
106
107 (defun append1 (x y)
108 (append x (cons y ())))
109
110 (defmacro delete1 (e lst)
111 ; ;
112 ; (delete1 elt lst) --> (delete elt lst 1) ;
113 ; ;
114 `(delete ,e ,lst :count 1))
115
116 (defun explode2 (m)
117 ; ;
118 ; (explode2 arg) --> (explodec arg) ;
119 ; ;
120 (coerce (princ-to-string m) 'list))
121
122
123
124 (defmacro flag (&rest m)
125 ; ;
126 ; (flag varlst fname) --> (foreach v in varlst do ;
127 ; (putprop v t fname)) ;
128 ; ;
129 `(loop for v in ,(cadr m) do ;; rjf fix?
130 (putprop v t ,(caddr m))))
131
132
133 (defun flagp (var fname)
134 ; ;
135 ; (flagp var fname) --> (get var fname) ;
136 ; ;
137 (get var fname))
138
139
140 (defun geq (n1 n2)
141 ; ;
142 ; (geq n1 n2) --> (>= n1 n2) ;
143 ; ;
144 (>= n1 n2))
145
146
147 (defun idp (m)
148 ; ;
149 ; (idp exp) --> (symbolp exp) ;
150 ; ;
151 (symbolp m))
152
153
154 (defun mkfil (m)
155 ; ;
156 ; (mkfil arg) --> (stripdollar arg) ;
157 ; ;
158 ;;; (cons 'stripdollar m)) --mds
159 (stripdollar m))
160
161 (defun posn ()
162 ; ;
163 ; (posn) --> (nwritn) ;
164 ; ;
165 #+clisp (SYS::LINE-POSITION)
166 #+gcl (si::file-column *standard-output*)
167 #+cmu (lisp::charpos *standard-output*)
168 #+sbcl (sb-impl::charpos))
169
170
171
172 (defmacro prettyprint (m)
173 ; ;
174 ; (prettyprint exp) --> (prog1 ($prpr exp) (terpri)) ;
175 ; ;
176 `(prog1 (linear-displa ,m) (terpri)))
177
178
179 (defun put (id proptype propval)
180 ; ;
181 ; (put id proptype propval) --> (putprop id propval proptype) ;
182
183 (setf (get id proptype) propval) ;; rjf
184 ; ;
185 #+ignore (putprop id propval proptype)
186 )
187
188
189
190 (defun rederr (m)
191 ; ;
192 ; (rederr msg) --> (error msg) ;
193 ; ;
194 (cons 'error m))
195
196
197 (defmacro remflag (varlst fname)
198 ; ;
199 ; (remflag varlst fname) --> (foreach v in varlst do ;
200 ; (remprop v fname)) ;
201 ; ;
202 `(foreach v in ,varlst do
203 (remprop v ,fname)))
204
205
206
207 (defmacro repeat (stmt exp)
208 ; ;
209 ; (repeat stmt exp) --> (prog () ;
210 ; loop ;
211 ; stmt ;
212 ; (cond ((not exp) (go loop)))) ;
213 ; ;
214 `(prog ()
215 loop
216 ,stmt
217 (cond ((not ,exp) (go loop))))) ;; keep old definition due to evaluation order side effects -- mds
218
219 (defmacro spaces (m)
220 ; ;
221 ; (spaces n) --> (do ((i n (sub1 i))) ;
222 ; ((< i 1)) ;
223 ; (princ " ")) ;
224 ; ;
225 `(dotimes (i ,m) (princ " ")))
226
227
228
229
230 ;; ----------- ;;
231 ;; templt.l ;; template processing routines
232 ;; ----------- ;;
233
234
235
236 ;; ;;
237 ;; 1. text processing routines ;;
238 ;; ;;
239
240
241 ;; fortran ;;
242
243
244 (defun procforttem ()
245 (prog (c)
246 (setq c (procfortcomm))
247 (loop while (not (eq c '$eof$)) do ;;changed, rjf
248 (cond ((eql c *cr*)
249 (progn (pprin2 *cr*)
250 (setq c (procfortcomm))))
251 ((eql c #\<)
252 (setq c (read-char (cdr *currin*) nil '$eof$))
253 (cond ((eql c #\<)
254 (setq c (procactive)))
255 (t
256 (pprin2 #\<)
257 (pprin2 c)
258 (setq c (read-char (cdr *currin*) nil '$eof$)))))
259
260 ((eq c #\>)
261 (setq c (read-char (cdr *currin*) nil '$eof$))
262 (cond ((eql c #\>)
263 (setq c '$eof$)) ;;-mds terminate file processing if >> found in "passive" section (consistent Macsyma 2.4)
264 (t
265 (pprin2 #\>)
266 (pprin2 c)
267 (setq c (read-char (cdr *currin*) nil '$eof$)))))
268
269 (t
270 (progn (pprin2 c)
271 (setq c (read-char (cdr *currin*) nil '$eof$))))))))
272
273
274
275 ;;; The following now checks for EOF seen in a comment. --mds courtesy of Macsyma
276 (defun procfortcomm ()
277 ; <col 1>c ... <cr> ;
278 ; <col 1>C ... <cr> ;
279 ; <col 1>* ... <cr> ;
280 (do ((c))
281 ((not (member (setq c (read-char (cdr *currin*) nil '$eof$))
282 '(#\c #\C #\*)))
283 c)
284 (pprin2 c)
285 (loop (setq c (read-char (cdr *currin*) nil '$eof$))
286 (cond ((eql c #\Newline) (pprin2 c) (return nil))
287 ((eq c '$eof$) (pprin2 #\Newline) (return c))
288 (t (pprin2 c))))))
289
290
291 ;; ratfor ;;
292
293
294 (defun procrattem () ;;; use character objects --mds. gentranlang:ratfor has not been extensively tested
295 (prog (c)
296 (setq c (read-char (cdr *currin*) nil '$eof$))
297 (loop while (not (eq c '$eof$)) do
298 (cond ((eq c sharpsign)
299 (setq c (procratcomm)))
300 ((eql c #\<)
301 (setq c (read-char (cdr *currin*) nil '$eof$))
302 (cond ((eql c #\<)
303 (setq c (procactive)))
304 (t
305 (pprin2 '<)
306 (pprin2 c)
307 (setq c (read-char (cdr *currin*) nil '$eof$)))))
308 ((eq c #\>)
309 (setq c (read-char (cdr *currin*) nil '$eof$))
310 (cond ((eq c #\>)
311 (setq c '$eof$))
312 (t
313 (pprin2 #\>)
314 (pprin2 c)
315 (setq c (read-char (cdr *currin*) nil '$eof$)))))
316 (t
317 (progn (pprin2 c)
318 (setq c (read-char (cdr *currin*) nil '$eof$))))))))
319
320 (defun procratcomm ()
321 ; # ... <cr> ;
322 (prog (c)
323 (pprin2 sharpsign)
324 (loop while (not (eql (setq c (read-char (cdr *currin*) nil '$eof$)) *cr*)) do
325 (pprin2 c))
326 (pprin2 *cr*)
327 (return (read-char (cdr *currin*) nil '$eof$))))
328
329
330 ;; c ;;
331
332
333 (defun procctem () ;;; use character objects --mds
334 (prog (c)
335 (setq c (read-char (cdr *currin*) nil '$eof$))
336 (loop while (not (eq c '$eof$)) do
337 (cond ((eql c *slash*)
338 (setq c (procccomm)))
339 ((eql c #\<)
340 (setq c (read-char (cdr *currin*) nil '$eof$))
341 (cond ((eql c #\<)
342 (setq c (procactive)))
343 (t
344 (pprin2 #\<)
345 (pprin2 c)
346 (setq c (read-char (cdr *currin*) nil '$eof$)))))
347
348 ((eql c #\>)
349 (setq c (read-char (cdr *currin*) nil '$eof$))
350 (cond ((eql c #\>)
351 (setq c '$eof$))
352 (t
353 (pprin2 #\>)
354 (pprin2 c)
355 (setq c (read-char (cdr *currin*) nil '$eof$)))))
356 (t
357 (progn (pprin2 c)
358 (setq c (read-char (cdr *currin*) nil '$eof$))))))))
359
360 (defun procccomm () ;;; use character objects --mds
361 ; /* ... */ ;
362 (prog (c)
363 (pprin2 *slash*)
364 (setq c (read-char (cdr *currin*) nil '$eof$))
365 (cond ((eql c #\*)
366 (progn (pprin2 c)
367 (setq c (read-char (cdr *currin*) nil '$eof$))
368 (repeat (progn (loop while (not (eql c #\*)) do
369 (progn (pprin2 c)
370 (setq c (read-char (cdr *currin*) nil '$eof$))))
371 (pprin2 c)
372 (setq c (read-char (cdr *currin*) nil '$eof$)))
373 (eql c *slash*))
374 (pprin2 c)
375 (setq c (read-char (cdr *currin*) nil '$eof$)))))
376 (return c)))
377
378
379 ;; ;;
380 ;; 2. template file active part handler ;;
381 ;; ;;
382
383
384 (defun procactive ()
385 ; procactive reads vaxima expressions and statements inside "<<" and ">>" ;
386 ; and mevals each. ;
387 (prog (vexp vexptrm c)
388 loop (setq vexp ($readvexp *currin*))
389 (setq vexptrm *vexptrm)
390 (meval vexp)
391 (cond ((member vexptrm '(#\NULL #\>))
392 (return (cond ((equal (setq c (read-char (cdr *currin*) nil '$eof$)) *cr*)
393 (read-char (cdr *currin*) nil '$eof$))
394 (c)))))
395 (go loop)))
396
397 (defun $readvexp (in) ;; parsing now done by mread --mds
398 (prog (test iport)
399 (setq iport (cdr in))
400 (setq test (peek-char t iport))
401 (cond
402 ((equal test #\>)
403 (cond
404 ((and (equal (tyi iport) #\>) (equal (tyi iport) #\>))
405 (setq *vexptrm test)
406 (return nil))
407 (t (gentranerr 'e nil "single > after active statement" nil))))
408
409 ((member test '(#\; #\$ #\NULL))
410 (setq *vexptrm test)))
411 (setq *vexptrm #\$)
412 (setq test (let (*prompt-on-read-hang*) (mread iport nil)))
413 (return (third test))))
414
415
416
417
418 ;; --------- ;;
419 ;; init.l ;; declarations & initializations
420 ;; --------- ;;
421
422
423 ;; ;;
424 ;; 1. user-accessible commands, functions, operators, switches & variables ;;
425 ;; ;;
426
427
428 ;; gentran commands ;;
429
430 ;; The following will be declared with defmfun instead.
431 ;(declare (nlambda $gentran $gentranin $gentranout $gentranshut
432 ; $gentranpush $gentranpop $gentran_on $gentran_off)) $on, $off renamed consistent with Macsyma --mds
433
434 ;; gentran functions ;;
435
436 ;; gentran operators ;;
437
438 ;; user-accessible primitive functions ;;
439
440
441 ;; mode switches ;;
442
443
444
445 (setq *fortran nil)
446 (setq *ratfor nil)
447 (setq *c nil)
448 (setq *gendecs t)
449
450 (put 'fortran 'simpfg '((nil) (t (gentranswitch 'fortran))))
451 (put 'ratfor 'simpfg '((nil) (t (gentranswitch 'ratfor))))
452 (put 'c 'simpfg '((nil) (t (gentranswitch 'c))))
453 (put 'gendecs 'simpfg '((nil) (t (gendecs nil))))
454 ;; flags ;;
455
456
457
458
459
460 ;; user-accessible global variables ;;
461 (setq $genfloat nil)
462 (setq $dblfloat nil)
463 (setq $usefortcomplex nil)
464 (setq $gentranopt nil)
465 (setq $gentranseg t)
466 (setq $gentranparser nil)
467 (setq $gentranlang 'fortran)
468 (setq $maxexpprintlen 800)
469 (setq $tempvarname '$t)
470 (setq $optimvarname '$u)
471 (setq $tempvarnum 0)
472 (setq $tempvartype nil)
473 (setq $implicit nil)
474 (setq $genstmtno 25000)
475 (setq $genstmtincr 1)
476 (setq $fortcurrind 6)
477 (setq $ratcurrind 0)
478 (setq $ccurrind 0)
479 (setq $tablen 4)
480 (setq $fortlinelen 72)
481 (setq $ratlinelen 80)
482 (setq $clinelen 80)
483 (setq $geninpath nil)
484 (setq $genoutpath nil)
485
486
487
488 ;; these functions enable input/output filepath selection --mds
489 (defun concat2 (str1 str2)
490 (compress (append (exploden str1) (exploden str2))))
491
492 (defun outpath (fname)
493 (if (and $genoutpath (not (member fname '($all t nil))))
494 (concat2 $genoutpath fname)
495 fname))
496
497 (defun fsearch (inf)
498 (if $geninpath
499 ($file_search inf $geninpath)
500 ($file_search inf)))
501
502
503 ;; ;;
504 ;; 2. system variables, operators & property lists ;;
505 ;; ;;
506
507
508 ;; global variables ;;
509
510
511
512 (setq *stdin* (cons t *standard-input*))
513 (setq *instk* (list *stdin*))
514 (setq *currin* (car *instk*))
515 (setq *stdout* (cons t *standard-output*))
516 (setq *outstk* (list *stdout*))
517 (setq *currout* (car *outstk*))
518 (setq *outchanl* (list (cdr *currout*)))
519 (setq *symboltable* (list '*main*))
520 (setq *endofloopstack* ())
521 (setq *lisparithexpops* (list 'expt 'minus 'plus 'quotient 'times))
522 (setq *lisplogexpops* (list 'and 'equal 'geqp 'greaterp 'leqp 'lessp 'not
523 'notequal 'or))
524 (setq *lispstmtops* (list 'break 'cond 'do 'end 'go 'princ 'return 'setq
525 'stop))
526 (setq *lispstmtgpops* (list 'prog 'progn))
527 (setq *lispdefops* (list 'defun))
528 (setq *slash* (code-char 47))
529 (setq *cr* (code-char 10))
530 (setq *eof* (code-char 0))
531 (setq *reswds* '(lambda mand mcond mdefine mdo mdoin mequal mexpt mgeqp
532 mgo mgreaterp mleqp mlessp mlist mminus mnot mnotequal
533 mor mplus mprog mprogn mquotient mreturn msetq mtimes
534 rat $end $ev $false $matrix $print $readonly $stop))
535
536 ;; dummy operator ;;
537
538
539 ;; property list values ;;
540 (progn (defprop mor or franznotn)
541 (defprop mand and franznotn)
542 (defprop mnot not franznotn)
543 (defprop mgreaterp greaterp franznotn)
544 (defprop mequal equal franznotn)
545 (defprop mnotequal notequal franznotn)
546 (defprop mlessp lessp franznotn)
547 (defprop mgeqp geqp franznotn)
548 (defprop mleqp leqp franznotn)
549 (defprop mplus plus franznotn)
550 (defprop mtimes times franznotn)
551 (defprop mquotient quotient franznotn)
552 (defprop rat quotient franznotn)
553 (defprop mexpt expt franznotn)
554 (defprop mminus minus franznotn)
555 (defprop mabs abs franznotn))
556
557
558
559
560 ;; ----------- ;;
561 ;; global.l ;; general functions
562 ;; ----------- ;;
563
564
565 ;; ;;
566 ;; 1. temporary variable generation, marking & unmarking functions ;;
567 ;; ;;
568
569
570 (defun tempvar (type)
571 ; ;
572 ; if type member '(nil 0) then type <- $tempvartype ;
573 ; ;
574 ; if type neq 'nil and type neq 'unknown then ;
575 ; var <- 1st unmarked tvar of vtype type or of vtype nil ;
576 ; which isn't in the symbol table ;
577 ; put type on var's vtype property list ;
578 ; put declaration in symbol table ;
579 ; else if type = nil then ;
580 ; var <- 1st unmarked tvar of type nil ;
581 ; which isn't in the symbol table ;
582 ; else type = 'unknown ;
583 ; var <- 1st unmarked tvar of type nil ;
584 ; which isn't in the symbol table ;
585 ; put 'unknown on var's vtype property list ;
586 ; print warning - "undeclared" ;
587 ; ;
588 ; return var ;
589 ; ;
590 (prog (tvar num)
591 (cond ($tempvartype (setq $tempvartype (stripdollar1 $tempvartype))))
592 (cond ((member type '(nil 0)) (setq type $tempvartype)))
593 (cond (type (setq type (stripdollar1 type))))
594 (setq $tempvarname (stripdollar1 $tempvarname))
595 (setq num $tempvarnum)
596 (prog ()
597 loop
598 (setq tvar (implode (append (exploden $tempvarname)(explode num))))
599 (cond ((or (markedvarp tvar) (not(member (getvartype tvar) (list type nil)))) (setq num (+ 1 num))(go loop))))
600 (put tvar '*vtype* type)
601 (cond ((equal type 'unknown)
602 (gentranerr 'w tvar "undeclared variable" nil))
603 (type
604 (symtabput nil tvar (list type))))
605 (return tvar)))
606
607 (defun markvar (var)
608 (cond ((numberp var) var)
609 ((atom var)
610 (putprop var t '*marked*)
611 var) ;;was (flag (list var) '*marked*) var)
612 (t (loop for v in var do (markvar v)) var)))
613
614 (defun markedvarp (var)
615 (flagp var '*marked*))
616
617 (defun unmarkvar (var)
618 (cond ((numberp var) var)
619 (t (remflag (list var) '*marked*))))
620
621 (defun recurunmark (exp)
622 (cond ((atom exp) (unmarkvar exp))
623 (t (foreach elt in exp do (recurunmark elt)))))
624
625
626 ;; ;;
627 ;; 2. statement number generation function ;;
628 ;; ;;
629
630 (defun genstmtno ()
631 (incf $genstmtno $genstmtincr))
632
633 ;; ;;
634 ;; 3. symbol table insertion, retrieval & deletion functions ;;
635 ;; ;;
636
637
638 (defun symtabput (name type value)
639 ; ;
640 ; call inserts ;
641 ; (symtabput subprogname nil nil ) subprog name ;
642 ; (symtabput subprogname '*type* subprogtype ) subprogram type ;
643 ; (symtabput subprogname '*params* paramlist ) parameter list ;
644 ; (symtabput subprogname vname '(type d1 d2 ...)) type & dimensions ;
645 ; for variable, ;
646 ; variable range, ;
647 ; if subprogname=nil parameter, or ;
648 ; then subprogname <- car symboltable function name ;
649 ; ;
650 (progn
651 (setq name (or name (car *symboltable*)))
652 (setq *symboltable* (cons name (delete1 name *symboltable*)))
653 (cond ((member type '(*type* *params*))
654 (put name type value))
655 (type
656 (prog (v vtype vdims dec decs)
657 (setq v type)
658 (setq vtype (car value))
659 (setq vdims (cdr value))
660 (setq decs (get name '*decs*))
661 (setq dec (assoc v decs))
662 (setq decs (delete1 dec decs))
663 (setq vtype (or vtype (cond ((> (length dec) 1)
664 (cadr dec)))))
665 (setq vdims (or vdims (cond ((> (length dec) 2)
666 (cddr dec)))))
667 (setq dec (cons v (cons vtype vdims)))
668 (put name '*decs* (aconc decs dec)))))))
669
670 (defun symtabget (name type)
671 ; ;
672 ; call retrieves ;
673 ; (symtabget nil nil ) all subprogram names ;
674 ; (symtabget subprogname '*type* ) subprogram type ;
675 ; (symtabget subprogname '*params*) parameter list ;
676 ; (symtabget subprogname vname ) type & dimensions for variable, ;
677 ; variable range, parameter, or ;
678 ; function name ;
679 ; (symtabget subprogname '*decs* ) all types & dimensions ;
680 ; ;
681 ; if subprogname=nil & 2nd arg is non-nil ;
682 ; then subprogname <- car symboltable ;
683 ; ;
684 (progn
685 (cond (type (setq name (or name (car *symboltable*)))))
686 (cond ((null name) *symboltable*)
687 ((member type '(*type* *params* *decs*)) (get name type))
688 ((assoc type (get name '*decs*))))))
689
690 (defun symtabrem (name type)
691 ; ;
692 ; call deletes ;
693 ; (symtabrem subprogname nil ) subprogram name ;
694 ; (symtabrem subprogname '*type* ) subprogram type ;
695 ; (symtabrem subprogname '*params*) parameter list ;
696 ; (symtabrem subprogname vname ) type & dimensions for variable, ;
697 ; variable range, parameter, or ;
698 ; function name ;
699 ; (symtabrem subprogname '*decs* ) all types & dimensions ;
700 ; ;
701 ; if subprogname=nil ;
702 ; then subprogname <- car symboltable ;
703 ; ;
704 (progn
705 (setq name (or name (car *symboltable*)))
706 (cond ((null type)
707 (setq *symboltable* (or (delete1 name *symboltable*) '(*main*))))
708 ((member type '(*type* *params* *decs*))
709 (remprop name type))
710 (t (prog (v dec decs)
711 (setq v type)
712 (setq decs (get name '*decs*))
713 (setq dec (assoc v decs))
714 (setq decs (delete1 dec decs))
715 (put name '*decs* decs))))))
716
717 (defun getvartype (var)
718 (prog (type)
719 (cond ((listp var) (setq var (car var))))
720 (setq type (symtabget nil var))
721 (cond ((and type (> (length type) 1))
722 (setq type (cadr type)))
723 ((setq type nil)))
724
725 ;; suppress implicit typing of tvars --mds
726 (cond ((and $implicit (not (eq (stripdollar1 $gentranlang) 'c)) (atom var) (null type))
727 (setq type (imptype var))))
728 (return type)))
729
730
731 ;; A function to set gentranlang with checking. Can also set it directly from Maxima
732
733 (defun $setgentranlang(a)
734 (setq a (stripdollar1 a))
735 (cond ((not (member a '(fortran ratfor c) :test #'eq))
736 (merror "arg must be one of fortran c or ratfor")))
737 (setq $gentranlang a))
738
739 (defun imptype(var)
740 (cond ((member (car (exploden var)) '(#\i #\j #\k #\l #\m #\n #\I #\J #\K #\L #\M #\N)) 'integer) ;; fixed old char's for implicit --mds
741 (t 'real)))
742
743 (defun arrayeltp (exp)
744 (or (get (car exp) 'array) (> (length (symtabget nil (car exp))) 2))) ;;--mds display undeclared array elements with [...] in c.
745
746
747 ;; ;;
748 ;; 4. input & output file stack manipulation functions ;;
749 ;; ;;
750
751
752 (defun delinstk (pr)
753 (progn
754 (setq *instk* (or (delete1 pr *instk*) (list *stdin*)))
755 (setq *currin* (car *instk*))))
756
757 (defun delstk (pr)
758 ; remove all occurrences of filepair from output file stack ;
759 (loop while (member pr (cdr (reverse *outstk*)))
760 do (popstk pr)))
761
762 (defun flisteqp (flist1 flist2)
763 (progn
764 (setq flist1 (foreach f in flist1 collect (mkfil f)))
765 (foreach f in flist2 do (setq flist1 (delete1 (mkfil f) flist1)))
766 (null flist1)))
767
768 (defun filpr (fname stk)
769 ; retrieve fname's filepair from stack stk ;
770 (cond ((null stk) nil)
771 ((and (caar stk) (equal (mkfil fname) (mkfil (caar stk))))
772 (car stk))
773 ((filpr fname (cdr stk)))))
774
775 (defun mkfilpr (fname)
776 ; open output channel & return filepair (fname . chan#) ;
777 (cons fname (if (streamp fname)
778 fname
779 (open fname :direction :output :if-exists :append :if-does-not-exist :create))))
780
781 (defun pfilpr (flist stk)
782 ; retrieve flist's "parallel" filepair from stack stk ;
783 (cond ((null stk) nil)
784 ((and (null (caar stk)) (flisteqp flist (cdar stk)))
785 (car stk))
786 ((pfilpr flist (cdr stk)))))
787
788 (defun popinstk ()
789 (delinstk *currin*))
790
791 (defun popstk (pr)
792 ; remove top-most occurrence of filepair from output file stack ;
793 (cond ((car pr)
794 (resetstk (delete1 pr *outstk*)))
795 (t
796 (prog (stk1 stk2)
797 (setq stk1 *outstk*)
798 (loop while (not (equal (car stk1) pr))
799 do (progn (setq stk2 (aconc stk2 (car stk1)))
800 (setq stk1 (cdr stk1))))
801 (loop while (not (equal (car stk1) '(nil)))
802 do (setq stk1 (cdr stk1)))
803 (resetstk (append stk2 (cdr stk1)))))))
804
805 (defun pushinstk (pr)
806 (progn (setq *instk* (cons pr *instk*))
807 (setq *currin* (car *instk*))))
808
809 (defun pushstk (pr)
810 ; push filepair onto output file stack ;
811 (progn (setq *outstk* (cons pr *outstk*))
812 (resetstkvars)))
813
814 (defun resetstk (stk)
815 (prog (s)
816 (cond (stk
817 (repeat (cond ((or (caar stk) (equal (car stk) '(nil)))
818 (setq s (aconc s (car stk))))
819 (t (progn
820 (foreach f in (cdar stk) do
821 (cond ((not (filpr f *outstk*))
822 (setq stk
823 (cons
824 (delete1 f (car stk))
825 (cdr stk))))))
826 (cond ((equal (car stk) '(nil))
827 (setq stk (cdr stk)))
828 (t
829 (setq s (aconc s (car stk))))))))
830 (null (setq stk (cdr stk))))))
831 (setq *outstk* (or s (list *stdout*)))
832 (resetstkvars)))
833
834 (defun resetstkvars ()
835 ; reset current-output to filepair on top of output file stack, ;
836 ; reset output channel list to channel #'s corresponding to ;
837 ; name(s) in current-output ;
838 (progn
839 (setq *currout* (car *outstk*))
840 (setq *outchanl* (cond ((car *currout*) (list (cdr *currout*)))
841 (t (foreach f in (cdr *currout*) collect
842 (cdr (filpr f *outstk*))))))))
843
844
845 ;; ;;
846 ;; 5. functions for making lisp forms ;;
847 ;; ;;
848
849
850 (defun mkassign (var exp)
851 (list 'setq var exp))
852
853 (defun mkcond (pairs)
854 (cons 'cond pairs))
855
856 (defun mkdef (name params body)
857 (append (list 'defun name params) body))
858
859 (defun mkdo (var exitcond body)
860 (append (list 'do var exitcond) body))
861
862 (defun mkreturn (exp)
863 (list 'return exp))
864
865 (defun mkstmtgp (vars stmts)
866 (cond ((numberp vars) (cons 'progn stmts))
867 ((cons 'prog (cons vars stmts)))))
868
869 (defun mkterpri ()
870 '(terpri))
871
872
873 ;; ;;
874 ;; 6. lisp form predicates ;;
875 ;; ;;
876
877
878 (defun lispassignp (stmt)
879 (and (listp stmt)
880 (equal (car stmt) 'setq)))
881
882 (defun lispbreakp (form)
883 (equal (car form) 'break))
884
885 (defun lispcallp (form)
886 (listp form))
887
888 (defun lispcondp (stmt)
889 (and (listp stmt)
890 (equal (car stmt) 'cond)))
891
892 (defun lispdefp (form)
893 (and (listp form)
894 (member (car form) *lispdefops*)))
895
896 (defun lispdop (stmt)
897 (and (listp stmt)
898 (equal (car stmt) 'do)))
899
900 (defun lispexpp (form)
901 (or (atom form)
902 (member (car form) (append *lisparithexpops* *lisplogexpops*))
903 (not (member (car form) (append (append *lispstmtops* *lispstmtgpops*)
904 *lispdefops*)))))
905
906 (defun lispendp (form)
907 (and (listp form)
908 (equal (car form) 'end)))
909
910 (defun lispgop (form)
911 (equal (car form) 'go))
912
913 (defun lisplabelp (form)
914 (atom form))
915
916 (defun lisplogexpp (form)
917 (or (atom form)
918 (member (car form) *lisplogexpops*)
919 (not (member (car form) (append (append *lisparithexpops* *lispstmtops*)
920 (append *lispstmtgpops* *lispdefops*))))))
921
922 (defun lispprintp (form)
923 (equal (car form) 'princ))
924
925 (defun lispreadp (form)
926 (and (equal (car form) 'setq)
927 (listp (caddr form))
928 (equal (caaddr form) 'read)))
929
930 (defun lispreturnp (stmt)
931 (and (listp stmt)
932 (equal (car stmt) 'return)))
933
934 (defun lispstmtp (form)
935 (or (atom form)
936 (member (car form) *lispstmtops*)
937 (and (atom (car form))
938 (not (member (car form) (append
939 (append *lisparithexpops* *lisplogexpops*)
940 (append *lispstmtgpops* *lispdefops*)))))))
941
942 (defun lispstmtgpp (form)
943 (and (listp form)
944 (member (car form) *lispstmtgpops*)))
945
946 (defun lispstopp (form)
947 (equal (car form) 'stop))
948
949
950 ;; ;;
951 ;; 7. type predicates ;;
952 ;; ;;
953
954
955 (defun gfunctionp (stmt name)
956 ; does stmt contain an assignment which assigns a value to name? ;
957 ; does it contain a (return exp) stmt? ;
958 ; i.e., (setq name exp) -or- (return exp) ;
959 (cond ((or (null stmt) (atom stmt)) nil)
960 ((and (equal (car stmt) 'setq) (equal (cadr stmt) name)) t)
961 ((and (equal (car stmt) 'return) (cdr stmt)) t)
962 ((eval (cons 'or
963 (foreach st in stmt collect (gfunctionp st name)))))))
964
965 (defun implicitp (type)
966 (prog (xtype ximp r)
967 (cond ((stringp type)
968 (setq xtype (exploden type))
969 (setq ximp (exploden 'implicit)))
970 (t
971 (setq xtype (explode2 type))
972 (setq ximp (explode2 'implicit))))
973 (setq r t)
974 (repeat (setq r (and r (equal (car xtype) (car ximp))))
975 (or (null (setq xtype (cdr xtype)))
976 (null (setq ximp (cdr ximp)))))
977 (return r)))
978
979
980 (defun inttypep (type)
981 (cond ((member type '(integer int long short)))
982 ((prog (xtype xint r)
983 (setq xtype (exploden type))
984 (setq xint (exploden 'integer))
985 (setq r t)
986 (repeat (setq r (and r (equal (car xtype) (car xint))))
987 (or (null (setq xtype (cdr xtype)))
988 (null (setq xint (cdr xint)))))
989 (return r)))))
990
991
992 ;; ;;
993 ;; 8. misc. functions ;;
994 ;; ;;
995
996
997 (defun complexdop (dostmt)
998 (and (lispdop dostmt)
999 (or (> (length (cadr dostmt)) 1)
1000 (> (length (caddr dostmt)) 1))))
1001
1002 (defun formtypelists (varlists)
1003 ; ( (var type d1 d2 ..) ( (type (var d1 d2 ..) ..) ;
1004 ; . --> . ;
1005 ; . . ;
1006 ; (var type d1 d2 ..) ) (type (var d1 d2 ..) ..) ) ;
1007 (prog (type typelists tl)
1008 (foreach vl in varlists do
1009 (progn
1010 (setq type (cadr vl))
1011 (cond ((onep (length (setq vl (delete1 type vl))))
1012 (setq vl (car vl))))
1013 (cond ((setq tl (assoc type typelists))
1014 (setq typelists (delete1 tl typelists)))
1015 (t
1016 (setq tl (list type))))
1017 (setq typelists (aconc typelists (aconc tl vl)))))
1018 (return typelists)))
1019
1020 (defun insertcommas (lst)
1021 (prog (result)
1022 (cond ((null lst) (return nil)))
1023 (setq result (list (car lst)))
1024 (loop while (setq lst (cdr lst))
1025 do (setq result (cons (car lst)
1026 (cons '|,| result))))
1027 (return (reverse result))))
1028
1029
1030 (defun noerrmevalp (pred)
1031 ;mevalp without call to merror
1032 (let ((ans (mevalp1 pred)))
1033 (cond ((member ans '(t nil)) ans)
1034 (t '$unknown))))
1035
1036 (defun simplifydo (dostmt)
1037 (prog (varlst exitlst stmtlst result tmp1 tmp2)
1038 (cond ((not (lispdop dostmt)) (return dostmt)))
1039 (setq varlst (reverse (cadr dostmt)))
1040 (setq exitlst (caddr dostmt))
1041 (setq stmtlst
1042 (foreach st in (cdddr dostmt) collect (simplifydo st)))
1043 (setq result
1044 (foreach st in (cdr exitlst) collect (simplifydo st)))
1045 (setq exitlst (list (car exitlst)))
1046 (foreach var in (cdr varlst) do
1047 (progn
1048 (setq tmp1 (cons (mkassign (car var) (cadr var)) tmp1))
1049 (cond ((cddr var)
1050 (setq tmp2
1051 (cons (mkassign (car var) (caddr var)) tmp2))))))
1052 (setq varlst (list (car varlst)))
1053 (setq result (cons (mkdo varlst exitlst (append stmtlst tmp2)) result))
1054 (setq result (append tmp1 result))
1055 (return result)))
1056
1057 (defun seqtogp (lst)
1058 (cond ((or (null lst) (atom lst) (lispstmtp lst) (lispstmtgpp lst))
1059 lst)
1060 ((and (onep (length lst)) (listp (car lst)))
1061 (seqtogp (car lst)))
1062 ((mkstmtgp 0 (foreach st in lst collect (seqtogp st))))))
1063
1064
1065 (defun stripdollar1 (x)
1066 (cond ((not (atom x))
1067 (cond ((and (eq (caar x) 'bigfloat)
1068 (not (minusp (cadr x))))
1069 (implode (fpformat x)))
1070 (t
1071 (merror "atomic arg required" x))))
1072 ((numberp x)
1073 x)
1074 ((member (char (string x) 0) '(#\$ #\% #\&))
1075 (intern (subseq (string x) 1)))
1076 (t
1077 x)))
1078
1079
1080
1081
1082 ;; ----------- ;;
1083 ;; output.l ;; code formatting & printing
1084 ;; ----------- ;; and error handler
1085
1086
1087
1088 ;; ;;
1089 ;; code formatting & printing functions ;;
1090 ;; ;;
1091
1092 ;; princ with case inverted
1093 (defun princ-invert-case (sym)
1094 (princ (print-invert-case sym)))
1095
1096 ;; fortran code formatting & printing functions ;;
1097
1098 (defun formatfort (lst)
1099 (foreach c in *outchanl* do
1100 (let ((*standard-output* c))
1101 (formatfort1 lst))))
1102
1103 (defun formatfort1 (lst)
1104 (foreach elt in lst do
1105 (cond ((listp elt)
1106 (eval elt))
1107 (t
1108 (progn
1109 (cond ((> (+ (posn) (length (explode2 elt))) $fortlinelen)
1110 (fortcontline)))
1111 (princ-invert-case elt))))))
1112
1113 (defun fortcontline ()
1114 (progn
1115 (terpri)
1116 (princ " .")
1117 (forttab (- $fortcurrind 6))
1118 (spaces 1)))
1119
1120 (defun forttab (n)
1121 (progn
1122 (setq $fortcurrind (min (+ n 6) (- $fortlinelen 40)))
1123 (spaces (- $fortcurrind (posn)))))
1124
1125 ;; ratfor code formatting & printing functions ;;
1126
1127 (defun formatrat (lst)
1128 (foreach c in *outchanl* do
1129 (let ((*standard-output* c))
1130 (formatrat1 lst))))
1131
1132 (defun formatrat1 (lst)
1133 (foreach elt in lst do
1134 (cond ((listp elt)
1135 (eval elt))
1136 (t
1137 (progn
1138 (cond ((> (+ (posn) (length (explode2 elt)))
1139 $ratlinelen)
1140 (ratcontline)))
1141 (princ-invert-case elt))))))
1142
1143 (defun ratcontline ()
1144 (progn
1145 (terpri)
1146 (rattab $ratcurrind)
1147 (spaces 1)))
1148
1149 (defun rattab (n)
1150 (progn
1151 (setq $ratcurrind (min n (- $ratlinelen 40)))
1152 (spaces (- $ratcurrind (posn)))))
1153
1154 ;; c code formatting & printing functions ;;
1155
1156 (defun formatc (lst)
1157 (foreach c in *outchanl* do
1158 (let ((*standard-output* c))
1159 (formatc1 lst))))
1160
1161 (defun formatc1 (lst)
1162 (foreach elt in lst do
1163 (cond ((listp elt)
1164 (eval elt))
1165 (t
1166 (progn
1167 (cond ((> (+ (posn) (length (explode2 elt)))
1168 $clinelen)
1169 (ccontline)))
1170 (princ-invert-case elt))))))
1171
1172 (defun ccontline ()
1173 (progn
1174 (terpri)
1175 (ctab $ccurrind)
1176 (spaces 1)))
1177
1178 (defun ctab (n)
1179 (progn
1180 (setq $ccurrind (min n (- $clinelen 40)))
1181 (spaces (- $ccurrind (posn)))))
1182
1183
1184 ;; ;;
1185 ;; general printing function ;;
1186 ;; ;;
1187
1188
1189 (defun pprin2 (arg)
1190 (if (eql arg *cr*)
1191 (foreach c in *outchanl* do (terpri c))
1192 (foreach c in *outchanl* do (princ arg c))))
1193
1194
1195 ;; ;;
1196 ;; error handler ;;
1197 ;; ;;
1198
1199
1200 ;; error & warning message printing routine ;;
1201 (defun gentranerr( msgtype exp msg1 msg2)
1202 (if (eq msgtype 'e) ($error exp msg1 msg2) (mtell exp msg1 msg2)))
1203
1204
1205
1206
1207
1208 ;; ----------- ;;
1209 ;; vaxlsp.l ;; lisp code generation module
1210 ;; ----------- ;;
1211
1212 (defvar lefttype 'real)
1213
1214
1215 ;; genfloat is an option variable, if set to t to cause all constants to be floated
1216 ;; dblfloat is an option variable if set to t to cause all floats to convert or display as doubles --mds
1217
1218 ;; ;;
1219 ;; 2. vaxima -> lisp translation ;;
1220 ;; ;;
1221
1222 (defun safe-car (x) (if (listp x) (car x) nil))
1223 (defun safe-caar (x) (if (listp x) (car (safe-car x)) nil))
1224
1225 (defun franz (form)
1226 ; translate form from macsyma internal representation into franz lisp ;
1227 (foreach f in form collect
1228 (cond ((member f '($begin_group $end_group))
1229 f)
1230 ((macexpp f)
1231 (franzexp f 0 f))
1232 (t
1233 (franzstmt f)) )))
1234
1235
1236 (defun franzexp (exp ind context)
1237
1238 (setq allnum t ) ;;set flag to check if all numbers in an expression
1239 (cond ((atom exp)
1240
1241 (cond
1242 ((and (numberp exp) (not $genfloat)(not(equal ind 3))(not (and (listp context) (listp (car context)) (equal (caar context) 'rat)))
1243 exp)) ;; floats integers in denominator --mds
1244 ((numberp exp)
1245 (cond ((equal ind 0)
1246
1247 (setq expty (exptype context ))
1248 (cond(allnum (setq expty lefttype)))
1249 ;;solve all numbers in an expression
1250
1251 (cond ((eq expty 'integer)
1252 exp)
1253 ((eq expty 'real)
1254 (float exp))
1255 ((eq expty 'double) ;"double" & "complex"
1256 (coerce exp 'double-float)) ;are for the time being
1257 ((eq expty 'complex)
1258 (gcomplex exp))
1259 (t (float exp)) ))
1260
1261 ((equal ind 1)
1262 (if (and (listp context) (listp (car context)) (equal (caar context) 'rat)) (float exp)
1263 exp)) ;;;; floats integers in rational power --mds
1264
1265 ((equal ind 2)
1266 (float exp))
1267
1268 ((equal ind 3)
1269 (coerce exp 'double-float))
1270
1271 ((equal ind 4)
1272 (gcomplex exp))))
1273
1274 ((char= (char (string exp) 0) #\&)
1275 (format nil "\"~A\"" (stripdollar1 exp)))
1276 ((eq exp t) (cond ((eq (stripdollar1 $gentranlang) 'c) 1)
1277 (t '| .true. |)))
1278 (t
1279 (stripdollar1 exp))))
1280
1281 ((eq (caar exp) '$gquote) (cadr exp)) ;; gquote added by pwang 11/10/86
1282 ((eq (caar exp) 'mtimes)
1283 (simptimes1 (foreach term in (cdr exp) collect
1284 (franzexp term ind exp))
1285 ))
1286
1287 ((eq (caar exp) 'mexpt)
1288 ;; ((mexpt) x -1) --> (quotient 1.0 x) ;
1289 ;; ((mexpt) x ((mminus) i)) --> (quotient 1.0 (expt x i)) ;
1290 ;; ((mexpt) $%e x) --> (exp x) ;rjf 10/14/2018
1291
1292 (let ((var (cadr exp)) (pow (caddr exp)))
1293 (cond ((eq var '$%e) (list 'exp (franzexp pow 3 context))) ;;rjf --mds double-float numbers in exponentials
1294
1295 ((or (eql pow -1)
1296 (and (listp pow)
1297 (eq (caar pow) 'mminus)
1298 (onep (cadr pow))))
1299 (list 'quotient (franzexp 1 ind exp) (franzexp var ind exp)))
1300 ((and (numberp pow) (minusp pow))
1301 (list 'quotient
1302 (franzexp 1 ind exp)
1303 (list 'expt (franzexp var ind exp)
1304 (franzexp (abs pow) (if (equal (stripdollar1 $gentranlang) 'c) 3 1) nil))))
1305 ((and (listp pow) (eq (caar pow) 'mminus))
1306 (list 'quotient
1307 (franzexp 1 ind exp)
1308 (list 'expt (franzexp var ind exp)
1309 (franzexp (cadr pow) (if (equal (stripdollar1 $gentranlang) 'c) 3 1) nil))))
1310 (t
1311 (list 'expt (franzexp (cadr exp) ind exp)
1312 (franzexp (caddr exp) (if (equal (stripdollar1 $gentranlang) 'c) 3 1) nil)))))) ;;dfloat powers in c --mds
1313 ((and (and (eq (caar exp) 'mminus) (numberp (cadr exp)))
1314 (and (= 1 (length (car exp)))
1315 (and (numberp (cadr exp)) (numberp (caddr exp))) ))
1316
1317 (cond ((get (caar exp) 'franznotn)
1318 (cons (get (caar exp) 'franznotn)
1319 (mapcar (function
1320 (lambda (elt) (franzexp elt ind context)))
1321 (cdr exp))))
1322 (t
1323 (cons (franzexp (caar exp) 1 nil)
1324 (mapcar (function
1325 (lambda (elt) (franzexp elt 1 nil)))
1326 (cdr exp)))) ) )
1327 ;; added by Trevor 12/28/86
1328
1329 ((setq fnotn (get (caar exp) 'franznotn))
1330 (if (and (equal fnotn 'plus) (equal (car exp) '(mplus simp)))
1331 (cons fnotn
1332 (mapcar (function
1333 (lambda (elt) (franzexp elt ind exp)))
1334 (reverse (cdr exp)))) ;; --mds reverse terms in simp sum consistent with Macsyma 2.4
1335 (cons fnotn
1336 (mapcar (function
1337 (lambda (elt) (franzexp elt ind exp)))
1338 (cdr exp)))))
1339 (t
1340 (if (member 'array (car exp)) (put (stripdollar1 (caar exp)) 'array t)) ;;--mds mark undeclared array indices for [...] in c.
1341 (cons (franzexp (caar exp) 1 nil)
1342 (mapcar (function
1343 (lambda (elt) (franzexp elt 1 nil)))
1344 (cdr exp))))))
1345 ;; 1 is always the right selection?????
1346
1347 ;; Following several functions were added by Trevor 12/86
1348
1349 ( defun exptype ( exp )
1350 ( prog(ty1 ty2)
1351
1352 ( cond ( ( null exp ) ( return 'integer ) ) )
1353 ( cond ( ( atom exp ) ( return ( itemtype exp ) ) ) )
1354
1355 (cond ((and (listp (car exp)) (eq 'array (cadar exp)))
1356 (return (exptype (caar exp))) ))
1357
1358 (cond ((member (car exp)
1359 '((mplus) (mminus) (mtimes) (mquotient) (mexpt)) )
1360 (setq ty1 'integer))
1361
1362 (t (setq ty1 (exptype (car exp)))))
1363
1364 (setq ty2 (exptype (cdr exp)))
1365
1366 (cond((or (eq ty1 'complex) (eq ty2 'complex))
1367 (return 'complex)))
1368
1369 (cond((or (eq ty1 'double) (eq ty2 'double))
1370 (return 'double)))
1371
1372 (cond((or (eq ty1 'real) (eq ty2 'real))
1373 (return 'real)))
1374
1375 (cond((and (eq ty1 'integer) (eq ty2 'integer))
1376 (return 'integer))
1377 (t (return 'nil))) ))
1378
1379
1380 ( defun itemtype ( item )
1381 ( prog()
1382
1383 ( cond ( ( numberp item )
1384 ( cond ( ( floatp item ) ( return 'real ) )
1385 ( t ( return 'integer ) ) ))
1386 ( t
1387 (setq allnum nil)
1388 ;; set flag to to nil to show
1389 ;; not all numbers in an expression
1390 ( return ( getvartype (stripdollar1 item)) ) ) )))
1391
1392
1393 ;; --mds A purely syntactic mechanism to display floats as doubles
1394 (defun dfix (c)
1395 (if (member c '(#\e #\d #\E #\D))
1396 #\d c))
1397
1398 (defun double (num)
1399 (prog (dnum)
1400 (cond ((floatp num)
1401 (setq dnum (exploden num))
1402 (setq dnum (map 'list 'dfix dnum))
1403 (if (member #\d dnum) dnum
1404 (setq dnum (append dnum '(#\d #\0))))
1405 (return (implode dnum)))
1406 (t num))))
1407
1408 ;; this prints real numbers in Fortran complex format by a purely synntactic mechanism --mds
1409 (defun gcomplex (num)
1410 (if (and $usefortcomplex (not (equal (stripdollar1 $gentranlang) 'c)))
1411 (prog (cnum)
1412 (cond ((floatp num)
1413 (setq cnum (append (exploden num) '( #\, #\0 #\. #\0 #\))))
1414 (setq cnum (cons '|(| cnum ))
1415 (return (implode cnum)))
1416 (t (return (intern (format nil "(~a.0,0.0)" num))))))
1417 (float num)))
1418
1419
1420 (defun simptimes1 (terms)
1421 (let ((neg) (denoms))
1422 (setq terms
1423 (foreach trm in (simptimes2 terms) conc
1424 (cond ((atom trm)
1425 (cond ((member trm '(1 1.0)) ())
1426 ((member trm '(-1 -1.0)) (setq neg (not neg))
1427 ())
1428 (t (list trm))))
1429 ((and (eq (car trm) 'minus)
1430 (member (cadr trm) '(1 1.0)))
1431 (setq neg (not neg)) ())
1432 ((and (eq (car trm) 'quotient)
1433 (member (cadr trm) '(1 1.0)))
1434 (setq denoms (aconc denoms (caddr trm))) ())
1435 (t (list trm)))))
1436 (setq terms (or terms (list (franzexp 1 0 terms))))
1437
1438 (cond (neg (setq terms (cons (list 'minus (car terms))
1439 (cdr terms)))))
1440 (setq terms (cond ((onep (length terms)) (car terms))
1441 (t (cons 'times terms))))
1442 (foreach d in denoms do
1443 (setq terms (list 'quotient terms d)))
1444 terms))
1445
1446 (defun simptimes2 (terms)
1447 (foreach trm in terms conc
1448 (cond ((atom trm) (list trm))
1449 ((eq (car trm) 'times) (simptimes2 (cdr trm)))
1450 (t (list trm)))))
1451
1452 (defun franzstmt (stmt)
1453 ; return the franz lisp equivalent statement ;
1454 (cond ((member (safe-caar stmt) '( msetq mdo ))
1455 (setq lefttype (exptype (cadr stmt))) ))
1456 ;;added by Trevor 12/28/86
1457
1458 (cond ((null stmt) nil)
1459 ((maclabelp stmt) (franzlabel stmt))
1460 ((macstmtgpp stmt) (franzstmtgp stmt))
1461 ((macdefp stmt) (franzdef stmt))
1462 ((macreadp stmt) (franzread stmt))
1463 ((macmatassignp stmt) (franzmatassign stmt))
1464 ((macnestassignp stmt) (franznestassign stmt))
1465 ((macassignp stmt) (franzassign stmt))
1466 ((macifp stmt) (franzif stmt))
1467 ((macforp stmt) (franzfor stmt))
1468 ((macforinp stmt) (franzforin stmt))
1469 ((macgop stmt) (franzgo stmt))
1470 ((macretp stmt) (franzret stmt))
1471 ((macprintp stmt) (franzprint stmt))
1472 ((macstopp stmt) (franzstop))
1473 ((macendp stmt) (franzend))
1474 ((mac$literalp stmt) (franzliteral (stripdollar1 (caar stmt)) stmt))
1475 ;;; ((maccallp stmt) (franzcall stmt)))) must be a mac call if it's nothing else.
1476 (t (franzcall stmt))))
1477
1478 (defun mac$literalp (stmt)
1479 ; is stmt a $literal function? ;
1480 (member (caar stmt) '($literal literal $data data) :test #'eq))
1481
1482 (defun franzliteral (fn stmt)
1483 (cons fn
1484 (foreach exp in (cdr stmt) collect
1485 (cond ((member exp '($tab $cr) :test #'eq) exp)
1486 ((listp exp) (franzexp exp 0 stmt))
1487 (t (stripdollar1 exp))))))
1488
1489 (defun franzlabel (label)
1490 ; return the franz lisp representation for a label ;
1491 (stripdollar1 label))
1492
1493 (defun franzstmtgp (stmtgp)
1494 ; return the franz lisp representation for a statement group ;
1495 (append '(prog ()) (mapcar 'franzstmt (cdr stmtgp))))
1496
1497 (defun franzdef (def)
1498 ; return the franz lisp representation for a function definition ;
1499 ; case 1: ((msetq) id ((lambda) ((mlist) id ... id) exp)) ;
1500 ; --> (defun id (id ... id) (prog () (return exp))) ;
1501 ; case 2: ((mdefine) ((id) id ... id) exp) ;
1502 ; --> (defun id (id ... id) (prog () (return exp))) ;
1503 ; case 3: ((mdefine) ((id) id ... id) stmtgp) ;
1504 ; --> (defun id (id ... id) (prog () stmt ... stmt)) ;
1505 (cond ((equal (caar def) 'msetq)
1506 `(defun ,(franzexp (cadr def) 0 ( cadr def ) )
1507
1508 ;; not sure how to change here and below a lot. mainly the ind;;
1509
1510
1511 ,(mapcar (function (lambda (elt)
1512 (franzexp elt 0 elt)))
1513 (cdadaddr def))
1514 (prog () (return ,(franzexp (caddaddr def) 0 ( caddaddr def ))))))
1515 ((macexpp (caddr def))
1516 `(defun ,(franzexp (caaadr def) 0 ( caaadr def ))
1517 ,(mapcar (function (lambda (elt)
1518 (franzexp elt 0 elt )))
1519 (cdadr def))
1520 (prog () (return ,(franzexp (caddr def) 0 ( caddr def ) )))))
1521 (t
1522 `(defun ,(franzexp (caaadr def) 0 ( caaadr def ) )
1523 ,(mapcar (function (lambda (elt)
1524 (franzexp elt 0 elt )))
1525 (cdadr def))
1526 ,(franzstmt (caddr def))))))
1527
1528 (defun franzread (stmt)
1529 ; return the franz lisp representation for a read statement ;
1530 (let (varlist outlist fr)
1531 (setq varlist nil)
1532 (do ((s stmt (caddr s)))
1533 ((or (null s) (atom s) (not (macstmtp s))))
1534 (cond ((equal (caar s) 'msetq)
1535 (setq varlist (cons (franzexp (cadr s) 0 ( cadr s ) )
1536 varlist)))
1537 (t
1538 (setq outlist
1539 (mapcar (function (lambda (elt)
1540 (franzexp elt 0 elt )))
1541 (cdr s))))))
1542 (setq fr nil)
1543 (cond (outlist (setq fr (append1 fr (cons 'princ outlist)))))
1544 (cond (varlist (setq fr (append1 fr `(setq ,(car varlist) (read))))))
1545 (do ((v varlist (cdr v)))
1546 ((null (cdr v)))
1547 (setq fr (append1 fr `(setq ,(cadr v) ,(car v)))))
1548 (cond ((> (length fr) 1) (cons 'progn fr))
1549 (t (car fr)))))
1550
1551 (defun franzmatassign (stmt)
1552 ; return the franz lisp representation for a matrix assignment statement ;
1553 (put (stripdollar1 (cadr stmt)) 'array t) ;; print matrix elements with [...] in c
1554 (do ((rows (cdaddr stmt) (cdr rows)) (r 1 (1+ r)) (fr (list 'progn)))
1555 ((null rows) fr)
1556 (do ((cols (cdar rows) (cdr cols)) (c 1 (1+ c)))
1557 ((null cols))
1558 (setq fr (append1 fr (list 'setq
1559 (franzexp (list (list (cadr stmt)) r c)
1560 0 (list (list (cadr stmt)) r c))
1561 (franzexp (car cols)
1562 0 (car cols) )))))))
1563
1564 (defun franznestassign (stmt)
1565 ; return the franz lisp representation for a nested assignment statement ;
1566 (let (varlist exp fr)
1567 (do ((s stmt (caddr s)))
1568 ((or (atom s) (not (macstmtp s)))
1569 (setq exp (franzexp s 0 s )))
1570 (setq varlist (cons (franzexp (cadr s) 0 ( cadr s )) varlist)))
1571 (setq fr `(progn (setq ,(car varlist) ,exp)))
1572 (do ((v varlist (cdr v)))
1573 ((null (cdr v)))
1574 (setq fr (append1 fr `(setq ,(cadr v) ,(car v)))))
1575 fr))
1576
1577 (defun franzassign (stmt)
1578 ; return the franz lisp representation for an assignment statement ;
1579 `(setq ,(franzexp (cadr stmt) 0 ( cadr stmt ))
1580 ,(franzexp (caddr stmt) 0 ( caddr stmt ) )))
1581
1582 (defun franzif (stmt)
1583 ; return the franz lisp representation for an if statement ;
1584 (destructuring-bind (x exp stmt1 y stmt2) stmt
1585 (declare (ignore x y))
1586 (let ((fr '(cond)))
1587 (setq fr (append1 fr (list (franzexp exp 0 exp)
1588 (franzstmt stmt1))))
1589 (cond ((not (equal stmt2 '$false))
1590 (append1 fr (list 't (franzstmt stmt2))))
1591 (t
1592 fr)))))
1593
1594 (defun franzfor (stmt)
1595 ; return the franz lisp representation for a for statement ;
1596 ; ((mdo) var lo incr nextexp hi exitcond dobody) ;
1597 ; --> (do ((var lo (+ var incr)) =or= (var lo nextexp)) ;
1598 ; ((or (> var hi) exitcond)) ;
1599 ; dobody) ;
1600 (destructuring-bind (var lo incr nextexp hi exitcond dobody) (cdr stmt)
1601 (let (dovars doexit posincr)
1602 (setq oincr incr
1603 onextexp nextexp)
1604 (setq var (franzexp var 0 var )
1605 lo (franzexp lo 0 lo )
1606 incr (franzexp incr 0 incr )
1607 nextexp (franzexp nextexp 0 nextexp )
1608 hi (franzexp hi 0 hi )
1609 exitcond (franzexp exitcond 0 exitcond )
1610 dobody (franzstmt dobody))
1611 (cond ((and (not var) (or lo incr nextexp hi))
1612 (setq tvname $tempvarname)
1613 (setq $tempvarname 'i)
1614 (setq var ($tempvar nil))
1615 (setq $tempvarname tvname)))
1616 (cond ((and (not lo) (or var incr hi))
1617 (setq lo 1)))
1618 (cond ((and (not incr) (not nextexp) (or var lo hi))
1619 (setq incr 1)))
1620 (cond (incr
1621 (cond ((or (null (getvartype var))
1622 (inttypep (getvartype var)))
1623 (cond ((numberp lo) (setq lo (floor lo))))
1624 (cond ((numberp hi) (setq hi (floor hi))))
1625 (cond ((numberp incr) (setq incr (floor incr))))))
1626 (setq dovars `((,var ,lo (plus ,var ,incr))))))
1627 (cond (nextexp
1628 (setq dovars `((,var ,lo ,nextexp)))))
1629 (cond (hi
1630 (cond (nextexp
1631 (setq posincr (noerrmevalp '((mgeqp) onextexp 0))))
1632 (t
1633 (setq posincr (noerrmevalp '((mgeqp) oincr 0)))))
1634 (cond (posincr
1635 (setq doexit `((greaterp ,var ,hi))))
1636 (t
1637 (setq doexit `((lessp ,var ,hi)))))))
1638 (cond (exitcond (setq doexit (append1 doexit exitcond))))
1639 (cond ((> (length doexit) 1)
1640 (setq doexit (list (cons 'or doexit)))))
1641 `(do ,dovars ,doexit ,dobody))))
1642
1643 (defun franzforin (stmt)
1644 ; return the franz lisp representation for a for-in statement ;
1645 ; ((mdoin) dovar dolist nil nil nil doexitcond dobody) ;
1646 ; --> (do ((genvar 1 (+ genvar 1))) ;
1647 ; ((> genvar listlength)) ;
1648 ; (cond ((equal genvar 1) (setq dovar list(1))) ;
1649 ; ((equal genvar 2) (setq dovar list(2))) ;
1650 ; . ;
1651 ; . ;
1652 ; ((equal genvar listlength) (setq dovar list(length)))) ;
1653 ; (cond ((doexitcond) (break))) ;
1654 ; dobody) ;
1655 (let ((gvar) condbody)
1656 (destructuring-bind (dovar (_x1 . dolist) _x2 _x3 _x4 doexitcond dobody) (cdr stmt)
1657 (declare (ignore _x1 _x2 _x3 _x4))
1658 (setq tvname $tempvarname)
1659 (setq $tempvarname 'i)
1660 (setq gvar ($tempvar nil))
1661 (setq $tempvarname tvname)
1662 (setq dovar (franzexp dovar 0 dovar ))
1663 (do ((i 1 (1+ i)))
1664 ((> i (length dolist)))
1665 (setq condbody
1666 (append condbody
1667 `(((equal ,gvar ,i)
1668 (setq ,dovar ,(franzexp (nthelem i dolist)
1669 0 (nthelem i dolist))))))))
1670 (cond (doexitcond
1671 `(do ((,gvar 1 (+ ,gvar 1)))
1672 ((> ,gvar ,(length dolist)))
1673 (progn
1674 ,(cons 'cond condbody)
1675 (cond (,(franzexp doexitcond 0 doexitcond ) (break)))
1676 ,(franz dobody))))
1677 (t
1678 `(do ((,gvar 1 (+ ,gvar 1)))
1679 ((> ,gvar ,(length dolist)))
1680 (progn
1681 ,(cons 'cond condbody)
1682 ,(franz dobody))))))))
1683
1684 (defun franzgo (stmt)
1685 ; return the franz lisp representation for a go statement ;
1686 `(go ,(franzlabel (cadr stmt))))
1687
1688 (defun franzret (stmt)
1689 ; return the franz lisp representation for a return statement ;
1690 (cond ((cdr stmt) `(return ,(franzexp (cadr stmt) 0 ( cadr stmt ) )))
1691 (t '(return))))
1692
1693 (defun franzprint (stmt)
1694 ; return the franz lisp representation for a print statement ;
1695 (cons 'princ
1696 (mapcar (function (lambda (elt)
1697 (franzexp elt 0 elt )))
1698 (cdr stmt))))
1699
1700 (defun franzstop ()
1701 ; return the franz lisp representation for a stop statement ;
1702 '(stop))
1703
1704 (defun franzend ()
1705 ; return the franz lisp representation for an end statement ;
1706 '(end))
1707
1708 (defun franzcall (exp)
1709 ; return the franz lisp representation for a call statement ;
1710 (cond ((cdr exp) (cons (franzexp (caar exp) 0 ( caar exp ))
1711 (mapcar (function (lambda (elt)
1712 (franzexp elt
1713 0 elt )))
1714 (cdr exp))))
1715 (t (list (franzexp (caar exp) 0 ( caar exp ) )))))
1716
1717
1718
1719
1720 (defun macexpp (exp)
1721 ; is exp an arithmetic or logical macsyma expression? ;
1722 (cond ((null exp) nil)
1723 ((atom exp))
1724 ((atom (car exp)) nil)
1725 ((not (member (caar exp) '(mcond mdefine mdo mdoin mgo mprog mprogn
1726 mreturn msetq $end $ev $literal $print
1727 $readonly $stop $data) :test #'eq)))))
1728
1729 (defun maclogexpp (exp)
1730 ; is exp a macsyma logical expression? ;
1731 (cond ((atom exp)
1732 (not (numberp exp)))
1733 ((listp (car exp))
1734 (not (member (caar exp)
1735 '(mcond mdefine mdo mdoin mgo mexpt mminus mplus mprog
1736 mprogn mquotient mreturn msetq mtimes rat $end $ev
1737 $print $readonly $stop) :test #'eq)))))
1738
1739 (defun macstmtp (stmt)
1740 ; is stmt a macsyma statement? ;
1741 (cond ((null stmt) nil)
1742 ((atom stmt))
1743 ((atom (car stmt)) nil)
1744 ((member (caar stmt) '(mcond mdo mdoin mgo mreturn msetq $end $print
1745 $readonly $stop))
1746 t)))
1747
1748 (defun macstmtgpp (stmt)
1749 ; is stmt a macsyma statement group? ;
1750 (cond ((or (null stmt) (atom stmt) (atom (car stmt))) nil)
1751 ((member (caar stmt) '(mprog mprogn $ev)) t)))
1752
1753 (defun macdefp (stmt)
1754 ; is stmt a macsyma function or procedure definition? ;
1755 (cond ((or (null stmt) (atom stmt) (atom (car stmt))) nil)
1756 ((or (equal (caar stmt) 'mdefine)
1757 (and (equal (caar stmt) 'msetq)
1758 (listp (caddr stmt))
1759 (listp (caaddr stmt))
1760 (equal (caaaddr stmt) 'lambda))))))
1761
1762
1763 (defun macassignp (stmt)
1764 ; is stmt a macsyma assignment statement? ;
1765 (equal (safe-caar stmt) 'msetq))
1766
1767 (defun macnestassignp (stmt)
1768 ; is stmt a macsyma nested assignment statement? ;
1769 (and (macassignp stmt)
1770 (listp (caddr stmt))
1771 (listp (caaddr stmt))
1772 (macassignp (caddr stmt))))
1773
1774 (defun macmatassignp (stmt)
1775 ; is stmt a macsyma matrix assignment statement? ;
1776 (cond ((or (null stmt) (atom stmt) (atom (car stmt))) nil)
1777 ((equal (caar stmt) '$matrix))
1778 ((equal (caar stmt) 'msetq)
1779 (macmatassignp (caddr stmt)))))
1780
1781 (defun macifp (stmt)
1782 ; is stmt a macsyma if-then or if-then-else statement? ;
1783 (equal (safe-caar stmt) 'mcond))
1784
1785 (defun macforp (stmt)
1786 ; is stmt a macsyma for-loop? ;
1787 (equal (safe-caar stmt) 'mdo))
1788
1789 (defun macforinp (stmt)
1790 ; is stmt a macsyma for-in-loop? ;
1791 (equal (safe-caar stmt) 'mdoin))
1792
1793 (defun macgop (stmt)
1794 ; is stmt a macsyma go statement? ;
1795 (equal (safe-caar stmt) 'mgo))
1796
1797 (defun maclabelp (stmt)
1798 ; is stmt a macsyma statement label? ;
1799 (atom stmt))
1800
1801
1802 ;;;(defun maccallp (stmt)
1803 ;;; ; is stmt a macsyma call statement? ;
1804 ;;; t)
1805
1806 (defun macretp (stmt)
1807 ; is stmt a macsyma return statement? ;
1808 (equal (safe-caar stmt) 'mreturn))
1809
1810 (defun macreadp (stmt)
1811 ; is stmt a macsyma read statement? ;
1812 (cond ((or (null stmt) (atom stmt) (atom (car stmt))) nil)
1813 ((equal (safe-caar stmt) '$readonly))
1814 ((equal (safe-caar stmt) 'msetq)
1815 (macreadp (caddr stmt)))))
1816
1817 (defun macprintp (stmt)
1818 ; is stmt a macsyma print statement? ;
1819 (equal (safe-caar stmt) '$print))
1820
1821 (defun macstopp (stmt)
1822 ; is stmt a macsyma stop statement? ;
1823 (equal (safe-caar stmt) '$stop))
1824
1825 (defun macendp (stmt)
1826 ; is stmt a macsyma end statement? ;
1827 (equal (safe-caar stmt) '$end))
1828
1829
1830
1831 ;; ----------- ;;
1832 ;; parser.l ;; gentran parser module
1833 ;; ----------- ;;
1834
1835
1836 ;; ;;
1837 ;; 2. vaxima internal representation parser ;;
1838 ;; ;;
1839
1840
1841 (defun gentranparse (forms)
1842 (foreach f in forms do
1843 (cond ((not (or (pmstmt f)
1844 (pmexp f)
1845 (pmlogexp f)))
1846 (gentranerr 'e f "cannot be translated" nil)))))
1847
1848 (defun pmexp (s)
1849 ; exp ::= const | var | funcall | ((mminus ~) exp) | ;
1850 ; ((mquotient ~) exp exp) | ((rat ~) exp exp) | ;
1851 ; ((mexpt ~) exp exp) | ((mplus ~) exp exp exp') | ;
1852 ; ((mtimes ~) exp exp exp') ;
1853 ; funcall ::= ((id ~) exp') ;
1854 (cond ((atom s)
1855 (or (pmconst s)
1856 (pmid s)))
1857 ((and (listp s)
1858 (listp (car s)))
1859 (cond ((pmidop (car s))
1860 (pmexp1 (cdr s)))
1861 ((pmmminusop (car s))
1862 (and (equal (length s) 2)
1863 (pmexp (cadr s))))
1864 ((or (pmmquotientop (car s))
1865 (pmratop (car s))
1866 (pmmexptop (car s)))
1867 (and (equal (length s) 3)
1868 (pmexp (cadr s))
1869 (pmexp (caddr s))))
1870 ((or (pmmplusop (car s))
1871 (pmmtimesop (car s)))
1872 (and (> (length s) 2)
1873 (pmexp (cadr s))
1874 (pmexp (caddr s))
1875 (pmexp1 (cdddr s))))))))
1876
1877 (defun pmexp1 (s)
1878 ; exp' ::= exp exp' | epsilon ;
1879 (or (null s)
1880 (and (pmexp (car s))
1881 (pmexp1 (cdr s)))))
1882
1883 (defun pmlogexp (s)
1884 ; logexp ::= t | nil | var | funcall | relexp | ((mnot ~) logexp) | ;
1885 ; ((mand ~) logexp logexp logexp') | ;
1886 ; ((mor ~) logexp logexp logexp') ;
1887 ; relexp ::= ((mgreaterp ~) exp exp) | ((mequal ~) exp exp) | ;
1888 ; ((mnotequal ~) exp exp) | ((mlessp ~) exp exp) | ;
1889 ; ((mgeqp ~) exp exp) | ((mleqp ~) exp exp) ;
1890 ; funcall ::= (id exp') ;
1891 (cond ((atom s)
1892 (or (pmid s)
1893 (null s)
1894 (equal s t)))
1895 ((and (listp s)
1896 (listp (car s)))
1897 (cond ((pmidop (car s))
1898 (pmexp1 (cdr s)))
1899 ((or (pmmgreaterpop (car s))
1900 (pmmequalop (car s))
1901 (pmmnotequalop (car s))
1902 (pmmlesspop (car s))
1903 (pmmgeqpop (car s))
1904 (pmmleqpop (car s)))
1905 (and (equal (length s) 3)
1906 (pmexp (cadr s))
1907 (pmexp (caddr s))))
1908 ((pmmnotop (car s))
1909 (and (equal (length s) 2)
1910 (pmlogexp (cadr s))))
1911 ((or (pmmandop (car s))
1912 (pmmorop (car s)))
1913 (and (> (length s) 2)
1914 (pmlogexp (cadr s))
1915 (pmlogexp (caddr s))
1916 (pmlogexp1 (cdddr s))))))))
1917
1918 (defun pmlogexp1 (s)
1919 ; logexp' ::= logexp logexp' | epsilon ;
1920 (or (null s)
1921 (and (pmlogexp (car s))
1922 (pmlogexp1 (cdr s)))))
1923
1924 (defun pmstmt (s)
1925 ; stmt ::= assign | nestassign | matassign | cond | for | forin | go | ;
1926 ; label | call | return | stop | end | read | print | stmtgp | ;
1927 ; defn ;
1928 ; assign ::= ((msetq ~) var exp) | ((msetq ~) var logexp) ;
1929 ; nestassign ::= ((msetq ~) var ((msetq ~) var nestassign')) ;
1930 ; nestassign' ::= ((msetq ~) var nestassign') | exp | logexp ;
1931 ; matassign ::= ((msetq ~) var (($matrix ~) list list')) ;
1932 ; cond ::= ((mcond ~) logexp stmt t $false) | ;
1933 ; ((mcond ~) logexp stmt t stmt) ;
1934 ; for ::= ((mdo ~) varnil exp exp exp exp logexp stmt) ;
1935 ; forin ::= ((mdoin ~) var list nil nil nil logexp stmt) ;
1936 ; go ::= ((mgo ~) label) ;
1937 ; label ::= id ;
1938 ; call ::= ((id ~) params) ;
1939 ; return ::= ((mreturn ~) retexp) ;
1940 ; stop ::= (($stop ~)) ;
1941 ; end ::= (($end ~)) ;
1942 ; read ::= ((msetq ~) var read') ;
1943 ; read' ::= ((msetq ~) var read') | (($readonly ~) var) ;
1944 ; print ::= (($print ~) params) ;
1945 ; stmtgp ::= ((mprog ~) stmt stmt') | ((mprogn ~) stmt stmt') | ;
1946 ; (($ev ~) stmt stmt') ;
1947 ; defn ::= ((msetq ~) id ((lambda ~) list retexp)) | ;
1948 ; ((mdefine ~) ((id ~) id') retexp) | ;
1949 ; ((mdefine ~) ((id ~) id') stmt) | ;
1950 ; ((mdefine ~) ((id ~) id')) ;
1951 (cond ((atom s)
1952 (pmid s))
1953 ((and (listp s)
1954 (listp (car s)))
1955 (cond ((pmmsetqop (car s))
1956 (pmmsetq1 (cdr s)))
1957 ((pmmcondop (car s))
1958 (and (> (length s) 4)
1959 (pmlogexp (cadr s))
1960 (pmstmt (caddr s))
1961 (equal (cadddr s) 't)
1962 (pmmcond1 (cddddr s))))
1963 ((pmmdoop (car s))
1964 (and (equal (length s) 8)
1965 (pmvarnil (cadr s))
1966 (pmexp (caddr s))
1967 (pmexp (cadddr s))
1968 (pmexp (caddddr s))
1969 (pmexp (cadddddr s))
1970 (pmlogexp (caddddddr s))
1971 (pmstmt (cadddddddr s))))
1972 ((pmmdoinop (car s))
1973 (and (equal (length s) 8)
1974 (pmvar (cadr s))
1975 (pmlist (caddr s))
1976 (null (cadddr s))
1977 (null (caddddr s))
1978 (null (cadddddr s))
1979 (pmlogexp (caddddddr s))
1980 (pmstmt (cadddddddr s))))
1981 ((pmmgoop (car s))
1982 (and (equal (length s) 2)
1983 (pmid (cadr s))))
1984 ((pmmreturnop (car s))
1985 (or (equal (length s) 1)
1986 (and (equal (length s) 2)
1987 (pmretexp (cadr s)))))
1988 ((pm$stopop (car s))
1989 (equal (length s) 1))
1990 ((pm$endop (car s))
1991 (equal (length s) 1))
1992 ((pm$printop (car s))
1993 (pmparams1 (cdr s)))
1994 ((pm$declare_typeop (car s)))
1995 ((or (pmmprogop (car s))
1996 (pmmprognop (car s))
1997 (pm$evop (car s)))
1998 (and (> (length s) 1)
1999 (pmstmt (cadr s))
2000 (pmstmt1 (cddr s))))
2001 ((pmmdefineop (car s))
2002 (and (> (length s) 1)
2003 (pmidparamop (cadr s))
2004 (or (null (cddr s))
2005 (pmmdefine1 (cddr s)))))
2006 ((pmidop (car s))
2007 (pmparams1 (cdr s)))))))
2008
2009 (defun pmstmt1 (s)
2010 ; stmt' ::= stmt stmt' | epsilon ;
2011 (or (null s)
2012 (and (pmstmt (car s))
2013 (pmstmt1 (cdr s)))))
2014
2015 (defun pmmsetq1 (s)
2016 (cond ((and (listp s)
2017 (atom (car s)))
2018 (and (pmid (car s))
2019 (pmmsetq2 (cdr s))))
2020 ((and (listp s)
2021 (listp (car s)))
2022 (and (> (length (car s)) 1)
2023 (pmidop (caar s))
2024 (pmexp (cadar s))
2025 (pmexp1 (cddar s))
2026 (pmmsetq3 (cdr s))))))
2027
2028 (defun pmmsetq2 (s)
2029 (cond ((and (listp s)
2030 (listp (car s))
2031 (equal (length s) 1)
2032 (equal (length (car s)) 3)
2033 (pmlambdaop (caar s)))
2034 (and (pmlist (cadar s))
2035 (pmretexp (caddar s))))
2036 ((pmmsetq3 s))))
2037
2038 (defun pmmsetq3 (s)
2039 (cond ((and (listp s)
2040 (listp (car s))
2041 (equal (length s) 1)
2042 (> (length (car s)) 1)
2043 (pm$matrixop (caar s)))
2044 (and (pmlist (cadar s))
2045 (pmlist1 (cddar s))))
2046 ((pmmsetq4 s))))
2047
2048 (defun pmmsetq4 (s)
2049 (cond ((listp s)
2050 (cond ((pmexp (car s))
2051 (null (cdr s)))
2052 ((pmlogexp (car s))
2053 (null (cdr s)))
2054 ((and (listp (car s))
2055 (pmmsetqop (caar s)))
2056 (and (equal (length s) 1)
2057 (> (length (car s)) 1)
2058 (pmvar (cadar s))
2059 (pmmsetq4 (cddar s))))
2060 ((and (listp (car s))
2061 (pm$readonlyop (caar s)))
2062 (and (equal (length s) 1)
2063 (or (equal (length (car s)) 1)
2064 (and (equal (length (car s)) 2)
2065 (pmvar (cadar s))))))))))
2066
2067 (defun pmmcond1 (s)
2068 (cond ((equal s '($false)))
2069 ((pmstmt (car s))
2070 (null (cdr s)))))
2071
2072 (defun pmidop (s)
2073 (and (listp s)
2074 (not (member (car s) *reswds*))))
2075
2076 (defun pmmminusop (s)
2077 (and (listp s)
2078 (equal (car s) 'mminus)))
2079
2080 (defun pmmquotientop (s)
2081 (and (listp s)
2082 (equal (car s) 'mquotient)))
2083
2084 (defun pmratop (s)
2085 (and (listp s)
2086 (equal (car s) 'rat)))
2087
2088 (defun pmmexptop (s)
2089 (and (listp s)
2090 (equal (car s) 'mexpt)))
2091
2092 (defun pmmplusop (s)
2093 (and (listp s)
2094 (equal (car s) 'mplus)))
2095
2096 (defun pmmtimesop (s)
2097 (and (listp s)
2098 (equal (car s) 'mtimes)))
2099
2100 (defun pmmgreaterpop (s)
2101 (and (listp s)
2102 (equal (car s) 'mgreaterp)))
2103
2104 (defun pmmequalop (s)
2105 (and (listp s)
2106 (equal (car s) 'mequal)))
2107
2108 (defun pmmnotequalop (s)
2109 (and (listp s)
2110 (equal (car s) 'mnotequal)))
2111
2112 (defun pmmlesspop (s)
2113 (and (listp s)
2114 (equal (car s) 'mlessp)))
2115
2116 (defun pmmgeqpop (s)
2117 (and (listp s)
2118 (equal (car s) 'mgeqp)))
2119
2120 (defun pmmleqpop (s)
2121 (and (listp s)
2122 (equal (car s) 'mleqp)))
2123
2124 (defun pmmnotop (s)
2125 (and (listp s)
2126 (equal (car s) 'mnot)))
2127
2128 (defun pmmandop (s)
2129 (and (listp s)
2130 (equal (car s) 'mand)))
2131
2132 (defun pmmorop (s)
2133 (and (listp s)
2134 (equal (car s) 'mor)))
2135
2136 (defun pmmsetqop (s)
2137 (and (listp s)
2138 (equal (car s) 'msetq)))
2139
2140 (defun pmmcondop (s)
2141 (and (listp s)
2142 (equal (car s) 'mcond)))
2143
2144 (defun pmmdoop (s)
2145 (and (listp s)
2146 (equal (car s) 'mdo)))
2147
2148 (defun pmmdoinop (s)
2149 (and (listp s)
2150 (equal (car s) 'mdoin)))
2151
2152 (defun pmmgoop (s)
2153 (and (listp s)
2154 (equal (car s) 'mgo)))
2155
2156 (defun pmmreturnop (s)
2157 (and (listp s)
2158 (equal (car s) 'mreturn)))
2159
2160 (defun pm$stopop (s)
2161 (and (listp s)
2162 (equal (car s) '$stop)))
2163
2164 (defun pm$endop (s)
2165 (and (listp s)
2166 (equal (car s) '$end)))
2167
2168 (defun pm$printop (s)
2169 (and (listp s)
2170 (equal (car s) '$print)))
2171
2172 (defun pm$declare_typeop (s)
2173 (and (listp s)
2174 (equal (car s) '$declare_type)))
2175
2176 (defun pmmprogop (s)
2177 (and (listp s)
2178 (equal (car s) 'mprog)))
2179
2180 (defun pmmprognop (s)
2181 (and (listp s)
2182 (equal (car s) 'mprogn)))
2183
2184 (defun pm$evop (s)
2185 (and (listp s)
2186 (equal (car s) '$ev)))
2187
2188 (defun pmmdefineop (s)
2189 (and (listp s)
2190 (equal (car s) 'mdefine)))
2191
2192 (defun pm$readonlyop (s)
2193 (and (listp s)
2194 (equal (car s) '$readonly)))
2195
2196 (defun pmlambdaop (s)
2197 (and (listp s)
2198 (equal (car s) 'lambda)))
2199
2200 (defun pm$matrixop (s)
2201 (and (listp s)
2202 (equal (car s) '$matrix)))
2203
2204 (defun pmmlistop (s)
2205 (and (listp s)
2206 (equal (car s) 'mlist)))
2207
2208 (defun pmidparamop (s)
2209 (and (listp s)
2210 (pmidop (car s))
2211 (pmid1 (cdr s))))
2212
2213 (defun pmmdefine1 (s)
2214 (and (listp s)
2215 (equal (length s) 1)
2216 (or (pmretexp (car s))
2217 (pmstmt (car s)))))
2218
2219 (defun pmid1 (s)
2220 ; id' ::= id id' | epsilon ;
2221 (or (null s)
2222 (and (pmid (car s))
2223 (pmid1 (cdr s)))))
2224
2225 (defun pmvar (s)
2226 ; var ::= id | arrelt ;
2227 ; arrelt ::= ((id ~) exp exp') ;
2228 (cond ((atom s)
2229 (pmid s))
2230 ((listp s)
2231 (and (> (length s) 1)
2232 (pmidop (car s))
2233 (pmexp (cadar s))
2234 (pmexp1 (cddar s))))))
2235
2236 (defun pmvarnil (s)
2237 ; varnil ::= var | nil ;
2238 (or (null s)
2239 (pmvar s)))
2240
2241 (defun pmretexp (s)
2242 ; retexp ::= exp | logexp | string | epsilon ;
2243 (or (null s)
2244 (pmexp s)
2245 (pmlogexp s)
2246 (pmstring s)))
2247
2248 (defun pmparams1 (s)
2249 ; params ::= exp params | logexp params | string params | epsilon ;
2250 (or (null s)
2251 (and (pmexp (car s))
2252 (pmparams1 (cdr s)))
2253 (and (pmlogexp (car s))
2254 (pmparams1 (cdr s)))
2255 (and (pmstring (car s))
2256 (pmparams1 (cdr s)))))
2257
2258 (defun pmlist (s)
2259 ; list ::= ((mlist ~) exp exp') | ((mlist ~) logexp logexp') ;
2260 (and (listp s)
2261 (pmmlistop (car s))
2262 (pmlist2 (cdr s))))
2263
2264 (defun pmlist2 (s)
2265 (or (and (pmexp (car s))
2266 (pmexp1 (cdr s)))
2267 (and (pmlogexp (car s))
2268 (pmlogexp1 (cdr s)))))
2269
2270 (defun pmlist1 (s)
2271 ; list' ::= list list' | epsilon ;
2272 (or (null s)
2273 (and (pmlist (car s))
2274 (pmlist1 (cdr s)))))
2275
2276 (defun pmconst (s)
2277 (or (numberp s)
2278 (null s)
2279 (equal s t)))
2280
2281 (defun pmstring (s)
2282 (and (atom s)
2283 (equal (car (explodec s)) '&)))
2284
2285 (defun pmid (s)
2286 (and (atom s)
2287 (not (member s '(t nil)))))
2288
2289
2290
2291
2292
2293 ;; ----------- ;;
2294 ;; segmnt.l ;; segmentation module
2295 ;; ----------- ;;
2296
2297
2298
2299 ;; ;;
2300 ;; 1. segmentation routines ;;
2301 ;; ;;
2302
2303
2304 (defun seg (forms)
2305 ; exp --+--> exp ;
2306 ; +--> (assign assign ... assign exp ) ;
2307 ; (1) (2) (n-1) (n) ;
2308 ; stmt --+--> stmt ;
2309 ; +--> stmtgp ;
2310 ; stmtgp -----> stmtgp ;
2311 ; def -----> def ;
2312 (foreach f in forms collect
2313 (cond ((and (not (atom f)) (not (equal (car f) 'literal)) (lispexpp f))
2314 (cond ((toolongexpp f)
2315 (segexp f 'unknown))
2316 (t
2317 f)))
2318 ((lispstmtp f)
2319 (segstmt f))
2320 ((lispstmtgpp f)
2321 (cond ((toolongstmtgpp f)
2322 (seggroup f))
2323 (t
2324 f)))
2325 ((lispdefp f)
2326 (cond ((toolongdefp f)
2327 (segdef f))
2328 (t
2329 f)))
2330 (t
2331 f))))
2332
2333 (defun segexp (exp type)
2334 ; exp --> (assign assign ... assign exp ) ;
2335 ; (1) (2) (n-1) (n) ;
2336 (reverse (segexp1 exp type)))
2337
2338 (defun segexp1 (exp type)
2339 ; exp --> (exp assign assign ... assign ) ;
2340 ; (n) (n-1) (n-2) (1) ;
2341 (prog (res tempvarname)
2342 (setq tempvarname $tempvarname)
2343 (setq res (segexp2 exp type))
2344 (recurunmark res)
2345 (setq $tempvarname tempvarname)
2346 (cond ((equal (car res) (cadadr res))
2347 (progn
2348 (setq res (cdr res))
2349 (rplaca res (caddar res)))))
2350 (return res)))
2351
2352 (defun segexp2 (exp type)
2353 ; exp --> (exp assign assign ... assign ) ;
2354 ; (n) (n-1) (n-2) (1) ;
2355 (prog (expn assigns newassigns unops op termlist var tmp)
2356 (setq expn exp)
2357 (loop while (equal (length expn) 2) do
2358 (setq unops (cons (car expn) unops))
2359 (setq expn (cadr expn)))
2360 (setq op (car expn))
2361 (foreach term in (cdr expn) do
2362 (progn
2363 (cond ((toolongexpp term)
2364 (progn
2365 (setq tmp (segexp2 term type))
2366 (setq term (car tmp))
2367 (setq newassigns (cdr tmp))))
2368 (t
2369 (setq newassigns 'nil)))
2370 (cond ((and (toolongexpp (cons op (cons term termlist)))
2371 termlist
2372 (or (> (length termlist) 1)
2373 (listp (car termlist))))
2374 (progn
2375 (recurunmark termlist)
2376 (setq var (or var (tempvar type)))
2377 (markvar var)
2378 (setq assigns
2379 (cons (mkassign var
2380 (cond ((onep (length termlist))
2381 (car termlist))
2382 (t
2383 (cons op termlist))))
2384 assigns))
2385 (setq termlist (list var term))))
2386 (t
2387 (setq termlist (aconc termlist term))))
2388 (setq assigns (append newassigns assigns))))
2389 (setq expn (cond ((onep (length termlist))
2390 (car termlist))
2391 (t
2392 (cons op termlist))))
2393 (loop while unops do
2394 (setq expn (list (car unops) expn))
2395 (setq unops (cdr unops)))
2396 (cond ((equal expn exp)
2397 (progn
2398 (recurunmark expn)
2399 (setq var (or var (tempvar type)))
2400 (markvar var)
2401 (setq assigns (list (mkassign var expn)))
2402 (setq expn var))))
2403 (return (cons expn assigns))))
2404
2405 (defun segstmt (stmt)
2406 ; assign --+--> assign ;
2407 ; +--> stmtgp ;
2408 ; cond --+--> cond ;
2409 ; +--> stmtgp ;
2410 ; do --+--> do ;
2411 ; +--> stmtgp ;
2412 ; return --+--> return ;
2413 ; +--> stmtgp ;
2414 (cond ((lispassignp stmt)
2415 (cond ((toolongassignp stmt)
2416 (segassign stmt))
2417 (t
2418 stmt)))
2419 ((lispcondp stmt)
2420 (cond ((toolongcondp stmt)
2421 (segcond stmt))
2422 (t
2423 stmt)))
2424 ((lispdop stmt)
2425 (cond ((toolongdop stmt)
2426 (segdo stmt))
2427 (t
2428 stmt)))
2429 ((lispreturnp stmt)
2430 (cond ((toolongreturnp stmt)
2431 (segreturn stmt))
2432 (t
2433 stmt)))
2434 (t
2435 stmt)))
2436
2437 (defun segassign (stmt)
2438 ; assign --> stmtgp ;
2439 (prog (var exp type)
2440 (setq var (cadr stmt))
2441 (setq type (getvartype var))
2442 (setq exp (caddr stmt))
2443 (setq stmt (segexp1 exp type))
2444 (rplaca stmt (mkassign var (car stmt)))
2445 (return (mkstmtgp 0 (reverse stmt)))))
2446
2447 (defun segcond (cond)
2448 ; cond --+--> cond ;
2449 ; +--> stmtgp ;
2450 (prog (tassigns res markedvars type)
2451 (cond ((eq (stripdollar1 $gentranlang) 'c)
2452 (setq type 'int))
2453 (t
2454 (setq type 'logical)))
2455 (loop while (setq cond (cdr cond)) do
2456 (prog (exp stmt)
2457 (cond ((toolongexpp (setq exp (caar cond)))
2458 (progn
2459 (setq exp (segexp1 exp type))
2460 (setq tassigns (append (cdr exp) tassigns))
2461 (setq exp (car exp))
2462 (markvar exp)
2463 (setq markedvars (cons exp markedvars)))))
2464 (setq stmt (foreach st in (cdar cond) collect
2465 (segstmt st)))
2466 (setq res (cons (cons exp stmt) res))))
2467 (recurunmark markedvars)
2468 (return (cond (tassigns
2469 (mkstmtgp 0
2470 (reverse (cons (mkcond (reverse res))
2471 tassigns))))
2472 (t
2473 (mkcond (reverse res)))))))
2474
2475 (defun segdo (stmt)
2476 ; do --+--> do ;
2477 ; +--> stmtgp ;
2478 (prog (tassigns var initexp nextexp exitcond body markedvars type)
2479 (setq body (cdddr stmt))
2480 (cond ((setq var (cadr stmt))
2481 (progn
2482 (cond ((toolongexpp (setq initexp (cadar var)))
2483 (progn
2484 (setq type (getvartype (caar var)))
2485 (setq initexp (segexp1 initexp type))
2486 (setq tassigns (cdr initexp))
2487 (setq initexp (car initexp))
2488 (markvar initexp)
2489 (setq markedvars (cons initexp markedvars)))))
2490 (cond ((toolongexpp (setq nextexp (caddar var)))
2491 (progn
2492 (setq type (getvartype (caar var)))
2493 (setq nextexp (segexp1 nextexp type))
2494 (setq body (append body (reverse (cdr nextexp))))
2495 (setq nextexp (car nextexp))
2496 (markvar nextexp)
2497 (setq markedvars (cons nextexp markedvars)))))
2498 (setq var (list (list (caar var) initexp nextexp))))))
2499 (cond ((toolongexpp (car (setq exitcond (caddr stmt))))
2500 (prog (texps ltype)
2501 (cond ((eq (stripdollar1 $gentranlang) 'c)
2502 (setq ltype 'int))
2503 (t
2504 (setq ltype 'logical)))
2505 (setq texps (segexp1 (car exitcond) ltype))
2506 (markvar (car texps))
2507 (setq markedvars (cons (car texps) markedvars))
2508 (rplaca exitcond (car texps))
2509 (foreach texp in (reverse (cdr texps)) do
2510 (progn
2511 (setq texp (reverse texp))
2512 (setq var
2513 (cons (cdr (reverse (cons (car texp)
2514 texp)))
2515 var))))
2516 (setq var (reverse var)))))
2517 (setq body (foreach st in body collect (segstmt st)))
2518 (recurunmark markedvars)
2519 (return (cond (tassigns
2520 (mkstmtgp 0 (reverse (cons (mkdo var exitcond body)
2521 tassigns))))
2522 (t
2523 (mkdo var exitcond body))))))
2524
2525 (defun segreturn (ret)
2526 ; return --> stmtgp ;
2527 (progn
2528 (setq ret (segexp1 (cadr ret) 'unknown))
2529 (rplaca ret (mkreturn (car ret)))
2530 (mkstmtgp 0 (reverse ret))))
2531
2532 (defun seggroup (stmtgp)
2533 ; stmtgp --> stmtgp ;
2534 (prog (locvars res)
2535 (cond ((equal (car stmtgp) 'prog)
2536 (progn
2537 (setq locvars (cadr stmtgp))
2538 (setq stmtgp (cdr stmtgp))))
2539 (t
2540 (setq locvars 0)))
2541 (loop while (setq stmtgp (cdr stmtgp)) do
2542 (setq res (cons (segstmt (car stmtgp)) res)))
2543 (return (mkstmtgp locvars (reverse res)))))
2544
2545 (defun segdef (def)
2546 ; def --> def ;
2547 (mkdef (cadr def)
2548 (caddr def)
2549 (foreach stmt in (cdddr def) collect (segstmt stmt))))
2550
2551
2552 ;; ;;
2553 ;; 2. long statement & expression predicates ;;
2554 ;; ;;
2555
2556
2557 (defun toolongexpp (exp)
2558 (> (numprintlen exp) $maxexpprintlen))
2559
2560 (defun toolongstmtp (stmt)
2561 (cond ((atom stmt) nil) ;; pwang 11/11/86
2562 ((lispstmtp stmt)
2563 (cond ((lispcondp stmt)
2564 (toolongcondp stmt))
2565 ((lispassignp stmt)
2566 (toolongassignp stmt))
2567 ((lispreturnp stmt)
2568 (toolongreturnp stmt))
2569 ((lispdop stmt)
2570 (toolongdop stmt))
2571 (t
2572 (eval (cons 'or
2573 (foreach exp in stmt collect (toolongexpp exp)))))))
2574 (t
2575 (toolongstmtgpp stmt))))
2576
2577 (defun toolongassignp (assign)
2578 (toolongexpp (caddr assign)))
2579
2580 (defun toolongcondp (cond)
2581 (prog (toolong)
2582 (loop while (setq cond (cdr cond)) do
2583 (cond ((or (toolongexpp (caar cond))
2584 (toolongstmtp (cadar cond)))
2585 (setq toolong t))))
2586 (return toolong)))
2587
2588 (defun toolongdop (dostmt)
2589 (cond ((> (eval (cons '+ (foreach exp in (caadr dostmt) collect
2590 (numprintlen exp))))
2591 $maxexpprintlen) t)
2592 ((toolongexpp (caaddr dostmt)) t)
2593 ((lispstmtgpp (cadddr dostmt)) (toolongstmtgpp (cadddr dostmt)))
2594 (t (eval (cons 'or (foreach stmt in (cdddr dostmt) collect
2595 (toolongstmtp stmt)))))))
2596
2597 (defun toolongreturnp (ret)
2598 (toolongexpp (cadr ret)))
2599
2600 (defun toolongstmtgpp (stmtgp)
2601 (eval (cons 'or
2602 (foreach stmt in (cdr stmtgp) collect (toolongstmtp stmt)))))
2603
2604 (defun toolongdefp (def)
2605 (cond ((lispstmtgpp (cadddr def))
2606 (toolongstmtgpp (cadddr def)))
2607 (t
2608 (eval (cons 'or
2609 (foreach stmt in (cdddr def) collect
2610 (toolongstmtp stmt)))))))
2611
2612
2613 ;; ;;
2614 ;; 3. print length function ;;
2615 ;; ;;
2616
2617
2618 (defun numprintlen (exp)
2619 (cond ((atom exp)
2620 (length (explode exp)))
2621 ((onep (length exp))
2622 (numprintlen (car exp)))
2623 (t
2624 (+ (length exp)
2625 (eval (cons '+
2626 (foreach elt in (cdr exp) collect
2627 (numprintlen elt))))))))
2628
2629
2630
2631
2632
2633
2634 ;; ----------- ;;
2635 ;; lspfor.l ;; lisp-to-fortran translation module
2636 ;; ----------- ;;
2637
2638 (put 'or '*fortranprecedence* 1)
2639 (put 'and '*fortranprecedence* 2)
2640 (put 'not '*fortranprecedence* 3)
2641 (put 'equal '*fortranprecedence* 4)
2642 (put 'notequal '*fortranprecedence* 4)
2643 (put '> '*fortranprecedence* 4)
2644 (put 'greaterp '*fortranprecedence* 4)
2645 (put 'geqp '*fortranprecedence* 4)
2646 (put '< '*fortranprecedence* 4)
2647 (put 'lessp '*fortranprecedence* 4)
2648 (put 'leqp '*fortranprecedence* 4)
2649 (put '+ '*fortranprecedence* 5)
2650 (put 'plus '*fortranprecedence* 5)
2651 (put '* '*fortranprecedence* 6)
2652 (put 'times '*fortranprecedence* 6)
2653 (put 'quotient '*fortranprecedence* 6)
2654 (put '- '*fortranprecedence* 7)
2655 (put 'minus '*fortranprecedence* 7)
2656 (put 'expt '*fortranprecedence* 8)
2657 (put 'or '*fortranop* '| .or. |)
2658 (put 'and '*fortranop* '| .and. |)
2659 (put 'not '*fortranop* '| .not. |)
2660 (put 'equal '*fortranop* '| .eq. |)
2661 (put 'notequal '*fortranop* '| .ne. |)
2662 (put '> '*fortranop* '| .gt. |)
2663 (put 'greaterp '*fortranop* '| .gt. |)
2664 (put 'geqp '*fortranop* '| .ge. |)
2665 (put '< '*fortranop* '| .lt. |)
2666 (put 'lessp '*fortranop* '| .lt. |)
2667 (put 'leqp '*fortranop* '| .le. |)
2668 (put '+ '*fortranop* '|+|)
2669 (put 'plus '*fortranop* '|+|)
2670 (put '* '*fortranop* '|*|)
2671 (put 'times '*fortranop* '|*|)
2672 (put 'quotient '*fortranop* '|/|)
2673 (put 'expt '*fortranop* '|**|)
2674 (put '- '*fortranop* '|-|)
2675 (put 'minus '*fortranop* '|-|)
2676 (put nil '*fortranname* ".false.")
2677
2678 ;; ;;
2679 ;; lisp-to-fortran translation functions ;;
2680 ;; ;;
2681
2682
2683 ;; control function ;;
2684
2685
2686 (defun fortcode (forms)
2687 (foreach f in forms conc
2688 (cond ((atom f)
2689 (cond ((member f '($begin_group $end_group)) ())
2690 (t (fortexp f))))
2691 ((or (lispstmtp f)
2692 (lispstmtgpp f))
2693 (cond (*gendecs
2694 (prog (r)
2695 (setq r
2696 (append (fortdecs (symtabget '*main*
2697 '*decs*))
2698 (fortstmt f)))
2699 (symtabrem '*main* '*decs*)
2700 (return r)))
2701 (t
2702 (fortstmt f))))
2703 ((lispdefp f)
2704 (fortsubprog f))
2705 (t
2706 (fortexp f)))))
2707
2708
2709 ;; subprogram translation ;;
2710
2711
2712 (defun fortsubprog (def)
2713 (prog (type stype name params body lastst r)
2714 (setq name (cadr def))
2715 (setq body (cdddr def))
2716 (cond ((and body (equal body '(nil))) (setq body ())))
2717 (cond ((and (onep (length body))
2718 (lispstmtgpp (car body)))
2719 (progn (setq body (cdar body))
2720 (cond ((null (car body))
2721 (setq body (cdr body)))))))
2722 (cond (body
2723 (cond ((lispreturnp (setq lastst (car (reverse body))))
2724 (setq body (aconc body '(end))))
2725 ((not (lispendp lastst))
2726 (setq body (append body (list '(return) '(end))))))))
2727 (cond ((setq type (symtabget name name))
2728 (progn
2729 (setq type (cadr type))
2730 (symtabrem name name))))
2731 (setq stype (or (symtabget name '*type*)
2732 (cond ((or type
2733 (gfunctionp body name))
2734 'function)
2735 (t
2736 'subroutine))))
2737 (symtabrem name '*type*)
2738 (setq params (or (symtabget name '*params*) (caddr def)))
2739 (symtabrem name '*params*)
2740 (setq r (mkffortsubprogdec type stype name params))
2741 (cond (*gendecs
2742 (setq r (append r (fortdecs (symtabget name '*decs*))))))
2743 (setq r (append r (foreach s in body conc (fortstmt s))))
2744 (cond (*gendecs
2745 (progn
2746 (symtabrem name nil)
2747 (symtabrem name '*decs*))))
2748 (return r)))
2749
2750 ;; generation of declarations ;;
2751
2752 (defun fortdecs (decs)
2753 (foreach tl in (formtypelists decs) conc
2754 (mkffortdec (car tl) (cdr tl))))
2755
2756 ;; expression translation ;;
2757
2758 ;; --mds print floats as "double" n.0d0
2759 (defun dbl (n)
2760 (cond ((= (float 1) 1.0d0)
2761 (if (floatp n) (double n) n))
2762 (t (if (floatp n) (coerce n 'double-float) n))))
2763
2764 (defun fortexp (exp)
2765 (if $dblfloat (map 'list 'dbl (fortexp1 exp 0))
2766 (fortexp1 exp 0)))
2767
2768 (defun fortexp1 (exp wtin)
2769 (cond ((atom exp) (list (fortranname exp)))
2770 ((eq (car exp) 'data) (fortdata exp))
2771 ((eq (car exp) 'literal) (fortliteral exp))
2772 ((null (cdr exp)) exp)
2773 ((member (car exp) '(minus not) :test #'eq)
2774 (let* ((wt (fortranprecedence (car exp)))
2775 (res (cons (fortranop (car exp)) (fortexp1 (cadr exp) wt))))
2776 (cond ((< wt wtin) (aconc (cons '|(| res) '|)|))
2777 (t res))))
2778 ((or (member (car exp) *lisparithexpops* :test #'eq)
2779 (member (car exp) *lisplogexpops* :test #'eq))
2780 (let* ((wt (fortranprecedence (car exp)))
2781 (op (fortranop (car exp)))
2782 (res (fortexp1 (cadr exp) wt))
2783 (res1))
2784 (setq exp (cdr exp))
2785 (cond ((eq op '+)
2786 (loop while (setq exp (cdr exp)) do
2787 (progn
2788 (setq res1 (fortexp1 (car exp) wt))
2789 (cond ((or (eq (car res1) '-)
2790 (and (numberp (car res1))
2791 (minusp (car res1))))
2792 (setq res (append res res1)))
2793 (t
2794 (setq res (append res (cons op res1))))))))
2795 (t
2796 (loop while (setq exp (cdr exp)) do
2797 (setq res (append res
2798 (cons op
2799 (fortexp1 (car exp) wt)))))))
2800 (cond ((< wt wtin) (aconc (cons '|(| res) '|)|))
2801 (t res))))
2802 (t
2803 (let ((res (cons (car exp) (cons '|(| (fortexp1 (cadr exp) 0)))))
2804 (setq exp (cdr exp))
2805 (loop while (setq exp (cdr exp)) do
2806 (setq res (append res (cons '|,| (fortexp1 (car exp) 0)))))
2807 (aconc res '|)|)))))
2808
2809 (defun fortranname (name)
2810 (if (symbolp name) (or (get name '*fortranname*) name)
2811 name))
2812
2813 (defun fortranop (op)
2814 (or (get op '*fortranop*) op))
2815
2816 (defun fortranprecedence (op)
2817 (or (get op '*fortranprecedence*) 9))
2818
2819 ;; statement translation ;;
2820
2821 (defun fortstmt (stmt)
2822 (cond ((null stmt) nil)
2823 ((member stmt '($begin_group $end_group)) nil)
2824 ((lisplabelp stmt) (fortstmtno stmt))
2825 ((eq (car stmt) 'data) (fortdata stmt))
2826 ((eq (car stmt) 'literal) (fortliteral stmt))
2827 ((lispreadp stmt) (fortread stmt))
2828 ((lispassignp stmt) (fortassign stmt))
2829 ((lispprintp stmt) (fortwrite stmt))
2830 ((lispcondp stmt) (fortif stmt))
2831 ((lispbreakp stmt) (fortbreak stmt))
2832 ((lispgop stmt) (fortgoto stmt))
2833 ((lispreturnp stmt) (fortreturn stmt))
2834 ((lispstopp stmt) (fortstop stmt))
2835 ((lispendp stmt) (fortend stmt))
2836 ((lispdop stmt) (fortloop stmt))
2837 ((lispstmtgpp stmt) (fortstmtgp stmt))
2838 ((lispdefp stmt) (fortsubprog stmt))
2839 ((lispcallp stmt) (fortcall stmt))))
2840
2841 (defun fortassign (stmt)
2842 (mkffortassign (cadr stmt) (caddr stmt)))
2843
2844 (defun fortbreak (stmt)
2845 (declare (ignore stmt))
2846 (cond ((null *endofloopstack*)
2847 (gentranerr 'e nil "break not inside loop - cannot be translated" nil))
2848 ((atom (car *endofloopstack*))
2849 (prog (n1)
2850 (setq n1 (genstmtno))
2851 (rplaca *endofloopstack* (list (car *endofloopstack*) n1))
2852 (return (mkffortgo n1))))
2853 (t
2854 (mkffortgo (cadar *endofloopstack*)))))
2855
2856 (defun fortcall (stmt)
2857 (mkffortcall (car stmt) (cdr stmt)))
2858
2859 (defun fortdo (var lo nextexp exitcond body)
2860 (prog (n1 hi incr result)
2861 (setq n1 (genstmtno))
2862 (setq *endofloopstack* (cons n1 *endofloopstack*))
2863 (setq hi (car (delete1 'greaterp (delete1 'lessp (delete1 var exitcond)))))
2864 (setq incr (car (delete1 'plus (delete1 var nextexp))))
2865 (setq result (mkffortdo n1 var lo hi incr))
2866 (indentfortlevel (+ 1))
2867 (setq result (append result (foreach st in body conc (fortstmt st))))
2868 (indentfortlevel (- 1))
2869 (setq result (append result (mkffortcontinue n1)))
2870 (cond ((listp (car *endofloopstack*))
2871 (setq result
2872 (append result
2873 (mkffortcontinue (cadar *endofloopstack*))))))
2874 (setq *endofloopstack* (cdr *endofloopstack*))
2875 (return result)))
2876
2877 (defun fortend (stmt)
2878 (declare (ignore stmt))
2879 (mkffortend))
2880
2881 (defun fortfor (var lo nextexp exitcond body)
2882 (prog (n1 n2 result)
2883 (setq n1 (genstmtno))
2884 (setq n2 (genstmtno))
2885 (setq *endofloopstack* (cons n2 *endofloopstack*))
2886 (cond (var (setq result (mkffortassign var lo))))
2887 (cond (exitcond
2888 (setq result (append result
2889 (append (list n1 '| | )
2890 (mkffortifgo exitcond n2)))))
2891 (t
2892 (setq result (append result (mkffortcontinue n1)))))
2893 (indentfortlevel (+ 1))
2894 (setq result (append result (foreach st in body conc (fortstmt st))))
2895 (cond (nextexp
2896 (progn
2897 (cond ((equal nextexp '(nil)) (setq nextexp nil)))
2898 (setq result (append result (mkffortassign var nextexp))))))
2899 (setq result (append result (mkffortgo n1)))
2900 (indentfortlevel (- 1))
2901 (setq result (append result (mkffortcontinue n2)))
2902 (cond ((listp (car *endofloopstack*))
2903 (setq result
2904 (append result
2905 (mkffortcontinue (cadar *endofloopstack*))))))
2906 (setq *endofloopstack* (cdr *endofloopstack*))
2907 (return result)))
2908
2909 (defun fortgoto (stmt)
2910 (prog (stmtno)
2911 (cond ((not (setq stmtno (get (cadr stmt) '*stmtno*)))
2912 (setq stmtno (put (cadr stmt) '*stmtno* (genstmtno)))))
2913 (return (mkffortgo stmtno))))
2914
2915 (defun fortif (stmt)
2916 (prog (n1 n2 res)
2917 (setq stmt (cdr stmt))
2918 (cond ((onep (length stmt))
2919 (cond ((equal (caar stmt) 't)
2920 (return (foreach st in (cdar stmt) conc
2921 (fortstmt st))))
2922 (t
2923 (return
2924 (progn
2925 (setq n1 (genstmtno))
2926 (setq res (mkffortifgo (list 'not (caar stmt)) n1))
2927 (indentfortlevel (+ 1))
2928 (setq res (append res (foreach st in (cdar stmt) conc
2929 (fortstmt st))))
2930 (indentfortlevel (- 1))
2931 (append res (mkffortcontinue n1)))))))
2932 (t
2933 (return
2934 (progn
2935 (setq n1 (genstmtno))
2936 (setq n2 (genstmtno))
2937 (setq res (mkffortifgo (list 'not (caar stmt)) n1))
2938 (indentfortlevel (+ 1))
2939 (setq res (append res (foreach st in (cdar stmt) conc
2940 (fortstmt st))))
2941 (setq res (append res (mkffortgo n2)))
2942 (indentfortlevel (- 1))
2943 (setq res (append res (mkffortcontinue n1)))
2944 (indentfortlevel (+ 1))
2945 (setq res (append res (fortif (cons 'cond (cdr stmt)))))
2946 (indentfortlevel (- 1))
2947 (append res (mkffortcontinue n2))))))))
2948
2949 (defun fortliteral (stmt)
2950 (foreach a in (cdr stmt) conc
2951 (cond ((equal a '$tab) (list (mkforttab)))
2952 ((equal a '$cr) (list (mkterpri)))
2953 ((listp a) (fortexp a))
2954 (t (list a)))))
2955
2956 ;; fortdata added by pwang 12/12/88
2957 (defun fortdata (stmt)
2958 (append (list (mkforttab) "data " (cadr stmt) '|/|)
2959 (addcom (cddr stmt))
2960 (list '|/|))
2961 )
2962
2963 (setq COMMA* ",")
2964
2965 (defun addcom(nl)
2966 (cond ((null nl) nil)
2967 ((null (cdr nl)) nl)
2968 (t (cons (car nl) (cons COMMA* (addcom (cdr nl)))))
2969 )
2970 )
2971
2972 (defun fortloop (stmt)
2973 (prog (var lo nextexp exitcond body)
2974 (cond ((complexdop stmt)
2975 (return (fortstmt (seqtogp (simplifydo stmt))))))
2976 (cond ((setq var (cadr stmt))
2977 (progn
2978 (setq lo (cadar var))
2979 (cond ((equal (length (car var)) 3)
2980 (setq nextexp (or (caddar var) (list 'nil)))))
2981 (setq var (caar var)))))
2982 (cond ((setq exitcond (caddr stmt))
2983 (setq exitcond (car exitcond))))
2984 (setq body (cdddr stmt))
2985 (cond ((and var
2986 lo
2987 (equal (car nextexp) 'plus)
2988 (member var nextexp)
2989 (member (car exitcond) (list 'greaterp 'lessp))
2990 (member var exitcond))
2991 (return (fortdo var lo nextexp exitcond body)))
2992 ((and exitcond
2993 (not var))
2994 (return (fortwhile exitcond body)))
2995 ((and var
2996 (not lo)
2997 (lisplogexpp nextexp)
2998 (equal exitcond var))
2999 (return (fortrepeat body nextexp)))
3000 (t
3001 (return (fortfor var lo nextexp exitcond body))))))
3002
3003 (defun fortread (stmt)
3004 (mkffortread (cadr stmt)))
3005
3006 (defun fortrepeat (body exitcond)
3007 (prog (n result)
3008 (setq n (genstmtno))
3009 (setq *endofloopstack* (cons 'dummy *endofloopstack*))
3010 (setq result (mkffortcontinue n))
3011 (indentfortlevel (+ 1))
3012 (setq result (append result (foreach st in body conc (fortstmt st))))
3013 (indentfortlevel (- 1))
3014 (setq result (append result (mkffortifgo (list 'not exitcond) n)))
3015 (cond ((listp (car *endofloopstack*))
3016 (setq result
3017 (append result
3018 (mkffortcontinue (cadar *endofloopstack*))))))
3019 (setq *endofloopstack* (cdr *endofloopstack*))
3020 (return result)))
3021
3022 (defun fortreturn (stmt)
3023 (cond ((onep (length stmt))
3024 (mkffortreturn))
3025 ((not (eq (car *symboltable*) '*main*))
3026 (append (mkffortassign (car *symboltable*) (cadr stmt))
3027 (mkffortreturn)))
3028 (t
3029 (gentranerr 'e
3030 nil
3031 "return not inside function - cannot be translated"
3032 nil))))
3033
3034 (defun fortstmtgp (stmtgp)
3035 (progn
3036 (cond ((equal (car stmtgp) 'progn)
3037 (setq stmtgp (cdr stmtgp)))
3038 (t
3039 (setq stmtgp (cddr stmtgp))))
3040 (foreach stmt in stmtgp conc (fortstmt stmt))))
3041
3042 (defun fortstmtno (label)
3043 (prog (stmtno)
3044 (cond ((not (setq stmtno (get label '*stmtno*)))
3045 (setq stmtno (put label '*stmtno* (genstmtno)))))
3046 (return (mkffortcontinue stmtno))))
3047
3048 (defun fortstop (stmt)
3049 (declare (ignore stmt))
3050 (mkffortstop))
3051
3052 (defun fortwhile (exitcond body)
3053 (prog (n1 n2 result)
3054 (setq n1 (genstmtno))
3055 (setq n2 (genstmtno))
3056 (setq *endofloopstack* (cons n2 *endofloopstack*))
3057 (setq result (append (list n1 '| |) (mkffortifgo exitcond n2)))
3058 (indentfortlevel (+ 1))
3059 (setq result (append result (foreach st in body conc (fortstmt st))))
3060 (setq result (append result (mkffortgo n1)))
3061 (indentfortlevel (- 1))
3062 (setq result (append result (mkffortcontinue n2)))
3063 (cond ((listp (car *endofloopstack*))
3064 (setq result
3065 (append result
3066 (mkffortcontinue (cadar *endofloopstack*))))))
3067 (setq *endofloopstack* (cdr *endofloopstack*))
3068 (return result)))
3069
3070 (defun fortwrite (stmt)
3071 (mkffortwrite (cdr stmt)))
3072
3073
3074 ;; ;;
3075 ;; fortran code formatting functions ;;
3076 ;; ;;
3077
3078
3079 ;; statement formatting ;;
3080
3081 (defun mkffortassign (lhs rhs)
3082 (append (append (cons (mkforttab) (fortexp lhs))
3083 (cons '= (fortexp rhs)))
3084 (list (mkterpri))))
3085
3086 (defun mkffortcall (fname params)
3087 (progn
3088 (cond (params
3089 (setq params (append (append (list '|(|)
3090 (foreach p in (insertcommas params)
3091 conc (fortexp p)))
3092 (list '|)|)))))
3093 (append (append (list (mkforttab) 'call '| |)
3094 (fortexp fname))
3095 (append params (list (mkterpri))))))
3096
3097 (defun mkffortcontinue (stmtno)
3098 (list stmtno '| | (mkforttab) 'continue (mkterpri)))
3099
3100 (defun mkffortdec (type varlist)
3101 (progn
3102 (setq type (or type 'dimension))
3103 (setq varlist (foreach v in (insertcommas varlist)
3104 conc (fortexp v)))
3105 (cond ((implicitp type)
3106 (append (list (mkforttab) type '| | '|(|)
3107 (append varlist
3108 (list '|)| (mkterpri)))))
3109 (t
3110 (append (list (mkforttab) type '| |)
3111 (aconc varlist (mkterpri)))))))
3112
3113 (defun mkffortdo (stmtno var lo hi incr)
3114 (progn
3115 (cond ((onep incr)
3116 (setq incr nil))
3117 (incr
3118 (setq incr (cons '|,| (fortexp incr)))))
3119 (append (append (append (list (mkforttab) 'do '| | stmtno '| | )
3120 (fortexp var))
3121 (append (cons '= (fortexp lo))
3122 (cons '|,| (fortexp hi))))
3123 (append incr
3124 (list (mkterpri))))))
3125
3126 (defun mkffortend ()
3127 (list (mkforttab) 'end (mkterpri)))
3128
3129 (defun mkffortgo (stmtno)
3130 (list (mkforttab) 'goto '| | stmtno (mkterpri)))
3131
3132 (defun mkffortifgo (exp stmtno)
3133 (append (append (list (mkforttab) 'if '| | '|(|)
3134 (fortexp exp))
3135 (list '|)| '| | 'goto '| | stmtno (mkterpri))))
3136
3137
3138 (defun mkffortread (var)
3139 (append (list (mkforttab) 'read '|(*,*)| '| | )
3140 (append (fortexp var)
3141 (list (mkterpri)))))
3142
3143 (defun mkffortreturn ()
3144 (list (mkforttab) 'return (mkterpri)))
3145
3146 (defun mkffortstop ()
3147 (list (mkforttab) 'stop (mkterpri)))
3148
3149 (defun mkffortsubprogdec (type stype name params)
3150 (progn
3151 (cond (params
3152 (setq params
3153 (aconc (cons '|(|
3154 (foreach p in (insertcommas params) conc
3155 (fortexp p)))
3156 '|)|))))
3157 (cond (type
3158 (setq type (list (mkforttab) type '| | stype '| | )))
3159 (t
3160 (setq type (list (mkforttab) stype '| | ))))
3161 (append (append type (fortexp name))
3162 (aconc params (mkterpri)))))
3163
3164 (defun quotstring (arg)
3165 (if (stringp arg) (compress (cons #\" (append (exploden arg) '(#\")))) ;; -mds fix absent "..." in fortwrite of strings
3166 arg))
3167
3168 (defun mkffortwrite (arglist)
3169 (append (append (list (mkforttab) 'write '|(*,*)| '| | )
3170 (foreach arg in (insertcommas (map 'list 'quotstring arglist)) conc (fortexp arg))) ;; -mds
3171 (list (mkterpri))))
3172
3173 ;; indentation control ;;
3174
3175 (defun mkforttab ()
3176 (list 'forttab (- $fortcurrind 6)))
3177
3178 (defun indentfortlevel (n)
3179 (setq $fortcurrind (+ $fortcurrind (* n $tablen))))
3180
3181
3182
3183
3184 ;; ----------- ;;
3185 ;; lsprat.l ;; lisp-to-ratfor translation module
3186 ;; ----------- ;;
3187
3188 (put nil '*ratforname* ".false.")
3189 (put 'or '*ratforprecedence* 1)
3190 (put 'and '*ratforprecedence* 2)
3191 (put 'not '*ratforprecedence* 3)
3192 (put 'equal '*ratforprecedence* 4)
3193 (put 'notequal '*ratforprecedence* 4)
3194 (put 'greaterp '*ratforprecedence* 4)
3195 (put 'geqp '*ratforprecedence* 4)
3196 (put 'lessp '*ratforprecedence* 4)
3197 (put 'leqp '*ratforprecedence* 4)
3198 (put 'plus '*ratforprecedence* 5)
3199 (put 'times '*ratforprecedence* 6)
3200 (put 'quotient '*ratforprecedence* 6)
3201 (put 'minus '*ratforprecedence* 7)
3202 (put 'expt '*ratforprecedence* 8)
3203 (put 'or '*ratforop* "||")
3204 (put 'and '*ratforop* '|&|)
3205 (put 'not '*ratforop* '|!|)
3206 (put 'equal '*ratforop* '|==|)
3207 (put 'notequal '*ratforop* '|!=|)
3208 (put 'greaterp '*ratforop* '|>|)
3209 (put 'geqp '*ratforop* '|>=|)
3210 (put 'lessp '*ratforop* '|<|)
3211 (put 'leqp '*ratforop* '|<=|)
3212 (put 'plus '*ratforop* '|+|)
3213 (put 'times '*ratforop* '|*|)
3214 (put 'quotient '*ratforop* '|/|)
3215 (put 'expt '*ratforop* '|**|)
3216 (put 'minus '*ratforop* '|-|)
3217
3218 ;; ;;
3219 ;; lisp-to-ratfor translation functions ;;
3220 ;; ;;
3221
3222
3223 ;; control function ;;
3224
3225 (defun ratcode (forms)
3226 (foreach f in forms conc
3227 (cond ((atom f)
3228 (cond ((equal f '$begin_group)
3229 (mkfratbegingp))
3230 ((equal f '$end_group)
3231 (mkfratendgp))
3232 (t
3233 (ratexpgen f))))
3234 ((or (lispstmtp f) (lispstmtgpp f))
3235 (cond (*gendecs
3236 (prog (r)
3237 (setq r (append (ratdecs (symtabget '*main*
3238 '*decs*))
3239 (ratstmt f)))
3240 (symtabrem '*main* '*decs*)
3241 (return r)))
3242 (t
3243 (ratstmt f))))
3244 ((lispdefp f)
3245 (ratsubprog f))
3246 (t
3247 (ratexpgen f)))))
3248
3249 ;; subprogram translation ;;
3250
3251 (defun ratsubprog (def)
3252 (prog (type stype name params body lastst r)
3253 (setq name (cadr def))
3254 (setq body (cdddr def))
3255 (cond ((and body (equal body '(nil))) (setq body ())))
3256 (cond ((and (onep (length body))
3257 (lispstmtgpp (car body)))
3258 (progn
3259 (setq body (cdar body))
3260 (cond ((null (car body))
3261 (setq body (cdr body)))))))
3262 (cond (body
3263 (cond ((lispreturnp (setq lastst (car (reverse body))))
3264 (setq body (aconc body '(end))))
3265 ((not (lispendp lastst))
3266 (setq body (append body (list '(return) '(end))))))))
3267 (cond ((setq type (symtabget name name))
3268 (progn
3269 (setq type (cadr type))
3270 (symtabrem name name))))
3271 (setq stype (or (symtabget name '*type*)
3272 (cond ((or type (gfunctionp body name))
3273 'function)
3274 (t
3275 'subroutine))))
3276 (symtabrem name '*type*)
3277 (setq params (or (symtabget name '*params*) (caddr def)))
3278 (symtabrem name '*params*)
3279 (setq r (mkfratsubprogdec type stype name params))
3280 (cond (*gendecs
3281 (setq r (append r (ratdecs (symtabget name '*decs*))))))
3282 (setq r (append r (foreach s in body conc (ratstmt s))))
3283 (cond (*gendecs
3284 (progn
3285 (symtabrem name nil)
3286 (symtabrem name '*decs*))))
3287 (return r)))
3288
3289 ;; generation of declarations ;;
3290
3291 (defun ratdecs (decs)
3292 (foreach tl in (formtypelists decs) conc (mkfratdec (car tl) (cdr tl))))
3293
3294 ;; expression translation ;;
3295
3296 (defun ratexpgen (exp)
3297 (if $dblfloat (map 'list 'dbl (ratexpgen1 exp 0))
3298 (ratexpgen1 exp 0)))
3299
3300 (defun ratexpgen1 (exp wtin)
3301 (cond ((atom exp) (list (ratforname exp)))
3302 ((eq (car exp) 'literal) (ratliteral exp))
3303 ((onep (length exp)) exp)
3304 ((member (car exp) '(minus not) :test #'eq)
3305 (let* ((wt (ratforprecedence (car exp)))
3306 (res (cons (ratforop (car exp)) (ratexpgen1 (cadr exp) wt))))
3307 (cond ((< wt wtin) (aconc (cons '|(| res) '|)|))
3308 (t res))))
3309 ((or (member (car exp) *lisparithexpops* :test #'eq)
3310 (member (car exp) *lisplogexpops* :test #'eq))
3311 (let* ((wt (ratforprecedence (car exp)))
3312 (op (ratforop (car exp)))
3313 (res (ratexpgen1 (cadr exp) wt))
3314 (res1))
3315 (setq exp (cdr exp))
3316 (cond ((eq op '+)
3317 (loop while (setq exp (cdr exp)) do
3318 (progn
3319 (setq res1 (ratexpgen1 (car exp) wt))
3320 (cond ((or (eq (car res1) '-)
3321 (and (numberp (car res1))
3322 (minusp (car res1))))
3323 (setq res (append res res1)))
3324 (t
3325 (setq res (append res (cons op res1))))))))
3326 (t
3327 (loop while (setq exp (cdr exp)) do
3328 (setq res (append res
3329 (cons op
3330 (ratexpgen1 (car exp) wt)))))))
3331 (cond ((< wt wtin) (aconc (cons '|(| res) '|)|))
3332 (t res))))
3333 (t
3334 (let ((res (cons (car exp) (cons '|(| (ratexpgen1 (cadr exp) 0)))))
3335 (setq exp (cdr exp))
3336 (loop while (setq exp (cdr exp)) do
3337 (setq res (append res (cons '|,| (ratexpgen1 (car exp) 0)))))
3338 (aconc res '|)| )))))
3339
3340 (defun ratforname (name)
3341 (if (symbolp name) (or (get name '*ratforname*) name) name))
3342
3343 (defun ratforop (op)
3344 (or (get op '*ratforop*) op))
3345
3346 (defun ratforprecedence (op)
3347 (or (get op '*ratforprecedence*) 9))
3348
3349 ;; statement translation ;;
3350
3351 (defun ratstmt (stmt)
3352 (cond ((null stmt) nil)
3353 ((equal stmt '$begin_group) (mkfratbegingp))
3354 ((equal stmt '$end_group) (mkfratendgp))
3355 ((lisplabelp stmt) (ratstmtno stmt))
3356 ((equal (car stmt) 'literal) (ratliteral stmt))
3357 ((lispreadp stmt) (ratread stmt))
3358 ((lispassignp stmt) (ratassign stmt))
3359 ((lispprintp stmt) (ratwrite stmt))
3360 ((lispcondp stmt) (ratif stmt))
3361 ((lispbreakp stmt) (ratbreak stmt))
3362 ((lispgop stmt) (ratgoto stmt))
3363 ((lispreturnp stmt) (ratreturn stmt))
3364 ((lispstopp stmt) (ratstop stmt))
3365 ((lispendp stmt) (ratend stmt))
3366 ((lispdop stmt) (ratloop stmt))
3367 ((lispstmtgpp stmt) (ratstmtgp stmt))
3368 ((lispdefp stmt) (ratsubprog stmt))
3369 ((lispcallp stmt) (ratcall stmt))))
3370
3371 (defun ratassign (stmt)
3372 (mkfratassign (cadr stmt) (caddr stmt)))
3373
3374 (defun ratbreak (stmt)
3375 (declare (ignore stmt))
3376 (mkfratbreak))
3377
3378 (defun ratcall (stmt)
3379 (mkfratcall (car stmt) (cdr stmt)))
3380
3381 (defun ratdo (var lo nextexp exitcond body)
3382 (prog (r hi incr)
3383 (setq hi
3384 (car (delete1 'greaterp (delete1 'lessp (delete1 var exitcond)))))
3385 (setq incr (car (delete1 'plus (delete1 var nextexp))))
3386 (setq r (mkfratdo var lo hi incr))
3387 (indentratlevel (+ 1))
3388 (setq r (append r (ratstmt body)))
3389 (indentratlevel (- 1))
3390 (return r)))
3391
3392 (defun ratend (stmt)
3393 (declare (ignore stmt))
3394 (mkfratend))
3395
3396 (defun ratforfor (var lo nextexp cond body)
3397 (prog (r)
3398 (cond (cond
3399 (setq cond (list 'not cond))))
3400 (cond ((equal nextexp '(nil))
3401 (setq r (mkfratfor var lo cond var nil)))
3402 (nextexp
3403 (setq r (mkfratfor var lo cond var nextexp)))
3404 (t
3405 (setq r (mkfratfor var lo cond nil nil))))
3406 (indentratlevel (+ 1))
3407 (setq r (append r (ratstmt body)))
3408 (indentratlevel (- 1))
3409 (return r)))
3410
3411 (defun ratgoto (stmt)
3412 (prog (stmtno)
3413 (setq stmtno (or (get (cadr stmt) '*stmtno*)
3414 (put (cadr stmt) '*stmtno* (genstmtno))))
3415 (return (mkfratgo stmtno))))
3416
3417 (defun ratif (stmt)
3418 (prog (r st)
3419 (setq r (mkfratif (caadr stmt)))
3420 (indentratlevel (+ 1))
3421 (setq st (seqtogp (cdadr stmt)))
3422 (cond ((and (listp st)
3423 (equal (car st) 'cond)
3424 (equal (length st) 2))
3425 (setq st (mkstmtgp 0 (list st)))))
3426 (setq r (append r (ratstmt st)))
3427 (indentratlevel (- 1))
3428 (setq stmt (cdr stmt))
3429 (loop while (and (setq stmt (cdr stmt))
3430 (not (eq (caar stmt) t))) do
3431 (setq r (append r (mkfratelseif (caar stmt))))
3432 (indentratlevel (+ 1))
3433 (setq st (seqtogp (cdar stmt)))
3434 (cond ((and (listp st)
3435 (equal (car st) 'cond)
3436 (equal (length st) 2))
3437 (setq st (mkstmtgp 0 (list st)))))
3438 (setq r (append r (ratstmt st)))
3439 (indentratlevel (- 1)))
3440 (cond (stmt
3441 (progn
3442 (setq r (append r (mkfratelse)))
3443 (indentratlevel (+ 1))
3444 (setq st (seqtogp (cdar stmt)))
3445 (cond ((and (listp st)
3446 (equal (car st) 'cond)
3447 (equal (length st) 2))
3448 (setq st (mkstmtgp 0 (list st)))))
3449 (setq r (append r (ratstmt st)))
3450 (indentratlevel (- 1)))))
3451 (return r)))
3452
3453 (defun ratliteral (stmt)
3454 (mkfratliteral (cdr stmt)))
3455
3456 (defun ratloop (stmt)
3457 (prog (var lo nextexp exitcond body)
3458 (cond ((complexdop stmt)
3459 (return (ratstmt (seqtogp (simplifydo stmt))))))
3460 (cond ((setq var (cadr stmt))
3461 (progn
3462 (setq lo (cadar var))
3463 (cond ((equal (length (car var)) 3)
3464 (setq nextexp (or (caddar var) (list 'nil)))))
3465 (setq var (caar var)))))
3466 (cond ((setq exitcond (caddr stmt))
3467 (setq exitcond (car exitcond))))
3468 (setq body (seqtogp (cdddr stmt)))
3469 (cond ((and var
3470 lo
3471 (equal (car nextexp) 'plus)
3472 (member var nextexp)
3473 (member (car exitcond) '(greaterp lessp))
3474 (member var exitcond))
3475 (return (ratdo var lo nextexp exitcond body)))
3476 ((and exitcond
3477 (not var))
3478 (return (ratwhile exitcond body)))
3479 ((and var
3480 (not lo)
3481 (lisplogexpp nextexp)
3482 (equal exitcond var))
3483 (return (ratrepeat body nextexp)))
3484 (t
3485 (return (ratforfor var lo nextexp exitcond body))))))
3486
3487 (defun ratread (stmt)
3488 (mkfratread (cadr stmt)))
3489
3490 (defun ratrepeat (body exitcond)
3491 (prog (r)
3492 (setq r (mkfratrepeat))
3493 (indentratlevel (+ 1))
3494 (setq r (append r (ratstmt body)))
3495 (indentratlevel (- 1))
3496 (return (append r (mkfratuntil exitcond)))))
3497
3498 (defun ratreturn (stmt)
3499 (mkfratreturn (cadr stmt)))
3500
3501 (defun ratstmtgp (stmtgp)
3502 (prog (r)
3503 (cond ((equal (car stmtgp) 'progn)
3504 (setq stmtgp (cdr stmtgp)))
3505 (t
3506 (setq stmtgp (cddr stmtgp))))
3507 (setq r (mkfratbegingp))
3508 (indentratlevel (+ 1))
3509 (setq r (append r (foreach stmt in stmtgp conc (ratstmt stmt))))
3510 (indentratlevel (- 1))
3511 (return (append r (mkfratendgp)))))
3512
3513 (defun ratstmtno (label)
3514 (prog (stmtno)
3515 (setq stmtno (or (get label '*stmtno*)
3516 (put label '*stmtno* (genstmtno))))
3517 (return (mkfratcontinue stmtno))))
3518
3519 (defun ratstop (stmt)
3520 (declare (ignore stmt))
3521 (mkfratstop))
3522
3523 (defun ratwhile (cond body)
3524 (prog (r)
3525 (cond (cond
3526 (setq cond (list 'not cond))))
3527 (setq r (mkfratwhile cond))
3528 (indentratlevel (+ 1))
3529 (setq r (append r (ratstmt body)))
3530 (indentratlevel (- 1))
3531 (return r)))
3532
3533 (defun ratwrite (stmt)
3534 (mkfratwrite (cdr stmt)))
3535
3536
3537 ;; ;;
3538 ;; ratfor code formatting functions ;;
3539 ;; ;;
3540
3541
3542 ;; statement formatting ;;
3543
3544 (defun mkfratassign (lhs rhs)
3545 (append (append (cons (mkrattab) (ratexpgen lhs))
3546 (cons '= (ratexpgen rhs)))
3547 (list (mkterpri))))
3548
3549 (defun mkfratbegingp ()
3550 (list (mkrattab) '{ (mkterpri)))
3551
3552 (defun mkfratbreak ()
3553 (list (mkrattab) 'break (mkterpri)))
3554
3555 (defun mkfratcall (fname params)
3556 (progn
3557 (cond (params
3558 (setq params (append (append (list '|(|)
3559 (foreach p in (insertcommas params)
3560 conc (ratexpgen p)))
3561 (list '|)|)))))
3562 (append (append (list (mkrattab) 'call '| |)
3563 (ratexpgen fname))
3564 (append params
3565 (list (mkterpri))))))
3566
3567 (defun mkfratcontinue (stmtno)
3568 (list stmtno '| | (mkrattab) 'continue (mkterpri)))
3569
3570 (defun mkfratdec (type varlist)
3571 (progn
3572 (setq type (or type 'dimension))
3573 (setq varlist (foreach v in (insertcommas varlist) conc (ratexpgen v)))
3574 (cond ((implicitp type)
3575 (append (list (mkrattab) type '| | '|(|)
3576 (append varlist (list '|)| (mkterpri)))))
3577 (t
3578 (append (list (mkrattab) type '| | )
3579 (aconc varlist (mkterpri)))))))
3580
3581 (defun mkfratdo (var lo hi incr)
3582 (progn
3583 (cond ((onep incr)
3584 (setq incr nil))
3585 (incr
3586 (setq incr (cons '|,| (ratexpgen incr)))))
3587 (append (append (append (list (mkrattab) 'do '| |)
3588 (ratexpgen var))
3589 (append (cons '|=| (ratexpgen lo))
3590 (cons '|,| (ratexpgen hi))))
3591 (append incr
3592 (list (mkterpri))))))
3593
3594 (defun mkfratelse ()
3595 (list (mkrattab) 'else (mkterpri)))
3596
3597 (defun mkfratelseif (exp)
3598 (append (append (list (mkrattab) 'else '| | 'if '| | '|(|)
3599 (ratexpgen exp))
3600 (list '|)| (mkterpri))))
3601
3602 (defun mkfratend ()
3603 (list (mkrattab) 'end (mkterpri)))
3604
3605 (defun mkfratendgp ()
3606 (list (mkrattab) '} (mkterpri)))
3607
3608 (defun mkfratfor (var1 lo cond var2 nextexp)
3609 (progn
3610 (cond (var1
3611 (setq var1 (append (ratexpgen var1) (cons '= (ratexpgen lo))))))
3612 (cond (cond
3613 (setq cond (ratexpgen cond))))
3614 (cond (var2
3615 (setq var2 (append (ratexpgen var2) (cons '= (ratexpgen nextexp))))))
3616 (append (append (append (list (mkrattab) 'for '| | '|(|)
3617 var1)
3618 (cons semicolon cond))
3619 (append (cons semicolon var2)
3620 (list '|)| (mkterpri))))))
3621
3622 (defun mkfratgo (stmtno)
3623 (list (mkrattab) 'goto '| | stmtno (mkterpri)))
3624
3625 (defun mkfratif (exp)
3626 (append (append (list (mkrattab) 'if '| | '|(|)
3627 (ratexpgen exp))
3628 (list '|)| (mkterpri))))
3629
3630 (defun mkfratliteral (args)
3631 (foreach a in args conc
3632 (cond ((equal a '$tab) (list (mkrattab)))
3633 ((equal a '$cr) (list (mkterpri)))
3634 ((listp a) (ratexpgen a))
3635 (t (list a)))))
3636
3637 (defun mkfratread (var)
3638 (append (list (mkrattab) 'read '|(*,*)| '| | )
3639 (append (ratexpgen var) (list (mkterpri)))))
3640
3641 (defun mkfratrepeat ()
3642 (list (mkrattab) 'repeat (mkterpri)))
3643
3644 (defun mkfratreturn (exp)
3645 (cond (exp
3646 (append (append (list (mkrattab) 'return '|(|) (ratexpgen exp))
3647 (list '|)| (mkterpri))))
3648 (t
3649 (list (mkrattab) 'return (mkterpri)))))
3650
3651 (defun mkfratstop ()
3652 (list (mkrattab) 'stop (mkterpri)))
3653
3654 (defun mkfratsubprogdec (type stype name params)
3655 (progn
3656 (cond (params
3657 (setq params (aconc (cons '|(|
3658 (foreach p in (insertcommas params)
3659 conc (ratexpgen p)))
3660 '|)|))))
3661 (cond (type
3662 (setq type (list (mkrattab) type '| | stype '| | )))
3663 (t
3664 (setq type (list (mkrattab) stype '| | ))))
3665 (append (append type (ratexpgen name))
3666 (aconc params (mkterpri)))))
3667
3668 (defun mkfratuntil (logexp)
3669 (append (list (mkrattab) 'until '| | '|(|)
3670 (append (ratexpgen logexp) (list '|)| (mkterpri)))))
3671
3672 (defun mkfratwhile (exp)
3673 (append (append (list (mkrattab) 'while '| | '|(|)
3674 (ratexpgen exp))
3675 (list '|)| (mkterpri))))
3676
3677 (defun mkfratwrite (arglist)
3678 (append (append (list (mkrattab) 'write '|(*,*)| '| | )
3679 (foreach arg in (insertcommas (map 'list 'quotstring arglist)) conc (ratexpgen arg)))
3680 (list (mkterpri))))
3681
3682 ;; indentation control ;;
3683
3684 (defun mkrattab ()
3685 (list 'rattab $ratcurrind))
3686
3687 (defun indentratlevel (n)
3688 (setq $ratcurrind (+ $ratcurrind (* n $tablen))))
3689
3690
3691
3692 ;; --------- ;;
3693 ;; lspc.l ;; lisp-to-c translation module
3694 ;; --------- ;;
3695
3696 (put nil '*cname* 0)
3697
3698 (put 'or '*cprecedence* 1)
3699 (put 'and '*cprecedence* 2)
3700 (put 'equal '*cprecedence* 3)
3701 (put 'notequal '*cprecedence* 3)
3702 (put 'greaterp '*cprecedence* 4)
3703 (put 'geqp '*cprecedence* 4)
3704 (put 'lessp '*cprecedence* 4)
3705 (put 'leqp '*cprecedence* 4)
3706 (put 'plus '*cprecedence* 5)
3707 (put 'times '*cprecedence* 6)
3708 (put 'quotient '*cprecedence* 6)
3709 (put 'not '*cprecedence* 7)
3710 (put 'minus '*cprecedence* 7)
3711 (put 'and '*cop* '|&&|)
3712 (put 'not '*cop* '|!|)
3713 (put 'equal '*cop* '|==|)
3714 (put 'notequal '*cop* '|!=|)
3715 (put 'greaterp '*cop* '|>|)
3716 (put 'geqp '*cop* '|>=|)
3717 (put 'lessp '*cop* '|<|)
3718 (put 'leqp '*cop* '|<=|)
3719 (put 'plus '*cop* '|+|)
3720 (put 'times '*cop* '|*|)
3721 (put 'quotient '*cop* '|/|)
3722 (put 'minus '*cop* '|-|)
3723 (put 'or '*cop* "||")
3724 ;; ;;
3725 ;; lisp-to-c transltion functions ;;
3726 ;; ;;
3727
3728
3729 ;; control function ;;
3730
3731 (defun ccode (forms)
3732 (foreach f in forms conc
3733 (cond ((atom f)
3734 (cond ((equal f '$begin_group) (mkfcbegingp))
3735 ((equal f '$end_group) (mkfcendgp))
3736 (t (cexp f))))
3737 ((or (lispstmtp f) (lispstmtgpp f))
3738 (cond (*gendecs (prog (r)
3739 (setq r
3740 (append
3741 (cdecs (symtabget '*main*
3742 '*decs*))
3743 (cstmt f)))
3744 (symtabrem '*main* '*decs*)
3745 (return r)))
3746 (t (cstmt f))))
3747 ((lispdefp f) (cproc f))
3748 (t (cexp f)))))
3749
3750 ;; procedure translation ;;
3751
3752 (defun cproc (def)
3753 (prog (type name params paramtypes vartypes body r)
3754 (setq name (cadr def))
3755 (setq body (cdddr def))
3756 (cond ((and body (equal body '(nil))) (setq body ())))
3757 (cond ((and (onep (length body))
3758 (lispstmtgpp (car body)))
3759 (progn
3760 (setq body (cdar body))
3761 (cond ((null (car body))
3762 (setq body (cdr body)))))))
3763 (cond ((setq type (symtabget name name))
3764 (progn
3765 (setq type (cadr type))
3766 (symtabrem name name))))
3767 (setq params (or (symtabget name '*params*) (caddr def)))
3768 (symtabrem name '*params*)
3769 (foreach dec in (symtabget name '*decs*) do
3770 (cond ((member (car dec) params)
3771 (setq paramtypes (aconc paramtypes dec)))
3772 (t
3773 (setq vartypes (aconc vartypes dec)))))
3774 (setq r (append (mkfcprocdec type name params)
3775 (cdecs paramtypes)))
3776 (cond (body
3777 (setq r (append r (mkfcbegingp)))
3778 (indentclevel (+ 1))
3779 (cond (*gendecs (setq r (append r (cdecs vartypes)))))
3780 (setq r (append r (foreach s in body conc (cstmt s))))
3781 (indentclevel (- 1))
3782 (setq r (append r (mkfcendgp)))))
3783 (cond (*gendecs
3784 (progn
3785 (symtabrem name nil)
3786 (symtabrem name '*decs*))))
3787 (return r)))
3788
3789 ;; generation of declarations ;;
3790
3791 (defun cdecs (decs)
3792 (foreach tl in (formtypelists decs) conc (mkfcdec (car tl) (cdr tl))))
3793
3794 ;; expression translation ;;
3795
3796 (defun cexp (exp)
3797 (if $dblfloat (map 'list 'dbl (cexp1 exp 0))
3798 (cexp1 exp 0)))
3799
3800 (defun cexp1 (exp wtin)
3801 (cond ((atom exp) (list (cname exp)))
3802 ((eq (car exp) 'literal) (cliteral exp))
3803 ((member (car exp) '(minus not) :test #'eq)
3804 (let* ((wt (cprecedence (car exp)))
3805 (res (cons (cop (car exp)) (cexp1 (cadr exp) wt))))
3806 (cond ((< wt wtin) (aconc (cons '|(| res) '|)| ))
3807 (t res))))
3808 ((eq (car exp) 'expt)
3809 (append (cons 'pow (cons '|(| (cexp1 (cadr exp) 0)))
3810 (aconc (cons '|,| (cexp1 (caddr exp) 0)) '|)| )))
3811 ((or (member (car exp) *lisparithexpops* :test #'eq)
3812 (member (car exp) *lisplogexpops* :test #'eq))
3813 (let* ((wt (cprecedence (car exp)))
3814 (op (cop (car exp)))
3815 (res (cexp1 (cadr exp) wt))
3816 (res1))
3817 (setq exp (cdr exp))
3818 (cond ((eq op '+)
3819 (loop while (setq exp (cdr exp)) do
3820 (setq res1 (cexp1 (car exp) wt))
3821 (cond ((or (eq (car res1) '-)
3822 (and (numberp (car res1))
3823 (minusp (car res1))))
3824 (setq res (append res res1)))
3825 (t
3826 (setq res (append res (cons op res1)))))))
3827 (t
3828 (loop while (setq exp (cdr exp)) do
3829 (setq res (append res
3830 (cons op
3831 (cexp1 (car exp) wt)))))))
3832 (cond ((< wt wtin) (aconc (cons '|(| res) '|)| ))
3833 (t res))))
3834 ((arrayeltp exp)
3835 (let ((res (list (car exp))))
3836 (loop while (setq exp (cdr exp)) do
3837 (setq res (append res
3838 (aconc (cons '|[| (cexp1 (car exp) 0)) '|]|))))
3839 res))
3840 ((onep (length exp)) (aconc (aconc exp '|(|) '|)| ))
3841 (t
3842 (let ((res (cons (car exp) (cons '|(| (cexp1 (cadr exp) 0)))))
3843 (setq exp (cdr exp))
3844 (loop while (setq exp (cdr exp)) do
3845 (setq res (append res (cons '|,| (cexp1 (car exp) 0)))))
3846 (aconc res '|)|)))))
3847
3848 (defun cname (name)
3849 (if (symbolp name) (or (get name '*cname*) name) name))
3850
3851 (defun cop (op)
3852 (or (get op '*cop*) op))
3853
3854 (defun cprecedence (op)
3855 (or (get op '*cprecedence*) 8))
3856
3857 ;; statement translation ;;
3858
3859 (defun cstmt (stmt)
3860 (cond ((null stmt) nil)
3861 ((equal stmt '$begin_group) (mkfcbegingp))
3862 ((equal stmt '$end_group) (mkfcendgp))
3863 ((lisplabelp stmt) (clabel stmt))
3864 ((equal (car stmt) 'literal) (cliteral stmt))
3865 ((lispassignp stmt) (cassign stmt))
3866 ((lispcondp stmt) (cif stmt))
3867 ((lispbreakp stmt) (cbreak stmt))
3868 ((lispgop stmt) (cgoto stmt))
3869 ((lispreturnp stmt) (creturn stmt))
3870 ((lispstopp stmt) (cexit stmt))
3871 ((lispdop stmt) (cloop stmt))
3872 ((lispstmtgpp stmt) (cstmtgp stmt))
3873 ((lispdefp stmt) (cproc stmt))
3874 (t (cexpstmt stmt))))
3875
3876 (defun cassign (stmt)
3877 (mkfcassign (cadr stmt) (caddr stmt)))
3878
3879 (defun cbreak (stmt)
3880 (declare (ignore stmt))
3881 (mkfcbreak))
3882
3883 (defun cexit (stmt)
3884 (declare (ignore stmt))
3885 (mkfcexit))
3886
3887 (defun cexpstmt (exp)
3888 (append (cons (mkctab) (cexp exp))
3889 (list semicolon (mkterpri))))
3890
3891 (defun cfor (var lo nextexp cond body)
3892 (prog (r)
3893 (cond (cond (setq cond (list 'not cond))))
3894 (cond ((equal nextexp '(nil))
3895 (setq r (mkfcfor var lo cond var nil)))
3896 (nextexp
3897 (setq r (mkfcfor var lo cond var nextexp)))
3898 (t
3899 (setq r (mkfcfor var lo cond nil nil))))
3900 (indentclevel (+ 1))
3901 (setq r (append r (cstmt body)))
3902 (indentclevel (- 1))
3903 (return r)))
3904
3905 (defun cgoto (stmt)
3906 (mkfcgo (cadr stmt)))
3907
3908 (defun cif (stmt)
3909 (prog (r st)
3910 (setq r (mkfcif (caadr stmt)))
3911 (indentclevel (+ 1))
3912 (setq st (seqtogp (cdadr stmt)))
3913 (cond ((and (listp st)
3914 (equal (car st) 'cond)
3915 (equal (length st) 2))
3916 (setq st (mkstmtgp 0 (list st)))))
3917 (setq r (append r (cstmt st)))
3918 (indentclevel (- 1))
3919 (setq stmt (cdr stmt))
3920 (loop while (and (setq stmt (cdr stmt)) (progn
3921 (not (eq (caar stmt) t)))) do
3922 (progn
3923 (setq r (append r (mkfcelseif (caar stmt))))
3924 (indentclevel (+ 1))
3925 (setq st (seqtogp (cdar stmt)))
3926 (cond ((and (listp st)
3927 (equal (car st) 'cond)
3928 (equal (length st) 2))
3929 (setq st (mkstmtgp 0 (list st)))))
3930 (setq r (append r (cstmt st)))
3931 (indentclevel (- 1))))
3932 (cond (stmt (progn
3933 (setq r (append r (mkfcelse)))
3934 (indentclevel (+ 1))
3935 (setq st (seqtogp (cdar stmt)))
3936 (cond ((and (listp st)
3937 (equal (car st) 'cond)
3938 (equal (length st) 2))
3939 (setq st (mkstmtgp 0 (list st)))))
3940 (setq r (append r (cstmt st)))
3941 (indentclevel (- 1)))))
3942 (return r)))
3943
3944 (defun clabel (label)
3945 (mkfclabel label))
3946
3947 (defun cliteral (stmt)
3948 (mkfcliteral (cdr stmt)))
3949
3950 (defun cloop (stmt)
3951 (prog (var lo nextexp exitcond body)
3952 (cond ((complexdop stmt)
3953 (return (cstmt (seqtogp (simplifydo stmt))))))
3954 (cond ((setq var (cadr stmt))
3955 (progn
3956 (setq lo (cadar var))
3957 (cond ((equal (length (car var)) 3)
3958 (setq nextexp (or (caddar var) (list 'nil)))))
3959 (setq var (caar var)))))
3960 (cond ((setq exitcond (caddr stmt))
3961 (setq exitcond (car exitcond))))
3962 (setq body (seqtogp (cdddr stmt)))
3963 (cond ((and exitcond (not var))
3964 (return (cwhile exitcond body)))
3965 ((and var
3966 (not lo)
3967 (lisplogexpp nextexp)
3968 (equal exitcond var))
3969 (return (crepeat body nextexp)))
3970 (t
3971 (return (cfor var lo nextexp exitcond body))))))
3972
3973 (defun crepeat (body logexp)
3974 (prog (r)
3975 (setq r (mkfcdo))
3976 (indentclevel (+ 1))
3977 (setq r (append r (cstmt body)))
3978 (indentclevel (- 1))
3979 (return (append r (mkfcdowhile (list 'not logexp))))))
3980
3981 (defun creturn (stmt)
3982 (mkfcreturn (cadr stmt)))
3983
3984 (defun cstmtgp (stmtgp)
3985 (prog (r)
3986 (cond ((equal (car stmtgp) 'progn)
3987 (setq stmtgp (cdr stmtgp)))
3988 (t
3989 (setq stmtgp (cddr stmtgp))))
3990 (setq r (mkfcbegingp))
3991 (indentclevel (+ 1))
3992 (setq r (append r (foreach stmt in stmtgp conc (cstmt stmt))))
3993 (indentclevel (- 1))
3994 (return (append r (mkfcendgp)))))
3995
3996 (defun cwhile (cond body)
3997 (prog (r)
3998 (cond (cond (setq cond (list 'not cond))))
3999 (setq r (mkfcwhile cond))
4000 (indentclevel (+ 1))
4001 (setq r (append r (cstmt body)))
4002 (indentclevel (- 1))
4003 (return r)))
4004
4005
4006 ;; ;;
4007 ;; c code formatting functions ;;
4008 ;; ;;
4009
4010
4011 ;; statement formatting ;;
4012
4013 (defun mkfcassign (lhs rhs)
4014 (append (append (cons (mkctab) (cexp lhs))
4015 (cons '= (cexp rhs)))
4016 (list semicolon (mkterpri))))
4017
4018 (defun mkfcbegingp ()
4019 (list (mkctab) '{ (mkterpri)))
4020
4021 (defun mkfcbreak ()
4022 (list (mkctab) 'break semicolon (mkterpri)))
4023
4024 (defun mkfcdec (type varlist)
4025 (progn
4026 (setq varlist
4027 (foreach v in varlist collect
4028 (cond ((atom v) v)
4029 (t (cons (car v)
4030 (foreach dim in (cdr v) collect
4031 (1+ dim)))))))
4032 (append (cons (mkctab)
4033 (cons type
4034 (cons '| | (foreach v in (insertcommas varlist) conc
4035 (cexp v)))))
4036 (list semicolon (mkterpri)))))
4037
4038 (defun mkfcdo ()
4039 (list (mkctab) 'do (mkterpri)))
4040
4041 (defun mkfcdowhile (exp)
4042 (append (append (list (mkctab) 'while '| | '|(|)
4043 (cexp exp))
4044 (list '|)| semicolon (mkterpri))))
4045
4046 (defun mkfcelse ()
4047 (list (mkctab) 'else (mkterpri)))
4048
4049 (defun mkfcelseif (exp)
4050 (append (append (list (mkctab) 'else '| | 'if '| | '|(|) (cexp exp))
4051 (list '|)| (mkterpri))))
4052
4053 (defun mkfcendgp ()
4054 (list (mkctab) '} (mkterpri)))
4055
4056 (defun mkfcexit ()
4057 (list (mkctab) 'exit '|(| 0 '|)| semicolon (mkterpri)))
4058
4059 (defun mkfcfor (var1 lo cond var2 nextexp)
4060 (progn
4061 (cond (var1 (setq var1 (append (cexp var1) (cons '= (cexp lo))))))
4062 (cond (cond (setq cond (cexp cond))))
4063 (cond (var2 (setq var2 (append (cexp var2) (cons '= (cexp nextexp))))))
4064 (append (append (append (list (mkctab) 'for '| | '|(|) var1)
4065 (cons semicolon cond))
4066 (append (cons semicolon var2)
4067 (list '|)| (mkterpri))))))
4068
4069 (defun mkfcgo (label)
4070 (list (mkctab) 'goto '| | label semicolon (mkterpri)))
4071
4072 (defun mkfcif (exp)
4073 (append (append (list (mkctab) 'if '| | '|(|)
4074 (cexp exp))
4075 (list '|)| (mkterpri))))
4076
4077 (defun mkfclabel (label)
4078 (list label '|:| (mkterpri)))
4079
4080 (defun mkfcliteral (args)
4081 (foreach a in args conc
4082 (cond ((equal a '$tab) (list (mkctab)))
4083 ((equal a '$cr) (list (mkterpri)))
4084 ((listp a) (cexp a))
4085 (t (list a)))))
4086
4087 (defun mkfcprocdec (type name params)
4088 (progn
4089 (setq params
4090 (aconc (cons '|(| (foreach p in (insertcommas params) conc
4091 (cexp p)))
4092 '|)|))
4093 (cond (type (append (cons (mkctab) (cons type (cons '| | (cexp name))))
4094 (aconc params (mkterpri))))
4095 (t (append (cons (mkctab) (cexp name))
4096 (aconc params (mkterpri)))))))
4097
4098 (defun mkfcreturn (exp)
4099 (cond (exp
4100 (append (append (list (mkctab) 'return '|(|) (cexp exp))
4101 (list '|)| semicolon (mkterpri))))
4102 (t
4103 (list (mkctab) 'return semicolon (mkterpri)))))
4104
4105 (defun mkfcwhile (exp)
4106 (append (append (list (mkctab) 'while '| | '|(|)
4107 (cexp exp))
4108 (list '|)| (mkterpri))))
4109
4110 ;; indentation control ;;
4111
4112 (defun mkctab ()
4113 (list 'ctab $ccurrind))
4114
4115 (defun indentclevel (n)
4116 (setq $ccurrind (+ $ccurrind (* n $tablen))))
4117
4118
4119
4120 ;; ----------- ;;
4121 ;; intrfc.l ;; command parsing routines & control functions
4122 ;; ----------- ;;
4123
4124
4125
4126 ;; ;;
4127 ;; 1. command parsing routines ;;
4128 ;; ;;
4129
4130
4131 ;; command parsers ;;
4132
4133 ;; functions callable from Maxima append genoutpath to output filespecs -- mds
4134
4135 (defmspec $gentran (forms)
4136 ; ;
4137 ; gentran(stmt1,stmt2,...,stmtn {,[f1,f2,...,fm]}); ;
4138 ; --> ;
4139 ; (gentran (stmt1 stmt2 ... stmtn) ;
4140 ; (f1 f2 ... fm)) ;
4141 ; ;
4142 (prog (flist)
4143 (setq forms (reverse forms))
4144 (cond ((and (listp (car forms))
4145 (listp (caar forms))
4146 (equal (caaar forms) 'mlist))
4147 (setq flist (cdar forms))
4148 (setq forms (cdr forms))))
4149 (setq forms (cdr (reverse forms)))
4150 (return (gentran forms (setq flist (map 'list 'outpath flist))))))
4151
4152
4153 (defmfun $gentranout (&rest flist)
4154 ; ;
4155 ; gentranout(f1,f2,...,fn); --> (gentranoutpush (f1 f2 ... fn) t) ;
4156 ; ;
4157 (gentranoutpush (setq flist (map 'list 'outpath flist)) t))
4158
4159 (defun gentranout (flist)
4160 ; ;
4161 ; (gentranout (f1 f2 ... fn)) --> (gentranoutpush (f1 f2 ... fn) t) ;
4162 ; ;
4163 (gentranoutpush flist t))
4164
4165
4166 (defmfun $gentranshut (&rest flist)
4167 ; ;
4168 ; gentranshut(f1,f2,...,fn); --> (gentranshut (f1 f2 ... fn)) ;
4169 ; ;
4170 (gentranshut (setq flist (map 'list 'outpath flist))))
4171
4172
4173 (defmfun $gentranpush (&rest flist)
4174 ; ;
4175 ; gentranpush(f1,f2,...,fn); --> (gentranoutpush (f1 f2 ... fn) nil) ;
4176 ; ;
4177 (gentranoutpush (setq flist (map 'list 'outpath flist)) nil))
4178
4179 (defun gentranpush (flist)
4180 ; ;
4181 ; (gentranpush (f1 f2 ... fn)) --> (gentranoutpush (f1 f2 ... fn) nil) ;
4182 ; ;
4183 (gentranoutpush flist nil))
4184
4185
4186 (defmfun $gentranpop (&rest flist)
4187 ; ;
4188 ; gentranpop(f1,f2,...,fn); --> (gentranpop (f1 f2 ... fn)) ;
4189 ; ;
4190 (gentranpop (setq flist (map 'list 'outpath flist))))
4191
4192
4193 (defmfun $gentranin (&rest forms)
4194 ; ;
4195 ; gentranin(f1,f2,...,fn {,[f1,f2,...,fm]}); ;
4196 ; --> ;
4197 ; (gentranin (f1 f2 ... fn) (f1 f2 ... fm)) ;
4198 ; ;
4199 (prog (outflist)
4200 (setq forms (reverse forms))
4201 (cond ((and (listp (car forms))
4202 (listp (caar forms))
4203 (equal (caaar forms) 'mlist))
4204 (setq outflist (cdar forms))
4205 (setq forms (cdr forms))))
4206 (setq forms (reverse forms))
4207 (return (gentranin forms (setq outflist (map 'list 'outpath outflist))))))
4208
4209 ;; cleanup function for when gentranin hangs ==mds courtesy of Macsyma inc.
4210 (defun $gentraninshut () (popinstk) '$done)
4211
4212
4213 (defmfun $gentran_on (&rest flaglist) ;; renamed consistent with Macsyma --mds
4214 ; ;
4215 ; on(flag1,flag2,...,flagn); ;
4216 ; --> ;
4217 ; (onoff flaglist t) ;
4218 ; ;
4219 (onoff flaglist t))
4220
4221 (defun on (flaglist)
4222 ; ;
4223 ; (on flaglist) --> (onoff flaglist t) ;
4224 ; ;
4225 (onoff flaglist t))
4226
4227
4228 (defmfun $gentran_off (&rest flaglist) ;; renamed consistent with Macsyma --mds
4229 ; ;
4230 ; off(flag1,flag2,...,flagn); ;
4231 ; --> ;
4232 ; (onoff flaglist nil) ;
4233 ; ;
4234 (onoff flaglist nil))
4235
4236 (defun gentran_off (flaglist) ;; renamed consistent with Macsyma --mds
4237 ; ;
4238 ; (off flaglist) --> (onoff flaglist nil) ;
4239 ; ;
4240 (onoff flaglist nil))
4241
4242
4243
4244 ;; ;;
4245 ;; 2. control functions ;;
4246 ;; ;;
4247
4248
4249 ;; command control functions ;;
4250
4251
4252 (defun gentran (forms flist)
4253 (prog ()
4254 (cond ((setq flist (preproc flist))
4255 (eval (list 'gentranoutpush (list 'quote flist) nil))))
4256 (setq forms (preproc forms))
4257 (cond ($gentranparser (gentranparse forms)))
4258 (setq forms (franz forms))
4259 (cond ($gentranseg (setq forms (seg forms))))
4260 (cond ((eq (stripdollar1 $gentranlang) 'ratfor)
4261 (formatrat (ratcode forms)))
4262 ((eq (stripdollar1 $gentranlang) 'c)
4263 (formatc (ccode forms)))
4264 ((formatfort (fortcode forms))))
4265 (return (cond (flist
4266 (progn
4267 (setq flist (or (car *currout*)
4268 (cons '(mlist) (cdr *currout*))))
4269 (eval '(gentranpop '(nil)))
4270 flist))
4271 (t
4272 (or (car *currout*)
4273 (cons '(mlist)
4274 (cdr *currout*))))))))
4275
4276
4277 (defun gentranoutpush (flist outp)
4278 ; open, [delete,] push ;
4279 (prog (fp)
4280 (setq flist (fargstonames (preproc flist) t))
4281 (cond ((onep (length flist))
4282 (progn
4283 (setq fp (or (filpr (car flist) *outstk*)
4284 (mkfilpr (car flist))))
4285 (cond (outp (delstk fp)))
4286 (pushstk fp)))
4287 (t
4288 (progn
4289 (setq fp (foreach f in flist collect
4290 (or (filpr f *outstk*) (mkfilpr f))))
4291 (cond (outp
4292 (progn
4293 (foreach p in fp do (delstk p))
4294 (delstk (pfilpr flist *outstk*)))))
4295 (pushstk '(nil))
4296 (cond (outp
4297 (foreach p in fp do (pushstk p)))
4298 ((foreach p in fp do
4299 (cond ((not (member p *outstk*))
4300 (pushstk p))))))
4301 (pushstk (cons nil flist)))))
4302 (resetstk *outstk*)
4303 (return (or (car *currout*)
4304 (cons '(mlist) (cdr *currout*))))))
4305
4306
4307 (defun gentranshut (flist)
4308 ; close, delete, [output to t] ;
4309 (prog (trm fp)
4310 (setq flist (fargstonames (preproc flist) nil))
4311 (cond ((onep (length flist))
4312 (progn
4313 (setq trm (equal (car *currout*) (car flist)))
4314 (setq fp (filpr (car flist) *outstk*))
4315 (close (cdr fp))
4316 (delstk fp)
4317 (cond (trm (pushstk *stdout*)))))
4318 (t
4319 (progn
4320 (cond ((car *currout*)
4321 (setq trm (member (car *currout*) flist)))
4322 (t
4323 (setq trm
4324 (eval (cons 'and
4325 (foreach f in (cdr *currout*) collect
4326 (cond ((member f flist)
4327 t))))))))
4328 (setq fp (foreach f in flist collect (filpr f *outstk*)))
4329 (foreach p in fp do (close (cdr p)))
4330 (foreach p in fp do (delstk p))
4331 (delstk (pfilpr flist *outstk*))
4332 (cond (trm (pushstk *stdout*))))))
4333 (resetstk *outstk*)
4334 (return (or (car *currout*)
4335 (cons '(mlist) (cdr *currout*))))))
4336
4337
4338 (defun gentranpop (flist)
4339 ; [close,] delete ;
4340 (prog (fp)
4341 (setq flist (preproc flist))
4342 (cond ((member '$all flist)
4343 (loop while (> (length *outstk*) 1) do
4344 (gentranpop '(nil)))
4345 (return (car *currout*))))
4346 (setq flist (fargstonames flist nil))
4347 (cond ((onep (length flist))
4348 (progn
4349 (setq fp (filpr (car flist) *outstk*))
4350 (popstk fp)
4351 (cond ((not (member fp *outstk*)) (close (cdr fp))))))
4352 (t
4353 (progn
4354 (setq fp (foreach f in flist collect (filpr f *outstk*)))
4355 (popstk (pfilpr flist *outstk*))
4356 (foreach p in fp do
4357 (cond ((not (member p *outstk*))
4358 (close (cdr p))))))))
4359 (return (or (car *currout*)
4360 (cons '(mlist)
4361 (cdr *currout*))))))
4362
4363
4364 (defun gentranin (inlist outlist)
4365 (prog (ogendecs) ;; disable declarations of tempvars in template --mds
4366 (setq ogendecs *gendecs)
4367 (setq *gendecs nil)
4368 (setq inlist (map 'list 'fsearch inlist)) ;; use filesearch to find input files --mds
4369 (foreach inf in (setq inlist (preproc inlist)) do
4370 (cond ((listp inf)
4371 (if (not inf)(gentranerr 'e inf "file not found in searchpath" nil)
4372 (gentranerr 'e inf "wrong type of arg" nil)))
4373
4374 ((not(open (stripdollar inf) :direction :probe)) ;; rjf 11/1/2018
4375 (gentranerr 'e inf "nonexistent input file" nil))
4376
4377 ))
4378 (cond (outlist
4379 (eval (list 'gentranoutpush (list 'quote outlist) nil))))
4380 (foreach inf in inlist do
4381 (progn
4382 (cond ((equal inf (car *stdin*))
4383 (pushinstk *stdin*))
4384 ((filpr inf *instk*)
4385 (gentranerr 'e
4386 inf
4387 "template file already open for input"
4388 nil))
4389 (t
4390 (pushinstk (cons inf (open inf
4391 :direction :input)))))
4392
4393
4394
4395 (cond ((eq (stripdollar1 $gentranlang) 'ratfor) (procrattem))
4396 ((eq (stripdollar1 $gentranlang) 'c) (procctem))
4397 (t (procforttem)))
4398 (cond ((cdr *currin*) (close (cdr *currin*))))
4399 (popinstk)))
4400 (setq *gendecs ogendecs) ;;re-enable gendecs --mds
4401 (return (cond (outlist
4402 (progn
4403 (setq outlist (or (car *currout*)
4404 (cons '(mlist) (cdr *currout*))))
4405 (eval '(gentranpop '(nil)))
4406 outlist))
4407 (t
4408 (or (car *currout*)
4409 (cons '(mlist) (cdr *currout*))))))
4410 ))
4411
4412
4413
4414 ;; misc. control functions ;;
4415
4416
4417
4418 (defun onoff (flags onp)
4419 (foreach f in flags do
4420 (prog (flag funlist)
4421 (setq flag (setq f (stripdollar1 f)))
4422 (setq f (implode (cons #\* (exploden f)))) ;;--mds
4423 (set f onp)
4424 (cond ((setq funlist (assoc onp (get flag 'simpfg)))
4425 (foreach form in (cdr funlist) do (eval form))))))
4426 '$done)
4427
4428
4429
4430 (defun $tempvar (type)
4431 (tempvar (stripdollar1 type)))
4432
4433
4434 (defun $markvar (var)
4435 (markvar (stripdollar1 var))
4436 var)
4437
4438
4439 (defun $markedvarp (var)
4440 (markedvarp (stripdollar1 var)))
4441
4442
4443 (defun $unmarkvar (var)
4444 (unmarkvar (stripdollar1 var))
4445 '$done)
4446
4447
4448 (defun $recurunmark (exp)
4449 (cond ((atom exp) (unmarkvar (stripdollar1 exp)))
4450 (t (foreach elt in exp do ($recurunmark elt))))
4451 '$done)
4452
4453
4454 (defun $gendecs (name)
4455 (gendecs name))
4456
4457
4458 ;; file arg conversion function ;;
4459
4460
4461 (defun fargstonames (args openp)
4462 (prog (names)
4463 (setq args
4464 (foreach a in (if (listp args) args (list args)) conc
4465 (cond ((member a '(nil 0))
4466 (cond ((car *currout*)
4467 (list (car *currout*)))
4468 (t
4469 (cdr *currout*))))
4470 ((eq a 't)
4471 (list (car *stdout*)))
4472 ((eq a '$all)
4473 (foreach fp in *outstk* conc
4474 (cond ((and (car fp)
4475 (not (equal fp *stdout*)))
4476 (list (car fp))))))
4477 ((atom a)
4478 (cond (openp
4479 (progn (list a)))
4480 ((filpr a *outstk*)
4481 (list a))
4482 (t
4483 (gentranerr 'w
4484 a
4485 "file not open for output"
4486 nil))))
4487 (t
4488 (gentranerr 'e a "wrong type of arg" nil)))))
4489
4490
4491 (loop for z in args do (if (not (member z names))(push z names)))
4492 (return (nreverse names))))
4493
4494
4495
4496
4497
4498
4499 ;; mode switch control functions ;;
4500
4501
4502 (defun gentranswitch (lang)
4503 ; ;
4504 ; on/off fortran; ;
4505 ; on/off ratfor; ;
4506 ; on/off c; ;
4507 ; ;
4508 (prog (hlang flag exp)
4509 (setq hlang $gentranlang)
4510 (setq $gentranlang lang)
4511 (setq flag (implode (cons #\* (exploden lang)))) ;;--mds
4512 (loop while (eval flag) do
4513 (setq exp (gentranswitch1 (list (third (mread (cdr *currin*) nil))
4514 )))
4515 (eval (list 'gentran (list 'quote exp) 'nil)))
4516 (setq $gentranlang hlang)))
4517
4518 (defun gentranswitch1 (exp)
4519 (prog (r)
4520 (setq r (gentranswitch2 exp))
4521 (cond (r (return (car r)))
4522 (t (return r)))))
4523
4524 (defun gentranswitch2 (exp)
4525 (cond ((atom exp)
4526 (list exp))
4527 ((and (listp (car exp))
4528 (member (caar exp) '(gentran_off $gentran_off))) ;;renamed --mds
4529 (foreach f in (cdr exp) do
4530 (onoff (list f) nil)))
4531 (t
4532 (list (foreach e in exp conc (gentranswitch2 e))))))
4533
4534
4535 (defun gendecs (name)
4536 ; ;
4537 ; on/off gendecs; ;
4538 ; ;
4539 ; gendecs subprogname; ;
4540 ; ;
4541 (progn
4542 (cond ((equal name 0)
4543 (setq name nil)))
4544 (cond ((eq (stripdollar1 $gentranlang) 'ratfor)
4545 (formatrat (ratdecs (symtabget name '*decs*))))
4546 ((eq (stripdollar1 $gentranlang) 'c)
4547 (formatc (cdecs (symtabget name '*decs*))))
4548 ((formatfort (fortdecs (symtabget name '*decs*)))))
4549 (symtabrem name nil)
4550 (symtabrem name '*decs*)
4551 '$done))
4552
4553
4554 ;; misc. control functions ;;
4555
4556
4557 (defun gentranpairs (prs)
4558 ; ;
4559 ; gentranpairs dottedpairlist; ;
4560 ; ;
4561 (progn
4562 (cond ((eq (stripdollar1 $gentranlang) 'ratfor)
4563 (foreach pr in prs do
4564 (formatrat (mkfratassign (car pr) (cdr pr)))))
4565 ((eq (stripdollar1 $gentranlang) 'c)
4566 (foreach pr in prs do
4567 (formatc (mkfcassign (car pr) (cdr pr)))))
4568 ((foreach pr in prs do
4569 (formatfort (mkffortassign (car pr) (cdr pr))))))))
4570
4571
4572
4573 ;; -------- ;;
4574 ;; pre.l ;; preprocessing module
4575 ;; -------- ;;
4576
4577
4578
4579 (defun preproc (exp)
4580 (prog (r)
4581 (setq r (preproc1 exp))
4582 (cond (r (return (car r)))
4583 (t (return r)))))
4584
4585
4586 (defun preproc1 (exp)
4587 (cond ((atom exp)
4588 (list exp))
4589 ((or (atom (car exp))
4590 (listp (caar exp)))
4591 (list (foreach e in exp conc (preproc1 e))))
4592 ((and $gentranopt
4593 ;; (member gentranopt* '(vaxima macsyma $vaxima $macsyma))
4594 (macassignp exp)
4595 (not (macdefp exp))
4596 (not (macnestassignp exp))
4597 (not (macmatassignp exp)))
4598 (setq exp (foreach e in exp conc (preproc1 e)))
4599 (prog (lhs rhs tvarlist tvartype tassigns tvarname)
4600 (setq lhs (cadr exp))
4601 (setq rhs ($optimize (caddr exp)))
4602 (cond ((macexpp rhs)
4603 (return (list (list '(msetq) lhs rhs)))))
4604 (setq rhs (cdr rhs))
4605 (cond ((and (listp (car rhs))
4606 (listp (caar rhs))
4607 (equal (caaar rhs) 'mlist))
4608 (setq tvarname $tempvarname)
4609 (setq $tempvarname $optimvarname) ;; use optimvarname for tempvars generated by optimize --mds
4610 (setq tvarlist (cdar rhs))
4611 (setq rhs (cdr rhs))
4612 (setq tvartype (getvartype (cond ((atom lhs) lhs)
4613 (t (car lhs)))))
4614 (foreach tv in tvarlist do
4615 (prog (v)
4616 (setq v (tempvar tvartype))
4617 (markvar v)
4618 (putprop tv v '*varname*)
4619 (setq rhs (subst v tv rhs))))
4620 (foreach tv in tvarlist do
4621 (progn
4622 (unmarkvar (get tv '*varname*))
4623 (putprop tv nil '*varname*)))
4624 (setq rhs (reverse rhs))
4625 (setq tassigns (reverse (cdr rhs)))
4626 (setq rhs (car rhs))
4627 (setq $tempvarname tvarname)))
4628 (cond (tassigns
4629 (return (list (append1 (cons '(mprogn) tassigns)
4630 (list '(msetq) lhs rhs)))))
4631 (t
4632 (return (list (list '(msetq) lhs rhs)))))))
4633 ((member (stripdollar1 (caar exp)) '(lsetq rsetq lrsetq))
4634 ; (($lsetq ~) (name d1 d2 ... dn) exp) ;
4635 ; --> ((msetq) ((name) (($eval) d1) (($eval) d2) ... (($eval) dn)) ;
4636 ; exp) ;
4637 ; (($rsetq ~) var exp) ;
4638 ; --> ((msetq) var (($eval) exp)) ;
4639 ; (($lrsetq ~) ((name) d1 d2 ... dn) exp) ;
4640 ; --> ((msetq) (name (($eval) d1) (($eval) d2) ... (($eval) dn)) ;
4641 ; (($eval) exp)) ;
4642 (prog (op lhs rhs)
4643 (setq op (stripdollar1 (caar exp)))
4644 (setq lhs (cadr exp))
4645 (setq rhs (caddr exp))
4646 (cond ((and (member op '(lsetq lrsetq))
4647 (listp lhs))
4648 (setq lhs
4649 (cons (list (caar lhs))
4650 (foreach s in (cdr lhs) collect
4651 (list '($eval) s))))))
4652 (cond ((member op '(rsetq lrsetq))
4653 (setq rhs (list '($eval) rhs))))
4654 (return (preproc1 (list '(msetq) lhs rhs)))))
4655 ((equal (stripdollar1 (caar exp)) 'eval)
4656 (preproc1 (meval (cadr exp))))
4657 ((and (equal (caar exp) 'msetq)
4658 (listp (caddr exp))
4659 (listp (caaddr exp))
4660 (equal (caaaddr exp) 'lambda))
4661 ; store subprogram name & parameters in symbol table ;
4662 (symtabput (stripdollar1 (cadr exp))
4663 '*params*
4664 (foreach p in (cdadaddr exp) collect (stripdollar1 p)))
4665 (list (foreach e in exp conc (preproc1 e))))
4666 ((equal (caar exp) 'mdefine)
4667 ; store subprogram name & parameters in symbol table ;
4668 (symtabput (stripdollar1 (caaadr exp))
4669 '*params*
4670 (foreach p in (cdadr exp) collect (stripdollar1 p)))
4671 (list (foreach e in exp conc (preproc1 e))))
4672 ((equal (stripdollar1 (caar exp)) 'type)
4673 ; store type declarations in symbol table ;
4674 (setq exp (car (preproc1 (cdr exp))))
4675 (setq exp (preprocdec exp))
4676 (foreach var in (cdr exp) do
4677 (cond ((member (car exp) '(subroutine function))
4678 (symtabput var '*type* (car exp)))
4679 (t
4680 (symtabput nil
4681 (cond ((atom var) var)
4682 (t (caar var)))
4683 (cond ((atom var) (list (car exp)))
4684 (t (cons (car exp) (cdr var))))))))
4685 nil)
4686 ((equal (stripdollar1 (caar exp)) 'body)
4687 ; (($body) stmt1 stmt2 ... stmtn) ;
4688 ; --> ;
4689 ; if a main (fortran or ratfor) program is being generated then ;
4690 ; ((mprogn) stmt1 stmt2 ... stmtn (($stop)) (($end))) ;
4691 ; else if fortran or ratfor then ;
4692 ; ((mprogn) stmt1 stmt2 ... stmtn ((mreturn)) (($end))) ;
4693 ; else c ;
4694 ; ((mprog) stmt1 stmt2 ... stmtn) ;
4695 (cond ((eq (stripdollar1 $gentranlang) 'c)
4696 (preproc1 (cons '(mprog) (cdr exp))))
4697 (t
4698 (progn
4699 (setq exp (reverse (cons '(mprogn) (cdr exp))))
4700 (cond ((equal (car *symboltable*) '*main*)
4701 (setq exp (cons '(($end)) (cons '(($stop)) exp))))
4702 (t
4703 (setq exp (cons '(($end)) (cons '((mreturn)) exp)))))
4704 (preproc1 (reverse exp))))))
4705 ((member (stripdollar1 (caar exp)) '(subroutine function cprocedure))
4706 ; store subprogram name, (subprogram type), (return value type), ;
4707 ; parameter list in symbol table ;
4708 ; (($subroutine/$function/$cprocedure) {&type} (($name) $p1..$pn)) ;
4709 ; --> ((mdefine) (($name) $p1..$pn)) ;
4710 (prog (decs)
4711 (cond ((member (stripdollar1 $gentranlang) '(fortran ratfor) :test #'eq)
4712 (setq decs (list `(($type) ,(caar exp)
4713 ,(caaar (last exp)))))))
4714 (cond ((equal (length exp) 3)
4715 (setq decs
4716 (aconc decs
4717 `(($type) ,(cadr exp)
4718 ,(caaar (last exp)))))))
4719 (setq decs
4720 (cons '(mdefine)
4721 (cons (car (last exp))
4722 decs)))
4723 (return (preproc1 decs))))
4724 (t
4725 (list (foreach e in exp conc (preproc1 e))))))
4726
4727 (defun preprocdec (arg) ;; tries to parse type declarations that look like expressions. Better to use strings for types.
4728 ; $var --> var ;
4729 ; |$implicit type| --> implicit\ type ;
4730 ; ((mtimes) $type int) --> type*int ;
4731 ; ((mplus) $v1 ((mminus) $v2)) --> v1-v2 ;
4732 (cond ((atom arg)
4733 (stripdollar1 arg))
4734 ((atom (car arg))
4735 (foreach a in arg collect (preprocdec a)))
4736 ((equal (caar arg) 'mtimes)
4737 (intern (compress (append (append (exploden (stripdollar1 (cadr arg)))
4738 (exploden #\*))
4739 (exploden (caddr arg)))))) ;;--mds works but reverses case of declarations
4740 ((equal (caar arg) 'mplus)
4741 (intern (compress (append (append (exploden (stripdollar1 (cadr arg)))
4742 (exploden #\-))
4743 (exploden (stripdollar1 (cadaddr arg)))))))
4744 (t
4745 (foreach a in arg collect (preprocdec a)))))
4746
4747
Maxima, a Computer Algebra System