xref: /csrg-svn/old/lisp/fp/fp.vax/codeGen.l (revision 21724)
112065Sbaden ;  FP interpreter/compiler
212065Sbaden ;  Copyright (c) 1982  Scott B. Baden
312065Sbaden ;  Berkeley, California
4*21724Sdist ;
5*21724Sdist ;  Copyright (c) 1982 Regents of the University of California.
6*21724Sdist ;  All rights reserved.  The Berkeley software License Agreement
7*21724Sdist ;  specifies the terms and conditions for redistribution.
8*21724Sdist ;
9*21724Sdist (setq SCCS-codeGen.l "@(#)codeGen.l	5.1 (Berkeley) 05/31/85")
1012065Sbaden 
1112065Sbaden ; Main Routine to do code generation
1212065Sbaden 
1312065Sbaden (include specials.l)
1412065Sbaden (declare
1512065Sbaden   (localf build_constr mName condit$fp alpha$fp insert$fp ti$fp while$fp)
1612065Sbaden   )
1712065Sbaden 
1812065Sbaden (defmacro getFform (xx)
1912065Sbaden   `(implode (nreverse `(p f ,@(cdr (nreverse (explodec (cxr 0 ,xx))))))))
2012065Sbaden 
2112065Sbaden (defun mName (name)
2212065Sbaden   (cond ((atom name) `',name)
2312065Sbaden 	(t `',(getFform name))))
2412065Sbaden 
2512065Sbaden (defun mNameI (name)
2612065Sbaden   (cond ((atom name) name)
2712065Sbaden 	(t (getFform name))))
2812065Sbaden 
2912065Sbaden (defun codeGen (ptree)
3012065Sbaden   (cond ((atom ptree) `',ptree)		; primitive or
3112065Sbaden 							; user defined
3212065Sbaden 
3312065Sbaden 	((eq (cxr 0 ptree) 'alpha$$)			; apply to all
3412065Sbaden 	 (alpha$fp (cxr 1 ptree)))
3512065Sbaden 
3612065Sbaden 	((eq (cxr 0 ptree) 'insert$$)			; insert
3712065Sbaden 	 (insert$fp (cxr 1 ptree)))
3812065Sbaden 
3912065Sbaden 	((eq (cxr 0 ptree) 'ti$$)			; tree insert
4012065Sbaden 	 (ti$fp (cxr 1 ptree)))
4112065Sbaden 
4212065Sbaden 	((eq (cxr 0 ptree) 'select$$)			; selector
4312065Sbaden 	 (let ((sel (cxr 1 ptree)))
4412065Sbaden 
4512065Sbaden 	      (If (zerop sel) 		; No stats for errors
4612065Sbaden 		  then `#'(lambda (x) (bottom))
4712065Sbaden 
4812065Sbaden 		  else
4912065Sbaden 
5012065Sbaden 		  `#'(lambda (x)
5112065Sbaden 			     (cond ((not (listp x)) (bottom)))
5212065Sbaden 			     (cond (DynTraceFlg (measSel ,sel x)))
5312065Sbaden 			     ,(cond ((plusp sel)
5412065Sbaden 				     `(If (greaterp ,sel (length x))
5512065Sbaden 					  then (bottom)
5612065Sbaden 					  else (nthelem ,sel x)))
5712065Sbaden 
5812065Sbaden 
5912065Sbaden 				    ((minusp sel)
6012065Sbaden 				     `(let  ((len (length x)))
6112065Sbaden 					    (If (greaterp ,(absval sel) len)
6212065Sbaden 						then (bottom)
6312065Sbaden 						else (nthelem (plus len ,(1+ sel)) x)))))))))
6412065Sbaden 
6512065Sbaden 
6612065Sbaden 
6712065Sbaden 	((eq (cxr 0 ptree) 'constant$$)			; constant
6812065Sbaden 	 (let ((const (cxr 1 ptree)))
6912065Sbaden 	      (If (eq const '?)
7012065Sbaden 		  then `#'(lambda (x) (bottom))
7112065Sbaden 
7212065Sbaden 		  else
7312065Sbaden 
7412065Sbaden 		  `#'(lambda (x)
7512065Sbaden 			     (cond (DynTraceFlg (measCons ,const x)))
7612065Sbaden 			     ,const))))
7712065Sbaden 
7812065Sbaden 
7912065Sbaden 
8012065Sbaden 	((eq (cxr 0 ptree) 'condit$$)			; conditional
8112065Sbaden 	 (condit$fp (cxr 1 ptree) (cxr 2 ptree) (cxr 3 ptree)))
8212065Sbaden 
8312065Sbaden 	((eq (cxr 0 ptree) 'while$$)			; while
8412065Sbaden 	 (while$fp (cxr 1 ptree) (cxr 2 ptree)))
8512065Sbaden 
8612065Sbaden 
8712065Sbaden 	((eq (cxr 0 ptree) 'compos$$)			; composition
8812065Sbaden 	 (let ((cm1 (cxr 1 ptree))
8912065Sbaden 	       (cm2 (cxr 2 ptree)))
9012065Sbaden 	      `#'(lambda (x)
9112065Sbaden 			 (cond (DynTraceFlg
9212065Sbaden 				(measComp ,(mName cm1) ,(mName cm2) x)))
9312065Sbaden 			 (funcall ,(codeGen cm1)
9412065Sbaden 				  (funcall ,(codeGen cm2)
9512065Sbaden 					   x)))))
9612065Sbaden 
9712065Sbaden 
9812065Sbaden 	((eq (cxr 0 ptree) 'constr$$)
9912065Sbaden 	 (build_constr ptree))				; construction
10012065Sbaden 
10112065Sbaden 	(t 'error)))					; error, sb '?
10212065Sbaden 
10312065Sbaden 
10412065Sbaden ; build up the list of arguments for a construction
10512065Sbaden 
10612065Sbaden (defun build_constr (pt)
10712065Sbaden   (cond ((and (eq 2 (hunksize pt)) (null (cxr 1 pt)))
10812065Sbaden 	 `#'(lambda (x) (cond (DynTraceFlg (measCons nil x)))  nil))
10912065Sbaden 	(t
11012065Sbaden 	 (do ((i 2 (1+ i))
11112065Sbaden 	      (stat (list `,(mNameI (cxr 1 pt))))
11212065Sbaden 	      (con (list (codeGen (cxr 1 pt)))))
11312065Sbaden 	     ((greaterp i (1- (hunksize pt)))
11412065Sbaden 	      (return
11512065Sbaden 	       (funcall 'constr$fp con stat)))
11612065Sbaden 	     (setq stat (append stat (list `,(mNameI (cxr i pt)))))
11712065Sbaden 	     (setq con (append con (list (codeGen (cxr i pt)))))))))
11812065Sbaden 
11912065Sbaden 
12012065Sbaden ; generate a lisp function definition from an FP parse tree
12112065Sbaden 
12212065Sbaden (defun put_fn (fn_name p_tree)
12312065Sbaden   (untraceDel (extName fn_name))
12412065Sbaden   (putd fn_name
12512065Sbaden 	`(lambda (x)
12612065Sbaden 		 (cond (DynTraceFlg (IncrUDF ',fn_name x)))
12712065Sbaden 		 (funcall ,(codeGen p_tree) x))))
12812065Sbaden 
12912065Sbaden 
13012065Sbaden ; The Functional forms
13112065Sbaden ;
13212065Sbaden 
13312065Sbaden 
13412065Sbaden ; fp conditional
13512065Sbaden 
13612065Sbaden (def condit$fp
13712065Sbaden   (lambda (Pptree Tptree Fptree)
13812065Sbaden 	  (let ((test (codeGen Pptree))
13912065Sbaden 		(true (codeGen Tptree))
14012065Sbaden 		(false (codeGen Fptree)))
14112065Sbaden 
14212065Sbaden 	       (let ((q
14312065Sbaden 		      `(lambda (x)
14412065Sbaden 				(cond (DynTraceFlg
14512065Sbaden 				       (measCond
14612065Sbaden 					,(mName Pptree)
14712065Sbaden 					,(mName Tptree)
14812065Sbaden 					,(mName Fptree) x)))
14912065Sbaden 
15012065Sbaden 				(let ((z (funcall ,test x)))
15112065Sbaden 				     (cond
15212065Sbaden 				      ((eq 'T z) (funcall ,true x))
15312065Sbaden 				      ((eq 'F z) (funcall ,false x))
15412065Sbaden 				      (t (bottom)))))))
15512065Sbaden 		    `(function ,q)))))
15612065Sbaden 
15712065Sbaden 
15812065Sbaden 
15912065Sbaden ; construction
16012065Sbaden 
16112065Sbaden (def constr$fp
16212065Sbaden   (lexpr (v)
16312065Sbaden 	 (let* ((vl (listify v))
16412065Sbaden 		(q
16512065Sbaden 		 `(lambda (x)
16612065Sbaden 			  (cond (DynTraceFlg
16712065Sbaden 				 (measConstr ',(cadr vl) x)))
16812065Sbaden 			  (let* ((savelevel level)
16912065Sbaden 				 (h
17012065Sbaden 				  (list
17112065Sbaden 				   ,@(mapcar
17212065Sbaden 				      #'(lambda
17312065Sbaden 					 (y)
17412065Sbaden 					 `(let ((r ,`(funcall ,y x)))
17512065Sbaden 					       (setq level savelevel)
17612065Sbaden 					       r))
17712065Sbaden 				      (car vl)))))
17812065Sbaden 				(setq level savelevel)
17912065Sbaden 				h
18012065Sbaden 				))))
18112065Sbaden 	       `(function ,q))))
18212065Sbaden 
18312065Sbaden 
18412065Sbaden 
18512065Sbaden 
18612065Sbaden ; apply to all
18712065Sbaden 
18812065Sbaden (def alpha$fp
18912065Sbaden   (lambda (ptree)
19012065Sbaden 	  (let* ((fn (codeGen ptree))
19112065Sbaden 		 (q
19212065Sbaden 		  `(lambda (x)
19312065Sbaden 			   (cond (DynTraceFlg
19412065Sbaden 				  (measAlph ,(mName ptree) x)))
19512065Sbaden 			   (cond ((null x) nil)
19612065Sbaden 				 ((not (listp x)) (bottom))
19712065Sbaden 				 (t
19812065Sbaden 				  (let* ((savelevel level)
19912065Sbaden 					 (h
20012065Sbaden 					  (mapcar
20112065Sbaden 					   '(lambda (y)
20212065Sbaden 						    (setq level savelevel)
20312065Sbaden 						    (funcall ,fn y))
20412065Sbaden 					   x)))
20512065Sbaden 
20612065Sbaden 					(setq level savelevel)
20712065Sbaden 					h))))))
20812065Sbaden 		`(function ,q))))
20912065Sbaden 
21012065Sbaden 
21112065Sbaden ; insert
21212065Sbaden 
21312065Sbaden (def insert$fp
21412065Sbaden   (lambda (ptree)
21512065Sbaden 	  (let* ((fn (codeGen ptree))
21612065Sbaden 		 (q
21712065Sbaden 		  `(lambda (x)
21812065Sbaden 			   (cond (DynTraceFlg (measIns ,(mName ptree) x)))
21912065Sbaden 			   (cond ((not (listp x)) (bottom))
22012065Sbaden 				 ((null x)
22112065Sbaden 				  (let ((ufn (get 'u-fnc ,fn)))
22212065Sbaden 				       (cond
22312065Sbaden 					(ufn (funcall ufn))
22412065Sbaden 					(t (bottom)))))
22512065Sbaden 				 (t (let ((v (reverse x)) (z nil))
22612065Sbaden 					 (setq z (car v))
22712065Sbaden 					 (setq v (cdr v))
22812065Sbaden 					 (mapc '(lambda (y) (setq z (funcall ,fn (list y z)))) v)
22912065Sbaden 					 z))))))
23012065Sbaden 		`(function ,q))))
23112065Sbaden 
23212065Sbaden 
23312065Sbaden 
23412065Sbaden 
23512065Sbaden (defun while$fp (pFn fFn)
23612065Sbaden   (let* ((fn_p (codeGen pFn))
23712065Sbaden 	 (fn_f (codeGen fFn))
23812065Sbaden 	 (q
23912065Sbaden 	  `(lambda (x)
24012065Sbaden 		   (cond (DynTraceFlg
24112065Sbaden 			  (measWhile ,(mName pFn) ,(mName fFn) x)))
24212065Sbaden 		   (do
24312065Sbaden 		    ((z (funcall ,fn_p x) (funcall ,fn_p rslt))
24412065Sbaden 		     (rslt x))
24512065Sbaden 		    ((eq 'F z) rslt)
24612065Sbaden 		    (cond ((undefp z) (bottom)))
24712065Sbaden 		    (setq rslt (funcall ,fn_f rslt))))))
24812065Sbaden 	`(function ,q)))
24912065Sbaden 
25012065Sbaden 
25112065Sbaden 
25212065Sbaden 
25312065Sbaden ; Tree insert
25412065Sbaden 
25512065Sbaden (def ti$fp
25612065Sbaden   (lambda (ptree)
25712065Sbaden 	  (let* ((fn (codeGen ptree))
25812065Sbaden 		 (q
25912065Sbaden 		  `(lambda (x)
26012065Sbaden 			   (cond (DynTraceFlg (measAi ,(mName ptree) x)))
26112065Sbaden 			   (treeIns$fp ,fn x))))
26212065Sbaden 		`(function ,q))))
263